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