idk

.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/CPS/Lower.hs

@@ -1,95 +0,0 @@
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE OverloadedRecordDot #-}
-{-# LANGUAGE OverloadedLabels #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE MultilineStrings #-}
-{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
-module Gyehoek.CPS.Lower
-  (
-  lower) where
-
-import Gyehoek.CPS.Syntax
-import Data.Generics.Labels
-import Gyehoek.Scheme.Syntax qualified as Scm
-import Gyehoek.GenSym
-import Data.List.NonEmpty (NonEmpty((:|)))
-import Effectful
-import Control.Monad.Cont qualified as Cont
-import Effectful.Writer.Static.Local
-import Data.Text (Text)
-import Data.Vector.Strict (Vector)
-import Control.Lens
-import Data.Foldable
-import Data.HashMap.Strict (HashMap)
-import Numeric.Natural
-import GHC.Generics (Generic)
-import Gyehoek.Scheme.Syntax (Lit(LitInt))
-import Text.Printf
-import qualified Data.Text as T
-import qualified Data.Vector.Strict as V
-import Data.IntMap.Strict (IntMap)
-
-
-data Env = MkEnv { vars :: Vector Name }
-  deriving (Show, Generic)
-
-emptyEnv :: Env
-emptyEnv = MkEnv mempty
-
-type instance Index Env = Natural
-type instance IxValue Env = Name
-
-instance Ixed Env where
-  ix i = #vars . ix (fromIntegral i)
-
-
-
-tshow :: Show a => a -> Text
-tshow = T.pack . show
-
-
-
-lowerVal :: Env -> Val -> Vector Text
-
-lowerVal g (ValLit l) =
-  case l of
-    LitInt n -> [ "i32.const " <> tshow n ]
-    _ -> _
-
-lowerVal g (ValVar x) = [ "local.get " <> tshow i ]
-  where
-    i = V.elemIndex x g.vars ^?! _Just
-
-lower' :: Env -> Exp -> Vector Text
-
-lower' g (Halt [e]) = lowerVal g e
-
-lower' g (ExpPrim p rs e) =
-  case p of
-    PrimAdd x y -> lowerBinOp "i32.add" g x y r e
-    PrimMul x y -> lowerBinOp "i32.mul" g x y r e
-  where
-    r = head rs
-
-lowerBinOp op g x y r e =
-  lowerVal g x
-  <> lowerVal g y
-  <> [ op, "local.set " <> tshow n ]
-  <> lower' g' e
-  where
-    g' = g & #vars <>~ [r]
-    n = length (g ^. #vars)
-
-
-
-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

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

doc/data-model.org

@@ -0,0 +1,17 @@
+#+title: representation of Scheme types
+
+the Scheme unitype is encoded as ~(ref eq)~ with immediates in ~(ref i31)~ and heap objects in ~$heap-object~:
+#+begin_src wat
+  (type $heap-object (sub (struct (field $hash (mut i32)))))
+#+end_src
+
+* immediates
+
+all immediates are stored in ~(ref i31)~ and thus must fit in 31 bits. the most important immediate, the integer, is indicated by a null low bit.
+#+begin_example
+XXXX XXXX XXXX XXXX XXXX XXXX XXXX XX00
+                                     || 
+                                     |\ used by wasm's i31 rep
+      zero indicates a 30-bit fixnum /
+      in the upper bits
+#+end_example

flake.nix

@@ -16,12 +16,30 @@
         "x86_64-darwin" "x86_64-linux"
       ];
 
+
       overlays = [
         haskellNix.overlay
+        (final: prev: {
+          gyehoek-wasmtime-wrapper = final.callPackage ./wasmtime.nix {};
+        })
         (final: prev: {
           gyehoek = final.haskell-nix.project' {
             src = ./.;
             compiler-nix-name = "ghc912";
+            modules = [({ pkgs, lib, ...}: {
+              packages.gyehoek.components.tests.test.preCheck =
+                let
+                  bin = [
+                    pkgs.gyehoek-wasmtime-wrapper
+                    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,16 +48,14 @@
                 haskell-language-server = {};
               };
               buildInputs = with final; [
-                gcc
-                qbe
                 haskellPackages.cabal-fmt
                 self.packages.${final.stdenv.hostPlatform.system}.shake
                 final.wabt
                 final.nodejs
-                final.wasmtime
                 final.wasm-tools
                 final.wac-cli
                 final.guile
+                final.gyehoek-wasmtime-wrapper
               ];
             };
           };
@@ -67,14 +83,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,47 @@
+(module
+  (type $heap-object (sub (struct (field (mut i32)))))
+  (func
+    (param)
+    (result (ref eq))
+    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+    (i32.const 3)
+    (i32.const 2)
+    i32.shl
+    ref.i31
+    (ref.cast (ref i31))
+    i31.get_s
+    (i32.const 4)
+    (i32.const 2)
+    i32.shl
+    ref.i31
+    (ref.cast (ref i31))
+    i31.get_s
+    i32.mul
+    ref.i31
+    (local.set 0)
+    (i32.const 2)
+    (i32.const 2)
+    i32.shl
+    ref.i31
+    (ref.cast (ref i31))
+    i31.get_s
+    (i32.const 5)
+    (i32.const 2)
+    i32.shl
+    ref.i31
+    (ref.cast (ref i31))
+    i31.get_s
+    i32.mul
+    ref.i31
+    (local.set 1)
+    (local.get 0)
+    (ref.cast (ref i31))
+    i31.get_s
+    (local.get 1)
+    (ref.cast (ref i31))
+    i31.get_s
+    i32.add
+    ref.i31
+    (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,13 @@
+(module
+  (type (sub (struct (field (mut i32)))))
+  (func
+    (param)
+    (result (ref eq))
+    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+    (i32.const 0)
+    ref.i31
+    (if
+      (result i32)
+      (then (i32.const 777) ref.i31)
+      (else (i32.const 555) ref.i31)))
+  (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,13 @@
+(module
+  (type (sub (struct (field (mut i32)))))
+  (func
+    (param)
+    (result (ref eq))
+    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+    (i32.const 1)
+    ref.i31
+    (if
+      (result i32)
+      (then (i32.const 777) ref.i31)
+      (else (i32.const 555) ref.i31)))
+  (export "main" (func 0)))

golden/if-true/source.scm

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

golden/lambda/source.scm

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

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

index.html

@@ -0,0 +1,20 @@
+<html>
+  <head>
+    <script>
+      const imports = {
+          guppy: {
+              print: (arg) => console.log (arg)
+          }
+      }
+
+      fetch("u.wasm")
+    .then((response) => response.arrayBuffer())
+    .then((bytes) => WebAssembly.instantiate(bytes, imports))
+    .then((results) => {
+        results.instance.exports.main ();
+    });
+    </script>
+  </head>
+  <body>
+  </body>
+</html>

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

@@ -0,0 +1,250 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultilineStrings #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE ApplicativeDo #-}
+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
+module Gyehoek.CPS.Lower
+  (lower, lowerProgram) where
+
+import Gyehoek.CPS.Syntax
+import Data.Generics.Labels
+import Gyehoek.Scheme.Syntax qualified as Scm
+import Gyehoek.GenSym
+import Data.List.NonEmpty (NonEmpty((:|)))
+import Effectful
+import Control.Monad.Cont qualified as Cont
+import Effectful.Writer.Static.Local
+import Data.Text (Text)
+import Data.Vector.Strict (Vector)
+import Control.Lens
+import Data.Foldable
+import Data.HashMap.Strict (HashMap)
+import Numeric.Natural
+import GHC.Generics (Generic)
+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 hiding (Expr)
+import Language.Sexp.Located (pattern ParenList)
+import Debug.Pretty.Simple
+import Control.Monad.Fix
+
+
+data Env = MkEnv
+  { runtime :: Runtime
+  , vars :: Vector Name
+  , kvars :: Vector Name
+  }
+  deriving (Show, Generic)
+
+type instance Index Env = Natural
+type instance IxValue Env = Name
+
+instance Ixed Env where
+  ix i = #vars . ix (fromIntegral i)
+
+data Runtime = MkRuntime
+  { argArrayType :: Idx
+  , argArray :: Idx
+  , contType :: Idx
+  , contStackType :: Idx
+  , contStackTop :: Idx
+  , contStack :: Idx
+  , result :: Idx
+  , halt :: Idx
+  }
+  deriving (Show, Generic)
+
+
+
+-- | @makeSmallFixnum@ emits an expression injecting the i32 on top
+-- of the stack into the SCM unitype.
+makeSmallFixnum :: Wasm.Expr
+makeSmallFixnum = mconcat
+  [ ins "i32.const" [sxp @Int 1]
+  , ins "i32.shl" []
+  , ins "ref.i31" []
+  ]
+
+-- | Given an expression @e@ leaving a @ref eq@ atop the stack,
+-- @pushArg rt n e@ sets the nth slot of the arg-passing array to the
+-- result of @e@.
+pushArg :: Runtime -> Int -> Wasm.Expr -> Wasm.Expr
+pushArg (MkRuntime {argArrayType,argArray}) n e = mconcat
+  [ ins "global.get" [sxp argArray]
+  , ins "i32.const" [sxp n]
+  , e
+  , ins "array.set" [sxp argArrayType]
+  ]
+
+-- | Pop the nth arg from the arg-passing array onto the stack.
+popArg :: Runtime -> Int -> Wasm.Expr
+popArg (MkRuntime {argArrayType,argArray}) n = mconcat
+  [ ins "global.get" [sxp argArray]
+  , ins "i32.const" [sxp n]
+  , ins "array.get" [sxp argArrayType]
+  , ins "ref.as_non_null" []
+  ]
+
+
+
+lowerVal :: Env -> Val -> Wasm.Expr
+
+lowerVal g (ValLit l) =
+  case l of
+    LitInt n -> 
+      ins "i32.const" [sxp n]
+      <> makeSmallFixnum
+    LitBool b ->
+      ins "i32.const" [sxp @Int $ if b then 1 else 0]
+      <> ins "ref.i31" []
+    _ -> _
+
+lowerVal g (ValVar x) = ins "local.get" [sxp (1+l)]
+  where
+    l = V.elemIndex x g.vars ^?! _Just
+
+lower' :: (GenMod :> es) => Env -> Exp -> Eff es Wasm.Expr
+
+lower' g (Halt [v]) = pure . mconcat $
+  [ pushArg g.runtime 0 (lowerVal g v)
+  , ins "return_call" [sxp @Int 1]
+  ]
+
+lower' g (ExpPrim p rs e) =
+  case p of
+    PrimAdd x y -> lowerBinOp "i32.add" g x y r e
+    PrimMul x y -> lowerBinOp "i32.mul" g x y r e
+  where
+    r = head rs
+
+lower' g (ExpIf c t f) = do
+  t' <- lower' g t
+  f' <- lower' g f
+  pure $ lowerVal g c
+    <> Wasm.if' (Wasm.result [i32]) t' f'
+
+lower' g (ExpContinue k [x]) = pure . mconcat $
+  [ pushArg rt 0 (lowerVal g x)
+  , ins "i32.const" [sxp @Int 1] -- nargs
+  -- get the return continuation.
+  , ins "global.get" [sxp rt.contStack]
+  , ins "global.get" [sxp rt.contStackTop]
+  , ins "array.get" [sxp rt.contStackType]
+  , ins "ref.as_non_null" []
+  -- decrement contStackTop, completing the "pop."
+  , ins "global.get" [sxp rt.contStackTop]
+  , ins "i32.const" [sxp @Int (1 + l)]
+  , ins "i32.sub" []
+  , ins "global.set" [sxp rt.contStackTop]
+  , ins "return_call_ref" [sxp rt.contType]
+  ]
+  where
+    rt = g.runtime
+    l = V.elemIndex k g.kvars ^?! _Just
+
+lower' g (ExpLet [(r,MkLambda xs ktail m)] e) = do
+  idx <- defun [i32] [] (replicate 5 scm) \_ -> do
+    let g' = g & #vars <>~ V.fromList xs
+               & #kvars <>~ [ktail]
+    m' <- lower' g' m
+    pure . mconcat $
+      [ xs & ifoldMap \n _ ->
+          popArg g.runtime n <> ins "local.set" [sxp (1+n)]
+      , m'
+      ]
+  declareFuncref idx
+  let g' = g & #vars <>~ [r]
+  let n = length g.vars
+  e' <- lower' g' e
+  pure . mconcat $
+    [ ins "ref.func" [sxp idx]
+    , ins "local.set" [sxp (n+1)]
+    , e'
+    ]
+
+lower' g e = error . show $ e
+
+lowerBinOp
+  :: (GenMod :> es)
+  => Text -> Env -> Val -> Val -> Name -> Exp -> Eff es Wasm.Expr
+lowerBinOp op g x y r e = do
+  e' <- lower' g' e
+  pure . mconcat $
+    [ lowerVal g x
+    , ins "ref.cast" [sxp $ ref i31]
+    , ins "i31.get_s" []
+    , lowerVal g y
+    , ins "ref.cast" [sxp $ ref i31]
+    , ins "i31.get_s" []
+    , ins op []
+    , ins "ref.i31" []
+    , ins "local.set" [sxp (1+n)]
+    , e'
+    ]
+  where
+    g' = g & #vars <>~ [r]
+    n = length (g ^. #vars)
+
+
+
+scm = ref eq
+
+
+
+emitRuntime :: GenMod :> es => Eff es Runtime
+emitRuntime = mfix \runtime -> do
+  heapObjectIdx <- Wasm.deftypeNamed "$heap-object" $ Wasm.sub [] $ Wasm.struct
+    [ Wasm.mut i32 ]
+  -- cont stack
+  contType <- Wasm.deftype $ Wasm.func [i32] []
+  contStackType <- Wasm.deftype $ array $ mut $ refnull (fromIdx contType)
+  contStackTop <- Wasm.defglobal (mut i32) $ ins "i32.const" [sxp @Int 0]
+  contStack <- Wasm.defglobal (ref (Wasm.fromIdx contStackType)) $
+    ins "i32.const" [sxp @Int 128]
+    <> ins "array.new_default" [sxp contStackType]
+  -- arg array
+  argArrayType <- Wasm.deftype $ Wasm.array $ mut $ refnull eq
+  argArray <- Wasm.defglobal (ref (Wasm.fromIdx argArrayType)) $
+    ins "i32.const" [sxp @Int 32]
+    <> ins "array.new_default" [sxp argArrayType]
+  -- consIdx <- Wasm.defun _ _ _ _
+  result <- Wasm.defglobal (mut (refnull eq)) $ ins "ref.null" [sxp eq]
+  halt <- Wasm.defun [i32] [] (replicate 5 scm) \_ ->
+    pure . mconcat $
+      [ popArg runtime 0
+      , ins "global.set" [sxp result]
+      ]
+  pure $ MkRuntime
+    {argArray,argArrayType
+    ,contStack,contStackTop,contStackType,contType
+    ,result,halt}
+  -- pure $ error "todo"
+
+lower :: Exp -> Eff es Text
+lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do
+  runtime <- emitRuntime
+  let g = MkEnv runtime mempty mempty
+  scm_entry <- Wasm.defun [i32] [] (replicate 5 scm) \_ ->
+    lower' g e
+  main <- Wasm.defun [] [scm] [scm, scm, scm, scm, scm] \_ ->
+    pure . mconcat $
+      -- push return cont
+      [--  ins "ref.func" [sxp halt]
+      -- make call
+      ins "i32.const" [sxp @Int 0]
+      , ins "call" [sxp scm_entry]
+      , ins "global.get" [sxp runtime.result]
+      , ins "ref.as_non_null" []
+      ]
+  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
@@ -42,7 +48,9 @@ import GHC.IO.Unsafe (unsafePerformIO)
 import qualified Data.Text.IO as TIO
 import Control.Monad (join)
 import qualified Language.Sexp.Located as SexpLoc
-import Data.Void (absurd)
+import Data.Void (absurd, Void)
+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,426 @@
+{- HLINT ignore "Use newtype instead of data" -}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeepSubsumption #-}
+{-# LANGUAGE NoFieldSelectors #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE RecordPuns #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE ImpredicativeTypes #-}
+{-# LANGUAGE DerivingVia #-}
+module Gyehoek.Wasm
+  ( defun
+  , rec'
+  , start
+  , runGenMod
+  , execGenMod
+  , renderModule
+  , Module
+  , Function
+  , Type(..)
+  , Expr
+  , Instr
+  , GenMod
+  , Idx
+  , i32
+  , export
+  , ins
+  , sxp
+  , result
+  , param
+  , if'
+  , ref
+  , eq
+  , i31ref
+  , i31
+  , struct
+  , mut
+  , sub
+  , deftype
+  , namedType
+  , type'
+  , deftypeNamed
+  , defglobal
+  , array
+  , FromIdx(..)
+  , func
+  , refnull
+  , declareFuncref
+  )
+  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)
+import qualified Control.Category
+import Data.Functor (void)
+
+
+data Module = MkModule
+  { types :: Vector RecType
+  , functions :: Vector Function
+  , funcrefs :: Vector Funcref
+  , start :: Maybe Idx
+  , exports :: Vector Export
+  , globals :: Vector Global
+  }
+  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
+    , funcrefs = m1.funcrefs <> m2.funcrefs
+    , globals = m1.globals <> m2.globals
+    }
+
+instance Monoid Module where
+  mempty = MkModule mempty mempty mempty Nothing mempty mempty
+
+newtype Funcref = MkFuncref { inner :: Idx }
+  deriving (Show, Generic)
+
+data Global = MkGlobal
+  { ty :: Type
+  , body :: Expr
+  }
+  deriving (Show, Generic)
+
+newtype RecType = MkRecType { inner :: Vector Type }
+  deriving (Show, Generic)
+
+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)
+
+data Idx
+  = IdxNumeric Natural
+  | IdxNamed Text
+  deriving (Show, Generic)
+
+data GenMod :: Effect where
+  DefRecType :: List Type -> GenMod m (List Idx)
+  Defun :: List Type -> List Type -> List Type
+        -> (Idx -> m Expr) -> GenMod m Idx
+  Start :: Idx -> GenMod m ()
+  Export :: Text -> Text -> Idx -> GenMod m ()
+  DefGlobal :: Type -> Expr -> GenMod m Idx
+  DeclareFuncref :: 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
+
+rec' :: (GenMod :> es) => List Type -> Eff es (List Idx)
+rec' = send . DefRecType
+
+deftype :: (GenMod :> es) => Type -> Eff es Idx
+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])
+
+defglobal :: (GenMod :> es) => Type -> Expr -> Eff es Idx
+defglobal t e = send $ DefGlobal t e
+
+defun
+  :: (GenMod :> es)
+  => List Type -> List Type -> List Type
+  -> (Idx -> Eff es Expr)
+  -> Eff es Idx
+defun params res locals code = send $ Defun params res locals code
+
+declareFuncref :: GenMod :> es => Idx -> Eff es ()
+declareFuncref = send . DeclareFuncref
+
+-- 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 :: forall es a. Eff (GenMod : es) a -> Eff es (a, Module)
+runGenMod = 
+  reinterpret (runStateLocal (mempty :: Module)) \cases
+    _ (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 ] ]
+    env (Defun params result locals code) ->
+      localSeqUnlift env \unlift -> do
+        m <- get
+        -- the least unused function index, computed as the number
+        -- of currently allocated functions.
+        let idx = IdxNumeric . fromIntegral . length $ m.functions
+        -- the body is computed with access to the newly allocated
+        -- index `idx` for the sake of recursive occurences.
+        body <- unlift $ code idx
+        let func = MkFunction {params,result,locals,body}
+        #functions <>= V.singleton func
+        pure idx
+    _ (DefGlobal t e) -> state \m ->
+      let prev_n = IdxNumeric . fromIntegral . V.length $ m.globals
+          m' = m & #globals <>~ V.singleton (MkGlobal t e)
+      in (prev_n, m')
+    _ (DeclareFuncref idx) -> #funcrefs <>= V.singleton (MkFuncref idx)
+
+execGenMod = fmap snd . runGenMod
+
+renderModule :: Module -> Text
+renderModule = (^?! _Right) . Gyehoek.Sexp.encodePretty
+
+ref :: Type -> Type
+ref (MkType x) = MkType . ParenList $ [Symbol "ref", x]
+
+refnull :: Type -> Type
+refnull (MkType x) = MkType . ParenList $ ["ref", "null", x]
+
+sub :: List Idx -> Type -> Type
+sub supers (MkType x) = MkType . ParenList $
+  Symbol "sub" : (sxp <$> supers) ++ [x]
+
+array :: Type -> Type
+array (MkType x) = MkType . ParenList $ [Symbol "array", 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]
+
+func :: List Type -> List Type -> Type
+func params results =
+  MkType . ParenList $
+    [ Symbol "func"
+    , wrap "param" params
+    , wrap "result" results
+    ]
+  where
+    wrap s xs = ParenList $ Symbol s : xs ^.. each . #inner
+
+i32, i31ref, eq, i31 :: Type
+i32 = MkType $ Symbol "i32"
+i31ref = MkType $ Symbol "i31ref"
+eq = MkType $ Symbol "eq"
+i31 = MkType $ Symbol "i31"
+
+class FromIdx a where
+  fromIdx :: Idx -> a
+
+instance FromIdx Type where
+  fromIdx (IdxNumeric n) = MkType . Symbol . T.pack . show $ n
+
+
+
+instance SexpIso Idx where
+  sexpIso = match
+    $ With (\numeric -> num >>> numeric)
+    $ With (\named -> name >>> named)
+    $ End
+    where
+      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
+      l :: Prism' Text Text
+      l = prefixed "$"
+      name = Sexp.symbol >>> Sexp.partialOsi
+        (maybe (Left $ Sexp.expected "$-prefixed sym") Right . preview l)
+        (review l)
+
+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 Global where
+  sexpIso = with \glob ->
+    list ( el (sym "global")
+         >>> el (sexpIso @Type)
+         >>> restCode
+         )
+    >>> glob
+
+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
+
+restCode :: Sexp.Grammar Position (Sexp.List :- t) (Sexp.List :- (Expr :- t))
+restCode =
+  rest (sexpIso @Instr)
+  >>> Sexp.onTail
+           (Sexp.iso
+            (view instrsExpr)
+            (review instrsExpr))
+    where
+      instrsExpr :: Iso' (List Instr) Expr
+      instrsExpr = vector . coerced
+
+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))
+       >>> restCode
+         )
+     >>> func
+
+instance SexpIso Module where
+  sexpIso = Sexp.partialOsi (const $ Left mempty) \m ->
+    ParenList $
+      [ Symbol "module" ]
+      <> (m ^.. #types . each . to sxp)
+      <> (m ^.. #globals . each . to sxp)
+      <> (m ^.. #funcrefs . each . to sxp)
+      <> (m ^.. #functions . each . to sxp)
+      <> (m ^.. #exports . each . to sxp)
+
+instance SexpIso Funcref where
+  sexpIso = with \funcref ->
+    list ( el (sym "elem")
+         >>> el (sym "declare")
+         >>> el (sym "funcref")
+         >>> el (list $ el (sym "ref.func") >>> el (sexpIso @Idx))
+         )
+    >>> funcref
+
+instance SexpIso Sexp where
+  sexpIso = Control.Category.id
+
+instance Each Expr Expr Instr Instr where
+  each = #MkExpr . each
+
+sxp :: HasCallStack => SexpIso a => a -> Sexp
+sxp e = either error id . Sexp.toSexp sexpIso $ e
+
+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) ]

t.js

@@ -0,0 +1,18 @@
+const imports = {
+    guppy: {
+        print: (arg) => console.log (arg)
+    }
+}
+
+// Assume add.wasm file exists that contains a single function adding 2 provided arguments
+const fs = require('node:fs');
+
+// Use the readFileSync function to read the contents of the "add.wasm" file
+const wasmBuffer = fs.readFileSync('u.wasm');
+
+// Use the WebAssembly.instantiate method to instantiate the WebAssembly module
+WebAssembly.instantiate(wasmBuffer, imports).then(wasmModule => {
+    // Exported function lives under instance.exports object
+    const { main } = wasmModule.instance.exports;
+    main ()
+});

t.wat

@@ -0,0 +1,62 @@
+(module
+  (type $heap-object (sub (struct (field (mut i32)))))
+  (type (func (param i32) (result)))
+  (type (array (mut (ref null 1))))
+  (type (array (mut (ref null eq))))
+  (global (mut i32) (i32.const 0))
+  (global (ref 2) (i32.const 128) (array.new_default 2))
+  (global (ref 3) (i32.const 32) (array.new_default 3))
+  (global (mut (ref null eq)) (ref.null eq))
+  (elem declare funcref (ref.func 1))
+  (func
+    (param i32)
+    (result)
+    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+    (global.get 2)
+    (i32.const 0)
+    (array.get 3)
+    ref.as_non_null
+    (global.set 3))
+  (func
+    (param i32)
+    (result)
+    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+    (global.get 2)
+    (i32.const 0)
+    (array.get 3)
+    ref.as_non_null
+    (local.set 1)
+    (global.get 2)
+    (i32.const 0)
+    (local.get 1)
+    (array.set 3)
+    (i32.const 1)
+    (global.get 1)
+    (global.get 0)
+    (array.get 2)
+    ref.as_non_null
+    (global.get 0)
+    (i32.const 1)
+    i32.sub
+    (global.set 0)
+    (return_call_ref 1))
+  (func
+    (param i32)
+    (result)
+    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+    (ref.func 1)
+    (local.set 1)
+    (global.get 2)
+    (i32.const 0)
+    (local.get 1)
+    (array.set 3)
+    (return_call 1))
+  (func
+    (param)
+    (result (ref eq))
+    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+    (i32.const 0)
+    (call 1)
+    (global.get 3)
+    ref.as_non_null)
+  (export "main" (func 3)))

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]
+       ""

u.wat

@@ -0,0 +1,78 @@
+(module
+ (func $print (import "guppy" "print") (param i32))
+ (table 2 funcref)
+ (elem (i32.const 0) $halt)
+
+ (type $cont (func (param i32)))
+ (type $cont-stack-type (array (mut (ref null $cont))))
+ (global $cont-stack (ref $cont-stack-type)
+         (array.new_default $cont-stack-type (i32.const 128)))
+ (global $cont-stack-top (mut i32) (i32.const 0))
+
+ (type $arg-array-type (array (mut (ref null eq))))
+ (global $arg-array (ref $arg-array-type)
+         (array.new_default $arg-array-type (i32.const 32)))
+
+ ;; (memory $memory i32 1)
+ ;; (global $arg-stack-base i32 (i32.const 0))
+ ;; (global $arg-stack-ptr i32 (global.get $arg-stack-base))
+ ;; (global $cont-stack-base i32 (i32.const 32))
+ ;; (global $cont-stack-ptr i32 (global.get $cont-stack-base))
+
+ (func $add (param $nargs i32)
+       (local $x (ref eq))
+       (local $y (ref eq))
+       (local $return (ref $cont))
+       (local.set $x (ref.as_non_null
+                      (array.get $arg-array-type
+                                 (global.get $arg-array)
+                                 (i32.const 0))))
+       (local.set $y (ref.as_non_null
+                      (array.get $arg-array-type
+                                 (global.get $arg-array)
+                                 (i32.const 1))))
+       (array.set $arg-array-type
+                  (global.get $arg-array)
+                  (i32.const 0)
+                  (ref.i31
+                   (i32.add (i31.get_s (ref.cast (ref i31) (local.get $x)))
+                            (i31.get_s (ref.cast (ref i31) (local.get $y))))))
+       (return_call_ref
+        $cont
+        (i32.const 1)
+        (block (result (ref $cont))
+               (ref.as_non_null
+                (array.get $cont-stack-type
+                           (global.get $cont-stack)
+                           (global.get $cont-stack-top)))
+               (global.set $cont-stack-top
+                           (i32.sub (global.get $cont-stack-top)
+                                    (i32.const 1))))))
+ (func $halt (param $nargs i32)
+       (call $print
+             (i31.get_s
+              (ref.cast
+               (ref i31)
+               (ref.as_non_null
+                (array.get $arg-array-type
+                           (global.get $arg-array)
+                           (i32.const 0)))))))
+ (func (export "main")
+       ;; push args
+       (array.set $arg-array-type
+                  (global.get $arg-array)
+                  (i32.const 0)
+                  (ref.i31 (i32.const 4)))
+       (array.set $arg-array-type
+                  (global.get $arg-array)
+                  (i32.const 1)
+                  (ref.i31 (i32.const 5)))
+       ;; push return continuation
+       (array.set $cont-stack-type
+                  (global.get $cont-stack)
+                  (i32.const 0)
+                  (ref.func $halt))
+       ;; make call }:)
+       (return_call $add
+                    ;; inform $add how many arguments we called it with
+                    (i32.const 2))))

wasmtime.nix

@@ -0,0 +1,26 @@
+# A Wasmtime wrapper that provides our desired configuration.
+{ wasmtime
+, makeWrapper
+, symlinkJoin
+, formats
+, extraSettings ? {}
+}:
+
+let
+  config = {
+    wasm.gc = true;
+  };
+  config-file =
+    (formats.toml {}).generate
+      "gyehoek-wasmtime.toml"
+      (config // extraSettings);
+in symlinkJoin {
+  name = "gyehoek-wasmtime";
+  inherit (wasmtime) version;
+  paths = [ wasmtime ];
+  nativeBuildInputs = [ makeWrapper ];
+  postBuild = ''
+    wrapProgram $out/bin/wasmtime \
+      --add-flags "--config ${config-file}"
+  '';
+}

wasmtime.toml

@@ -0,0 +1,6 @@
+# Comment out certain settings to use default values.
+# For more settings, please refer to the documentation:
+# https://bytecodealliance.github.io/wasmtime/cli-cache.html
+
+[wasm]
+gc=true