higher-order defun

src/Gyehoek/Wasm.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE DeepSubsumption #-}
 {-# LANGUAGE NoFieldSelectors #-}
 {-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE RecordPuns #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE OverloadedLabels #-}
@@ -22,6 +23,7 @@ module Gyehoek.Wasm
   , Expr
   , Instr
   , GenMod
+  , Idx
   , i32
   , export
   , ins
@@ -125,7 +127,8 @@ data Idx
 
 data GenMod :: Effect where
   DefRecType :: List Type -> GenMod m (List Idx)
-  Defun :: List Type -> List Type -> List Type -> (Idx -> Expr) -> GenMod m Idx
+  Defun :: List Type -> List Type -> List Type
+        -> (Idx -> m Expr) -> GenMod m Idx
   Start :: Idx -> GenMod m ()
   Export :: Text -> Text -> Idx -> GenMod m ()
 
@@ -151,9 +154,9 @@ deftypeNamed name (MkType t) = void $ send (DefRecType [namedType name t])
 defun
   :: (GenMod :> es)
   => List Type -> List Type -> List Type
-  -> (Idx -> Expr)
+  -> (Idx -> Eff es Expr)
   -> Eff es Idx
-defun params result locals code = send $ Defun params result locals code
+defun params res locals code = send $ Defun params res locals code
 
 -- defun
 --   :: (GenMod :> es)
@@ -163,7 +166,7 @@ defun params result locals code = send $ Defun params result locals code
 -- defun params result locals code =
 --   send $ Defun params result locals (runPureEff . execWriterLocal . code)
 
-runGenMod :: Eff (GenMod : es) a -> Eff es (a, Module)
+runGenMod :: forall es a. Eff (GenMod : es) a -> Eff es (a, Module)
 runGenMod = 
   reinterpret (runStateLocal (mempty :: Module)) \cases
     _ (DefRecType ts) -> state \m ->
@@ -176,12 +179,18 @@ runGenMod =
        #exports <>= V.singleton e
       where e = MkExport $ ParenList
               [ "export", sxp name, ParenList [ "func", sxp idx ] ]
-    _ (Defun params res locals code) -> state \m ->
-      let idx = IdxNumeric . fromIntegral . length $ m.functions
-      in ( idx
-         , m & #functions <>~ V.singleton
-             (MkFunction params res locals (code idx))
-         )
+    env (Defun params result locals code) ->
+      localSeqUnlift env \unlift ->
+        stateM \m -> do
+          -- the least unused function index, computed as the number
+          -- of currently allocated functions.
+          let idx = IdxNumeric . fromIntegral . length $ m.functions
+          -- the body is computed with access to the newly allocated
+          -- index `idx` for the sake of recursive occurences.
+          body <- unlift $ code idx
+          let func = MkFunction {params,result,locals,body}
+          let m' = m & #functions <>~ V.singleton func
+          pure (idx, m')
 
 execGenMod = fmap snd . runGenMod
 
@@ -214,7 +223,7 @@ i31 = MkType $ Symbol "i31"
 instance SexpIso Idx where
   sexpIso = match
     $ With (\numeric -> num >>> numeric)
-    $ With (\named -> symbol >>> named)
+    $ With (\named -> name >>> named)
     $ End
     where
       num = Sexp.integer >>> Sexp.partialOsi f g
@@ -223,6 +232,11 @@ instance SexpIso Idx where
                             <> Sexp.expected "natural"
               | otherwise = Right $ fromIntegral n
           g n = fromIntegral n
+      l :: Prism' Text Text
+      l = prefixed "$"
+      name = Sexp.symbol >>> Sexp.partialOsi
+        (maybe (Left $ Sexp.expected "$-prefixed sym") Right . preview l)
+        (review l)
 
 instance SexpIso RecType where
   sexpIso = with \rectype ->
@@ -287,8 +301,8 @@ instance SexpIso Sexp where
 instance Each Expr Expr Instr Instr where
   each = #MkExpr . each
 
-sxp :: SexpIso a => a -> Sexp
-sxp e = Sexp.toSexp sexpIso e ^?! _Right
+sxp :: HasCallStack => SexpIso a => a -> Sexp
+sxp e = either error id . Sexp.toSexp sexpIso $ e
 
 ins :: Text -> List Sexp -> Expr
 ins op [] = [ MkInstr $ Symbol op ]