lam

src/Gyehoek/Wasm.hs

@@ -42,6 +42,11 @@ module Gyehoek.Wasm
   , namedType
   , type'
   , deftypeNamed
+  , defglobal
+  , array
+  , FromIdx(..)
+  , func
+  , refnull
   )
   where
 
@@ -82,6 +87,7 @@ data Module = MkModule
   , functions :: Vector Function
   , start :: Maybe Idx
   , exports :: Vector Export
+  , globals :: Vector Global
   }
   deriving (Show, Generic)
 
@@ -94,7 +100,13 @@ instance Semigroup Module where
     }
 
 instance Monoid Module where
-  mempty = MkModule mempty mempty Nothing mempty
+  mempty = MkModule mempty mempty Nothing mempty mempty
+
+data Global = MkGlobal
+  { ty :: Type
+  , body :: Expr
+  }
+  deriving (Show, Generic)
 
 newtype RecType = MkRecType { inner :: Vector Type }
   deriving (Show, Generic)
@@ -131,6 +143,7 @@ data GenMod :: Effect where
         -> (Idx -> m Expr) -> GenMod m Idx
   Start :: Idx -> GenMod m ()
   Export :: Text -> Text -> Idx -> GenMod m ()
+  DefGlobal :: Type -> Expr -> GenMod m Idx
 
 type instance DispatchOf GenMod = Dynamic
 
@@ -151,6 +164,9 @@ deftype (MkType t) = send (DefRecType [type' t]) <&> \case
 deftypeNamed :: (GenMod :> es) => Text -> Type -> Eff es ()
 deftypeNamed name (MkType t) = void $ send (DefRecType [namedType name t])
 
+defglobal :: (GenMod :> es) => Type -> Expr -> Eff es Idx
+defglobal t e = send $ DefGlobal t e
+
 defun
   :: (GenMod :> es)
   => List Type -> List Type -> List Type
@@ -191,6 +207,10 @@ runGenMod =
           let func = MkFunction {params,result,locals,body}
           let m' = m & #functions <>~ V.singleton func
           pure (idx, m')
+    _ (DefGlobal t e) -> state \m ->
+      let prev_n = IdxNumeric . fromIntegral . V.length $ m.globals
+          m' = m & #globals <>~ V.singleton (MkGlobal t e)
+      in (prev_n, m')
 
 execGenMod = fmap snd . runGenMod
 
@@ -200,10 +220,16 @@ renderModule = (^?! _Right) . Gyehoek.Sexp.encodePretty
 ref :: Type -> Type
 ref (MkType x) = MkType . ParenList $ [Symbol "ref", x]
 
+refnull :: Type -> Type
+refnull (MkType x) = MkType . ParenList $ ["ref", "null", x]
+
 sub :: List Idx -> Type -> Type
 sub supers (MkType x) = MkType . ParenList $
   Symbol "sub" : (sxp <$> supers) ++ [x]
 
+array :: Type -> Type
+array (MkType x) = MkType . ParenList $ [Symbol "array", x]
+
 mut :: Type -> Type
 mut (MkType x) = MkType . ParenList $ [Symbol "mut", x]
 
@@ -212,12 +238,28 @@ struct xs = MkType . ParenList $
   Symbol "struct" : (xs ^.. each . #inner . to field)
   where field x = ParenList [Symbol "field", x]
 
+func :: List Type -> List Type -> Type
+func params results =
+  MkType . ParenList $
+    [ Symbol "func"
+    , wrap "param" params
+    , wrap "result" results
+    ]
+  where
+    wrap s xs = ParenList $ Symbol s : xs ^.. each . #inner
+
 i32, i31ref, eq, i31 :: Type
 i32 = MkType $ Symbol "i32"
 i31ref = MkType $ Symbol "i31ref"
 eq = MkType $ Symbol "eq"
 i31 = MkType $ Symbol "i31"
 
+class FromIdx a where
+  fromIdx :: Idx -> a
+
+instance FromIdx Type where
+  fromIdx (IdxNumeric n) = MkType . Symbol . T.pack . show $ n
+
 
 
 instance SexpIso Idx where
@@ -261,6 +303,14 @@ type' e = MkType . ParenList $ [ "type", e ]
 namedType :: Text -> Sexp -> Type
 namedType name e = MkType . ParenList $ [ "type", Symbol name, e ]
 
+instance SexpIso Global where
+  sexpIso = with \glob ->
+    list ( el (sym "global")
+         >>> el (sexpIso @Type)
+         >>> restCode
+         )
+    >>> glob
+
 instance SexpIso Instr where
   sexpIso = Sexp.iso coerce coerce
 
@@ -270,22 +320,26 @@ instance SexpIso Type where
 instance SexpIso Export where
   sexpIso = Sexp.iso coerce coerce
 
+restCode :: Sexp.Grammar Position (Sexp.List :- t) (Sexp.List :- (Expr :- t))
+restCode =
+  rest (sexpIso @Instr)
+  >>> Sexp.onTail
+           (Sexp.iso
+            (view instrsExpr)
+            (review instrsExpr))
+    where
+      instrsExpr :: Iso' (List Instr) Expr
+      instrsExpr = vector . coerced
+
 instance SexpIso Function where
   sexpIso = with \func ->
     list ( el (sym "func")
        >>> el (list $ el (sym "param") >>> rest (sexpIso @Type))
        >>> el (list $ el (sym "result") >>> rest (sexpIso @Type))
        >>> el (list $ el (sym "local") >>> rest (sexpIso @Type))
-       >>> rest (sexpIso @Instr)
-       >>> Sexp.onTail
-           (Sexp.iso
-            (view instrsExpr)
-            (review instrsExpr))
+       >>> restCode
          )
      >>> func
-    where
-      instrsExpr :: Iso' (List Instr) Expr
-      instrsExpr = vector . coerced
 
 instance SexpIso Module where
   sexpIso = Sexp.partialOsi (const $ Left mempty) \m ->