qq!

src/Gyehoek/CPS/Lower.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE ApplicativeDo #-}
 {-# OPTIONS_GHC -Wno-incomplete-patterns #-}
+{- HLINT ignore "Use camelCase" -}
 module Gyehoek.CPS.Lower
   (lower, lowerProgram) where
 
@@ -14,6 +15,7 @@ import Data.Generics.Labels
 import Gyehoek.Scheme.Syntax qualified as Scm
 import Gyehoek.GenSym
 import Data.List.NonEmpty (NonEmpty((:|)))
+import Data.List (List)
 import Effectful
 import Control.Monad.Cont qualified as Cont
 import Effectful.Writer.Static.Local
@@ -32,9 +34,11 @@ import Data.IntMap.Strict (IntMap)
 import Data.String.Interpolate
 import Gyehoek.Wasm qualified as Wasm
 import Gyehoek.Wasm hiding (Expr)
-import Language.Sexp.Located (pattern ParenList)
+import Language.Sexp.Located qualified as SL
 import Debug.Pretty.Simple
 import Control.Monad.Fix
+import Language.Sexp.Located (Sexp)
+import Data.Functor.Foldable (cata)
 
 
 data Env = MkEnv
@@ -66,185 +70,222 @@ data Runtime = MkRuntime
 
 -- | @makeSmallFixnum@ emits an expression injecting the i32 on top
 -- of the stack into the SCM unitype.
-makeSmallFixnum :: Wasm.Expr
+-- makeSmallFixnum :: Wasm.Expr
-makeSmallFixnum = mconcat
+-- makeSmallFixnum = mconcat
-  [ ins "i32.const" [sxp @Int 1]
+--   [ ins "i32.const" [sxp @Int 1]
-  , ins "i32.shl" []
+--   , ins "i32.shl" []
-  , ins "ref.i31" []
+--   , ins "ref.i31" []
-  ]
+--   ]
 
 -- | Given an expression @e@ leaving a @ref eq@ atop the stack,
 -- @pushArg rt n e@ sets the nth slot of the arg-passing array to the
 -- result of @e@.
-pushArg :: Runtime -> Int -> Wasm.Expr -> Wasm.Expr
+-- pushArg :: Runtime -> Int -> Wasm.Expr -> Wasm.Expr
-pushArg (MkRuntime {argArrayType,argArray}) n e = mconcat
+-- pushArg (MkRuntime {argArrayType,argArray}) n e = mconcat
-  [ ins "global.get" [sxp argArray]
+--   [ ins "global.get" [sxp argArray]
-  , ins "i32.const" [sxp n]
+--   , ins "i32.const" [sxp n]
-  , e
+--   , e
-  , ins "array.set" [sxp argArrayType]
+--   , ins "array.set" [sxp argArrayType]
-  ]
+--   ]
 
 -- | Pop the nth arg from the arg-passing array onto the stack.
-popArg :: Runtime -> Int -> Wasm.Expr
+-- popArg :: Runtime -> Int -> Wasm.Expr
-popArg (MkRuntime {argArrayType,argArray}) n = mconcat
+-- popArg (MkRuntime {argArrayType,argArray}) n = mconcat
-  [ ins "global.get" [sxp argArray]
+--   [ ins "global.get" [sxp argArray]
-  , ins "i32.const" [sxp n]
+--   , ins "i32.const" [sxp n]
-  , ins "array.get" [sxp argArrayType]
+--   , ins "array.get" [sxp argArrayType]
-  , ins "ref.as_non_null" []
+--   , ins "ref.as_non_null" []
-  ]
+--   ]
 
 
 
-lowerVal :: Env -> Val -> Wasm.Expr
+-- lowerVal :: Env -> Val -> Wasm.Expr
 
-lowerVal g (ValLit l) =
+-- lowerVal g (ValLit l) =
-  case l of
+--   case l of
-    LitInt n -> 
+--     LitInt n -> 
-      ins "i32.const" [sxp n]
+--       ins "i32.const" [sxp n]
-      <> makeSmallFixnum
+--       <> makeSmallFixnum
-    LitBool b ->
+--     LitBool b ->
-      ins "i32.const" [sxp @Int $ if b then 1 else 0]
+--       ins "i32.const" [sxp @Int $ if b then 1 else 0]
-      <> ins "ref.i31" []
+--       <> ins "ref.i31" []
-    _ -> _
+--     _ -> _
 
-lowerVal g (ValVar x) = ins "local.get" [sxp (1+l)]
+-- lowerVal g (ValVar x) = ins "local.get" [sxp (1+l)]
-  where
+--   where
-    l = V.elemIndex x g.vars ^?! _Just
+--     l = V.elemIndex x g.vars ^?! _Just
 
-lower' :: (GenMod :> es) => Env -> Exp -> Eff es Wasm.Expr
+-- lower' :: (GenMod :> es) => Env -> Exp -> Eff es Wasm.Expr
 
-lower' g (Halt [v]) = pure . mconcat $
+-- lower' g (Halt [v]) = pure . mconcat $
-  [ pushArg g.runtime 0 (lowerVal g v)
+--   [ pushArg g.runtime 0 (lowerVal g v)
-  , ins "return_call" [sxp @Int 1]
+--   , ins "return_call" [sxp @Int 1]
-  ]
+--   ]
 
-lower' g (ExpPrim p rs e) =
+-- lower' g (ExpPrim p rs e) =
-  case p of
+--   case p of
-    PrimAdd x y -> lowerBinOp "i32.add" g x y r e
+--     PrimAdd x y -> lowerBinOp "i32.add" g x y r e
-    PrimMul x y -> lowerBinOp "i32.mul" g x y r e
+--     PrimMul x y -> lowerBinOp "i32.mul" g x y r e
-  where
+--   where
-    r = head rs
+--     r = head rs
 
-lower' g (ExpIf c t f) = do
+-- lower' g (ExpIf c t f) = do
-  t' <- lower' g t
+--   t' <- lower' g t
-  f' <- lower' g f
+--   f' <- lower' g f
-  pure $ lowerVal g c
+--   pure $ lowerVal g c
-    <> Wasm.if' (Wasm.result [i32]) t' f'
+--     <> Wasm.if' (Wasm.result [i32]) t' f'
 
-lower' g (ExpContinue k [x]) = pure . mconcat $
+-- lower' g (ExpContinue k [x]) = pure . mconcat $
-  [ pushArg rt 0 (lowerVal g x)
+--   [ pushArg rt 0 (lowerVal g x)
-  , ins "i32.const" [sxp @Int 1] -- nargs
+--   , ins "i32.const" [sxp @Int 1] -- nargs
-  -- get the return continuation.
+--   -- get the return continuation.
-  , ins "global.get" [sxp rt.contStack]
+--   , ins "global.get" [sxp rt.contStack]
-  , ins "global.get" [sxp rt.contStackTop]
+--   , ins "global.get" [sxp rt.contStackTop]
-  , ins "array.get" [sxp rt.contStackType]
+--   , ins "array.get" [sxp rt.contStackType]
-  , ins "ref.as_non_null" []
+--   , ins "ref.as_non_null" []
-  -- decrement contStackTop, completing the "pop."
+--   -- decrement contStackTop, completing the "pop."
-  , ins "global.get" [sxp rt.contStackTop]
+--   , ins "global.get" [sxp rt.contStackTop]
-  , ins "i32.const" [sxp @Int (1 + l)]
+--   , ins "i32.const" [sxp @Int (1 + l)]
-  , ins "i32.sub" []
+--   , ins "i32.sub" []
-  , ins "global.set" [sxp rt.contStackTop]
+--   , ins "global.set" [sxp rt.contStackTop]
-  , ins "return_call_ref" [sxp rt.contType]
+--   , ins "return_call_ref" [sxp rt.contType]
-  ]
+--   ]
-  where
+--   where
-    rt = g.runtime
+--     rt = g.runtime
-    l = V.elemIndex k g.kvars ^?! _Just
+--     l = V.elemIndex k g.kvars ^?! _Just
 
-lower' g (ExpLet [(r,MkLambda xs ktail m)] e) = do
+-- lower' g (ExpLet [(r,MkLambda xs ktail m)] e) = do
-  idx <- defun [i32] [] (replicate 5 scm) \_ -> do
+--   idx <- defun [i32] [] (replicate 5 scm) \_ -> do
-    let g' = g & #vars <>~ V.fromList xs
+--     let g' = g & #vars <>~ V.fromList xs
-               & #kvars <>~ [ktail]
+--                & #kvars <>~ [ktail]
-    m' <- lower' g' m
+--     m' <- lower' g' m
-    pure . mconcat $
+--     pure . mconcat $
-      [ xs & ifoldMap \n _ ->
+--       [ xs & ifoldMap \n _ ->
-          popArg g.runtime n <> ins "local.set" [sxp (1+n)]
+--           popArg g.runtime n <> ins "local.set" [sxp (1+n)]
-      , m'
+--       , m'
-      ]
+--       ]
-  declareFuncref idx
+--   declareFuncref idx
-  let g' = g & #vars <>~ [r]
+--   let g' = g & #vars <>~ [r]
-  let n = length g.vars
+--   let n = length g.vars
-  e' <- lower' g' e
+--   e' <- lower' g' e
-  pure . mconcat $
+--   pure . mconcat $
-    [ ins "ref.func" [sxp idx]
+--     [ ins "ref.func" [sxp idx]
-    , ins "local.set" [sxp (n+1)]
+--     , ins "local.set" [sxp (n+1)]
-    , e'
+--     , e'
-    ]
+--     ]
 
-lower' g e = error . show $ e
+-- lower' g e = error . show $ e
 
-lowerBinOp
+-- lowerBinOp
-  :: (GenMod :> es)
+--   :: (GenMod :> es)
-  => Text -> Env -> Val -> Val -> Name -> Exp -> Eff es Wasm.Expr
+--   => Text -> Env -> Val -> Val -> Name -> Exp -> Eff es Wasm.Expr
-lowerBinOp op g x y r e = do
+-- lowerBinOp op g x y r e = do
-  e' <- lower' g' e
+--   e' <- lower' g' e
-  pure . mconcat $
+--   pure . mconcat $
-    [ lowerVal g x
+--     [ lowerVal g x
-    , ins "ref.cast" [sxp $ ref i31]
+--     , ins "ref.cast" [sxp $ ref i31]
-    , ins "i31.get_s" []
+--     , ins "i31.get_s" []
-    , lowerVal g y
+--     , lowerVal g y
-    , ins "ref.cast" [sxp $ ref i31]
+--     , ins "ref.cast" [sxp $ ref i31]
-    , ins "i31.get_s" []
+--     , ins "i31.get_s" []
-    , ins op []
+--     , ins op []
-    , ins "ref.i31" []
+--     , ins "ref.i31" []
-    , ins "local.set" [sxp (1+n)]
+--     , ins "local.set" [sxp (1+n)]
-    , e'
+--     , e'
-    ]
+--     ]
-  where
+--   where
-    g' = g & #vars <>~ [r]
+--     g' = g & #vars <>~ [r]
-    n = length (g ^. #vars)
+--     n = length (g ^. #vars)
 
 
 
-scm = ref eq
+-- scm = ref eq
 
 
 
-emitRuntime :: GenMod :> es => Eff es Runtime
+-- emitRuntime :: GenMod :> es => Eff es Runtime
-emitRuntime = mfix \runtime -> do
+-- emitRuntime = mfix \runtime -> do
-  heapObjectIdx <- Wasm.deftypeNamed "$heap-object" $ Wasm.sub [] $ Wasm.struct
+--   heapObjectIdx <- Wasm.deftypeNamed "$heap-object" $ Wasm.sub [] $ Wasm.struct
-    [ Wasm.mut i32 ]
+--     [ Wasm.mut i32 ]
-  -- cont stack
+--   -- cont stack
-  contType <- Wasm.deftype $ Wasm.func [i32] []
+--   contType <- Wasm.deftype $ Wasm.func [i32] []
-  contStackType <- Wasm.deftype $ array $ mut $ refnull (fromIdx contType)
+--   contStackType <- Wasm.deftype $ array $ mut $ refnull (fromIdx contType)
-  contStackTop <- Wasm.defglobal (mut i32) $ ins "i32.const" [sxp @Int 0]
+--   contStackTop <- Wasm.defglobal (mut i32) $ ins "i32.const" [sxp @Int 0]
-  contStack <- Wasm.defglobal (ref (Wasm.fromIdx contStackType)) $
+--   contStack <- Wasm.defglobal (ref (Wasm.fromIdx contStackType)) $
-    ins "i32.const" [sxp @Int 128]
+--     ins "i32.const" [sxp @Int 128]
-    <> ins "array.new_default" [sxp contStackType]
+--     <> ins "array.new_default" [sxp contStackType]
-  -- arg array
+--   -- arg array
-  argArrayType <- Wasm.deftype $ Wasm.array $ mut $ refnull eq
+--   argArrayType <- Wasm.deftype $ Wasm.array $ mut $ refnull eq
-  argArray <- Wasm.defglobal (ref (Wasm.fromIdx argArrayType)) $
+--   argArray <- Wasm.defglobal (ref (Wasm.fromIdx argArrayType)) $
-    ins "i32.const" [sxp @Int 32]
+--     ins "i32.const" [sxp @Int 32]
-    <> ins "array.new_default" [sxp argArrayType]
+--     <> ins "array.new_default" [sxp argArrayType]
-  -- consIdx <- Wasm.defun _ _ _ _
+--   -- consIdx <- Wasm.defun _ _ _ _
-  result <- Wasm.defglobal (mut (refnull eq)) $ ins "ref.null" [sxp eq]
+--   result <- Wasm.defglobal (mut (refnull eq)) $ ins "ref.null" [sxp eq]
-  halt <- Wasm.defun [i32] [] (replicate 5 scm) \_ ->
+--   halt <- Wasm.defun [i32] [] (replicate 5 scm) \_ ->
-    pure . mconcat $
+--     pure . mconcat $
-      [ popArg runtime 0
+--       [ popArg runtime 0
-      , ins "global.set" [sxp result]
+--       , ins "global.set" [sxp result]
-      ]
+--       ]
-  pure $ MkRuntime
+--   pure $ MkRuntime
-    {argArray,argArrayType
+--     {argArray,argArrayType
-    ,contStack,contStackTop,contStackType,contType
+--     ,contStack,contStackTop,contStackType,contType
-    ,result,halt}
+--     ,result,halt}
-  -- pure $ error "todo"
+--   -- pure $ error "todo"
 
-lower :: Exp -> Eff es Text
+-- lower :: Exp -> Eff es Text
-lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do
+-- lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do
-  runtime <- emitRuntime
+--   runtime <- emitRuntime
-  let g = MkEnv runtime mempty mempty
+--   let g = MkEnv runtime mempty mempty
-  scm_entry <- Wasm.defun [i32] [] (replicate 5 scm) \_ ->
+--   scm_entry <- Wasm.defun [i32] [] (replicate 5 scm) \_ ->
-    lower' g e
+--     lower' g e
-  main <- Wasm.defun [] [scm] [scm, scm, scm, scm, scm] \_ ->
+--   main <- Wasm.defun [] [scm] [scm, scm, scm, scm, scm] \_ ->
-    pure . mconcat $
+--     pure . mconcat $
-      -- push return cont
+--       -- push return cont
-      [--  ins "ref.func" [sxp halt]
+--       [--  ins "ref.func" [sxp halt]
-      -- make call
+--       -- make call
-      ins "i32.const" [sxp @Int 0]
+--       ins "i32.const" [sxp @Int 0]
-      , ins "call" [sxp scm_entry]
+--       , ins "call" [sxp scm_entry]
-      , ins "global.get" [sxp runtime.result]
+--       , ins "global.get" [sxp runtime.result]
-      , ins "ref.as_non_null" []
+--       , ins "ref.as_non_null" []
-      ]
+--       ]
-  Wasm.export "main" "func" main
+--   Wasm.export "main" "func" main
 
-lowerProgram :: Program -> Eff es Text
+-- lowerProgram :: Program -> Eff es Text
-lowerProgram (MkProgram e) = lower e
+-- lowerProgram (MkProgram e) = lower e
+
+lower = _
+lowerProgram = _
+
+antiquote_example =
+  let
+    metavar :: Integer
+    metavar = 123
+
+    e1 :: Wasm.Expr
+    e1 = [expr|
+      (func $blah (result i32)
+        (i32.const #{metavar}))
+    |]
+
+    e2 :: Wasm.Expr
+    e2 = [expr|
+      (func $blah (result i32)
+        (i32.const 123))
+    |]
+  in (metavar,e1,e2,e1==e2)
+
+antiquote_splicing_example =
+  let
+    metavars :: List Sexp
+    metavars = [sxs'|i32 i64 f64|]
+
+    e1 :: Wasm.Expr
+    e1 = [expr|
+      (func $blah (param ##{metavars}))
+    |]
+
+    e2 :: Wasm.Expr
+    e2 = [expr|
+      (func $blah (param i32 i64 f64))
+    |]
+  in (metavars, e1, e2, e1 == e2)

src/Gyehoek/CPS/Syntax.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE PatternSynonyms #-}
 module Gyehoek.CPS.Syntax
   ( Val(..)
   , Kappa(..)

src/Gyehoek/Scheme/Syntax.hs

@@ -23,7 +23,6 @@ module Gyehoek.Scheme.Syntax
   , qexp
   , qprog
   , subst
-  , freeVariables
   )
   where
 
@@ -254,13 +253,3 @@ subst f = \e -> cata go e mempty where
   go (ExpLetF _ _) _ = error "todo lol"
   go (ExpLambdaF bs e) bound = e $ insertFrom bs bound
   go e bound = embed $ fmap ($ bound) e
-
--- | Unlawful!
-freeVariables :: Traversal Exp Exp Name Exp
-freeVariables k = \e -> cataA go e mempty where
-  go (ExpVarF x) bound
-    | not (x `HS.member` bound) = k x
-    | otherwise                 = pure $ ExpVar x
-  go (ExpLetF _ _) _ = error "todo lol"
-  go (ExpLambdaF bs e) bound = e $ insertFrom bs bound
-  go e bound = embed <$> traverse ($ bound) e

src/Gyehoek/Sexp.hs

@@ -34,11 +34,16 @@ module Gyehoek.Sexp
   , sxs
   , makeSx
   , makeSxs
+  , toSexp
+  , fromSexp
+  , stripLocation
+  , sx'
+  , sxs'
   )
 where
 
 import Data.Text (Text)
-import Language.SexpGrammar as Sexp hiding (toSexp, List, encode, decode, encodeWith, decodeWith, iso, encodePrettyWith, encodePretty)
+import Language.SexpGrammar as Sexp hiding (toSexp, List, encode, decode, encodeWith, decodeWith, iso, encodePrettyWith, encodePretty, fromSexp)
 import Language.SexpGrammar qualified as Sexp
 import Language.Sexp qualified as S
 import Language.SexpGrammar.Generic
@@ -67,6 +72,9 @@ import qualified Data.Text as T
 import qualified Control.Category
 import Data.Data (Data, Typeable, cast)
 import Language.Haskell.TH.Syntax (lift, Lift)
+import GHC.IsList (fromList)
+import Data.Functor.Foldable (cata)
+import Data.Functor.Classes (Show1(..))
 
 
 sexp :: SexpIso a => Iso' a Text
@@ -95,21 +103,21 @@ encodePrettyWith g =
 
 parseSexps :: SexpIso a => FilePath -> Text -> Either String (List a)
 parseSexps f = marshal . SL.parseSexps f . view lazy . encodeUtf8
-  where marshal = join . traverseOf (_Right . each) (fromSexp sexpIso)
+  where marshal = join . traverseOf (_Right . each) (Sexp.fromSexp sexpIso)
 
 parseSexp :: SexpIso a => FilePath -> Text -> Either String a
 parseSexp f = marshal . SL.parseSexp f . view lazy . encodeUtf8
-  where marshal = join . traverseOf _Right (fromSexp sexpIso)
+  where marshal = join . traverseOf _Right (Sexp.fromSexp sexpIso)
 
 parseSexpsWithPos :: SexpGrammar a -> Position -> Text -> Either String (List a)
 parseSexpsWithPos g pos =
   marshal . SL.parseSexpsWithPos pos . view lazy . encodeUtf8
-  where marshal = join . traverseOf (_Right . each) (fromSexp g)
+  where marshal = join . traverseOf (_Right . each) (Sexp.fromSexp g)
 
 parseSexpWithPos :: SexpGrammar a -> Position -> Text -> Either String a
 parseSexpWithPos g pos =
   marshal . SL.parseSexpWithPos pos . view lazy . encodeUtf8
-  where marshal = join . traverseOf _Right (fromSexp g)
+  where marshal = join . traverseOf _Right (Sexp.fromSexp g)
 
 nonEmptyGrammar :: Grammar p (NonEmpty x :- t) (List x :- x :- t)
 nonEmptyGrammar = IGB.Iso
@@ -231,21 +239,15 @@ getPos = do
   Loc {loc_filename,loc_start} <- location
   pure $ SL.Position loc_filename (fst loc_start) (snd loc_start)
 
-makeSxs :: Data b => SexpGrammar a -> (List a -> b) -> QuasiQuoter
+fromSexp :: SexpIso a => Sexp -> a
-makeSxs g f = QuasiQuoter
+fromSexp = either error id . Sexp.fromSexp sexpIso
-  { quoteExp = \str -> do
-      pos <- getPos
-      case parseSexpsWithPos g pos (T.pack str) of
-        Left e -> fail e
-        Right xs -> dataToExpQ (const Nothing) (f xs)
-  , quotePat = undefined
-  , quoteType = undefined
-  , quoteDec = undefined
-  }
 
 toSexp :: SexpIso a => a -> Sexp
 toSexp = either error id . Sexp.toSexp sexpIso
 
+toSexps :: (Foldable f, SexpIso a) => f a -> List Sexp
+toSexps = foldMap \x -> [toSexp x]
+
 pattern Unquote x =
   SL.Modified Hash (SL.BraceList [SL.Symbol x])
 pattern UnquoteSplicing x =
@@ -262,12 +264,17 @@ instance Each Sexp Sexp Sexp Sexp where
   each k (SL.BraceList xs)              = SL.BraceList <$> traverse k xs
   each _ e@(SL.Atom _; SL.Modified _ _) = pure e
 
+stripLocation :: Sexp -> Sexp
+stripLocation = cata \case
+  SL.Compose (a SL.:< e) ->
+    SL.Fix . SL.Compose $ SL.dummyPos SL.:< e
+
 metaSexp :: Sexp.Sexp -> Maybe ExpQ
 metaSexp (Unquote x) =
-  Just [| toSexp $(varE (mkName (T.unpack x))) |]
+  Just [| stripLocation . toSexp $ $(varE (mkName (T.unpack x))) |]
 metaSexp (SL.ParenList xs)
   | (_:_) <- xs ^.. each . _UnquoteSplicing
-  = Just [| SL.ParenList (mconcat $(listE spans)) |]
+  = Just [| stripLocation . toSexp $ SL.ParenList (mconcat $(listE spans)) |]
   where
     spans = xs
       & groupBy \cases
@@ -275,8 +282,9 @@ metaSexp (SL.ParenList xs)
           _ (UnquoteSplicing _) -> False
           _ _                   -> True
       & fmap \case
-        [UnquoteSplicing x] -> varE (mkName (T.unpack x))
+        [UnquoteSplicing x] ->
-        x -> lift x
+          [| stripLocation <$> toSexps $(varE (mkName (T.unpack x))) |]
+        x -> [| stripLocation <$> x |]
 metaSexp _ = Nothing
 
 -- 뻘짓뻘짓뻘짓뻘짓뻘짓
@@ -287,10 +295,10 @@ lift1 :: (Lift1 f, Lift a, Quote m) => f a -> m Exp
 lift1 = liftLift lift
 
 instance Lift1 f => Lift (SL.Fix f) where
-  lift (SL.Fix inner) = appE [|Fix|] (lift1 inner)
+  lift (SL.Fix inner) = appE [|SL.Fix|] (lift1 inner)
 
 instance (Lift1 f, Lift1 g) => Lift1 (SL.Compose f g) where
-  liftLift l (SL.Compose fga) = [|Compose $(liftLift (liftLift l) fga)|]
+  liftLift l (SL.Compose fga) = [|SL.Compose $(liftLift (liftLift l) fga)|]
 
 instance Lift a => Lift1 (SL.LocatedBy a) where
   liftLift l (a SL.:< e) = [|(SL.:<) $(lift a) $(l e)|]
@@ -314,17 +322,36 @@ deriving instance Lift SL.Prefix
 extQ :: (Typeable a, Typeable b) => (a -> r) -> (b -> r) -> a -> r
 extQ f g a = maybe (f a) g (cast a)
 
-makeSx :: Data a => SexpGrammar a -> QuasiQuoter
+makeSxs
-makeSx g = QuasiQuoter
+  :: Data b
+  => (List a -> b) -> SexpGrammar a -> QuasiQuoter
+makeSxs f g = QuasiQuoter
   { quoteExp = \str -> do
       pos <- getPos
-      case parseSexpWithPos g pos (T.pack str) of
+      case parseSexpsWithPos g pos (T.pack str) of
         Left e -> fail e
-        Right x -> dataToExpQ (const Nothing `extQ` metaSexp) x
+        Right xs -> dataToExpQ (const Nothing `extQ` metaSexp) (f xs)
   , quotePat = undefined
   , quoteType = undefined
   , quoteDec = undefined
   }
 
-sxs = makeSxs (sexpIso @Sexp) id
+makeSx
-sx = makeSx (sexpIso @Sexp)
+  :: (Data a, Data r)
+  => (a -> r) -> SexpGrammar a -> QuasiQuoter
+makeSx f g = QuasiQuoter
+  { quoteExp = \str -> do
+      pos <- getPos
+      case parseSexpWithPos g pos (T.pack str) of
+        Left e -> fail e
+        Right x -> dataToExpQ (const Nothing `extQ` metaSexp) (f x)
+  , quotePat = undefined
+  , quoteType = undefined
+  , quoteDec = undefined
+  }
+
+sxs = makeSxs id (sexpIso @Sexp)
+sx = makeSx id (sexpIso @Sexp)
+
+sxs' = makeSxs (fmap stripLocation) (sexpIso @Sexp)
+sx' = makeSx stripLocation (sexpIso @Sexp)

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 }
+newtype Expr = MkExpr { inner :: Vector Instr }
-  deriving (Show, Generic)
+  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)