sexp

app/Gyehoek/CPS/Lower.hs

@@ -1,9 +1,9 @@
-{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE MultilineStrings #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# OPTIONS_GHC -Wno-incomplete-patterns #-}
 module Gyehoek.CPS.Lower
   (
@@ -31,7 +31,7 @@ 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)
+import Gyehoek.Wasm (i32, ins, sxp)
 
 
 data Env = MkEnv { vars :: Vector Name }
@@ -57,10 +57,10 @@ lowerVal :: Env -> Val -> Wasm.Expr
 
 lowerVal g (ValLit l) =
   case l of
-    LitInt n -> [i|i32.const #{n}|]
+    LitInt n -> [ ins "i32.const" [sxp n] ]
     _ -> _
 
-lowerVal g (ValVar x) = [i|local.get #{l}|]
+lowerVal g (ValVar x) = [ ins "local.get" [sxp l] ]
   where
     l = V.elemIndex x g.vars ^?! _Just
 
@@ -81,8 +81,8 @@ lowerBinOp
 lowerBinOp op g x y r e =
   lowerVal g x
   <> lowerVal g y
-  <> op
+  <> [ ins op [] ]
-  <> [i|local.set #{n}|]
+  <> [ ins "local.set" [sxp n] ]
   <> lower' g' e
   where
     g' = g & #vars <>~ [r]

app/Gyehoek/Sexp.hs

@@ -19,11 +19,13 @@ module Gyehoek.Sexp
   , lambda
   , kappaKeyword
   , lambdaKeyword
+  , encodePrettyWith
+  , encodePretty
   )
 where
 
 import Data.Text (Text)
-import Language.SexpGrammar as Sexp hiding (List, encode, decode, encodeWith, decodeWith, iso)
+import Language.SexpGrammar as Sexp hiding (List, encode, decode, encodeWith, decodeWith, iso, encodePrettyWith, encodePretty)
 import Language.SexpGrammar qualified as Sexp
 import Language.Sexp qualified as S
 import Language.SexpGrammar.Generic
@@ -59,9 +61,16 @@ decode = decodeWith sexpIso
 encodeWith :: SexpGrammar a -> a -> Either String Text
 encodeWith g = (_Right %~ decodeUtf8 . view strict) . Sexp.encodeWith g
 
+encodePretty :: SexpIso a => a -> Either String Text
+encodePretty = encodePrettyWith sexpIso
+
 decodeWith :: SexpGrammar a -> Text -> Either String a
 decodeWith g = Sexp.decodeWith g "FILE" . view lazy . encodeUtf8
 
+encodePrettyWith :: SexpGrammar a -> a -> Either String Text
+encodePrettyWith g =
+  (_Right %~ decodeUtf8 . view strict) . Sexp.encodePrettyWith g 
+
 parseSexps :: SexpIso a => FilePath -> Text -> Either String (List a)
 parseSexps f = marshal . SexpLoc.parseSexps f . view lazy . encodeUtf8
   where marshal = join . traverseOf (_Right . each) (fromSexp sexpIso)

app/Gyehoek/Wasm.hs

@@ -1,8 +1,13 @@
 {- HLINT ignore "Use newtype instead of data" -}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeepSubsumption #-}
 {-# LANGUAGE NoFieldSelectors #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE ImpredicativeTypes #-}
 module Gyehoek.Wasm
   ( defun
   , deftype
@@ -17,9 +22,15 @@ module Gyehoek.Wasm
   , GenMod
   , i32
   , export
+  , ins
+  , sxp
   )
   where
 
+import Language.SexpGrammar
+  ( SexpIso(..), list, el, (>>>), rest, sym, symbol )
+import Language.SexpGrammar qualified as Sexp
+import Language.SexpGrammar.Generic
 import Data.List (List)
 import GHC.Generics (Generic)
 import Data.Text (Text)
@@ -37,6 +48,13 @@ import qualified Data.Vector as V
 import qualified Data.Text as T
 import Effectful.Writer.Dynamic
 import Control.Applicative (Alternative((<|>)))
+import Control.Category qualified as Cat
+import Data.Vector.Lens
+import Data.Either (fromLeft, fromRight)
+import Language.Sexp.Located
+import qualified Gyehoek.Sexp
+import GHC.IsList (IsList(..))
+import Data.Coerce (coerce)
 
 
 data Module = MkModule
@@ -66,30 +84,18 @@ data Function = MkFunction
   }
   deriving (Show, Generic)
 
-newtype Export = MkExport { getExport :: Text }
+newtype Export = MkExport { inner :: Sexp }
-  deriving (Generic)
+  deriving (Show, Generic)
-  deriving newtype (Show, IsString)
 
-newtype Expr = MkExpr { getExpr :: Vector Instr }
+newtype Expr = MkExpr { inner :: Vector Instr }
-  deriving (Generic)
+  deriving (Show, Generic)
   deriving newtype (Semigroup, Monoid)
 
-instance IsString Expr where
+newtype Instr = MkInstr { inner :: Sexp }
-  fromString s = MkExpr . V.fromList $ fromString <$> lines s
+  deriving (Show, Generic)
 
-instance Show Expr where
+newtype Type = MkType { inner :: Sexp }
-  show e = unlines . fmap show . V.toList $ e.getExpr
+  deriving (Show, Generic)
-
-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)
@@ -135,7 +141,9 @@ runGenMod =
      )
     _ (Start idx) -> assign #start (Just idx)
     _ (Export name ty idx) ->
-       #exports <>= V.singleton [i|(export #{show 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
       in ( idx
@@ -145,46 +153,66 @@ runGenMod =
 
 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|
+renderModule = (^?! _Right) . Gyehoek.Sexp.encodePretty
-  (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"
+i32 = MkType $ Symbol "i32"
+
+
+
+instance SexpIso Idx where
+  sexpIso = Sexp.integer >>> Sexp.partialOsi f g
+    where
+      f n | n < 0 = Left $ Sexp.unexpected "negative" <> Sexp.expected "natural"
+          | otherwise = Right . MkIdx $ fromIntegral n
+      g (MkIdx n) = fromIntegral n
+
+instance SexpIso Instr where
+  sexpIso = Sexp.iso coerce coerce
+
+instance SexpIso Type where
+  sexpIso = Sexp.iso coerce coerce
+
+instance SexpIso Export where
+  sexpIso = Sexp.iso coerce coerce
+
+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))
+         )
+     >>> func
+    where
+      instrsExpr :: Iso' (List Instr) Expr
+      instrsExpr = vector . coerced
+
+instance SexpIso Module where
+  sexpIso = Sexp.partialOsi (const $ Left mempty) \m ->
+    ParenList $
+      [ Symbol "module" ]
+      <> (m ^.. #types . each . #inner)
+      <> (m ^.. #functions . each . to sxp)
+      <> (m ^.. #exports . each . to sxp)
+
+sxp :: SexpIso a => a -> Sexp
+sxp e = Sexp.toSexp sexpIso e ^?! _Right
+
+ins :: Text -> List Sexp -> Instr
+ins op [] = MkInstr $ Symbol op
+ins op xs = MkInstr . ParenList $ Symbol op : xs
+
+instance IsString Sexp where
+  fromString = Symbol . T.pack
+
+instance IsList Expr where
+  type Item Expr = Instr
+  fromList = MkExpr . V.fromList
+  toList e = V.toList e.inner

t.wat

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