unitype

src/Gyehoek/Wasm.hs

@@ -11,13 +11,14 @@
 {-# LANGUAGE DerivingVia #-}
 module Gyehoek.Wasm
   ( defun
-  , deftype
+  , rec'
   , start
   , runGenMod
   , execGenMod
   , renderModule
   , Module
   , Function
+  , Type(..)
   , Expr
   , Instr
   , GenMod
@@ -32,11 +33,18 @@ module Gyehoek.Wasm
   , eq
   , i31ref
   , i31
+  , struct
+  , mut
+  , sub
+  , deftype
+  , namedType
+  , type'
+  , deftypeNamed
   )
   where
 
 import Language.SexpGrammar
-  ( SexpIso(..), list, el, (>>>), rest, sym, symbol )
+  ( SexpIso(..), list, el, (>>>), rest, sym, symbol, (:-) )
 import Language.SexpGrammar qualified as Sexp
 import Language.SexpGrammar.Generic
 import Data.List (List)
@@ -64,10 +72,11 @@ import qualified Gyehoek.Sexp
 import GHC.IsList (IsList(..))
 import Data.Coerce (coerce)
 import qualified Control.Category
+import Data.Functor (void)
 
 
 data Module = MkModule
-  { types :: Vector Type
+  { types :: Vector RecType
   , functions :: Vector Function
   , start :: Maybe Idx
   , exports :: Vector Export
@@ -85,6 +94,9 @@ instance Semigroup Module where
 instance Monoid Module where
   mempty = MkModule mempty mempty Nothing mempty
 
+newtype RecType = MkRecType { inner :: Vector Type }
+  deriving (Show, Generic)
+
 data Function = MkFunction
   { params :: List Type
   , result :: List Type
@@ -106,11 +118,13 @@ newtype Instr = MkInstr { inner :: Sexp }
 newtype Type = MkType { inner :: Sexp }
   deriving (Show, Generic)
 
-newtype Idx = MkIdx { getIdx :: Natural }
-  deriving newtype (Show)
+data Idx
+  = IdxNumeric Natural
+  | IdxNamed Text
+  deriving (Show, Generic)
 
 data GenMod :: Effect where
-  DefType :: Type -> GenMod m Idx
+  DefRecType :: List Type -> GenMod m (List Idx)
   Defun :: List Type -> List Type -> List Type -> (Idx -> Expr) -> GenMod m Idx
   Start :: Idx -> GenMod m ()
   Export :: Text -> Text -> Idx -> GenMod m ()
@@ -123,8 +137,16 @@ export name ty idx = send $ Export name ty idx
 start :: (GenMod :> es) => Idx -> Eff es ()
 start = send . Start
 
+rec' :: (GenMod :> es) => List Type -> Eff es (List Idx)
+rec' = send . DefRecType
+
 deftype :: (GenMod :> es) => Type -> Eff es Idx
-deftype = send . DefType
+deftype (MkType t) = send (DefRecType [type' t]) <&> \case
+  [x] -> x
+  x -> error $ "unreachable " <> show x
+
+deftypeNamed :: (GenMod :> es) => Text -> Type -> Eff es ()
+deftypeNamed name (MkType t) = void $ send (DefRecType [namedType name t])
 
 defun
   :: (GenMod :> es)
@@ -144,20 +166,21 @@ defun params result locals code = send $ Defun params result locals code
 runGenMod :: Eff (GenMod : es) a -> Eff es (a, Module)
 runGenMod = 
   reinterpret (runStateLocal (mempty :: Module)) \cases
-    _ (DefType t) -> state \m ->
-     ( MkIdx . fromIntegral . length $ m.types
-     , m & #types <>~ V.singleton t
+    _ (DefRecType ts) -> state \m ->
+     ( let prev_n = sumOf (#types . each . #inner . to V.length) m
+       in IdxNumeric . fromIntegral <$> [prev_n .. prev_n + length ts - 1]
+     , m & #types <>~ V.singleton (MkRecType (V.fromList ts))
      )
     _ (Start idx) -> assign #start (Just idx)
     _ (Export name ty idx) ->
        #exports <>= V.singleton e
       where e = MkExport $ ParenList
               [ "export", sxp name, ParenList [ "func", sxp idx ] ]
-    _ (Defun params result locals code) -> state \m ->
-      let idx = MkIdx . fromIntegral . length $ m.functions
+    _ (Defun params res locals code) -> state \m ->
+      let idx = IdxNumeric . fromIntegral . length $ m.functions
       in ( idx
          , m & #functions <>~ V.singleton
-             (MkFunction params result locals (code idx))
+             (MkFunction params res locals (code idx))
          )
 
 execGenMod = fmap snd . runGenMod
@@ -168,6 +191,18 @@ renderModule = (^?! _Right) . Gyehoek.Sexp.encodePretty
 ref :: Type -> Type
 ref (MkType x) = MkType . ParenList $ [Symbol "ref", x]
 
+sub :: List Idx -> Type -> Type
+sub supers (MkType x) = MkType . ParenList $
+  Symbol "sub" : (sxp <$> supers) ++ [x]
+
+mut :: Type -> Type
+mut (MkType x) = MkType . ParenList $ [Symbol "mut", x]
+
+struct :: List Type -> Type
+struct xs = MkType . ParenList $
+  Symbol "struct" : (xs ^.. each . #inner . to field)
+  where field x = ParenList [Symbol "field", x]
+
 i32, i31ref, eq, i31 :: Type
 i32 = MkType $ Symbol "i32"
 i31ref = MkType $ Symbol "i31ref"
@@ -177,11 +212,40 @@ i31 = MkType $ Symbol "i31"
 
 
 instance SexpIso Idx where
-  sexpIso = Sexp.integer >>> Sexp.partialOsi f g
+  sexpIso = match
+    $ With (\numeric -> num >>> numeric)
+    $ With (\named -> symbol >>> named)
+    $ End
     where
-      f n | n < 0 = Left $ Sexp.unexpected "negative" <> Sexp.expected "natural"
-          | otherwise = Right . MkIdx $ fromIntegral n
-      g (MkIdx n) = fromIntegral n
+      num = Sexp.integer >>> Sexp.partialOsi f g
+        where
+          f n | n < 0 = Left $ Sexp.unexpected "negative"
+                            <> Sexp.expected "natural"
+              | otherwise = Right $ fromIntegral n
+          g n = fromIntegral n
+
+instance SexpIso RecType where
+  sexpIso = with \rectype ->
+    Sexp.coproduct
+     [ sexpIso @Type >>> Sexp.partialIso
+       (\x -> [x])
+       (\case [x] -> Right x
+              _ -> Left $ Sexp.expected "a single type")
+     , list (el (sym "rec") >>> rest sexpIso)
+     ]
+    >>> Sexp.iso V.fromList V.toList
+    >>> rectype
+    -- where
+    --   typedef
+    --     :: forall a t. Sexp.Grammar Position (Sexp :- t) (a :- t)
+    --     -> Sexp.Grammar Position (Sexp :- t) (a :- t)
+    --   typedef x = list (el (sym "type") >>> el x)
+
+type' :: Sexp -> Type
+type' e = MkType . ParenList $ [ "type", e ]
+
+namedType :: Text -> Sexp -> Type
+namedType name e = MkType . ParenList $ [ "type", Symbol name, e ]
 
 instance SexpIso Instr where
   sexpIso = Sexp.iso coerce coerce
@@ -213,7 +277,7 @@ instance SexpIso Module where
   sexpIso = Sexp.partialOsi (const $ Left mempty) \m ->
     ParenList $
       [ Symbol "module" ]
-      <> (m ^.. #types . each . #inner)
+      <> (m ^.. #types . each . to sxp)
       <> (m ^.. #functions . each . to sxp)
       <> (m ^.. #exports . each . to sxp)