we r so bak

app/Gyehoek/CPS/Lower.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -28,6 +29,9 @@ import Text.Printf
 import qualified Data.Text as T
 import qualified Data.Vector.Strict as V
 import Data.IntMap.Strict (IntMap)
+import Data.String.Interpolate
+import Gyehoek.Wasm qualified as Wasm
+import Gyehoek.Wasm (i32)
 
 
 data Env = MkEnv { vars :: Vector Name }
@@ -49,18 +53,18 @@ tshow = T.pack . show
 
 
 
-lowerVal :: Env -> Val -> Vector Text
+lowerVal :: Env -> Val -> Wasm.Expr
 
 lowerVal g (ValLit l) =
   case l of
-    LitInt n -> [ "i32.const " <> tshow n ]
+    LitInt n -> [i|i32.const #{n}|]
     _ -> _
 
-lowerVal g (ValVar x) = [ "local.get " <> tshow i ]
+lowerVal g (ValVar x) = [i|local.get #{l}|]
   where
-    i = V.elemIndex x g.vars ^?! _Just
+    l = V.elemIndex x g.vars ^?! _Just
 
-lower' :: Env -> Exp -> Vector Text
+lower' :: Env -> Exp -> Wasm.Expr
 
 lower' g (Halt [e]) = lowerVal g e
 
@@ -71,10 +75,14 @@ lower' g (ExpPrim p rs e) =
   where
     r = head rs
 
+lowerBinOp
+  :: _
+  -> _ -> _ -> _ -> _ -> _ -> Wasm.Expr
 lowerBinOp op g x y r e =
   lowerVal g x
   <> lowerVal g y
-  <> [ op, "local.set " <> tshow n ]
+  <> op
+  <> [i|local.set #{n}|]
   <> lower' g' e
   where
     g' = g & #vars <>~ [r]
@@ -82,14 +90,8 @@ lowerBinOp op g x y r e =
 
 
 
-makeFunc :: Vector Text -> Text
-makeFunc = (preamble<>) . (<>postamble) . T.unlines . toList . fmap indent
-  where
-    indent = ("    "<>)
-    preamble  = "(module\n\
-                \  (func (export \"main\") (result i32)\n\
-                \    (local i32 i32 i32 i32 i32 i32)\n"
-    postamble = "  ))"
-
 lower :: Exp -> Eff es Text
-lower = pure . makeFunc . lower' emptyEnv
+lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do
+  idx <- Wasm.defun [] [i32] [i32, i32, i32, i32, i32] \_ ->
+    lower' emptyEnv e
+  Wasm.export "main" "func" idx

app/Gyehoek/GenSym.hs

@@ -35,3 +35,11 @@ runGenSym = reinterpret (evalStateLocal (0 :: Natural)) \cases
 instance Gen Text where
   gen = fromString . ('x':) . show
   gen' s = (s <>) . fromString . show
+
+instance Gen Natural where
+  gen = id
+  gen' = const id
+
+instance Gen Int where
+  gen = fromIntegral
+  gen' _ = fromIntegral

app/Gyehoek/Wasm.hs

@@ -1,19 +1,62 @@
 {- HLINT ignore "Use newtype instead of data" -}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE NoFieldSelectors #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE OverloadedLabels #-}
 module Gyehoek.Wasm
-  ()
+  ( defun
+  , deftype
+  , start
+  , runGenMod
+  , execGenMod
+  , renderModule
+  , Module
+  , Function
+  , Expr
+  , Instr
+  , GenMod
+  , i32
+  , export
+  )
   where
 
 import Data.List (List)
 import GHC.Generics (Generic)
+import Data.Text (Text)
+import Data.String (IsString (fromString))
+import Text.Printf
+import Effectful
+import Numeric.Natural (Natural)
+import Effectful.Dispatch.Dynamic
+import Effectful.State.Dynamic
+import Control.Lens
+import Data.Generics.Labels
+import Data.Vector (Vector)
+import Data.String.Interpolate
+import qualified Data.Vector as V
+import qualified Data.Text as T
+import Effectful.Writer.Dynamic
+import Control.Applicative (Alternative((<|>)))
 
 
 data Module = MkModule
-  { typeSection :: List Type
+  { types :: Vector Type
+  , functions :: Vector Function
+  , start :: Maybe Idx
+  , exports :: Vector Export
   }
   deriving (Show, Generic)
 
-data Type
+instance Semigroup Module where
-  deriving (Show, Generic)
+  m1 <> m2 = MkModule
+    { types = m1.types <> m2.types
+    , functions = m1.functions <> m2.functions
+    , start = m2.start <|> m1.start
+    , exports = m1.exports <> m2.exports
+    }
+
+instance Monoid Module where
+  mempty = MkModule mempty mempty Nothing mempty
 
 data Function = MkFunction
   { params :: List Type
@@ -23,6 +66,125 @@ data Function = MkFunction
   }
   deriving (Show, Generic)
 
-type Expr = List Instr
+newtype Export = MkExport { getExport :: Text }
+  deriving (Generic)
+  deriving newtype (Show, IsString)
 
-type Instr = ByteString
+newtype Expr = MkExpr { getExpr :: Vector Instr }
+  deriving (Generic)
+  deriving newtype (Semigroup, Monoid)
+
+instance IsString Expr where
+  fromString s = MkExpr . V.fromList $ fromString <$> lines s
+
+instance Show Expr where
+  show e = unlines . fmap show . V.toList $ e.getExpr
+
+newtype Instr = MkInstr { getInstr :: Text }
+  deriving (Generic)
+  deriving newtype (IsString)
+
+instance Show Instr where
+  show e = T.unpack e.getInstr
+
+newtype Type = MkType { getType :: Text }
+  deriving (Generic)
+  deriving newtype (Show, IsString)
+
+newtype Idx = MkIdx { getIdx :: Natural }
+  deriving newtype (Show)
+
+data GenMod :: Effect where
+  DefType :: Type -> GenMod m Idx
+  Defun :: List Type -> List Type -> List Type -> (Idx -> Expr) -> GenMod m Idx
+  Start :: Idx -> GenMod m ()
+  Export :: Text -> Text -> Idx -> GenMod m ()
+
+type instance DispatchOf GenMod = Dynamic
+
+export :: (GenMod :> es) => Text -> Text -> Idx -> Eff es ()
+export name ty idx = send $ Export name ty idx
+
+start :: (GenMod :> es) => Idx -> Eff es ()
+start = send . Start
+
+deftype :: (GenMod :> es) => Type -> Eff es Idx
+deftype = send . DefType
+
+defun
+  :: (GenMod :> es)
+  => List Type -> List Type -> List Type
+  -> (Idx -> Expr)
+  -> Eff es Idx
+defun params result locals code = send $ Defun params result locals code
+
+-- defun
+--   :: (GenMod :> es)
+--   => List Type -> List Type -> List Type
+--   -> (Idx -> Eff '[GenExp] a)
+--   -> Eff es Idx
+-- defun params result locals code =
+--   send $ Defun params result locals (runPureEff . execWriterLocal . 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
+     )
+    _ (Start idx) -> assign #start (Just idx)
+    _ (Export name ty idx) ->
+       #exports <>= V.singleton [i|(export #{show name} (#{ty} #{idx}))|]
+    _ (Defun params result locals code) -> state \m ->
+      let idx = MkIdx . fromIntegral . length $ m.functions
+      in ( idx
+         , m & #functions <>~ V.singleton
+             (MkFunction params result locals (code idx))
+         )
+
+execGenMod = fmap snd . runGenMod
+
+indent n = (T.replicate n " " <>)
+
+unlines' :: Foldable f => f Text -> Text
+unlines' = foldr f ""
+  where
+    f a "" = a
+    f a b = a <> "\n" <> b
+
+renderModule :: Module -> Text
+renderModule m = [__i|
+  (module
+    #{types}
+    #{functions}
+    #{strt}
+    #{exports})
+|]
+  where
+    strt :: Text
+    strt = case m.start of
+      Just x -> [i|(start #{x})|]
+      Nothing -> ""
+    exports = unlines' $ view #getExport <$> m.exports
+    types = foldMapOf (#types . each . #getType) (indent 2) m
+    functions = unlines' $
+      indent 2 . showfunc <$> m.functions
+    showtypes ts = T.unwords $ fmap (\x -> x.getType) ts
+    showfunc :: Function -> Text
+    showfunc func = [__i|
+      (func (param #{params})
+            (result #{result})
+            (local #{locals})
+        #{body})
+    |]
+      where
+        params = showtypes func.params
+        result = showtypes func.result
+        locals = showtypes func.locals
+        body = unlines' $ indent 4 . view #getInstr <$> func.body.getExpr
+
+type GenExp = Writer Expr
+
+i32 :: Type
+i32 = "i32"

gyehoek.cabal

@@ -29,6 +29,7 @@ common ghcstuffs
     OverloadedStrings
     PartialTypeSignatures
     PatternSynonyms
+    QuasiQuotes
 
 executable gyehoek
   import:           ghcstuffs, ghcstuffs-dev
@@ -70,6 +71,7 @@ executable gyehoek
     , text-short
     , unordered-containers
     , vector
+    , string-interpolate
 
   hs-source-dirs:   app
   default-language: GHC2024

t.wat

@@ -0,0 +1,20 @@
+(module
+  
+    (func (param )
+      (result i32)
+      (local i32 i32 i32 i32 i32)
+      i32.const 3
+    i32.const 4
+    i32.mul
+    local.set 0
+    i32.const 2
+    i32.const 5
+    i32.mul
+    local.set 1
+    local.get 0
+    local.get 1
+    i32.add
+    local.set 2
+    local.get 2)
+  
+  (export "main" (func 0)))