qq!

src/Gyehoek/Wasm.hs

@@ -11,7 +11,25 @@
 {-# LANGUAGE ImpredicativeTypes #-}
 {-# LANGUAGE DerivingVia #-}
 module Gyehoek.Wasm
-  ( Module
+  (
+    -- * syntax
+    Module
+  , Idx
+  , Expr
+    -- ** quasiquoters
+  , expr
+  , Gyehoek.Sexp.sx
+  , Gyehoek.Sexp.sxs
+  , Gyehoek.Sexp.sx'
+  , Gyehoek.Sexp.sxs'
+  -- * GenMod effect
+  , GenMod
+  , runGenMod
+  , execGenMod
+  , defineFunction
+  , defineType
+  , defineGlobal
+  , declare
   )
   where
 
@@ -45,18 +63,29 @@ import GHC.IsList (IsList(..))
 import Data.Coerce (coerce)
 import qualified Control.Category
 import Data.Functor (void)
+import Language.Haskell.TH.Quote (QuasiQuoter)
+import Data.Data (Data)
+import Data.Functor.Foldable (cata)
 
 
 newtype Module = MkModule { inner :: Vector Sexp }
   deriving (Show, Generic)
   deriving newtype (Semigroup, Monoid)
 
-newtype Expr = MkExpr { inner :: Vector Sexp }
-  deriving (Show, Generic)
+newtype Expr = MkExpr { inner :: Vector Instr }
+  deriving (Show, Generic, Data, Eq)
   deriving newtype (Semigroup, Monoid)
 
+instance IsList Expr where
+  type Item Expr = Instr
+  fromList = MkExpr . V.fromList
+  toList = V.toList . view #inner
+
+newtype Instr = MkInstr { inner :: Sexp }
+  deriving (Show, Generic, Data, Eq)
+
 newtype Idx = MkIdx { inner :: Natural }
-  deriving (Generic)
+  deriving (Generic, Data)
   deriving newtype (Show)
 
 
@@ -68,9 +97,89 @@ data GenModState = MkGenModState
   { mod :: Module
   , funcs :: Natural
   , types :: Natural
+  , globals :: Natural
   }
   deriving (Show, Generic)
 
+instance Semigroup GenModState where
+  m1 <> m2 = MkGenModState
+    { mod = m1.mod <> m2.mod
+    , funcs = m1.funcs + m2.funcs
+    , types = m1.types + m2.types
+    , globals = m1.globals + m2.globals
+    }
+
+instance Monoid GenModState where
+  mempty = MkGenModState
+    { mod = mempty
+    , funcs = 0
+    , types = 0
+    , globals = 0
+    }
+
 data GenMod :: Effect where
   DefineFunction :: Sexp -> GenMod m Idx
   DefineType :: Sexp -> GenMod m Idx
+  DefineGlobal :: Sexp -> GenMod m Idx
+  Declare :: Sexp -> GenMod m ()
+
+type instance DispatchOf GenMod = Dynamic
+
+defineFunction :: GenMod :> es => Sexp -> Eff es Idx
+defineFunction = send . DefineFunction
+
+defineType :: GenMod :> es => Sexp -> Eff es Idx
+defineType = send . DefineType
+
+defineGlobal :: GenMod :> es => Sexp -> Eff es Idx
+defineGlobal = send . DefineGlobal
+
+declare :: GenMod :> es => Sexp -> Eff es ()
+declare = send . Declare
+
+appendAndIncrement
+  :: State GenModState :> es
+  => LensLike' ((,) _) GenModState Natural
+  -> Sexp
+  -> Eff es Idx
+appendAndIncrement l s =
+  state \st -> st
+    & #mod . #inner <>~ V.singleton s
+    & l <<%~ succ
+    & _1 %~ MkIdx
+
+runGenMod :: Eff (GenMod : es) a -> Eff es (a, Module)
+runGenMod =
+  let run = (mapped . _2 %~ view #mod) . runStateLocal (mempty @GenModState)
+  in reinterpret run \cases
+    _ (DefineFunction s) -> appendAndIncrement #funcs s
+    _ (DefineType s) -> appendAndIncrement #types s
+    _ (DefineGlobal s) -> appendAndIncrement #globals s
+    _ (Declare s) -> #mod . #inner <>= V.singleton s
+
+execGenMod :: Eff (GenMod : es) a -> Eff es Module
+execGenMod = fmap snd . runGenMod
+
+
+-- SexpIso instances
+
+instance SexpIso Idx where
+  sexpIso = with \idx ->
+    Sexp.integer >>> Sexp.partialOsi f g
+    >>> idx
+    where
+      f n | n < 0 = Left $ Sexp.unexpected "negative"
+                        <> Sexp.expected "natural"
+          | otherwise = Right $ fromIntegral n
+      g = fromIntegral
+
+instance SexpIso Instr where
+  sexpIso = with id
+
+
+-- quasiquoters
+
+expr :: QuasiQuoter
+expr = Gyehoek.Sexp.makeSxs
+  (MkExpr . V.fromList . (each . #inner %~ Gyehoek.Sexp.stripLocation))
+  (sexpIso @Instr)