tests

app/Main.hs

@@ -1,84 +1,6 @@
-{-# LANGUAGE OverloadedLabels #-}
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE OrPatterns #-}
-module Main
-  (main)
-  where
+module Main (main) where
 
-import Gyehoek.Options
-import qualified Data.Text.IO as TIO
-import Data.Text (Text)
-import Prelude hiding (readFile)
-import Options.Applicative
-import Control.Lens
-import Data.Generics.Labels
-import System.OsPath (OsPath)
-import System.FilePath ((-<.>), dropExtension)
-import Effectful.FileSystem
-import Effectful
-import Effectful.FileSystem.IO qualified as FS
-import Effectful.FileSystem.IO.ByteString qualified as FB
-import Gyehoek.GenSym (runGenSym, GenSym, gensym, gensym')
-import qualified Gyehoek.Sexp as Sexp
-import Data.Text.Lens
-import Data.List (List)
-import qualified Gyehoek.Scheme.Syntax as Scm
-import Effectful.Exception
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as T
-import System.IO (Handle)
-import Data.List.NonEmpty (NonEmpty)
-import qualified Cradle as C
-import Gyehoek.CPS.Convert
-import Gyehoek.CPS.Lower
-import Data.Foldable
-import qualified Gyehoek.Scheme.Syntax
-import Gyehoek.CPS.Syntax
-import Data.Maybe (fromMaybe)
+import Gyehoek.Driver qualified
 
 
-main :: IO ()
-main = do
-  opts <- execParser $ info (helper <*> parser) fullDesc
-  runEff . runFileSystem . runGenSym . driver $ opts
-
-
-
-hPutStr :: FileSystem :> es => Handle -> Text -> Eff es ()
-hPutStr h = FB.hPutStr h . T.encodeUtf8
-
-hPutStrLn :: FileSystem :> es => Handle -> Text -> Eff es ()
-hPutStrLn h = FB.hPutStrLn h . T.encodeUtf8
-
-hGetContents :: FileSystem :> es => Handle -> Eff es Text
-hGetContents h = T.decodeUtf8 <$> FB.hGetContents h
-
-readFile :: FileSystem :> es => FilePath -> Eff es Text
-readFile f = FS.withFile f FS.ReadMode hGetContents
-
-withFile
-  :: (FileSystem :> es)
-  => FilePath -> FS.IOMode -> (Handle -> Eff es a) -> Eff es a
-withFile "-" FS.ReadMode k = k FS.stdin
-withFile "-" (FS.WriteMode; FS.AppendMode) k = k FS.stdout
-withFile f m k = FS.withFile f m k
-
-readScm :: FileSystem :> es => FilePath -> Eff es Scm.Exp
-readScm f =
-  withFile f FS.ReadMode $ \h ->
-    Sexp.parseSexps f <$> hGetContents h
-     >>= either error wrap
-  where
-    wrap [x] = pure x
-    wrap xs = pure . Gyehoek.Scheme.Syntax.ExpBegin $ xs
-
-driver
-  :: (GenSym :> es, FileSystem :> es, IOE :> es)
-  => Options -> Eff es ()
-driver opts = do
-  scm <- readScm opts.sourceFile
-  cps <- convert scm (pure . Halt1)
-  wat <- lower cps
-  withFile opts.output FS.WriteMode \h ->
-    hPutStr h wat
+main = Gyehoek.Driver.main

cabal.project

@@ -1,4 +1,5 @@
 packages: *.cabal
+tests: True
 
 source-repository-package
     type: git

flake.nix

@@ -30,10 +30,9 @@
                 haskell-language-server = {};
               };
               buildInputs = with final; [
-                gcc
-                qbe
                 haskellPackages.cabal-fmt
                 self.packages.${final.stdenv.hostPlatform.system}.shake
+                final.haskellPackages.shelltestrunner
                 final.wabt
                 final.nodejs
                 final.wasmtime

golden/arith/exec

@@ -0,0 +1,5 @@
+ret > ExitSuccess
+out > 22
+out >
+err > warning: using `--invoke` with a function that returns values is experimental and may break in the future
+err >

golden/arith/out.wat

@@ -1,5 +1,7 @@
 (module
-  (func (param) (result i32)
+  (func
+    (param)
+    (result i32)
     (local i32 i32 i32 i32 i32)
     (i32.const 3)
     (i32.const 4)

golden/if-false/exec

@@ -0,0 +1,5 @@
+ret > ExitSuccess
+out > 555
+out >
+err > warning: using `--invoke` with a function that returns values is experimental and may break in the future
+err >

golden/if-false/out.wat

@@ -0,0 +1,11 @@
+(module
+  (func
+    (param)
+    (result i32)
+    (local i32 i32 i32 i32 i32)
+    (i32.const 0)
+    (if
+      (result i32)
+      (then (i32.const 777))
+      (else (i32.const 555))))
+  (export "main" (func 0)))

golden/if-false/source.scm

@@ -0,0 +1 @@
+(if #false 777 555)

golden/if-true/exec

@@ -0,0 +1,5 @@
+ret > ExitSuccess
+out > 777
+out >
+err > warning: using `--invoke` with a function that returns values is experimental and may break in the future
+err >

golden/if-true/out.wat

@@ -0,0 +1,11 @@
+(module
+  (func
+    (param)
+    (result i32)
+    (local i32 i32 i32 i32 i32)
+    (i32.const 1)
+    (if
+      (result i32)
+      (then (i32.const 777))
+      (else (i32.const 555))))
+  (export "main" (func 0)))

golden/if-true/source.scm

@@ -0,0 +1 @@
+(if #true 777 555)

golden/square/source.scm

@@ -0,0 +1 @@
+((λ (x) (* x x)) 5)

gyehoek.cabal

@@ -20,7 +20,7 @@ common ghcstuffs-dev
 common ghcstuffs
   ghc-options:
     -Wall -fdefer-type-errors -fno-show-valid-hole-fits
-    -fdefer-out-of-scope-variables -fplugin=Effectful.Plugin -threaded
+    -fdefer-out-of-scope-variables -threaded
 
   default-extensions:
     BlockArguments
@@ -35,8 +35,19 @@ executable gyehoek
   import:           ghcstuffs, ghcstuffs-dev
   main-is:          Main.hs
 
-  -- cabal-fmt: expand app -Main
-  other-modules:
+  build-depends:
+    , base                  ^>=4.21.2.0
+    , gyehoek
+
+  hs-source-dirs:   app
+  default-language: GHC2024
+
+library
+  import:           ghcstuffs, ghcstuffs-dev
+  ghc-options: -fplugin=Effectful.Plugin
+
+  -- cabal-fmt: expand src
+  exposed-modules:
     Gyehoek.CPS.Convert
     Gyehoek.CPS.Lower
     Gyehoek.CPS.Syntax
@@ -45,6 +56,7 @@ executable gyehoek
     Gyehoek.Scheme.Syntax
     Gyehoek.Sexp
     Gyehoek.Wasm
+    Gyehoek.Driver
 
   build-depends:
     , base                  ^>=4.21.2.0
@@ -72,6 +84,20 @@ executable gyehoek
     , unordered-containers
     , vector
     , string-interpolate
+    , pretty-simple
 
-  hs-source-dirs:   app
+  hs-source-dirs:   src
   default-language: GHC2024
+
+test-suite test
+    import:           ghcstuffs, ghcstuffs-dev
+    type:             exitcode-stdio-1.0
+    hs-source-dirs:   test
+    main-is:          Main.hs
+    build-depends:    base
+                    , gyehoek
+                    , filepath
+                    , tasty
+                    , tasty-silver
+                    , directory
+    default-language: GHC2024

src/Gyehoek/CPS/Convert.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE OverloadedLists #-}
 module Gyehoek.CPS.Convert
   ( convert
+  , convertProgram
   ) where
 
 import Gyehoek.CPS.Syntax
@@ -9,6 +10,8 @@ import Gyehoek.GenSym
 import Data.List.NonEmpty (NonEmpty((:|)))
 import Effectful
 import Control.Monad.Cont qualified as Cont
+import Control.Lens
+import qualified Data.List.NonEmpty as NE
 
 
 -- 뻘짓이어라
@@ -31,11 +34,11 @@ convert (Scm.ExpPrim p) k =
     ExpPrim p' [r] <$> k (ValVar r)
 
 convert (Scm.ExpLambda xs e) k = do
-  f <- gensym' "f"
-  ktail <- gensym' "ktail"
+  f <- gensym' "λ-body"
+  ktail <- gensym' "λ-tail"
   m <- convert e $ \e' ->
-    pure $ ExpApply (ValVar ktail) [e']
-  ExpFix [(f, MkKappa (xs ++ [ktail]) m)] <$> k (ValVar f)
+    pure $ ExpContinue ktail [e']
+  ExpLet [(f, MkLambda xs ktail m)] <$> k (ValVar f)
 
 convert (Scm.ExpApply f xs) k =
   telescope (convert @es) (f:|xs) \(f':|xs') -> do
@@ -46,4 +49,15 @@ convert (Scm.ExpApply f xs) k =
 
 convert (Scm.ExpBegin xs) k = _
 
+convert (Scm.ExpIf c t f) k =
+  convert c \c' ->
+    ExpIf c' <$> convert t k <*> convert f k
+
 convert _ k = _
+
+convertProgram :: forall es. (GenSym :> es) => Scm.Program -> Eff es Program
+convertProgram p =
+  MkProgram <$> telescope (convert @es) (p ^.. each . _Left) \exps ->
+    pure . Halt1 $ case NE.nonEmpty exps of
+      Nothing -> ValLit Void
+      Just es -> NE.last es

src/Gyehoek/CPS/Lower.hs

@@ -7,7 +7,7 @@
 {-# OPTIONS_GHC -Wno-incomplete-patterns #-}
 module Gyehoek.CPS.Lower
   (
-  lower) where
+  lower, lowerProgram) where
 
 import Gyehoek.CPS.Syntax
 import Data.Generics.Labels
@@ -24,7 +24,7 @@ import Data.Foldable
 import Data.HashMap.Strict (HashMap)
 import Numeric.Natural
 import GHC.Generics (Generic)
-import Gyehoek.Scheme.Syntax (Lit(LitInt))
+import Gyehoek.Scheme.Syntax (Lit(..))
 import Text.Printf
 import qualified Data.Text as T
 import qualified Data.Vector.Strict as V
@@ -57,10 +57,11 @@ lowerVal :: Env -> Val -> Wasm.Expr
 
 lowerVal g (ValLit l) =
   case l of
-    LitInt n -> [ ins "i32.const" [sxp n] ]
+    LitInt n -> ins "i32.const" [sxp n]
+    LitBool b -> ins "i32.const" [sxp @Int $ if b then 1 else 0]
     _ -> _
 
-lowerVal g (ValVar x) = [ ins "local.get" [sxp l] ]
+lowerVal g (ValVar x) = ins "local.get" [sxp l]
   where
     l = V.elemIndex x g.vars ^?! _Just
 
@@ -75,14 +76,20 @@ lower' g (ExpPrim p rs e) =
   where
     r = head rs
 
+lower' g (ExpIf c t f) =
+  lowerVal g c
+  <> Wasm.if' (Wasm.result [i32])
+    (lower' g t)
+    (lower' g f)
+
 lowerBinOp
   :: _
   -> _ -> _ -> _ -> _ -> _ -> Wasm.Expr
 lowerBinOp op g x y r e =
   lowerVal g x
   <> lowerVal g y
-  <> [ ins op [] ]
-  <> [ ins "local.set" [sxp n] ]
+  <> ins op []
+  <> ins "local.set" [sxp n]
   <> lower' g' e
   where
     g' = g & #vars <>~ [r]
@@ -92,6 +99,9 @@ lowerBinOp op g x y r e =
 
 lower :: Exp -> Eff es Text
 lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do
-  idx <- Wasm.defun [] [i32] [i32, i32, i32, i32, i32] \_ ->
+  main <- Wasm.defun [] [i32] [i32, i32, i32, i32, i32] \_ ->
     lower' emptyEnv e
-  Wasm.export "main" "func" idx
+  Wasm.export "main" "func" main
+
+lowerProgram :: Program -> Eff es Text
+lowerProgram (MkProgram e) = lower e

src/Gyehoek/CPS/Syntax.hs

@@ -3,9 +3,13 @@
 module Gyehoek.CPS.Syntax
   ( Val(..)
   , Kappa(..)
+  , Lambda(..)
   , Exp(..)
   , Name(..)
   , Prim(..)
+  , Program(..)
+  , Lit(..)
+  , pattern Void
   , pattern Halt
   , pattern Halt1
   , _MkKappa
@@ -17,7 +21,7 @@ module Gyehoek.CPS.Syntax
 
 import Language.SexpGrammar qualified as S
 import Gyehoek.Sexp qualified
-import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primSexpIso, Lit)
+import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primSexpIso, Lit(..), pattern Void)
 import Data.Text (Text)
 import Data.List (List)
 import GHC.Generics (Generic)
@@ -28,6 +32,9 @@ import Data.Text qualified as T
 import Data.Generics.Labels
 import Prelude hiding ((.), id)
 import Data.List.NonEmpty (NonEmpty)
+import Data.InvertibleGrammar.Base qualified as IGB
+import Data.InvertibleGrammar.Base ((:-)((:-)))
+import qualified Data.InvertibleGrammar as IG
 
 -- Data types
 
@@ -40,11 +47,16 @@ data Val
 data Kappa = MkKappa (List Name) Exp
   deriving (Show, Generic)
 
+data Lambda = MkLambda (List Name) Name Exp
+  deriving (Show, Generic)
+
 data Exp
   = ExpPrim (Prim Val) (List Name) Exp
   | ExpFix (NonEmpty (Name, Kappa)) Exp
-  | ExpApply Val (List Val)
+  | ExpLet (NonEmpty (Name, Lambda)) Exp
+  | ExpContinue Name (List Val)
   | ExpIf Val Exp Exp
+  | ExpApply Val (List Val)
   deriving (Show, Generic)
 
 pattern Halt :: List Val -> Exp
@@ -53,6 +65,14 @@ pattern Halt xs = ExpApply (ValVar "halt") xs
 pattern Halt1 :: Val -> Exp
 pattern Halt1 x = ExpApply (ValVar "halt") [x]
 
+data Def = DefConstant Name Exp
+  deriving (Show, Generic)
+
+data Program = MkProgram
+  { body :: Exp
+  }
+  deriving (Show, Generic)
+
 makePrisms ''Kappa
 makePrisms ''Exp
 
@@ -69,6 +89,17 @@ instance S.SexpIso Val where
       label = S.keyword >>> S.iso MkName getName
       var = S.sexpIso
 
+instance S.SexpIso Lambda where
+  sexpIso = match
+    $ With (. lambda)
+    $ End
+    where
+      lambda = S.list $
+        S.el Gyehoek.Sexp.lambdaKeyword
+        >>> S.el (S.list (S.rest S.sexpIso))
+        >>> S.el S.sexpIso
+        >>> S.el S.sexpIso
+
 instance S.SexpIso Kappa where
   sexpIso = match
     $ With (. kappa)
@@ -82,16 +113,27 @@ instance S.SexpIso Kappa where
 instance S.SexpIso Exp where
   sexpIso = match
     $ With (. prim)
+    $ With (. fix)
     $ With (. let_)
-    $ With (. app)
+    $ With (. continue)
     $ With (. if_)
+    $ With (. app)
     $ End
     where
-      let_ = Gyehoek.Sexp.let_ "fix" S.sexpIso S.sexpIso S.sexpIso
-      if_ = S.list $ S.el S.sexpIso >>> S.el S.sexpIso >>> S.el S.sexpIso
+      continue = S.list $
+        S.el (S.sym "continue")
+        >>> S.el S.sexpIso
+        >>> S.rest S.sexpIso
+      fix = Gyehoek.Sexp.let_ "fix" S.sexpIso S.sexpIso S.sexpIso
+      let_ = Gyehoek.Sexp.let_ "let" S.sexpIso S.sexpIso S.sexpIso
+      if_ = S.list $ S.el (S.sym "if")
+        >>> S.el S.sexpIso >>> S.el S.sexpIso >>> S.el S.sexpIso
       app = S.list $ S.el S.sexpIso >>> S.rest S.sexpIso
       prim = S.list $
         S.el (S.sym "prim")
         >>> S.el (primSexpIso id (S.sexpIso @Val))
         >>> S.el S.sexpIso
         >>> S.el S.sexpIso
+
+instance S.SexpIso Program where
+  sexpIso = with \prog -> S.sexpIso @Exp >>> prog

src/Gyehoek/Driver.hs

@@ -0,0 +1,99 @@
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE OrPatterns #-}
+module Gyehoek.Driver
+  (main, lower_e2e, convert_e2e, parse_e2e)
+  where
+
+import Gyehoek.Options
+import qualified Data.Text.IO as TIO
+import Data.Text (Text)
+import Prelude hiding (readFile)
+import Options.Applicative
+import Control.Lens
+import Data.Generics.Labels
+import System.OsPath (OsPath)
+import System.FilePath ((-<.>), dropExtension)
+import Effectful.FileSystem
+import Effectful
+import Effectful.FileSystem.IO qualified as FS
+import Effectful.FileSystem.IO.ByteString qualified as FB
+import Gyehoek.GenSym (runGenSym, GenSym, gensym, gensym')
+import qualified Gyehoek.Sexp as Sexp
+import Data.Text.Lens
+import Data.List (List)
+import qualified Gyehoek.Scheme.Syntax as Scm
+import Effectful.Exception
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import System.IO (Handle)
+import Data.List.NonEmpty (NonEmpty)
+import qualified Cradle as C
+import Gyehoek.CPS.Convert
+import Gyehoek.CPS.Lower
+import Data.Foldable
+import qualified Gyehoek.Scheme.Syntax
+import Gyehoek.CPS.Syntax qualified as Cps
+import Data.Maybe (fromMaybe)
+import Control.Monad
+import Text.Pretty.Simple (pShow, pShowNoColor)
+
+
+main :: IO ()
+main = do
+  opts <- execParser $ info (helper <*> parser) fullDesc
+  runEff . runFileSystem . runGenSym . driver $ opts
+
+
+
+hPutStr :: FileSystem :> es => Handle -> Text -> Eff es ()
+hPutStr h = FB.hPutStr h . T.encodeUtf8
+
+hPutStrLn :: FileSystem :> es => Handle -> Text -> Eff es ()
+hPutStrLn h = FB.hPutStrLn h . T.encodeUtf8
+
+hGetContents :: FileSystem :> es => Handle -> Eff es Text
+hGetContents h = T.decodeUtf8 <$> FB.hGetContents h
+
+readFile :: FileSystem :> es => FilePath -> Eff es Text
+readFile f = FS.withFile f FS.ReadMode hGetContents
+
+withFile
+  :: (FileSystem :> es)
+  => FilePath -> FS.IOMode -> (Handle -> Eff es a) -> Eff es a
+withFile "-" FS.ReadMode k = k FS.stdin
+withFile "-" (FS.WriteMode; FS.AppendMode) k = k FS.stdout
+withFile f m k = FS.withFile f m k
+
+readScm :: FileSystem :> es => FilePath -> Eff es Scm.Program
+readScm f =
+  withFile f FS.ReadMode $ \h ->
+    Sexp.parseSexps @Scm.CommandOrDef f <$> hGetContents h
+     >>= either error (pure . Scm.MkProgram)
+
+driver
+  :: (GenSym :> es, FileSystem :> es, IOE :> es)
+  => Options -> Eff es ()
+driver opts = do
+  scm <- readScm opts.sourceFile
+  when opts.dumpParsed do
+    hPutStrLn FS.stdout . view strict . pShowNoColor $ scm
+  cps <- convertProgram scm
+  when opts.dumpCPS do
+    hPutStrLn FS.stdout $ Sexp.encodePretty cps ^?! _Right
+  wat <- lowerProgram cps
+  withFile opts.output FS.WriteMode \h ->
+    hPutStrLn h wat
+
+parse_e2e :: FilePath -> IO Scm.Program
+parse_e2e = runEff . runFileSystem . readScm
+
+convert_e2e :: FilePath -> IO Cps.Program
+convert_e2e = runEff . runFileSystem . runGenSym . (convertProgram <=< readScm)
+
+lower_e2e :: FilePath -> IO Text
+lower_e2e =
+  runEff . runFileSystem . runGenSym
+  . (lowerProgram <=< convertProgram <=< readScm)

src/Gyehoek/Options.hs

@@ -17,7 +17,9 @@ import GHC.Generics (Generic)
 data Options = MkOptions
   { -- dumpANF :: Maybe FilePath
   -- , dumpQBE :: Maybe FilePath
-  output :: FilePath
+  dumpCPS :: Bool
+  , dumpParsed :: Bool
+  , output :: FilePath
   , sourceFile :: FilePath
   }
   deriving (Show, Generic)
@@ -45,7 +47,12 @@ parseOutput = strOption
     <> value "-"
     )
 
+parseDumpCPS = switch (long "dump-cps")
+parseDumpParsed = switch (long "dump-parsed")
+
 parser :: Parser Options
 parser = MkOptions
-  <$> parseOutput
+  <$> parseDumpCPS
+  <*> parseDumpParsed
+  <*> parseOutput
   <*> argument str (metavar "FILE")

src/Gyehoek/Scheme/Syntax.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE DerivingStrategies #-}
@@ -9,10 +10,13 @@ module Gyehoek.Scheme.Syntax
   ( Name(..)
   , Prim(..)
   , Lit(..)
-  , Define(..)
+  , Def(..)
   , Exp(..)
   , Sexp(..)
+  , Program(..)
+  , CommandOrDef(..)
   , primSexpIso
+  , pattern Void
   )
   where
 
@@ -21,6 +25,7 @@ import Data.List (List)
 import Language.SexpGrammar
   ( SexpIso(..), list, el, (>>>), rest, sym, symbol )
 import Language.SexpGrammar qualified as Sexp
+import Language.Sexp.Located qualified as S
 import Language.SexpGrammar.Generic
 import GHC.Generics
 import Prelude hiding ((.), id)
@@ -28,9 +33,10 @@ import Control.Category
 import Data.List.NonEmpty (NonEmpty ((:|)))
 import Gyehoek.Sexp qualified
 import Gyehoek.GenSym (Gen)
-import Control.Lens (Each)
+import Control.Lens
 import Data.String (IsString)
 import Data.Hashable (Hashable)
+import Control.Lens.Unsound (prismSum)
 
 
 newtype Name = MkName { getName :: Text }
@@ -63,16 +69,18 @@ data Lit
   | LitQuote Sexp
   deriving (Show, Generic)
 
-data Define
-  = DefineConstant Name Exp
-  | DefineProcedure Name (List Name) (List Exp)
+pattern Void :: Lit
+pattern Void = LitNil
+
+data Def
+  = DefConstant Name Exp
+  | DefProcedure Name (List Name) (List Exp)
   deriving (Show, Generic)
 
 data Exp
   = ExpLet (NonEmpty (Name, Exp)) Exp
   | ExpPrim (Prim Exp)
   | ExpBegin (List Exp)
-  | ExpDefine Define
   | ExpIf Exp Exp Exp
   | ExpLit Lit
   | ExpLambda (List Name) Exp
@@ -86,6 +94,28 @@ data Sexp
   | SexpLit Lit
   deriving (Show, Generic)
 
+data CommandOrDef
+  = Command Exp
+  | Definition Def
+  | Begin (List CommandOrDef)
+  deriving (Show, Generic)
+
+data Program = MkProgram
+  { commandsAndDefs :: List CommandOrDef
+  }
+  deriving (Show, Generic)
+
+instance Each Program Program (Either Exp Def) (Either Exp Def) where
+  each = #commandsAndDefs . each . go
+    where
+      inj = either Command Definition
+      toeither (Command e) = Left e
+      toeither (Definition d) = Right d
+      go :: Traversal' CommandOrDef (Either Exp Def)
+      go k (Command e) = inj <$> k (Left e)
+      go k (Definition d) = inj <$> k (Right d)
+      go k (Begin xs) = Begin <$> traverse (go k) xs
+
 
 
 instance SexpIso Name where
@@ -124,10 +154,19 @@ instance SexpIso Lit where
   sexpIso = match
     $ With (. sexpIso)
     $ With (. sym "nil")
-    $ With (. sexpIso)
+    $ With (. bool)
     $ With (. sexpIso)
     $ With (. Gyehoek.Sexp.prefixSugar "quote" Sexp.Quote sexpIso)
     $ End
+    where
+      bool :: Sexp.SexpGrammar Bool
+      bool = Sexp.hashed $ Sexp.partialOsi f g
+        where
+          f (S.Symbol ("t";"true")) = Right True
+          f (S.Symbol ("f";"false")) = Right False
+          f _ = Left $ Sexp.expected "bool"
+          g True = S.Symbol "true"
+          g False = S.Symbol "false"
 
 instance SexpIso Sexp where
   sexpIso = match
@@ -136,7 +175,7 @@ instance SexpIso Sexp where
     $ With (\lit -> lit . sexpIso)
     $ End
 
-instance SexpIso Define where
+instance SexpIso Def where
   sexpIso = match
     $ With (. defconst)
     $ With (. defun)
@@ -151,7 +190,6 @@ instance SexpIso Exp where
     $ With (. Gyehoek.Sexp.let_ "let" sexpIso sexpIso sexpIso)
     $ With (. sexpIso)
     $ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso))
-    $ With (. sexpIso)
     $ With (. if_)
     $ With (. sexpIso)
     $ With (. lam)
@@ -164,3 +202,12 @@ instance SexpIso Exp where
         ( el Gyehoek.Sexp.lambdaKeyword
           >>> el (sexpIso @(List Name))
           >>> el sexpIso )
+
+instance SexpIso CommandOrDef where
+  sexpIso = match
+    $ With (\_Command -> _Command . sexpIso)
+    $ With (\_Definition -> _Definition . sexpIso)
+    $ With (\_Begin -> _Begin . bgn)
+    $ End
+    where
+      bgn = list $ el (sym "begin") >>> rest sexpIso

src/Gyehoek/Sexp.hs

@@ -2,6 +2,8 @@
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE StandaloneDeriving #-}
 module Gyehoek.Sexp
   ( let_
   , sexp
@@ -21,6 +23,8 @@ module Gyehoek.Sexp
   , lambdaKeyword
   , encodePrettyWith
   , encodePretty
+  , UglySexpIso(..)
+  , AsSexpIso(..)
   )
 where
 
@@ -45,6 +49,8 @@ import qualified Data.Text.IO as TIO
 import Control.Monad (join)
 import qualified Language.Sexp.Located as SexpLoc
 import Data.Void (absurd)
+import Data.Coerce (coerce)
+import qualified Data.Map
 
 
 sexp :: SexpIso a => Iso' a Text
@@ -150,3 +156,30 @@ kappaKeyword = coproduct [ sym "κ", sym "kappa" ]
 
 lambdaKeyword :: Grammar Position (Sexp :- t) t
 lambdaKeyword = coproduct [ sym "λ", sym "lambda" ]
+
+
+
+class UglySexpIso a where
+  uglySexpIso :: SexpGrammar a
+
+newtype AsSexpIso a = AsSexpIso a
+newtype AsUglySexpIso a = AsUglySexpIso a
+
+asSexpIso :: Grammar p (a :- t) (AsSexpIso a :- t)
+asSexpIso = Sexp.iso AsSexpIso (\(AsSexpIso x) -> x)
+
+instance UglySexpIso a => SexpIso (AsUglySexpIso a) where
+  sexpIso = uglySexpIso @a >>> Sexp.iso coerce coerce
+
+instance SexpIso a => UglySexpIso (AsSexpIso a) where
+  uglySexpIso = sexpIso >>> Sexp.iso (\x -> AsSexpIso x) (\(AsSexpIso x) -> x)
+
+-- why not work
+-- deriving via AsSexpIso Text instance UglySexpIso Text
+
+instance UglySexpIso Text where uglySexpIso = sexpIso
+instance UglySexpIso Integer where uglySexpIso = sexpIso
+instance UglySexpIso Int where uglySexpIso = sexpIso
+instance UglySexpIso Bool where uglySexpIso = sexpIso
+instance UglySexpIso Double where uglySexpIso = sexpIso
+instance UglySexpIso () where uglySexpIso = sexpIso

src/Gyehoek/Wasm.hs

@@ -8,6 +8,7 @@
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE ImpredicativeTypes #-}
+{-# LANGUAGE DerivingVia #-}
 module Gyehoek.Wasm
   ( defun
   , deftype
@@ -24,6 +25,9 @@ module Gyehoek.Wasm
   , export
   , ins
   , sxp
+  , result
+  , param
+  , if'
   )
   where
 
@@ -32,7 +36,7 @@ import Language.SexpGrammar
 import Language.SexpGrammar qualified as Sexp
 import Language.SexpGrammar.Generic
 import Data.List (List)
-import GHC.Generics (Generic)
+import GHC.Generics (Generic, Generically(..))
 import Data.Text (Text)
 import Data.String (IsString (fromString))
 import Text.Printf
@@ -202,12 +206,15 @@ instance SexpIso Module where
       <> (m ^.. #functions . each . to sxp)
       <> (m ^.. #exports . each . to sxp)
 
+instance Each Expr Expr Instr Instr where
+  each = #MkExpr . each
+
 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
+ins :: Text -> List Sexp -> Expr
+ins op [] = [ MkInstr $ Symbol op ]
+ins op xs = [ MkInstr . ParenList $ Symbol op : xs ]
 
 instance IsString Sexp where
   fromString = Symbol . T.pack
@@ -216,3 +223,35 @@ instance IsList Expr where
   type Item Expr = Instr
   fromList = MkExpr . V.fromList
   toList e = V.toList e.inner
+
+data ResultType = MkResultType
+  { params :: List Type
+  , result :: List Type
+  }
+  deriving stock (Generic)
+  deriving (Semigroup, Monoid)
+    via Generically ResultType
+
+param :: List Type -> ResultType
+param ts = MkResultType ts mempty
+
+result :: List Type -> ResultType
+result ts = MkResultType mempty ts
+
+resultTypeSexp :: ResultType -> List Sexp
+resultTypeSexp rt =
+  f "param" (coerce <$> rt.params) <> f "result" (coerce <$> rt.result)
+  where
+    f :: Text -> List Sexp -> List Sexp
+    f _ [] = []
+    f kw s = [ ParenList $ Symbol kw : s ]
+
+-- resultSexp :: ResultType -> Sexp
+-- resultSexp rt = ParenList $ Symbol "param" : (coerce <$> rt.result)
+
+if' :: ResultType -> Expr -> Expr -> Expr
+if' rt t f = MkExpr . V.singleton . MkInstr . ParenList $
+  [ Symbol "if" ]
+  <> resultTypeSexp rt
+  <> [ ParenList $ Symbol "then" : (t ^.. each . to sxp) ]
+  <> [ ParenList $ Symbol "else" : (f ^.. each . to sxp) ]

test/Main.hs

@@ -0,0 +1,57 @@
+module Main (main) where
+
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.Silver
+import Test.Tasty.Silver.Interactive (defaultMain)
+import Data.Traversable
+import Gyehoek.Driver qualified as Driver
+import System.FilePath
+import Data.List (List)
+import Data.Functor ((<&>))
+import System.Directory
+import Data.Function
+
+
+disabled :: List String
+disabled =
+  [ "square"
+  ]
+
+main :: IO ()
+main = defaultMain =<< goldenTests
+
+goldenTests :: IO TestTree
+goldenTests = do
+  all_cases <- listDirectory "golden"
+  let tests = all_cases
+            & filter (`notElem` disabled)
+            & fmap ("golden"</>)
+  pure $ testGroup "golden"
+    [ watTests tests
+    , executionTests tests
+    ]
+
+watTests :: List FilePath -> TestTree
+watTests files =
+  testGroup "wat" $ files <&> \test ->
+    let source = test </> "source.scm"
+        golden = test </> "out.wat"
+        testname = takeFileName test
+    in goldenVsAction
+      testname
+      golden
+      (Driver.lower_e2e source)
+      id
+
+executionTests :: List FilePath -> TestTree
+executionTests files =
+  testGroup "execution" $ files <&> \test ->
+    let wat = test </> "out.wat"
+        testname = takeFileName test
+        resultfile = test </> "exec"
+    in goldenVsProg
+       testname
+       resultfile
+       "wasmtime"
+       ["--invoke", "main", wat]
+       ""