gitea action

.gitea/workflows/build.yaml

@@ -0,0 +1,13 @@
+name: build
+on: [push]
+
+jobs:
+  build:
+    runs-on: nixos
+    steps:
+      - name: Check out repository code
+        uses: actions/checkout@v4
+      - name: build gyehoek
+        run: nix build -L .#gyehoek
+      - name: test gyehoek
+        run: nix flake check -L

app/Gyehoek/Wasm.hs

@@ -1,28 +0,0 @@
-{- HLINT ignore "Use newtype instead of data" -}
-module Gyehoek.Wasm
-  ()
-  where
-
-import Data.List (List)
-import GHC.Generics (Generic)
-
-
-data Module = MkModule
-  { typeSection :: List Type
-  }
-  deriving (Show, Generic)
-
-data Type
-  deriving (Show, Generic)
-
-data Function = MkFunction
-  { params :: List Type
-  , result :: List Type
-  , locals :: List Type
-  , body :: Expr
-  }
-  deriving (Show, Generic)
-
-type Expr = List Instr
-
-type Instr = ByteString

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

@@ -22,6 +22,16 @@
           gyehoek = final.haskell-nix.project' {
             src = ./.;
             compiler-nix-name = "ghc912";
+            modules = [({ pkgs, lib, ...}: {
+              packages.gyehoek.components.tests.test.preCheck =
+                let bin = [pkgs.wasmtime pkgs.git];
+                in ''
+                  # Wasmtime requires a cache in $HOME. This is less
+                  # painful than reconfiguring the cache location.
+                  export HOME=$(mktemp -d)
+                  export PATH=${lib.makeBinPath bin}:$PATH
+                '';
+            })];
             shell = {
               withHoogle = true;
               inputsFrom = [];
@@ -30,8 +40,6 @@
                 haskell-language-server = {};
               };
               buildInputs = with final; [
-                gcc
-                qbe
                 haskellPackages.cabal-fmt
                 self.packages.${final.stdenv.hostPlatform.system}.shake
                 final.wabt
@@ -67,14 +75,18 @@
       _pkgs = each-system ({ pkgs, ... }: pkgs);
       _hf = hf;
 
-      packages = each-system ({ pkgs, system, ... }:
-        hf.packages.${system} // {
-          default = hf.packages.${system}."gyehoek:exe:gyehoek";
+      packages = each-system ({ pkgs, lib, system, ... }:
+        hf.packages.${system} // lib.fix (packages: {
+          gyehoek = hf.packages.${system}."gyehoek:exe:gyehoek";
+          default = packages.gyehoek;
           shake = pkgs.callPackage ./shake-wrapper.nix {};
-        });
+        }));
 
       devShells = each-system
         ({ pkgs, system, ... }: hf.devShells.${system});
+
+      checks = each-system
+        ({ pkgs, system, ... }: hf.checks.${system});
     };
 
   nixConfig = {

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

@@ -0,0 +1,19 @@
+(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)))

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
@@ -29,13 +29,25 @@ common ghcstuffs
     OverloadedStrings
     PartialTypeSignatures
     PatternSynonyms
+    QuasiQuotes
 
 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
@@ -44,6 +56,7 @@ executable gyehoek
     Gyehoek.Scheme.Syntax
     Gyehoek.Sexp
     Gyehoek.Wasm
+    Gyehoek.Driver
 
   build-depends:
     , base                  ^>=4.21.2.0
@@ -70,6 +83,21 @@ executable gyehoek
     , text-short
     , 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

@@ -1,12 +1,13 @@
-{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE MultilineStrings #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# OPTIONS_GHC -Wno-incomplete-patterns #-}
 module Gyehoek.CPS.Lower
   (
-  lower) where
+  lower, lowerProgram) where
 
 import Gyehoek.CPS.Syntax
 import Data.Generics.Labels
@@ -23,11 +24,14 @@ 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
 import Data.IntMap.Strict (IntMap)
+import Data.String.Interpolate
+import Gyehoek.Wasm qualified as Wasm
+import Gyehoek.Wasm (i32, ins, sxp)
 
 
 data Env = MkEnv { vars :: Vector Name }
@@ -49,18 +53,19 @@ 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 -> ins "i32.const" [sxp n]
+    LitBool b -> ins "i32.const" [sxp @Int $ if b then 1 else 0]
     _ -> _
 
-lowerVal g (ValVar x) = [ "local.get " <> tshow i ]
+lowerVal g (ValVar x) = ins "local.get" [sxp 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 +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
-  <> [ op, "local.set " <> tshow n ]
+  <> ins op []
+  <> ins "local.set" [sxp n]
   <> lower' g' e
   where
     g' = g & #vars <>~ [r]
@@ -82,14 +97,11 @@ 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
+  main <- Wasm.defun [] [i32] [i32, i32, i32, i32, i32] \_ ->
+    lower' emptyEnv e
+  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/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

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
@@ -19,11 +21,15 @@ module Gyehoek.Sexp
   , lambda
   , kappaKeyword
   , lambdaKeyword
+  , encodePrettyWith
+  , encodePretty
+  , UglySexpIso(..)
+  , AsSexpIso(..)
   )
 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
@@ -43,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
@@ -59,9 +67,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)
@@ -141,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

@@ -0,0 +1,257 @@
+{- 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 #-}
+{-# LANGUAGE DerivingVia #-}
+module Gyehoek.Wasm
+  ( defun
+  , deftype
+  , start
+  , runGenMod
+  , execGenMod
+  , renderModule
+  , Module
+  , Function
+  , Expr
+  , Instr
+  , GenMod
+  , i32
+  , export
+  , ins
+  , sxp
+  , result
+  , param
+  , if'
+  )
+  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, Generically(..))
+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((<|>)))
+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
+  { types :: Vector Type
+  , functions :: Vector Function
+  , start :: Maybe Idx
+  , exports :: Vector Export
+  }
+  deriving (Show, Generic)
+
+instance Semigroup Module where
+  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
+  , result :: List Type
+  , locals :: List Type
+  , body :: Expr
+  }
+  deriving (Show, Generic)
+
+newtype Export = MkExport { inner :: Sexp }
+  deriving (Show, Generic)
+
+newtype Expr = MkExpr { inner :: Vector Instr }
+  deriving (Show, Generic)
+  deriving newtype (Semigroup, Monoid)
+
+newtype Instr = MkInstr { inner :: Sexp }
+  deriving (Show, Generic)
+
+newtype Type = MkType { inner :: Sexp }
+  deriving (Show, Generic)
+
+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 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
+         , m & #functions <>~ V.singleton
+             (MkFunction params result locals (code idx))
+         )
+
+execGenMod = fmap snd . runGenMod
+
+renderModule :: Module -> Text
+renderModule = (^?! _Right) . Gyehoek.Sexp.encodePretty
+
+i32 :: Type
+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)
+
+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 -> Expr
+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
+
+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]
+       ""