hacky unfinished scribblings about how to do fancy struct instances

StructExample.hs

{-# 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