Skip to content

Instantly share code, notes, and snippets.

@cartazio
Created June 6, 2019 23:31
Show Gist options
  • Save cartazio/7d4a3dc7f68eb5b637268c964afb1df1 to your computer and use it in GitHub Desktop.
Save cartazio/7d4a3dc7f68eb5b637268c964afb1df1 to your computer and use it in GitHub Desktop.
hacky unfinished scribblings about how to do fancy struct instances
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE ExplicitForAll#-}
module Main where
import Data.Struct
--import Data.Struct.TH
--import qualified Data.Coerce as Crc
import Data.Coerce (coerce)
import Control.Monad.Primitive
import Data.Word
import Numeric.Natural
import Data.Struct.Internal
import Data.Primitive
import Data.Primitive.ByteArray
main :: IO ()
main = putStrLn "success"
{-
this code requires the version of structs on github that has the TH support
-}
data ModelAST = ModLam !ModelAST | ModVar !Word64 | ModApp !ModelAST !ModelAST | ModPrimOp !String | ModLit !Literal
data AstF x = LamF !x | VarF !Word64 | AppF !x !x | PrimopF !String | LitF !Literal
data Literal = LString !String | LDouble !Double | LNat !Natural | LInteger !Integer
data SAstTag = LamTag | VarTag | AppTag | PrimopTag | LitTag
deriving(Eq,Ord,Show,Read,Enum)
encodeTag :: SAstTag -> Word64
encodeTag = \ x -> (fromIntegral $ fromEnum x )
{-# INLINE encodeTag #-}
decodeTag :: Word64 -> SAstTag
decodeTag = \ x -> (toEnum $ fromIntegral x )
{-# INLINE decodeTag #-}
newtype SimpleAst s = SimpleAst (Object s)
instance Struct (SimpleAst )
instance Eq (SimpleAst s) where -- this is reference equality rather than structure equality
(==) = eqStruct
astTagRaw :: Field SimpleAst Word64
astTagRaw = unboxedField 0 0
{-# INLINE astTagRaw #-}
{- can't use SAstTag direclty :''(
-}
{-$(makeStruct [d| data Lam s = Lam {tagLamPrivate :: {-#UNPACK#-}!Word64 , bodyLam :: !(SimpleAst s) } |])
$(makeStruct [d| data Var s = Var {tagVarPrivate :: {-#UNPACK#-}!Word64, varVal ::{-# UNPACK #-}!Word64 }|])
$(makeStruct [d| data App s = App {tagAppPrivate :: {-#UNPACK#-}!Word64, funApp :: !(SimpleAst s), argApp :: !(SimpleAst s) } |])
$(`makeStruct [d| data PrimOp s = PrimOp {tagPrimOpPrivate :: {-#UNPACK#-}!Word64, opNamePrimOp :: String}|])
im
-}
{-$(makeStruct [d| data Lam s = Lam {tagLamPrivate :: {-#UNPACK#-}!Word64 , bodyLam :: !(SimpleAst s) } |])-}
newtype Lam s = Lam (Object s)
instance Struct Lam where
struct = Data.Struct.Internal.Dict
instance Eq (Lam s) where
(==) = eqStruct
{-tagLamPrivate :: Field Lam Int
tagLamPrivate = unboxedField 0 0
{-# INLINE tagLamPrivate #-}-}
bodyLam :: Slot Lam SimpleAst
bodyLam = slot 1
{-# INLINE bodyLam #-}
newLam ::
forall m.
PrimMonad m =>
SimpleAst (PrimState m)
-> m (SimpleAst (PrimState m))
newLam valbodyLam
= coerce <$> Data.Struct.Internal.st
(do { this <- allocLamPrivate;
do { mba <- Data.Struct.Internal.initializeUnboxedField
0 1 (Data.Primitive.sizeOf (encodeTag LamTag)) this;
Data.Primitive.ByteArray.writeByteArray
mba 0 (encodeTag LamTag ) };
set bodyLam this valbodyLam;
return this })
allocLamPrivate ::
forall m.
PrimMonad m => m (Lam (PrimState m))
allocLamPrivate = alloc 2
{-# INLINE allocLamPrivate #-}
type role Lam nominal
{-MutableAST.hs:34:3-109: Splicing declarations
makeStruct
[d| data Var s3
= Var0 {tagVarPrivate1 :: {-# UNPACK #-} !Word64,
varVal2 :: {-# UNPACK #-} !Word64} |]
======>-}
newtype Var s = Var (Object s)
instance Struct Var where
struct = Data.Struct.Internal.Dict
instance Eq (Var s) where
(==) = eqStruct
{-tagVarPrivate :: Field Var Int
tagVarPrivate = unboxedField 0 0
{-# INLINE tagVarPrivate #-}-}
varVal :: Field Var Word64
varVal = unboxedField 0 1
{-# INLINE varVal #-}
newVar ::
forall m.
PrimMonad m => Word64 -> m (SimpleAst (PrimState m))
newVar thevarVal
= coerce <$> Data.Struct.Internal.st
(do { this <- allocVarPrivate;
do { mba <- Data.Struct.Internal.initializeUnboxedField
0 2 (Data.Primitive.sizeOf (encodeTag VarTag)) this;
Data.Primitive.ByteArray.writeByteArray
mba 0 (encodeTag VarTag);
Data.Primitive.ByteArray.writeByteArray mba 1 thevarVal };
return this })
allocVarPrivate ::
forall m.
PrimMonad m => m (Var (PrimState m))
allocVarPrivate = alloc 1
{-# INLINE allocVarPrivate #-}
type role Var nominal
{-
MutableAST.hs:35:3-129: Splicing declarations
makeStruct
[d| data App s
= App {tagAppPrivate :: {-# UNPACK #-} !Word64,
funApp :: !(SimpleAst s),
argApp :: !(SimpleAst s)} |]
======>-}
newtype App s3 = App (Object s3)
instance Struct App where
struct = Data.Struct.Internal.Dict
instance Eq (App s3) where
(==) = eqStruct
{-
tagAppPrivate0 :: Field App Word64
tagAppPrivate0 = unboxedField 0 0
{-# INLINE tagAppPrivate0 #-}
-}
funApp1 :: Slot App SimpleAst
funApp1 = slot 1
{-# INLINE funApp1 #-}
argApp2 :: Slot App SimpleAst
argApp2 = slot 2
{-# INLINE argApp2 #-}
newApp ::
forall m8.
PrimMonad m8 => SimpleAst (PrimState m8)
-> SimpleAst (PrimState m8)
-> m8 (SimpleAst (PrimState m8))
newApp funApp6 argApp7
= coerce <$> Data.Struct.Internal.st
(do { this4 <- allocAppPrivate;
do { mba9 <- Data.Struct.Internal.initializeUnboxedField
0 1 (Data.Primitive.sizeOf (encodeTag AppTag)) this4;
Data.Primitive.ByteArray.writeByteArray
mba9 0 (encodeTag AppTag) };
set funApp1 this4 funApp6;
set argApp2 this4 argApp7;
return this4 })
allocAppPrivate ::
forall m.
PrimMonad m => m (App (PrimState m))
allocAppPrivate = alloc 3
{-# INLINE allocAppPrivate #-}
type role App nominal
{-MutableAST.hs:36:3-105: Splicing declarations
makeStruct
[d| data PrimOp s
= PrimOp {tagPrimOpPrivate :: {-# UNPACK #-} !Word64,
opNamePrimOp :: String} |]
======>-}
newtype PrimOp s = PrimOp (Object s)
instance Struct PrimOp where
struct = Data.Struct.Internal.Dict
instance Eq (PrimOp s) where
(==) = eqStruct
{-tagPrimOpPrivate :: Field PrimOp Word64
tagPrimOpPrivate = unboxedField 0 0
{-# INLINE tagPrimOpPrivate #-}-}
opNamePrimOp :: Field PrimOp String
opNamePrimOp = field 1
{-# INLINE opNamePrimOp #-}
newPrimOp ::
forall m.
PrimMonad m => String -> m (SimpleAst (PrimState m))
newPrimOp valopNamePrimOp
= coerce <$> Data.Struct.Internal.st
(do { this <- allocPrimOpPrivate;
do { mba <- Data.Struct.Internal.initializeUnboxedField
0 1 (Data.Primitive.sizeOf (encodeTag PrimopTag)) this;
Data.Primitive.ByteArray.writeByteArray
mba 0 (encodeTag PrimopTag) };
setField opNamePrimOp this valopNamePrimOp;
return this })
allocPrimOpPrivate ::
forall m.
PrimMonad m => m (PrimOp (PrimState m))
allocPrimOpPrivate = alloc 2
{-# INLINE allocPrimOpPrivate #-}
type role PrimOp nominal
{-
MutableAST.hs:37:3-97: Splicing declarations
makeStruct
[d| data Lit s
= Lit {tagLitPrivate :: {-# UNPACK #-} !Word64,
literalLit :: String} |]-}
-- ======>
newtype Lit s = Lit (Object s)
instance Struct Lit where
struct = Data.Struct.Internal.Dict
instance Eq (Lit s) where
(==) = eqStruct
{- tagLitPrivate :: Field Lit Word64
tagLitPrivate = unboxedField 0 0
{-# INLINE tagLitPrivate #-}-}
literalLit :: Field Lit String
literalLit = field 1
{-# INLINE literalLit #-}
newLit ::
forall m.
PrimMonad m => String -> m (SimpleAst (PrimState m))
newLit valliteralLit
= coerce <$> Data.Struct.Internal.st
(do { this <- allocLitPrivate;
do { mba <- Data.Struct.Internal.initializeUnboxedField
0 1 (Data.Primitive.sizeOf (encodeTag LitTag)) this;
Data.Primitive.ByteArray.writeByteArray
mba 0 (encodeTag LitTag) };
setField literalLit this valliteralLit;
return this })
allocLitPrivate ::
forall m.
PrimMonad m => m (Lit (PrimState m))
allocLitPrivate = alloc 2
{-# INLINE allocLitPrivate #-}
type role Lit nominal
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment