doc

.dir-locals.el

@@ -2,4 +2,6 @@
   . ((eval
       . (progn (defun apply-cabal-fmt-h ()
                  (haskell-mode-buffer-apply-command "cabal-fmt"))
-               (add-hook 'before-save-hook #'apply-cabal-fmt-h nil t))))))
+               (add-hook 'before-save-hook #'apply-cabal-fmt-h nil t)
+               (add-to-list 'haskell-font-lock-quasi-quote-modes
+                            '("cps" . scheme-mode)))))))

.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/Convert.hs

@@ -1,49 +0,0 @@
-{-# LANGUAGE OverloadedLists #-}
-module Gyehoek.CPS.Convert
-  ( convert
-  ) where
-
-import Gyehoek.CPS.Syntax
-import Gyehoek.Scheme.Syntax qualified as Scm
-import Gyehoek.GenSym
-import Data.List.NonEmpty (NonEmpty((:|)))
-import Effectful
-import Control.Monad.Cont qualified as Cont
-
-
--- 뻘짓이어라
-telescope
-  :: Traversable t
-  => (a -> (b -> r) -> r)
-  -> t a -> (t b -> r) -> r
-telescope f = Cont.runCont . traverse (Cont.cont . f)
-
-convert
-  :: forall es. (GenSym :> es)
-  => Scm.Exp -> (Val -> Eff es Exp) -> Eff es Exp
-
-convert (Scm.ExpVar x) k = k $ ValVar x
-convert (Scm.ExpLit l) k = k $ ValLit l
-
-convert (Scm.ExpPrim p) k =
-  telescope (convert @es) p \p' -> do
-    r <- gensym' "r"
-    ExpPrim p' [r] <$> k (ValVar r)
-
-convert (Scm.ExpLambda xs e) k = do
-  f <- gensym' "f"
-  ktail <- gensym' "ktail"
-  m <- convert e $ \e' ->
-    pure $ ExpApply (ValVar ktail) [e']
-  ExpFix [(f, MkKappa (xs ++ [ktail]) m)] <$> k (ValVar f)
-
-convert (Scm.ExpApply f xs) k =
-  telescope (convert @es) (f:|xs) \(f':|xs') -> do
-    r <- gensym' "r"
-    x <- gensym' "x"
-    m <- k (ValVar x)
-    pure $ ExpFix [(r, MkKappa [x] m)] $ ExpApply f' (xs' ++ [ValVar r])
-
-convert (Scm.ExpBegin xs) k = _
-
-convert _ k = _

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

@@ -1,97 +0,0 @@
-{-# LANGUAGE OverloadedLabels #-}
-{-# LANGUAGE TemplateHaskell #-}
-module Gyehoek.CPS.Syntax
-  ( Val(..)
-  , Kappa(..)
-  , Exp(..)
-  , Name(..)
-  , Prim(..)
-  , pattern Halt
-  , pattern Halt1
-  , _MkKappa
-  , _ExpPrim
-  , _ExpFix
-  , _ExpApply
-  )
-  where
-
-import Language.SexpGrammar qualified as S
-import Gyehoek.Sexp qualified
-import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primSexpIso, Lit)
-import Data.Text (Text)
-import Data.List (List)
-import GHC.Generics (Generic)
-import Language.SexpGrammar.Generic
-import Control.Category
-import Control.Lens
-import Data.Text qualified as T
-import Data.Generics.Labels
-import Prelude hiding ((.), id)
-import Data.List.NonEmpty (NonEmpty)
-
--- Data types
-
-data Val
-  = ValLabel Name
-  | ValVar Name
-  | ValLit Lit
-  deriving (Show, Generic)
-
-data Kappa = MkKappa (List Name) Exp
-  deriving (Show, Generic)
-
-data Exp
-  = ExpPrim (Prim Val) (List Name) Exp
-  | ExpFix (NonEmpty (Name, Kappa)) Exp
-  | ExpApply Val (List Val)
-  | ExpIf Val Exp Exp
-  deriving (Show, Generic)
-
-pattern Halt :: List Val -> Exp
-pattern Halt xs = ExpApply (ValVar "halt") xs
-
-pattern Halt1 :: Val -> Exp
-pattern Halt1 x = ExpApply (ValVar "halt") [x]
-
-makePrisms ''Kappa
-makePrisms ''Exp
-
-
--- SexpIso instances
-
-instance S.SexpIso Val where
-  sexpIso = match
-    $ With (. label)
-    $ With (. var)
-    $ With (. S.sexpIso)
-    $ End
-    where
-      label = S.keyword >>> S.iso MkName getName
-      var = S.sexpIso
-
-instance S.SexpIso Kappa where
-  sexpIso = match
-    $ With (. kappa)
-    $ End
-    where
-      kappa = S.list $
-        S.el Gyehoek.Sexp.kappaKeyword
-        >>> S.el (S.list $ S.rest S.sexpIso)
-        >>> S.el S.sexpIso
-
-instance S.SexpIso Exp where
-  sexpIso = match
-    $ With (. prim)
-    $ With (. let_)
-    $ With (. app)
-    $ With (. if_)
-    $ 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
-      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

app/Gyehoek/Sexp.hs

@@ -1,143 +0,0 @@
-{-# LANGUAGE PartialTypeSignatures #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE OverloadedLabels #-}
-module Gyehoek.Sexp
-  ( let_
-  , sexp
-  , nonempty
-  , nonEmptyGrammar
-  , encode
-  , decode
-  , parseSexps
-  , prefixSugar
-  , todo
-  , isoIso
-  , encodeWith
-  , decodeWith
-  , kappa
-  , lambda
-  , kappaKeyword
-  , lambdaKeyword
-  )
-where
-
-import Data.Text (Text)
-import Language.SexpGrammar as Sexp hiding (List, encode, decode, encodeWith, decodeWith, iso)
-import Language.SexpGrammar qualified as Sexp
-import Language.Sexp qualified as S
-import Language.SexpGrammar.Generic
-import Data.InvertibleGrammar.Base qualified as IGB
-import Data.InvertibleGrammar qualified as IG
-import Data.InvertibleGrammar.Base ((:-)((:-)))
-import Data.List.NonEmpty (NonEmpty ((:|)))
-import Data.List (List)
-import Data.Text.Encoding
-import Data.Either (either)
-import GHC.Generics (Generic)
-import Control.Lens
-import Data.Generics.Labels
-import System.Process
-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)
-
-
-sexp :: SexpIso a => Iso' a Text
-sexp = iso
-  (either error id . encode)
-  (either error id . decode)
-
-encode :: SexpIso a => a -> Either String Text
-encode = encodeWith sexpIso
-
-decode :: SexpIso a => Text -> Either String a
-decode = decodeWith sexpIso
-
-encodeWith :: SexpGrammar a -> a -> Either String Text
-encodeWith g = (_Right %~ decodeUtf8 . view strict) . Sexp.encodeWith g
-
-decodeWith :: SexpGrammar a -> Text -> Either String a
-decodeWith g = Sexp.decodeWith g "FILE" . view lazy . encodeUtf8
-
-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)
-
-nonEmptyGrammar :: Grammar p (NonEmpty x :- t) (List x :- x :- t)
-nonEmptyGrammar = IGB.Iso
-  (\((x:|xs) :- t) -> reverse xs :- x :- t)
-  (\(xs :- x :- t) -> (x :| reverse xs) :- t)
-
-nonempty :: SexpGrammar a -> SexpGrammar (NonEmpty a)
-nonempty a =
-  list (el a >>> rest a) >>>
-    IG.flipped nonEmptyGrammar
-
-let_
-  :: Text
-  -> (forall t. Grammar Position (Sexp :- t) (a :- t))
-  -> (forall t. Grammar Position (Sexp :- t) (b :- t))
-  -> Grammar Position (Sexp :- (NonEmpty (a, b) :- t1)) t2
-  -> Grammar Position (Sexp :- t1) t2
-let_ kw name rhs e = list (el (sym kw) >>> el bindings >>> el e)
-  where
-    -- bindings :: Grammar Position (Sexp :- _) (List (_, _) :- _)
-    bindings = nonempty binding
-    binding :: Grammar Position (Sexp :- t) ((_, _) :- t)
-    binding = list (el name >>> el rhs) >>> pair
-
-data DotList a = MkDotList (NonEmpty a) a
-  deriving (Show, Generic)
-
-dotlist :: (forall t. Grammar Position (Sexp :- t) (a :- t)) -> _
-dotlist x = list $ rest $ coproduct
-  [ x >>> _
-  ]
-
--- | Define a sexp representation as either (⟨name⟩ ⟨e⟩) or '⟨e⟩.
-prefixSugar
-  :: Text -> Prefix
-  -> Grammar Position (Sexp :- t') a
-  -> Grammar Position (Sexp :- t') a
-prefixSugar name prefix e = coproduct
-  -- 'something
-  [ Sexp.prefixed prefix e
-  -- (quote something)
-  , list $ el (sym name) >>> el e
-  ]
-
-todo :: Grammar p (Sexp :- t) t'
-todo = (IGB.Flip $ IGB.PartialIso absurd f) >>> IGB.PartialIso absurd g
-  where
-    f _ = Left $ unexpected "todo"
-    g _ = Left $ unexpected "todo"
-
-kappa
-  :: (forall t. Grammar Position (Sexp :- t) (a :- t))
-  -> Grammar Position (Sexp :- List a :- t1) t2
-  -> Grammar Position (Sexp :- t1) t2
-kappa name e = list $
-  el kappaKeyword
-  >>> el (list $ rest name)
-  >>> el e
-
-lambda
-  :: (forall t. Grammar Position (Sexp :- t) (a :- t))
-  -> Grammar Position (Sexp :- List a :- t1) t2
-  -> Grammar Position (Sexp :- t1) t2
-lambda name e = list $
-  el lambdaKeyword
-  >>> el (list $ rest name)
-  >>> el e
-
-isoIso :: Iso' s a -> Grammar p (s :- t) (a :- t)
-isoIso l = Sexp.iso (view l) (review l)
-
-kappaKeyword :: Grammar Position (Sexp :- t) t
-kappaKeyword = coproduct [ sym "κ", sym "kappa" ]
-
-lambdaKeyword :: Grammar Position (Sexp :- t) t
-lambdaKeyword = coproduct [ sym "λ", sym "lambda" ]

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,23 @@
+#+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
+
+| type/value | low bits |
+|------------+----------|
+| small int  |        0 |
+| ~false~      |       01 |
+| ~true~       |       11 |

doc/index.org

@@ -0,0 +1,53 @@
+#+title: Gyehoek Scheme
+
+#+begin_center
+(this document is written in present tense as if the project is complete, but Gyehoek is a work-in-progress.)
+#+end_center
+
+Gyehoek is an R⁷RS-compliant Scheme compiler targeting WebAssembly 3.0, relying principally on the recently standardised garbage collector and tail call proposals. the Gyehoek compiler is implemented in Haskell, and the Gyehoek runtime is a Rust program providing primitive routines and WebAssembly execution via the Wasmtime library.
+
+primitives are implemented as native Rust functions made available to the guest by Wasmtime. in the future, it would be ideal to provide the primitives as a WASI interface to help decouple ourselves from a specific Wasm runtime, but it is not a priority.
+
+Gyehoek allows separate compilation, ~eval~, first-class continuations, and so on.
+
+* pipeline
+
+a Scheme program's journey through Gyehoek is as follows:
+1. read (source code → Scheme data)
+2. parse (Scheme data → AST)
+3. expand(?) (AST → AST)
+4. contify (AST → CPS)
+5. close (CPS → CPS)
+6. lower (CPS → Wasm)
+
+** read
+
+in the read phase, Gyehoek's reader serialises textual source code into a sequence of tokens, which are then parsed into S-expressions. this phase is completely agnostic towards any interpretation of the data — it's just data, not code (yet). this distinction between reading and parsing is made so that the reader can easily be shared amongst many parsers, allowing convenient definition of human-readable representations for all sorts of compiler internals. Gyehoek's intermediate languages and WebAssembly text format are of particular interest.
+
+the reader may be configured to extend R⁷RS's syntax with a special "antiquotation" notation, used internally in the compiler to elegantly interpolate and splice S-expression literals via Haskell's quasiquotation.
+#+begin_src haskell
+  let meta = 123 :: Int
+  in [sx|(a b c #{meta} d)|] -- ⇒ (a b c 123 d)
+
+  let metas = ["c","d"] :: List Text
+  in [sx|(a b ##{metas} e f)|] -- ⇒ (a b "c" "d" e f)
+#+end_src
+
+Gyehoek's lexer and parser are generated by Alex and Happy, respectively.
+
+unless otherwise noted, the term "parse" will be used in reference to the phase taking S-expressions to ASTs, while "read" refers to the combined Alex/Happy process. if the tokenisation process (Alex) must be distinguished from the "parse" process (Happy), the former is called "lexical analysis" and the latter "syntactic analysis."
+
+** parse
+
+- use invertible-grammar library
+
+** expand
+
+** contify
+
+- procedures are distinguished from continuations, and procedure applications are distinguished from continuation jumps.
+- all continuations and lambda will be named i think. the exception is continuations for primitive calls.
+
+** close
+
+** lower

flake.lock

@@ -66,6 +66,21 @@
         "type": "github"
       }
     },
+    "crane": {
+      "locked": {
+        "lastModified": 1784248371,
+        "narHash": "sha256-0l0Y4D4wbZhp1Oi6h8OpbLtIm/4FN88oCf54MK2ZgiM=",
+        "owner": "ipetkov",
+        "repo": "crane",
+        "rev": "f7d151ec0bf52cf9662e2f59d7bea28588c2f070",
+        "type": "github"
+      },
+      "original": {
+        "owner": "ipetkov",
+        "repo": "crane",
+        "type": "github"
+      }
+    },
     "flake-compat": {
       "flake": false,
       "locked": {
@@ -587,6 +602,7 @@
     },
     "root": {
       "inputs": {
+        "crane": "crane",
         "haskellNix": "haskellNix",
         "nixpkgs": [
           "haskellNix",

flake.nix

@@ -7,6 +7,7 @@
       url = "git+https://git.deertopia.net/msyds/sydpkgs";
       inputs.nixpkgs.follows = "nixpkgs";
     };
+    crane.url = "github:ipetkov/crane";
   };
 
   outputs = { self, nixpkgs, sydpkgs, haskellNix, ... }@inputs:
@@ -19,27 +20,43 @@
       overlays = [
         haskellNix.overlay
         (final: prev: {
+          shake-wrapper = final.callPackage ./shake-wrapper.nix {};
+          gyehoek-runtime = final.callPackage ./runtime {
+            crane-lib = inputs.crane.mkLib final;
+          };
           gyehoek = final.haskell-nix.project' {
             src = ./.;
             compiler-nix-name = "ghc912";
+            modules = [({ pkgs, lib, ...}: {
+              packages.gyehoek.components.tests.test.preCheck =
+                let
+                  bin = [
+                    pkgs.git # tasty uses git diff
+                  ];
+                in ''
+                  export GYEHOEK_RUNTIME=${lib.getExe final.gyehoek-runtime}
+                  export PATH=${lib.makeBinPath bin}:$PATH
+                '';
+            })];
             shell = {
               withHoogle = true;
-              inputsFrom = [];
+              inputsFrom = [
+                final.gyehoek-runtime
+              ];
               tools = {
                 cabal = {};
                 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
+                shake-wrapper
+                wabt
+                nodejs
+                wasm-tools
+                wac-cli
+                guile
+                rust-analyzer
+                wasmtime
               ];
             };
           };
@@ -67,14 +84,18 @@
       _pkgs = each-system ({ pkgs, ... }: pkgs);
       _hf = hf;
 
-      packages = each-system ({ pkgs, system, ... }:
-        hf.packages.${system} // {
-          default = hf.packages.${system}."gyehoek:exe:gyehoek";
-          shake = pkgs.callPackage ./shake-wrapper.nix {};
-        });
+      packages = each-system ({ pkgs, lib, system, ... }:
+        hf.packages.${system} // lib.fix (packages: {
+          gyehoek = hf.packages.${system}."gyehoek:exe:gyehoek";
+          default = packages.gyehoek;
+          inherit (pkgs) gyehoek-runtime shake-wrapper;
+        }));
 
       devShells = each-system
         ({ pkgs, system, ... }: hf.devShells.${system});
+
+      checks = each-system
+        ({ pkgs, system, ... }: hf.checks.${system});
     };
 
   nixConfig = {

golden/apply-twice/source.scm

@@ -0,0 +1,5 @@
+;; apply `f' to `x' twice.
+((λ (f x)
+   (f (f x)))
+ (λ (x) (+ x 4))
+ 9)

golden/arith/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 22

golden/false/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > #f

golden/false/source.scm

@@ -0,0 +1 @@
+#f

golden/fn-of-fn/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 128

golden/fn-of-fn/source.scm

@@ -0,0 +1 @@
+(((λ (f) f) (λ (x) (* x 4))) 32)

golden/if-false/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 555

golden/if-false/source.scm

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

golden/if-number/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 777

golden/if-number/source.scm

@@ -0,0 +1 @@
+(if 123 777 555)

golden/if-true/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 777

golden/if-true/source.scm

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

golden/lambda/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > #<procedure>

golden/lambda/source.scm

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

golden/square/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 25

golden/square/source.scm

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

golden/true/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > #t

golden/true/source.scm

@@ -0,0 +1 @@
+#t

gyehoek.cabal

@@ -20,25 +20,42 @@ 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
     DeriveGeneric
+    DerivingVia
+    DuplicateRecordFields
+    NoFieldSelectors
+    OrPatterns
+    OverloadedLabels
     OverloadedRecordDot
     OverloadedStrings
     PartialTypeSignatures
     PatternSynonyms
+    QuasiQuotes
 
 executable gyehoek
   import:           ghcstuffs, ghcstuffs-dev
   main-is:          Main.hs
+  build-depends:
+    , base     ^>=4.21.2.0
+    , gyehoek
 
-  -- cabal-fmt: expand app -Main
-  other-modules:
+  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
+    Gyehoek.Driver
     Gyehoek.GenSym
     Gyehoek.Options
     Gyehoek.Scheme.Syntax
@@ -49,7 +66,7 @@ executable gyehoek
     , base                  ^>=4.21.2.0
     , binary
     , containers
-    , cradle
+    , typed-process
     , effectful
     , effectful-core
     , effectful-plugin
@@ -61,15 +78,41 @@ executable gyehoek
     , megaparsec
     , mtl
     , optparse-applicative
+    , pretty-simple
     , prettyprinter
     , process
     , recursion-schemes
     , sexp-grammar
+    , string-interpolate
     , template-haskell
     , text
     , text-short
     , unordered-containers
     , vector
+    , bytestring
+
+  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
+  other-modules:
+    Gyehoek.Test.CPS.Syntax
+    Gyehoek.Test.Golden
+    Gyehoek.Test.Sexp
+
+  build-depends:
+    , base
+    , directory
+    , filepath
+    , gyehoek
+    , process-extras
+    , sexp-grammar
+    , tasty
+    , tasty-hunit
+    , tasty-silver
 
-  hs-source-dirs:   app
   default-language: GHC2024

runtime/.gitignore

@@ -0,0 +1 @@
+target/

runtime/Cargo.toml

@@ -0,0 +1,10 @@
+[package]
+name = "gyehoek-runtime"
+version = "0.1.0"
+edition = "2024"
+
+[dependencies]
+clap = { version = "4.6.1", features = ["derive"] }
+clio = { version = "0.3.5", features = ["clap-parse"] }
+memoize = "0.6.0"
+wasmtime = "46.0.1"

runtime/default.nix

@@ -0,0 +1,13 @@
+{ rustPlatform
+, lib
+, crane-lib
+}:
+
+crane-lib.buildPackage (lib.fix (finalAttrs: {
+  pname = "gyehoek-runtime";
+  version = "0.1.0";
+  src = ./.;
+  # cargoLock = ./Cargo.lock;
+  doCheck = true;
+  meta.mainProgram = "gyehoek-runtime";
+}))

runtime/src/gyehoek.rs

@@ -0,0 +1,38 @@
+use wasmtime::*;
+use crate::internal as scm;
+use crate::internal::{Scm,Immediate,HeapObject};
+
+// pub fn small_fixnum_p (_)
+
+// pub fn immediate_p (caller : Caller<'_, u32>, x : EqRef) -> EqRef {
+//     x.is_i31 ()
+// }
+
+fn write_immediate (_caller : Caller<'_, u32>, imm : Immediate) {
+    match imm {
+        Immediate::SmallFixnum (n) => print! ("{}", n),
+        Immediate::Bool (b) => print! ("{}", if b { "#t" } else { "#f" }),
+    }
+}
+
+pub fn write (caller : Caller<'_, u32>, x : Rooted<EqRef>) {
+    match scm::interpret (&caller, x).unwrap ().unwrap () {
+        Scm::Immediate (x) => write_immediate (caller, x),
+        Scm::HeapObject (x) => write_heap_object (caller, x),
+    }
+}
+
+fn write_heap_object (_caller : Caller<'_, u32>, x : HeapObject) {
+    match x {
+        HeapObject::Procedure => print! ("#<procedure>"),
+    }
+}
+
+pub fn truthy_p (caller : Caller<'_, u32>, x : Rooted<EqRef>,) -> u32 {
+    let r = scm::interpret (&caller, x).unwrap ().unwrap ();
+    if let Scm::Immediate (Immediate::Bool (false)) = r {
+        0
+    } else {
+        1
+    }
+}

runtime/src/internal.rs

@@ -0,0 +1,99 @@
+use wasmtime::*;
+use crate::types;
+
+pub fn immediate_p (store : impl AsContext, x : Rooted<EqRef>) -> bool {
+    x.is_i31 (store).unwrap ()
+}
+
+pub enum Immediate {
+    SmallFixnum (i32),
+    Bool (bool),
+}
+
+pub enum HeapObject {
+    Procedure
+}
+
+pub enum Scm {
+    Immediate (Immediate),
+    HeapObject (HeapObject),
+}
+
+#[allow(nonstandard_style)]
+pub type scm_bits = u32;
+
+#[allow(nonstandard_style)]
+pub const scm_false : scm_bits = 0b01;
+#[allow(nonstandard_style)]
+pub const scm_true : scm_bits = 0b11;
+
+pub fn interpret_immediate (x : scm_bits) -> Option<Immediate> {
+    if x & 1 == 0 {
+        Some (Immediate::SmallFixnum ((x >> 1).try_into ().unwrap ()))
+    } else if x == scm_true {
+        Some (Immediate::Bool (true))
+    } else if x == scm_false {
+        Some (Immediate::Bool (false))
+    } else {
+        None
+    }
+}
+
+pub fn interpret_heap_object (
+    store : impl AsContext,
+    x : Rooted<EqRef>
+) -> Result<Option<HeapObject>> {
+    if x.matches_ty (&store, &types::closure (&store)?)? {
+        Ok (Some (HeapObject::Procedure))
+    } else {
+        todo! ()
+    }
+}
+
+pub fn interpret (
+    store : impl AsContext,
+    x : Rooted<EqRef>
+) -> Result<Option<Scm>> {
+    if let Some (imm) = x.as_i31 (&store)? {
+        Ok (
+            interpret_immediate (imm.get_u32 ())
+                .map (Scm::Immediate)
+        )
+    } else {
+        Ok (
+            interpret_heap_object (&store, x)?
+                .map (Scm::HeapObject)
+        )
+    }
+}
+
+pub fn encode_immediate (
+    store : impl AsContext,
+    imm : Immediate
+) -> scm_bits {
+    use Immediate::*;
+    match imm {
+        SmallFixnum (n) => (n << 1).try_into ().unwrap (),
+        Bool (false) => scm_false,
+        Bool (true) => scm_true,
+    }
+}
+
+pub fn encode (store : impl AsContextMut, x : Scm) -> Rooted<EqRef> {
+    match x {
+        Scm::Immediate (imm) => {
+            let i31 = I31::new_u32 (encode_immediate (&store, imm))
+                .unwrap ();
+            EqRef::from_i31 (store, i31)
+        }
+        Scm::HeapObject (ho) => {
+            todo! ()
+        }
+    }
+}
+
+pub fn encode_bool (store : impl AsContextMut, b : bool) -> Rooted<EqRef> {
+    let x = if b { scm_true } else { scm_false };
+    let i31 = I31::new_u32 (x).unwrap ();
+    EqRef::from_i31 (store, i31)
+}

runtime/src/main.rs

@@ -0,0 +1,53 @@
+mod gyehoek;
+mod internal;
+mod types;
+
+use std::io;
+use std::io::Read;
+use clio::*;
+use clap::Parser;
+use wasmtime::*;
+
+/// A runtime for Gyehoek scheme.
+#[derive(Parser, Debug)]
+#[command(name = "gyehoek", version, about, long_about = None)]
+struct Args {
+    /// Path to Wasm binary or textual source
+    #[clap(value_parser)]
+    wasm: Input,
+}
+
+fn read<R : Read> (mut rdr : R) -> io::Result<Vec<u8>> {
+    let mut buf = vec! [];
+    rdr.read_to_end (&mut buf)?;
+    Ok (buf)
+}
+
+fn get_config () -> Config {
+    let mut cfg = Config::new ();
+    cfg.wasm_reference_types (true);
+    cfg.wasm_function_references (true);
+    cfg.wasm_tail_call (true);
+    cfg.wasm_gc (true);
+    cfg
+}
+
+fn link_primitives (linker : &mut Linker<u32>) -> wasmtime::Result<()> {
+    linker.func_wrap ("gyehoek", "write", gyehoek::write)?;
+    linker.func_wrap ("gyehoek", "truthy?", gyehoek::truthy_p)?;
+    Ok (())
+}
+
+pub fn main () -> wasmtime::Result<()> {
+    let args = Args::parse ();
+    let wasm_config = get_config ();
+    let engine = Engine::new (&wasm_config)?;
+    let module = Module::new (&engine, read (args.wasm)?)?;
+    let mut linker = Linker::new (&engine);
+    link_primitives (&mut linker)?;
+    let mut store : Store<u32> = Store::new (&engine, 4);
+    let instance = linker.instantiate (&mut store, &module)?;
+    let main = instance.get_typed_func::<(),()> (&mut store, "main")?;
+    main.call (&mut store, ())?;
+    Ok (())
+}

runtime/src/types.rs

@@ -0,0 +1,62 @@
+use wasmtime::*;
+use memoize::memoize;
+
+pub fn heap_object_struct (store : impl AsContext) -> Result<StructType> {
+    let ctx = store.as_context ();
+    let engine = ctx.engine ();
+    Ok (
+        StructType::with_finality_and_supertype (
+            engine,
+            Finality::NonFinal,
+            None,
+            vec![
+                hash_field ()
+            ]
+        )?
+    )
+}
+
+pub fn heap_object (_store : impl AsContext) -> Result<HeapType> {
+    todo! ()
+}
+
+#[memoize]
+pub fn hash_field () -> FieldType {
+    FieldType::new (
+        Mutability::Var,
+        StorageType::ValType (ValType::I32)
+    )
+}
+
+pub fn closure (store : impl AsContext) -> Result<HeapType> {
+    let ctx = store.as_context ();
+    let engine = ctx.engine ();
+    Ok (
+        HeapType::ConcreteStruct (
+            StructType::with_finality_and_supertype (
+                engine,
+                Finality::NonFinal,
+                Some (&heap_object_struct (&store)?),
+                vec![
+                    hash_field (),
+                    FieldType::new (
+                        Mutability::Const,
+                        StorageType::ValType (ValType::Ref (
+                            RefType::new (
+                                false,
+                                HeapType::ConcreteFunc (
+                                    FuncType::new (
+                                        engine,
+                                        vec![ValType::I32],
+                                        vec![],
+                                    )
+                                )
+                            )
+                        ))
+                    ),
+                ]
+            )?
+        )
+    )
+}
+

src/Gyehoek/CPS/Convert.hs

@@ -0,0 +1,75 @@
+{-# LANGUAGE OverloadedLists #-}
+{- HLINT ignore "Use camelCase" -}
+module Gyehoek.CPS.Convert
+  ( convertProgram
+  ) where
+
+import Gyehoek.CPS.Syntax
+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 Control.Lens
+import qualified Data.List.NonEmpty as NE
+import qualified Gyehoek.Sexp
+
+
+-- 뻘짓이어라
+telescope
+  :: Traversable t
+  => (a -> (b -> r) -> r)
+  -> t a -> (t b -> r) -> r
+telescope f = Cont.runCont . traverse (Cont.cont . f)
+
+
+
+pattern Atomic e <-
+  e@( Scm.ExpLambda _ _
+  ; Scm.ExpVar _
+  ; Scm.ExpLit _ )
+
+-- | Transform an expression with a meta-continuation.
+convert
+  :: forall es. (GenSym :> es)
+  => Scm.Exp -> (Val -> Eff es Exp) -> Eff es Exp
+
+convert (Scm.ExpVar x) k = k $ ValVar x
+convert (Scm.ExpLit l) k = k $ ValLit l
+
+convert (Scm.ExpPrim p) k =
+  telescope (convert @es) p \p' -> do
+    r <- gensym' "r"
+    ExpPrim p' . MkKappa [r] <$> k (ValVar r)
+
+convert (Scm.ExpLambda xs e) k = do
+  f <- gensym' "λ-body"
+  ktail <- gensym' "λ-tail"
+  m <- convert e $ \e' -> pure $ ExpContinue ktail [e']
+  ke <- k $ ValVar f
+  pure [cps|
+    (letrec ((#{f} (λ (##{xs} #{ktail}) #{m})))
+      #{ke})
+  |]
+
+convert (Scm.ExpApply f xs) k =
+  telescope (convert @es) (f:|xs) \(f':|xs') -> do
+    r <- gensym' "r"
+    x <- gensym' "x"
+    m <- k (ValVar x)
+    pure $ ExpLetRec [(r, AbsKappa' [x] m)] $ ExpApply f' xs' r
+
+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,350 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultilineStrings #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE ApplicativeDo #-}
+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
+{-# LANGUAGE RecursiveDo #-}
+{- HLINT ignore "Use camelCase" -}
+module Gyehoek.CPS.Lower
+  (lower, lowerProgram) where
+
+import Gyehoek.CPS.Syntax
+import Data.Generics.Labels ()
+import Effectful
+import Data.Text (Text)
+import Data.Vector.Strict (Vector)
+import Control.Lens hiding (op)
+import Numeric.Natural
+import GHC.Generics (Generic)
+import qualified Data.Vector.Strict as V
+import Gyehoek.Wasm qualified as Wasm
+import Gyehoek.Wasm hiding (Expr)
+import Language.Sexp.Located qualified as SL
+import Control.Monad.Fix
+import qualified Gyehoek.Sexp
+import Data.Text qualified as T
+import Data.Foldable (fold)
+import Gyehoek.Sexp (encodeOrShow, toSexp)
+import Debug.Pretty.Simple
+
+
+data Env = MkEnv
+  { 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)
+
+
+
+tonat :: Integral a => a -> Natural
+tonat = fromIntegral
+
+-- | @makeSmallFixnum@ emits an expression injecting the i32 on top
+-- of the stack into the SCM unitype.
+makeSmallFixnum :: Wasm.Expr
+makeSmallFixnum = [expr|
+    (@gyehoek "construct small fixnum")
+    (i32.const 1)
+    i32.shl
+    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 :: Natural -> Wasm.Expr -> Wasm.Expr
+pushArg n e = [expr|
+    (@gyehoek "push argument")
+    (global.get $arg-array)
+    (i32.const #{n})
+    ##{e}
+    (array.set $arg-array-type)
+  |]
+
+-- | Pop the nth arg from the arg-passing array onto the stack.
+popArg :: Int -> Wasm.Expr
+popArg n = [expr|
+  (@gyehoek "pop argument")
+  (global.get $arg-array)
+  (i32.const #{n})
+  (array.get $arg-array-type)
+  ref.as_non_null
+|]
+
+
+
+lowerVal :: GenMod :> es => Env -> Val -> Eff es Wasm.Expr
+
+lowerVal g (ValLit l) =
+  pure $ case l of
+    LitInt n -> [expr|
+      (i32.const #{n})
+      ##{makeSmallFixnum}
+    |]
+    LitBool b -> [expr|
+      (i32.const #{b'})
+      ref.i31
+    |]
+      where b' :: Int = if b then 0b11 else 0b01
+    _ -> _
+
+lowerVal g (ValVar x) = pure $ [expr|(local.get #{l})|]
+  where
+    l = succ $ V.elemIndex x g.vars ^?! _Just
+
+-- lowerVal g (ValLambda lam) = do
+--   idx <- lowerLambda g lam
+--   pure [expr|
+--     (i32.const 0)
+--     (ref.func #{idx})
+--     (struct.new $closure)
+--   |]
+
+lower' :: (GenMod :> es) => Env -> Exp -> Eff es Wasm.Expr
+
+lower' g (Halt [v]) = do
+  arg <- pushArg 0 <$> lowerVal g v
+  pure [expr|
+    ##{arg}
+    (return_call $halt (i32.const 1))
+  |]
+
+lower' g e@(ExpPrim p k) =
+  ([expr|(@gyehoek :origin #{origin})|]<>)
+  <$> case p of
+    PrimAdd x y -> lowerBinOp "i32.add" g x y k
+    PrimMul x y -> lowerBinOp "i32.mul" g x y k
+  where origin = encodeOrShow @_ @Text e
+
+lower' g (ExpIf c t f) = do
+  c' <- lowerVal g c
+  t' <- lower' g t
+  f' <- lower' g f
+  pure [expr|
+    ##{c'}
+    (call $gh-truthy?)
+    (if (then ##{t'})
+        (else ##{f'}))
+  |]
+
+lower' g (ExpLetRec [(r,AbsKappa kap)] e) = do
+  idx <- lowerKappa g kap
+  let g' = g & #kvars <>~ [r]
+  e' <- lower' g' e
+  let origin = encodeOrShow @_ @Text e
+  pure [expr|
+    (@gyehoek :origin #{origin})
+    (@gyehoek "push cont" :idx #{idx})
+    (array.set $cont-stack-type
+               (global.get $cont-stack)
+               (global.get $cont-stack-top)
+               (ref.func #{idx}))
+    (global.set $cont-stack-top
+                (i32.add (global.get $cont-stack-top)
+                         (i32.const 1)))
+    ##{e'}
+  |]
+
+lower' g (ExpLetRec [(r,AbsLambda lam)] e) = do
+  idx <- lowerLambda g lam
+  let g' = g & #vars <>~ [r]
+  let n = succ $ length g.vars
+  e' <- lower' g' e
+  pure [expr|
+    (i32.const 0)
+    (ref.func #{idx})
+    (struct.new $closure)
+    (local.set #{n})
+    ##{e'}
+  |]
+
+lower' g e@(ExpApply f xs ktail) = do
+  let nargs = length xs
+  f' <- lowerVal g f
+  let l = succ $ V.elemIndex ktail g.kvars ^?! _Just
+  args <- fold <$>
+    itraverse (\i -> fmap (pushArg $ tonat i) . lowerVal g) xs
+  let origin = encodeOrShow @_ @Text e
+  pure [expr|
+    (@gyehoek :origin #{origin})
+    (@gyehoek "load args")
+    ##{args}
+    (i32.const 1)
+    ##{f'}
+    (ref.cast (ref $closure))
+    (struct.get $closure $code)
+    (return_call_ref $cont-type)
+    (@gyehoek todo
+     (f' ##{f'})
+     (ktail #{l}))
+  |]
+
+lower' g e@(ExpContinue k xs) = do
+  let nargs = length xs
+  args <- fold <$>
+    itraverse (\i -> fmap (pushArg $ tonat i) . lowerVal g) xs
+  let origin = encodeOrShow @_ @Text e
+  pure [expr|
+    (@gyehoek :origin #{origin})
+    (@gyehoek "push args")
+    ##{args}
+    (@gyehoek "nargs")
+    (i32.const #{nargs})
+    (@gyehoek "pop cont stack")
+    (global.get $cont-stack-top)
+    (i32.const #{l})
+    i32.sub
+    (global.set $cont-stack-top)
+    (global.get $cont-stack)
+    (global.get $cont-stack-top)
+    (array.get $cont-stack-type)
+    ref.as_non_null
+    (return_call_ref $cont-type)
+  |]
+  where
+    l = succ $ V.elemIndex k g.kvars ^?! _Just
+
+lower' g e = error $ case Gyehoek.Sexp.encode e of
+  Left _ -> show e
+  Right x -> T.unpack x
+
+lowerKappa :: GenMod :> es => Env -> Kappa -> Eff es Idx
+lowerKappa g e@(MkKappa xs m) = do
+  let g' = g & #vars .~ V.fromList xs
+  m' <- lower' g' m
+  let body = mconcat
+        [ xs & ifoldMap \n _ ->
+            let n' = succ n
+            in popArg n <> [expr|(local.set #{n'})|]
+        , m'
+        ]
+  let origin = encodeOrShow @_ @Text e
+  idx <- Wasm.defineFunction [wat|
+    (func (param i32)
+      (@gyehoek :origin #{origin})
+      (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+      ##{body})
+  |]
+  Wasm.emit [wats|(elem declare funcref (ref.func #{idx}))|]
+  pure idx
+
+lowerLambda :: GenMod :> es => Env -> Lambda -> Eff es Idx
+lowerLambda g e@(MkLambda xs ktail m) = do
+  let g' = g & #vars .~ V.fromList xs
+             & #kvars <>~ [ktail]
+  m' <- lower' g' m
+  let body = mconcat
+        [ xs & ifoldMap \n _ ->
+            let n' = succ n
+            in popArg n <> [expr|(local.set #{n'})|]
+        , m'
+        ]
+  let origin = encodeOrShow @_ @Text e
+  idx <- Wasm.defineFunction [wat|
+    (func (param i32)
+      (@gyehoek :origin #{origin})
+      (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+      ##{body})
+  |]
+  Wasm.emit [wats|(elem declare funcref (ref.func #{idx}))|]
+  pure idx
+
+lowerBinOp
+  :: (GenMod :> es)
+  => Text -> Env -> Val -> Val -> Kappa -> Eff es Wasm.Expr
+lowerBinOp op g x y (MkKappa [r] e) = do
+  let op' = SL.Symbol op
+  let g' = g & #vars <>~ [r]
+  let n = succ $ length (g ^. #vars)
+  x' <- lowerVal g x
+  y' <- lowerVal g y
+  e' <- lower' g' e
+  pure [expr|
+    ##{x'}
+    (i31.get_s (ref.cast (ref i31)))
+    (i32.const 1)
+    i32.shr_u
+    ##{y'}
+    (i31.get_s (ref.cast (ref i31)))
+    (i32.const 1)
+    i32.shr_u
+    #{op'}
+    ##{makeSmallFixnum}
+    (local.set #{n})
+    ##{e'}
+  |]
+
+
+
+emitRuntime :: GenMod :> es => Eff es ()
+emitRuntime = mfix \runtime -> do
+  Wasm.defineFunctions [wats|
+    (import "gyehoek" "write" (func $gh-write (param (ref eq))))
+    (import "gyehoek" "truthy?" (func $gh-truthy? (param (ref eq))
+                                  (result i32)))
+  |]
+  -- cont stack
+  Wasm.defineTypes [wats|
+    (type $heap-object (sub (struct (field $hash (mut i32)))))
+    (type $cont-type (func (param i32)))
+    (type $cont-stack-type (array (mut (ref null $cont-type))))
+    (type $closure (sub $heap-object
+                        (struct (field $hash (mut i32))
+                                (field $code (ref $cont-type)))))
+  |]
+  Wasm.defineGlobals [wats|
+    (global $cont-stack-top (mut i32) (i32.const 0))
+    (global $cont-stack (ref $cont-stack-type)
+            (array.new_default $cont-stack-type (i32.const 128)))
+  |]
+  -- arg array
+  Wasm.defineType [wat|
+    (type $arg-array-type (array (mut (ref null eq))))
+  |]
+  Wasm.defineGlobal [wat|
+    (global $arg-array (ref $arg-array-type)
+            (array.new_default $arg-array-type (i32.const 32)))
+  |]
+  -- other  things 😼
+  Wasm.defineGlobal [wat|
+    (global $result (mut (ref null eq))
+            (ref.null eq))
+  |]
+  -- procedures
+  let arg = popArg 0
+  Wasm.defineFunction [wat|
+    (func $halt (param i32)
+      ##{arg}
+      (global.set $result))
+  |]
+  pure ()
+
+lower :: Exp -> Eff es Text
+lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do
+  runtime <- emitRuntime
+  let g = MkEnv mempty mempty
+  e' <- lower' g e
+  let origin = encodeOrShow @_ @Text e
+  Wasm.defineFunction [wat|
+    (func $scm-entry (param i32)
+      (@gyehoek :origin #{origin})
+      (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+      ##{e'})
+  |]
+  Wasm.defineFunction [wat|
+    (func (export "main")
+      (call $scm-entry (i32.const 0))
+      (call $gh-write (ref.as_non_null (global.get $result))))
+  |]
+  
+lowerProgram :: Program -> Eff es Text
+lowerProgram (MkProgram e) = lower e

src/Gyehoek/CPS/Syntax.hs

@@ -0,0 +1,282 @@
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FunctionalDependencies #-}
+module Gyehoek.CPS.Syntax
+  ( Val(..)
+  , Kappa(..)
+  , Lambda(..)
+  , Exp(..)
+  , Name(..)
+  , Prim(..)
+  , Program(..)
+  , Lit(..)
+  , pattern Void
+  , pattern Halt
+  , pattern Halt1
+  , _MkKappa
+  , _ExpPrim
+  , _ExpLetRec
+  , _ExpApply
+  , binders
+  , body
+  , op
+  , args
+  , cont
+  , cps
+  , pattern AbsLambda'
+  , pattern AbsKappa'
+  , Abs(..)
+  , free
+  , free'
+  )
+  where
+
+import Language.SexpGrammar qualified as S
+import Gyehoek.Sexp qualified
+import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primSexpIso, Lit(..), pattern Void, getName)
+import Data.List (List)
+import GHC.Generics (Generic)
+import Language.SexpGrammar.Generic
+import Control.Category
+import Control.Lens hiding (op)
+import Prelude hiding ((.), id)
+import Data.List.NonEmpty (NonEmpty)
+import Language.Haskell.TH.Quote (QuasiQuoter)
+import Data.Data (Data)
+import Language.Sexp.Located (Sexp)
+import qualified Data.InvertibleGrammar.Base as IG
+import qualified Gyehoek.Scheme.Syntax as Gyehoek
+import Data.InvertibleGrammar.Base (type (:-)((:-)))
+import Data.HashSet (HashSet)
+import qualified Data.HashSet as HS
+import Data.Hashable (Hashable)
+import Data.Monoid (Endo)
+import Data.Containers.ListUtils (nubOrd)
+
+-- Data types
+
+data Val
+  = ValVar Name
+  | ValLit Lit
+  deriving (Show, Generic, Data, Eq)
+
+data Kappa = MkKappa { binders :: List Name, body :: Exp }
+  deriving (Show, Generic, Data, Eq)
+
+data Lambda = MkLambda { binders :: List Name, ktail :: Name, body :: Exp }
+  deriving (Show, Generic, Data, Eq)
+
+data Abs
+  = AbsKappa Kappa
+  | AbsLambda Lambda
+  deriving (Show, Generic, Data, Eq)
+
+pattern AbsKappa' xs e = AbsKappa (MkKappa xs e)
+pattern AbsLambda' xs e ktail = AbsLambda (MkLambda xs e ktail)
+
+data Exp
+  = ExpPrim (Prim Val) Kappa
+  | ExpLetRec { binders :: NonEmpty (Name, Abs), body :: Exp }
+  | ExpContinue Name (List Val)
+  | ExpIf Val Exp Exp
+  | ExpApply
+    { op :: Val
+    , args :: List Val
+    , cont :: Name
+    }
+  deriving (Show, Generic, Data, Eq)
+
+pattern Halt :: List Val -> Exp
+pattern Halt xs = ExpContinue "halt" xs
+
+pattern Halt1 :: Val -> Exp
+pattern Halt1 x = ExpContinue "halt" [x]
+
+data Def = DefConstant Name Exp
+  deriving (Show, Generic, Data)
+
+data Program = MkProgram
+  { body :: Exp
+  }
+  deriving (Show, Generic, Data)
+
+makePrisms ''Kappa
+-- makeLenses ''Kappa
+makePrisms ''Exp
+-- makeLenses ''Exp
+-- makeFieldsNoPrefix ''Exp
+-- makeFieldsNoPrefix ''Kappa
+-- makeLensesWith abbreviatedFields ''Exp
+-- makeLensesFor [("binders", "_binders"), ("body", "_body")] ''Exp
+makeFieldsId ''Exp
+makeFieldsId ''Kappa
+makeFieldsId ''Lambda
+
+instance HasBinders Abs (List Name) where
+  binders k (AbsKappa kap) = AbsKappa <$> binders k kap
+  binders k (AbsLambda lam) = AbsLambda <$> binders k lam
+
+instance HasBody Abs Exp where
+  body k (AbsKappa kap) = AbsKappa <$> body k kap
+  body k (AbsLambda lam) = AbsLambda <$> body k lam
+
+
+-- SexpIso instances
+
+instance S.SexpIso Val where
+  sexpIso = match
+    $ With (\var -> var . S.sexpIso)
+    $ With (\lit -> lit . S.sexpIso)
+    $ End
+
+instance S.SexpIso Lambda where
+  sexpIso = match
+    $ With (. lambda)
+    $ End
+    where
+      lambda = S.list $
+        S.el Gyehoek.Sexp.lambdaKeyword
+        >>> S.el binders
+        >>> S.el S.sexpIso
+      binders :: forall t.
+        IG.Grammar S.Position (Sexp :- t) (Name :- List Name :- t)
+      binders = S.list $
+        S.rest (S.sexpIso @Name)
+        >>> S.onTail (S.flipped $ IG.PartialIso
+                     (\(ktail:-args:-t) -> (args ++ [ktail]) :- t)
+                     (\(args:-t) -> case args ^? _Snoc of
+                         Just (args',ktail) -> Right $ ktail :- args' :- t
+                         Nothing -> Left $ S.expected "cont param")
+                     )
+
+instance S.SexpIso Kappa where
+  sexpIso = match
+    $ With (. kappa)
+    $ End
+    where
+      kappa = S.list $
+        S.el Gyehoek.Sexp.kappaKeyword
+        >>> S.el (S.list $ S.rest S.sexpIso)
+        >>> S.el S.sexpIso
+
+instance S.SexpIso Abs where
+  sexpIso = match
+    $ With (\lambda -> lambda . S.sexpIso)
+    $ With (\kappa -> kappa . S.sexpIso)
+    $ End
+
+instance S.SexpIso Exp where
+  sexpIso = match
+    $ With (. prim)
+    $ With (. letrec)
+    $ With (. continue)
+    $ With (. if_)
+    $ With (. app)
+    $ End
+    where
+      continue = S.list $
+        S.el (S.sym "continue")
+        >>> S.el S.sexpIso
+        >>> S.rest S.sexpIso
+      letrec = Gyehoek.Sexp.let_ "letrec" 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 :: forall t.
+        IG.Grammar S.Position (Sexp :- t) (Name :- ([Val] :- (Val :- t)))
+      app = S.list $ S.el (S.sexpIso @Val)
+        -- >>> S.flipped Gyehoek.Sexp.nonEmptyGrammar
+        >>> S.rest (S.sexpIso @Val)
+        -- >>> _
+        >>> S.onTail (S.flipped $ IG.PartialIso
+                      (\(karg :- args :- op :- t) ->
+                         (args ++ [ValVar karg]) :- op :- t)
+                      (\(xs :- op :- t) -> case xs ^? _Snoc of
+                          Just (args,preview #ValVar -> Just karg) ->
+                            Right $ karg:- args :- op :- t
+                          _ -> Left $ S.expected "continuation arg"
+                      ))
+        where
+          _ = S.flipped $ Gyehoek.Sexp.nonEmptyGrammar @S.Position @Val
+      prim = S.list $
+        S.el (S.sym "prim")
+        >>> S.el (primSexpIso id (S.sexpIso @Val))
+        >>> S.el S.sexpIso
+
+instance S.SexpIso Program where
+  sexpIso = with \prog -> S.sexpIso @Exp >>> prog
+
+
+-- quasiquoters
+
+class Data a => CPS a where
+  toCPS :: Sexp -> a
+
+instance CPS Exp where toCPS = Gyehoek.Sexp.fromSexp
+instance CPS Val where toCPS = Gyehoek.Sexp.fromSexp
+instance CPS Kappa where toCPS = Gyehoek.Sexp.fromSexp
+instance CPS Lambda where toCPS = Gyehoek.Sexp.fromSexp
+instance CPS Abs where toCPS = Gyehoek.Sexp.fromSexp
+
+cps :: QuasiQuoter
+cps = Gyehoek.Sexp.makeSx' [| toCPS |]
+
+
+
+deleteFrom :: (Foldable f, Hashable a) => f a -> HashSet a -> HashSet a
+deleteFrom = flip $ foldr HS.delete
+
+insertFrom :: (Foldable f, Hashable a) => f a -> HashSet a -> HashSet a
+insertFrom = flip $ foldr HS.insert
+
+toHashSetOf :: Hashable a => Getting (Endo (HashSet a)) s a -> s -> HashSet a
+toHashSetOf l = foldrOf l HS.insert mempty
+
+free :: Exp -> HashSet Name
+free = go where
+  gokap (MkKappa xs m) = go m & deleteFrom xs
+  golam (MkLambda xs k m) = go m & deleteFrom xs & sans k
+  goabs = \case
+    AbsKappa kap -> gokap kap
+    AbsLambda lam -> golam lam
+  go = \case
+    ExpPrim p k ->
+      p & toHashSetOf (folded . #ValVar)
+        & HS.union (gokap k)
+    ExpLetRec bs m ->
+      foldMapOf (each . _2) goabs bs <> go m
+      & deleteFrom (bs ^.. each . _1)
+    ExpContinue k xs -> HS.fromList $ k : xs ^.. each . #ValVar
+    ExpIf c t f -> toHashSetOf #ValVar c <> go t <> go f
+    ExpApply f xs k -> toHashSetOf (each . #ValVar) (f:xs) <> HS.singleton k
+
+-- | Free variables given in the order of their appearance.
+free' :: Exp -> List Name
+free' = nubOrd . goFree HS.empty where
+
+goFreeKap bound (MkKappa xs m) = goFree (bound & insertFrom xs) m
+goFreeLam bound (MkLambda xs k m) = goFree (bound & insertFrom (k:xs)) m
+goFreeAbs bound = \case
+  AbsKappa kap -> goFreeKap bound kap
+  AbsLambda lam -> goFreeLam bound lam
+
+goFree :: HashSet Name -> Exp -> List Name
+goFree bound = \case
+  ExpPrim p k ->
+    p & toListOf (folded . #ValVar . filtered (`notElem` bound))
+      & (<> goFreeKap bound k)
+  ExpLetRec bs m ->
+    foldMapOf (each . _2) (goFreeAbs bound') bs <> goFree bound' m
+    where bound' = bound & insertFrom (bs ^.. each . _1)
+  ExpContinue k xs -> filter (`notElem` bound) (k : xs ^.. each . #ValVar)
+  ExpIf c t f ->
+    (c ^.. #ValVar . filtered (`notElem` bound))
+    <> goFree bound t <> goFree bound f
+  ExpApply f xs k ->
+    (f:xs) ^.. (each . #ValVar . filtered (`notElem` bound))
+    <> (k ^.. filtered (`notElem` bound))
+
+freeLambda :: Lambda -> List Name
+freeLambda (MkLambda {binders,ktail,body}) = _

src/Gyehoek/Driver.hs

@@ -0,0 +1,120 @@
+module Gyehoek.Driver
+  (main, lower_e2e, convert_e2e, parse_e2e)
+  where
+
+import Gyehoek.Options
+import Data.Text (Text)
+import Prelude hiding (readFile)
+import Options.Applicative
+import Control.Lens
+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)
+import qualified Gyehoek.Sexp as Sexp
+import qualified Gyehoek.Scheme.Syntax as Scm
+import qualified Data.Text.Encoding as T
+import System.IO (Handle)
+import System.IO qualified as IO
+import Gyehoek.CPS.Convert
+import Gyehoek.CPS.Lower
+import Gyehoek.CPS.Syntax qualified as Cps
+import Control.Monad
+import Text.Pretty.Simple (pShowNoColor)
+import System.Process.Typed
+import Data.Text.Encoding (encodeUtf8)
+import System.Environment.Blank (getEnvDefault)
+import GHC.Conc (atomically)
+import qualified Data.Text.IO as TIO
+import qualified Data.ByteString.Lazy as BS
+
+
+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
+
+fileName :: FilePath -> FilePath
+fileName "-" = "<interactive>"
+fileName e = e
+
+readScm :: FileSystem :> es => FilePath -> Eff es Scm.Program
+readScm f =
+  withFile f FS.ReadMode $ \h ->
+    Sexp.parseSexps @Scm.CommandOrDef (fileName f) <$> hGetContents h
+     >>= either error (pure . Scm.MkProgram)
+
+inspectWasm :: IOE :> es => Text -> Eff es ()
+inspectWasm wat = do
+  pager_cmd <- liftIO $ getEnvDefault "PAGER" "less"
+  let wasmtools_cfg
+        = proc "wasm-tools" ["print", "-pf", "--print-operand-stack"
+                            ,"--color", "always", "-"]
+          -- & setStdin (byteStringInput . view lazy . encodeUtf8 $ wat)
+          -- & setStdout byteStringOutput
+          & setStdin createPipe
+          & setStdout createPipe
+          & setStderr inherit
+  let pager_cfg = proc pager_cmd []
+                & setStdin createPipe
+                & setStdout inherit
+                & setStderr inherit
+  liftIO $ withProcessWait_ wasmtools_cfg \wasmtools -> do
+    TIO.hPutStrLn (getStdin wasmtools) wat
+    IO.hFlush (getStdin wasmtools)
+    IO.hClose (getStdin wasmtools)
+    withProcessWait_ pager_cfg \pager -> do
+      t <- BS.hGetContents (getStdout wasmtools)
+      BS.hPut (getStdin pager) t
+      IO.hFlush (getStdin pager)
+      IO.hClose (getStdin pager)
+
+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
+  if not opts.inspectWasm then
+    withFile opts.output FS.WriteMode \h ->
+      hPutStrLn h wat
+  else
+    inspectWasm 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,10 @@ import GHC.Generics (Generic)
 data Options = MkOptions
   { -- dumpANF :: Maybe FilePath
   -- , dumpQBE :: Maybe FilePath
-  output :: FilePath
+  dumpCPS :: Bool
+  , dumpParsed :: Bool
+  , inspectWasm :: Bool
+  , output :: FilePath
   , sourceFile :: FilePath
   }
   deriving (Show, Generic)
@@ -45,7 +48,14 @@ parseOutput = strOption
     <> value "-"
     )
 
+parseDumpCPS = switch (long "dump-cps")
+parseDumpParsed = switch (long "dump-parsed")
+parseInspectWasm = switch $ long "inspect-wasm" <> short 'p'
+
 parser :: Parser Options
 parser = MkOptions
-  <$> parseOutput
+  <$> parseDumpCPS
+  <*> parseDumpParsed
+  <*> parseInspectWasm
+  <*> parseOutput
   <*> argument str (metavar "FILE")

src/Gyehoek/Scheme/Syntax.hs

@@ -1,6 +1,9 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE OrPatterns #-}
@@ -9,33 +12,51 @@ module Gyehoek.Scheme.Syntax
   ( Name(..)
   , Prim(..)
   , Lit(..)
-  , Define(..)
+  , Def(..)
   , Exp(..)
   , Sexp(..)
+  , Program(..)
+  , CommandOrDef(..)
   , primSexpIso
+  , pattern Void
+  , free
+  , subst
+  , getName
+  , scm
   )
   where
 
 import Data.Text (Text)
 import Data.List (List)
 import Language.SexpGrammar
-  ( SexpIso(..), list, el, (>>>), rest, sym, symbol )
+  ( 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)
 import Control.Category
-import Data.List.NonEmpty (NonEmpty ((:|)))
+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 Data.Data (Data)
+import Data.Functor.Foldable.TH (makeBaseFunctor)
+import Data.Functor.Foldable hiding (fold)
+import Data.HashSet (HashSet)
+import qualified Data.HashSet as HS
+import Data.Foldable (fold)
+import Language.Haskell.TH.Quote (QuasiQuoter)
 
 
-newtype Name = MkName { getName :: Text }
-  deriving newtype (Show, Eq, IsString, Gen, Hashable)
-  deriving stock (Generic)
+newtype Name = MkName { inner :: Text }
+  deriving newtype (Show, Eq, Ord, IsString, Gen, Hashable)
+  deriving stock (Generic, Data)
+
+getName :: Name -> Text
+getName (MkName x) = x
 
 data Prim e
   = PrimAdd e e
@@ -51,7 +72,7 @@ data Prim e
   | PrimWrite e
   | PrimZeroP e
   | PrimNewline
-  deriving (Show, Generic, Functor, Foldable, Traversable)
+  deriving (Show, Generic, Functor, Foldable, Traversable, Data, Eq)
 
 instance Each (Prim e) (Prim e') e e'
 
@@ -61,30 +82,54 @@ data Lit
   | LitBool Bool
   | LitString Text
   | LitQuote Sexp
-  deriving (Show, Generic)
+  deriving (Show, Generic, Data, Eq)
 
-data Define
-  = DefineConstant Name Exp
-  | DefineProcedure Name (List Name) (List Exp)
-  deriving (Show, Generic)
+pattern Void :: Lit
+pattern Void = LitNil
+
+data Def
+  = DefConstant Name Exp
+  | DefProcedure Name (List Name) (List Exp)
+  deriving (Show, Generic, Data)
 
 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
   | ExpVar Name
   | ExpApply Exp (List Exp)
-  deriving (Show, Generic)
+  deriving (Show, Generic, Data)
 
 data Sexp
   = SexpCons Sexp Sexp
   | SexpSymbol Text
   | SexpLit Lit
-  deriving (Show, Generic)
+  deriving (Show, Generic, Data, Eq)
+
+data CommandOrDef
+  = Command Exp
+  | Definition Def
+  | Begin (List CommandOrDef)
+  deriving (Show, Generic, Data)
+
+data Program = MkProgram
+  { commandsAndDefs :: List CommandOrDef
+  }
+  deriving (Show, Generic, Data)
+
+instance Each Program Program (Either Exp Def) (Either Exp Def) where
+  each = #commandsAndDefs . each . go
+    where
+      inj = either Command Definition
+      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
+
+makeBaseFunctor ''Exp
 
 
 
@@ -124,19 +169,28 @@ 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
-    $ With (\cons -> cons . Gyehoek.Sexp.todo)
+    $ With (\conss -> conss . Gyehoek.Sexp.todo)
     $ With (\s -> s . symbol)
     $ With (\lit -> lit . sexpIso)
     $ End
 
-instance SexpIso Define where
+instance SexpIso Def where
   sexpIso = match
     $ With (. defconst)
     $ With (. defun)
@@ -151,7 +205,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 +217,40 @@ 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
+
+
+-- utilities
+
+scm :: QuasiQuoter
+scm = Gyehoek.Sexp.makeSx [|| Gyehoek.Sexp.fromSexp @Exp ||]
+
+free :: Exp -> HashSet Name
+free = cata \case
+  ExpVarF x -> HS.singleton x
+  ExpLetF bs e -> error "todo lol"
+  ExpLambdaF binders vs -> deleteFrom binders vs
+  e -> fold e
+
+deleteFrom :: (Foldable f, Hashable a) => f a -> HashSet a -> HashSet a
+deleteFrom = flip $ foldr HS.delete
+
+insertFrom :: (Foldable f, Hashable a) => f a -> HashSet a -> HashSet a
+insertFrom = flip $ foldr HS.insert
+
+subst :: (Name -> Maybe Exp) -> Exp -> Exp
+subst f = \e -> cata go e mempty where
+  go (ExpVarF x) bound
+    | not (x `HS.member` bound), Just e' <- f x = e'
+    | otherwise                         = ExpVar x
+  go (ExpLetF _ _) _ = error "todo lol"
+  go (ExpLambdaF bs e) bound = e $ insertFrom bs bound
+  go e bound = embed $ fmap ($ bound) e

src/Gyehoek/Sexp.hs

@@ -0,0 +1,437 @@
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
+{-# LANGUAGE OrPatterns #-}
+module Gyehoek.Sexp
+  ( let_
+  , sexp
+  , nonempty
+  , nonEmptyGrammar
+  , encode
+  , decode
+  , parseSexps
+  , prefixSugar
+  , todo
+  , isoIso
+  , encodeWith
+  , decodeWith
+  , kappa
+  , lambda
+  , kappaKeyword
+  , lambdaKeyword
+  , encodePrettyWith
+  , encodePretty
+  , UglySexpIso(..)
+  , AsSexpIso(..)
+  , SpliceSexp(..)
+  , parseSexpsWithPos
+  , parseSexpWithPos
+  , parseSexp
+  , sx
+  , sxs
+  , makeSx
+  , makeSxs
+  , makeSx'
+  , toSexp
+  , fromSexp
+  , stripLocation
+  , format
+  , equivalent
+  , encodeOrShow
+  )
+  where
+
+import Data.Text (Text)
+import Language.SexpGrammar as Sexp hiding (toSexp, List, encode, decode, encodeWith, decodeWith, iso, encodePrettyWith, encodePretty, fromSexp)
+import Language.SexpGrammar qualified as Sexp
+import Language.Sexp qualified as S
+import Language.SexpGrammar.Generic
+import Data.InvertibleGrammar.Base qualified as IGB
+import Data.InvertibleGrammar qualified as IG
+import Data.InvertibleGrammar.Base ((:-)((:-)))
+import Data.List.NonEmpty (NonEmpty ((:|)))
+import Data.List.NonEmpty qualified as NE
+import Data.List (List, groupBy)
+import Data.Text.Encoding
+import Data.Either (either)
+import GHC.Generics (Generic)
+import Control.Lens hiding (para)
+import Data.Generics.Labels
+import System.Process
+import GHC.IO.Unsafe (unsafePerformIO)
+import qualified Data.Text.IO as TIO
+import Control.Monad (join)
+import qualified Language.Sexp.Located as SL
+import Data.Void (absurd, Void)
+import Data.Coerce (coerce)
+import qualified Data.Map
+import Language.Haskell.TH.Quote
+import Language.Haskell.TH (Quote, location, Loc (..), ExpQ, varE, mkName, listE, Exp, appE, conE, Q, Code, unTypeCode)
+import qualified Data.Text as T
+import qualified Control.Category
+import Data.Data (Data (..), Typeable, cast)
+import Language.Haskell.TH.Syntax (lift, Lift, liftData)
+import GHC.IsList (fromList)
+import Data.Functor.Foldable (cata, para, embed)
+import Data.Functor.Classes (Show1(..))
+import Data.Vector (Vector)
+import Numeric.Natural (Natural)
+import Data.Maybe (fromMaybe)
+import Control.Applicative (Alternative((<|>)))
+import Debug.Pretty.Simple
+import qualified Data.Vector as V
+import qualified Data.Vector.Strict
+import Data.Function (on)
+import Data.String (IsString (fromString))
+
+
+sexp :: SexpIso a => Iso' a Text
+sexp = iso
+  (either error id . encode)
+  (either error id . decode)
+
+format :: Sexp -> Text
+format = decodeUtf8 . view strict . SL.format
+
+encode :: SexpIso a => a -> Either String Text
+encode = encodeWith sexpIso
+
+decode :: SexpIso a => Text -> Either String a
+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 . SL.parseSexps f . view lazy . encodeUtf8
+  where marshal = join . traverseOf (_Right . each) (Sexp.fromSexp sexpIso)
+
+parseSexp :: SexpIso a => FilePath -> Text -> Either String a
+parseSexp f = marshal . SL.parseSexp f . view lazy . encodeUtf8
+  where marshal = join . traverseOf _Right (Sexp.fromSexp sexpIso)
+
+readSexpWithPos :: Position -> Text -> Either String Sexp
+readSexpWithPos pos = SL.parseSexpWithPos pos . view lazy . encodeUtf8
+
+readSexpsWithPos :: Position -> Text -> Either String (List Sexp)
+readSexpsWithPos pos = SL.parseSexpsWithPos pos . view lazy . encodeUtf8
+
+parseSexpsWithPos :: SexpGrammar a -> Position -> Text -> Either String (List a)
+parseSexpsWithPos g pos =
+  marshal . SL.parseSexpsWithPos pos . view lazy . encodeUtf8
+  where marshal = join . traverseOf (_Right . each) (Sexp.fromSexp g)
+
+parseSexpWithPos :: SexpGrammar a -> Position -> Text -> Either String a
+parseSexpWithPos g pos =
+  marshal . SL.parseSexpWithPos pos . view lazy . encodeUtf8
+  where marshal = join . traverseOf _Right (Sexp.fromSexp g)
+
+nonEmptyGrammar :: Grammar p (NonEmpty x :- t) (List x :- x :- t)
+nonEmptyGrammar = IGB.Iso
+  (\((x:|xs) :- t) -> reverse xs :- x :- t)
+  (\(xs :- x :- t) -> (x :| reverse xs) :- t)
+
+nonempty :: SexpGrammar a -> SexpGrammar (NonEmpty a)
+nonempty a =
+  list (el a >>> rest a) >>>
+    IG.flipped nonEmptyGrammar
+
+let_
+  :: Text
+  -> (forall t. Grammar Position (Sexp :- t) (a :- t))
+  -> (forall t. Grammar Position (Sexp :- t) (b :- t))
+  -> Grammar Position (Sexp :- (NonEmpty (a, b) :- t1)) t2
+  -> Grammar Position (Sexp :- t1) t2
+let_ kw name rhs e = list (el (sym kw) >>> el bindings >>> el e)
+  where
+    -- bindings :: Grammar Position (Sexp :- _) (List (_, _) :- _)
+    bindings = nonempty binding
+    binding :: Grammar Position (Sexp :- t) ((_, _) :- t)
+    binding = list (el name >>> el rhs) >>> pair
+
+data DotList a = MkDotList (NonEmpty a) a
+  deriving (Show, Generic)
+
+dotlist :: (forall t. Grammar Position (Sexp :- t) (a :- t)) -> _
+dotlist x = list $ rest $ coproduct
+  [ x >>> _
+  ]
+
+-- | Define a sexp representation as either (⟨name⟩ ⟨e⟩) or '⟨e⟩.
+prefixSugar
+  :: Text -> Prefix
+  -> Grammar Position (Sexp :- t') a
+  -> Grammar Position (Sexp :- t') a
+prefixSugar name prefix e = coproduct
+  -- 'something
+  [ Sexp.prefixed prefix e
+  -- (quote something)
+  , list $ el (sym name) >>> el e
+  ]
+
+todo :: Grammar p (Sexp :- t) t'
+todo = (IGB.Flip $ IGB.PartialIso absurd f) >>> IGB.PartialIso absurd g
+  where
+    f _ = Left $ unexpected "todo"
+    g _ = Left $ unexpected "todo"
+
+kappa
+  :: (forall t. Grammar Position (Sexp :- t) (a :- t))
+  -> Grammar Position (Sexp :- List a :- t1) t2
+  -> Grammar Position (Sexp :- t1) t2
+kappa name e = list $
+  el kappaKeyword
+  >>> el (list $ rest name)
+  >>> el e
+
+lambda
+  :: (forall t. Grammar Position (Sexp :- t) (a :- t))
+  -> Grammar Position (Sexp :- List a :- t1) t2
+  -> Grammar Position (Sexp :- t1) t2
+lambda name e = list $
+  el lambdaKeyword
+  >>> el (list $ rest name)
+  >>> el e
+
+isoIso :: Iso' s a -> Grammar p (s :- t) (a :- t)
+isoIso l = Sexp.iso (view l) (review l)
+
+kappaKeyword :: Grammar Position (Sexp :- t) t
+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
+
+instance SexpIso Sexp where
+  sexpIso = Control.Category.id
+
+-- evil ass orphan instances
+deriving instance (Data a, Data e) => Data (SL.LocatedBy a e)
+deriving instance Data SL.Atom
+deriving instance Data SL.Prefix
+deriving instance Data SL.Position
+deriving instance (Data e) => Data (SL.SexpF e)
+
+
+-- Quasiquoter
+
+getPos = do
+  Loc {loc_filename,loc_start} <- location
+  pure $ SL.Position loc_filename (fst loc_start) (snd loc_start)
+
+fromSexp :: SexpIso a => Sexp -> a
+fromSexp = either error id . Sexp.fromSexp sexpIso
+
+fromSexp' :: SexpGrammar a -> Sexp -> a
+fromSexp' g = either error id . Sexp.fromSexp g
+
+toSexp :: SexpIso a => a -> Sexp
+toSexp = either error id . Sexp.toSexp sexpIso
+
+toSexps :: (Foldable f, SexpIso a) => f a -> List Sexp
+toSexps = foldMap \x -> [toSexp x]
+
+pattern Unquote x =
+  SL.Modified Hash (SL.BraceList [SL.Symbol x])
+pattern UnquoteSplicing x =
+  SL.Modified Hash (SL.Modified Hash (SL.BraceList [SL.Symbol x]))
+
+_UnquoteSplicing :: Prism' Sexp.Sexp Text
+_UnquoteSplicing = prism'
+  UnquoteSplicing
+  (\case { UnquoteSplicing x -> Just x ; _ -> Nothing })
+
+instance Each Sexp Sexp Sexp Sexp where
+  each k (SL.ParenList xs)              = SL.ParenList <$> traverse k xs
+  each k (SL.BracketList xs)            = SL.BracketList <$> traverse k xs
+  each k (SL.BraceList xs)              = SL.BraceList <$> traverse k xs
+  each _ e@(SL.Atom _; SL.Modified _ _) = pure e
+
+stripLocation :: Sexp -> Sexp
+stripLocation = cata \case
+  SL.Compose (a SL.:< e) ->
+    SL.Fix . SL.Compose $ SL.dummyPos SL.:< e
+
+-- | @('==')@ for 'Sexp's modulo source location — return true if the
+-- two sexps are equal in all but 'Position' fields.
+equivalent :: Sexp -> Sexp -> Bool
+equivalent = (==) `on` stripLocation
+
+instance SexpIso Natural where
+  sexpIso = 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
+
+class SpliceSexp a where
+  spliceSexp :: a -> List Sexp
+
+instance SexpIso a => SpliceSexp (Data.Vector.Strict.Vector a) where
+  spliceSexp = toSexps
+
+instance SexpIso a => SpliceSexp (Vector a) where
+  spliceSexp = toSexps
+
+instance SexpIso a => SpliceSexp (List a) where
+  spliceSexp = toSexps
+
+instance SpliceSexp Sexp where
+  spliceSexp = toListOf each
+
+unquoteSplicingRecursive :: List Sexp.Sexp -> ExpQ
+unquoteSplicingRecursive xs = [| mconcat $(spans) |]
+  where
+    spans = xs
+      & groupBy \cases
+          (UnquoteSplicing _) _ -> False
+          _ (UnquoteSplicing _) -> False
+          _ _                   -> True
+      & fmap \case
+        -- [e@(Unquote _)] ->
+        --   case unquote e of
+        --     Just x -> [| [$(x)] |]
+        --     Nothing -> error "unreachable"
+        [UnquoteSplicing x] ->
+          [| spliceSexp $(varE (mkName (T.unpack x))) |]
+        es -> listE $ unquoteRecursive <$> es
+      & listE
+
+unquoteRecursive :: Sexp.Sexp -> ExpQ
+unquoteRecursive = \case
+  Unquote x -> [| toSexp $(varE (mkName (T.unpack x))) |]
+  SL.ParenList xs -> [|SL.ParenList $(unquoteSplicingRecursive xs)|]
+  e -> liftData e
+
+_ParenList :: Prism' Sexp (List Sexp)
+_ParenList = prism' SL.ParenList \case
+  SL.ParenList xs -> Just xs
+  _ -> Nothing
+
+metaSexps :: List Sexp.Sexp -> Maybe ExpQ
+metaSexps = Just . unquoteSplicingRecursive
+
+metaSexp :: Sexp.Sexp -> Maybe ExpQ
+metaSexp = Just . unquoteRecursive
+
+-- 뻘짓뻘짓뻘짓뻘짓뻘짓
+class Lift1 f where
+  liftLift :: Quote m => (a -> m Exp) -> f a -> m Exp
+
+lift1 :: (Lift1 f, Lift a, Quote m) => f a -> m Exp
+lift1 = liftLift lift
+
+instance Lift1 f => Lift (SL.Fix f) where
+  lift (SL.Fix inner) = appE [|SL.Fix|] (lift1 inner)
+
+instance (Lift1 f, Lift1 g) => Lift1 (SL.Compose f g) where
+  liftLift l (SL.Compose fga) = [|SL.Compose $(liftLift (liftLift l) fga)|]
+
+instance Lift a => Lift1 (SL.LocatedBy a) where
+  liftLift l (a SL.:< e) = [|(SL.:<) $(lift a) $(l e)|]
+
+instance Lift1 List where
+  liftLift l xs = listE $ l <$> xs
+
+instance Lift1 SL.SexpF where
+  liftLift l = \case
+    SL.AtomF a -> [|SL.AtomF $(lift a)|]
+    SL.ParenListF es -> [|SL.ParenListF $(liftLift l es)|]
+    SL.BracketListF es -> [|SL.BracketListF $(liftLift l es)|]
+    SL.BraceListF es -> [|SL.BraceListF $(liftLift l es)|]
+    SL.ModifiedF p e -> [|SL.ModifiedF $(lift p) $(l e)|]
+
+-- deriving instance Lift a => Lift (SL.SexpF a)
+deriving instance Lift SL.Atom
+deriving instance Lift SL.Position
+deriving instance Lift SL.Prefix
+
+encodeOrShow :: (SexpIso a, Show a, IsString s) => a -> s
+encodeOrShow a = fromString case encode a of
+  Left _ -> show a
+  Right e -> T.unpack e
+
+extQ :: (Typeable a, Typeable b) => (a -> r) -> (b -> r) -> a -> r
+extQ f g a = maybe (f a) g (cast a)
+
+makeSxs :: Data r => Code Q (List Sexp -> r) -> QuasiQuoter
+makeSxs f = QuasiQuoter
+  { quoteExp = \str -> do
+      pos <- getPos
+      case readSexpsWithPos pos (T.pack str) of
+        Left e -> fail e
+        Right xs -> [| $(unTypeCode f) $e |]
+          where
+            e = dataToExpQ
+              (const Nothing `extQ` metaSexp `extQ` metaSexps)
+              xs
+  , quotePat = undefined
+  , quoteType = undefined
+  , quoteDec = undefined
+  }
+
+-- | An untyped variant of 'makeSx', useful when the user function is
+-- polymorphic in its return value.
+makeSx' :: ExpQ -> QuasiQuoter
+makeSx' f = QuasiQuoter
+  { quoteExp = \str -> do
+      pos <- getPos
+      case readSexpWithPos pos (T.pack str) of
+        Left e -> fail e
+        Right x -> [| $f $e |]
+          where
+            e = dataToExpQ
+              (const Nothing `extQ` metaSexp `extQ` metaSexps)
+              x
+  , quotePat = undefined
+  , quoteType = undefined
+  , quoteDec = undefined
+  }
+
+makeSx :: Data r => Code Q (Sexp -> r) -> QuasiQuoter
+makeSx = makeSx' . unTypeCode
+
+sxs = makeSxs [||id||]
+sx = makeSx [||id||]

src/Gyehoek/Wasm.hs

@@ -0,0 +1,192 @@
+{- HLINT ignore "Use newtype instead of data" -}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
+module Gyehoek.Wasm
+  (
+    -- * syntax
+    Module
+  , Idx
+  , Expr
+    -- ** quasiquoters
+  , expr
+  , Gyehoek.Sexp.sx
+  , Gyehoek.Sexp.sxs
+  -- * GenMod effect
+  , GenMod
+  , runGenMod
+  , execGenMod
+  , defineFunction
+  , defineType
+  , defineGlobal
+  , emit
+  , renderModule
+  , wat
+  , wats
+  , defineFunctions
+  , defineTypes
+  , defineGlobals
+  )
+  where
+
+import Language.SexpGrammar
+  ( SexpIso(..), (>>>) )
+import Language.SexpGrammar qualified as Sexp
+import Language.SexpGrammar.Generic
+import Data.List (List)
+import GHC.Generics (Generic)
+import Data.Text (Text)
+import Effectful
+import Numeric.Natural (Natural)
+import Effectful.Dispatch.Dynamic
+import Effectful.State.Dynamic
+import Control.Lens
+import Data.Vector.Strict (Vector)
+import qualified Data.Vector.Strict as V
+import Language.Sexp.Located
+import qualified Gyehoek.Sexp
+import GHC.IsList (IsList(..))
+import Language.Haskell.TH.Quote (QuasiQuoter)
+import Data.Data (Data)
+import Gyehoek.Sexp (sx)
+import Data.Foldable (traverse_)
+
+
+newtype Module = MkModule { inner :: Vector Sexp }
+  deriving (Show, Generic)
+  deriving newtype (Semigroup, Monoid)
+
+newtype Expr = MkExpr { inner :: Vector Instr }
+  deriving (Show, Generic, Data, Eq)
+  deriving newtype (Semigroup, Monoid)
+
+instance IsList Expr where
+  type Item Expr = Instr
+  fromList = MkExpr . V.fromList
+  toList = V.toList . view #inner
+
+newtype Instr = MkInstr { inner :: Sexp }
+  deriving (Show, Generic, Data, Eq)
+
+newtype Idx = MkIdx { inner :: Natural }
+  deriving (Generic, Data)
+  deriving newtype (Show)
+
+
+-- GenMod
+
+-- | 'GenModState' is a 'Module' paired with the numbers of functions,
+-- types, globals, etc. defined in the module.
+data GenModState = MkGenModState
+  { mod :: Module
+  , funcs :: Natural
+  , types :: Natural
+  , globals :: Natural
+  }
+  deriving (Show, Generic)
+
+instance Semigroup GenModState where
+  m1 <> m2 = MkGenModState
+    { mod = m1.mod <> m2.mod
+    , funcs = m1.funcs + m2.funcs
+    , types = m1.types + m2.types
+    , globals = m1.globals + m2.globals
+    }
+
+instance Monoid GenModState where
+  mempty = MkGenModState
+    { mod = mempty
+    , funcs = 0
+    , types = 0
+    , globals = 0
+    }
+
+data GenMod :: Effect where
+  DefineFunction :: Sexp -> GenMod m Idx
+  DefineType :: Sexp -> GenMod m Idx
+  DefineGlobal :: Sexp -> GenMod m Idx
+  Emit :: Sexp -> GenMod m ()
+
+type instance DispatchOf GenMod = Dynamic
+
+defineFunction :: GenMod :> es => Sexp -> Eff es Idx
+defineFunction = send . DefineFunction
+
+defineFunctions :: GenMod :> es => List Sexp -> Eff es (List Idx)
+defineFunctions = traverse (send . DefineFunction)
+
+defineType :: GenMod :> es => Sexp -> Eff es Idx
+defineType = send . DefineType
+
+defineTypes :: GenMod :> es => List Sexp -> Eff es (List Idx)
+defineTypes = traverse (send . DefineType)
+
+defineGlobal :: GenMod :> es => Sexp -> Eff es Idx
+defineGlobal = send . DefineGlobal
+
+defineGlobals :: GenMod :> es => List Sexp -> Eff es (List Idx)
+defineGlobals = traverse (send . DefineGlobal)
+
+emit :: GenMod :> es => List Sexp -> Eff es ()
+emit = traverse_ (send . Emit)
+
+appendAndIncrement
+  :: State GenModState :> es
+  => LensLike' ((,) Natural) GenModState Natural
+  -> Sexp
+  -> Eff es Idx
+appendAndIncrement l s =
+  state \st -> st
+    & #mod . #inner <>~ V.singleton s
+    & l <<%~ succ
+    & _1 %~ MkIdx
+
+runGenMod :: Eff (GenMod : es) a -> Eff es (a, Module)
+runGenMod =
+  let run = (mapped . _2 %~ view #mod) . runStateLocal (mempty @GenModState)
+  in reinterpret run \cases
+    _ (DefineFunction s) -> appendAndIncrement #funcs s
+    _ (DefineType s) -> appendAndIncrement #types s
+    _ (DefineGlobal s) -> appendAndIncrement #globals s
+    _ (Emit s) -> #mod . #inner <>= V.singleton s
+
+execGenMod :: Eff (GenMod : es) a -> Eff es Module
+execGenMod = fmap snd . runGenMod
+
+renderModule :: Module -> Text
+renderModule (MkModule ss) = Gyehoek.Sexp.format [sx|
+  (module ##{ss})
+|]
+
+
+-- SexpIso instances
+
+instance SexpIso Idx where
+  sexpIso = with \idx ->
+    Sexp.integer >>> Sexp.partialOsi f g
+    >>> idx
+    where
+      f n | n < 0 = Left $ Sexp.unexpected "negative"
+                        <> Sexp.expected "natural"
+          | otherwise = Right $ fromIntegral n
+      g = fromIntegral
+
+instance SexpIso Instr where
+  sexpIso = with id
+
+instance Gyehoek.Sexp.SpliceSexp Expr where
+  spliceSexp = toListOf $ #inner . each . #inner
+
+
+-- quasiquoters
+
+expr :: QuasiQuoter
+expr = Gyehoek.Sexp.makeSxs
+  [||MkExpr . V.fromList . (each . #inner %~ Gyehoek.Sexp.stripLocation)
+   . fmap (Gyehoek.Sexp.fromSexp @Instr) ||]
+
+wat :: QuasiQuoter
+wat = Gyehoek.Sexp.makeSx [|| id ||]
+
+wats :: QuasiQuoter
+wats = Gyehoek.Sexp.makeSxs [|| id ||]

t.scm

@@ -0,0 +1 @@
+(values 1 2)

t.wat

@@ -0,0 +1,265 @@
+(module
+  (import
+    "gyehoek"
+    "write"
+    (func $gh-write (param (ref eq))))
+  (import
+    "gyehoek"
+    "truthy?"
+    (func $gh-truthy? (param (ref eq)) (result i32)))
+  (type $heap-object (sub (struct (field $hash (mut i32)))))
+  (type $cont-type (func (param i32)))
+  (type $cont-stack-type (array (mut (ref null $cont-type))))
+  (type
+    $closure
+    (sub
+      $heap-object
+      (struct
+        (field $hash (mut i32))
+        (field $code (ref $cont-type)))))
+  (global $cont-stack-top (mut i32) (i32.const 0))
+  (global
+    $cont-stack
+    (ref $cont-stack-type)
+    (array.new_default $cont-stack-type (i32.const 128)))
+  (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)))
+  (global $result (mut (ref null eq)) (ref.null eq))
+  (func
+    $halt
+    (param i32)
+    (@gyehoek "pop argument")
+    (global.get $arg-array)
+    (i32.const 0)
+    (array.get $arg-array-type)
+    ref.as_non_null
+    (global.set $result))
+  (func
+    (param i32)
+    (@gyehoek :origin "(κ (x5) (continue λ-tail1 x5))")
+    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+    (@gyehoek "pop argument")
+    (global.get $arg-array)
+    (i32.const 0)
+    (array.get $arg-array-type)
+    ref.as_non_null
+    (local.set 1)
+    (@gyehoek :origin "(continue λ-tail1 x5)")
+    (@gyehoek "push args")
+    (@gyehoek "push argument")
+    (global.get $arg-array)
+    (i32.const 0)
+    (local.get 4)
+    (array.set $arg-array-type)
+    (@gyehoek "nargs")
+    (i32.const 1)
+    (@gyehoek "pop cont stack")
+    (global.get $cont-stack-top)
+    (i32.const 1)
+    i32.sub
+    (global.set $cont-stack-top)
+    (global.get $cont-stack)
+    (global.get $cont-stack-top)
+    (array.get $cont-stack-type)
+    ref.as_non_null
+    (return_call_ref $cont-type))
+  (elem declare funcref (ref.func 3))
+  (func
+    (param i32)
+    (@gyehoek
+      :origin
+      "(κ (x3) (letrec ((r4 (κ (x5) (continue λ-tail1 x5)))) (f x3 r4)))")
+    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+    (@gyehoek "pop argument")
+    (global.get $arg-array)
+    (i32.const 0)
+    (array.get $arg-array-type)
+    ref.as_non_null
+    (local.set 1)
+    (@gyehoek :origin "(f x3 r4)")
+    (@gyehoek "push cont" :idx 3)
+    (array.set
+      $cont-stack-type
+      (global.get $cont-stack)
+      (global.get $cont-stack-top)
+      (ref.func 3))
+    (global.set
+      $cont-stack-top
+      (i32.add (global.get $cont-stack-top) (i32.const 1)))
+    (@gyehoek :origin "(f x3 r4)")
+    (@gyehoek "load args")
+    (@gyehoek "push argument")
+    (global.get $arg-array)
+    (i32.const 0)
+    (local.get 3)
+    (array.set $arg-array-type)
+    (i32.const 1)
+    (local.get 1)
+    (ref.cast (ref $closure))
+    (struct.get $closure $code)
+    (return_call_ref $cont-type))
+  (elem declare funcref (ref.func 4))
+  (func
+    (param i32)
+    (@gyehoek
+      :origin
+      "(λ (f x λ-tail1) (letrec ((r2 (κ (x3) (letrec ((r4 (κ (x5) (continue λ-tail1 x5)))) (f x3 r4))))) (f x r2)))")
+    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+    (@gyehoek "pop argument")
+    (global.get $arg-array)
+    (i32.const 0)
+    (array.get $arg-array-type)
+    ref.as_non_null
+    (local.set 1)
+    (@gyehoek "pop argument")
+    (global.get $arg-array)
+    (i32.const 1)
+    (array.get $arg-array-type)
+    ref.as_non_null
+    (local.set 2)
+    (@gyehoek :origin "(f x r2)")
+    (@gyehoek "push cont" :idx 4)
+    (array.set
+      $cont-stack-type
+      (global.get $cont-stack)
+      (global.get $cont-stack-top)
+      (ref.func 4))
+    (global.set
+      $cont-stack-top
+      (i32.add (global.get $cont-stack-top) (i32.const 1)))
+    (@gyehoek :origin "(f x r2)")
+    (@gyehoek "load args")
+    (@gyehoek "push argument")
+    (global.get $arg-array)
+    (i32.const 0)
+    (local.get 2)
+    (array.set $arg-array-type)
+    (i32.const 1)
+    (local.get 1)
+    (ref.cast (ref $closure))
+    (struct.get $closure $code)
+    (return_call_ref $cont-type))
+  (elem declare funcref (ref.func 5))
+  (func
+    (param i32)
+    (@gyehoek
+      :origin
+      "(λ (x λ-tail7) (prim (+ x 4) (κ (r8) (continue λ-tail7 r8))))")
+    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+    (@gyehoek "pop argument")
+    (global.get $arg-array)
+    (i32.const 0)
+    (array.get $arg-array-type)
+    ref.as_non_null
+    (local.set 1)
+    (@gyehoek
+      :origin
+      "(prim (+ x 4) (κ (r8) (continue λ-tail7 r8)))")
+    (local.get 1)
+    (i31.get_s (ref.cast (ref i31)))
+    (i32.const 1)
+    i32.shr_u
+    (i32.const 4)
+    (@gyehoek "construct small fixnum")
+    (i32.const 1)
+    i32.shl
+    ref.i31
+    (i31.get_s (ref.cast (ref i31)))
+    (i32.const 1)
+    i32.shr_u
+    i32.add
+    (@gyehoek "construct small fixnum")
+    (i32.const 1)
+    i32.shl
+    ref.i31
+    (local.set 2)
+    (@gyehoek :origin "(continue λ-tail7 r8)")
+    (@gyehoek "push args")
+    (@gyehoek "push argument")
+    (global.get $arg-array)
+    (i32.const 0)
+    (local.get 2)
+    (array.set $arg-array-type)
+    (@gyehoek "nargs")
+    (i32.const 1)
+    (@gyehoek "pop cont stack")
+    (global.get $cont-stack-top)
+    (i32.const 1)
+    i32.sub
+    (global.set $cont-stack-top)
+    (global.get $cont-stack)
+    (global.get $cont-stack-top)
+    (array.get $cont-stack-type)
+    ref.as_non_null
+    (return_call_ref $cont-type))
+  (elem declare funcref (ref.func 6))
+  (func
+    (param i32)
+    (@gyehoek :origin "(κ (x10) (continue halt x10))")
+    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+    (@gyehoek "pop argument")
+    (global.get $arg-array)
+    (i32.const 0)
+    (array.get $arg-array-type)
+    ref.as_non_null
+    (local.set 1)
+    (@gyehoek "push argument")
+    (global.get $arg-array)
+    (i32.const 0)
+    (local.get 3)
+    (array.set $arg-array-type)
+    (return_call $halt (i32.const 1)))
+  (elem declare funcref (ref.func 7))
+  (func
+    $scm-entry
+    (param i32)
+    (@gyehoek
+      :origin
+      "(letrec ((λ-body0 (λ (f x λ-tail1) (letrec ((r2 (κ (x3) (letrec ((r4 (κ (x5) (continue λ-tail1 x5)))) (f x3 r4))))) (f x r2))))) (letrec ((λ-body6 (λ (x λ-tail7) (prim (+ x 4) (κ (r8) (continue λ-tail7 r8)))))) (letrec ((r9 (κ (x10) (continue halt x10)))) (λ-body0 λ-body6 9 r9))))")
+    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+    (i32.const 0)
+    (ref.func 5)
+    (struct.new $closure)
+    (local.set 1)
+    (i32.const 0)
+    (ref.func 6)
+    (struct.new $closure)
+    (local.set 2)
+    (@gyehoek :origin "(λ-body0 λ-body6 9 r9)")
+    (@gyehoek "push cont" :idx 7)
+    (array.set
+      $cont-stack-type
+      (global.get $cont-stack)
+      (global.get $cont-stack-top)
+      (ref.func 7))
+    (global.set
+      $cont-stack-top
+      (i32.add (global.get $cont-stack-top) (i32.const 1)))
+    (@gyehoek :origin "(λ-body0 λ-body6 9 r9)")
+    (@gyehoek "load args")
+    (@gyehoek "push argument")
+    (global.get $arg-array)
+    (i32.const 0)
+    (local.get 2)
+    (array.set $arg-array-type)
+    (@gyehoek "push argument")
+    (global.get $arg-array)
+    (i32.const 1)
+    (i32.const 9)
+    (@gyehoek "construct small fixnum")
+    (i32.const 1)
+    i32.shl
+    ref.i31
+    (array.set $arg-array-type)
+    (i32.const 1)
+    (local.get 1)
+    (ref.cast (ref $closure))
+    (struct.get $closure $code)
+    (return_call_ref $cont-type))
+  (func
+    (export "main")
+    (call $scm-entry (i32.const 0))
+    (call $gh-write (ref.as_non_null (global.get $result)))))

test/Gyehoek/Test/CPS/Syntax.hs

@@ -0,0 +1,52 @@
+{-# LANGUAGE OverloadedLists #-}
+module Gyehoek.Test.CPS.Syntax (root) where
+
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit
+import Language.Sexp.Located qualified as SL
+import Language.SexpGrammar ()
+import Gyehoek.CPS.Syntax (cps)
+import Gyehoek.CPS.Syntax qualified as Sut
+import Data.Function (on)
+import Gyehoek.Test.Sexp (equivto)
+
+
+root :: IO TestTree
+root = pure . testGroup "cps syntax" $
+  [ qqTree
+  , freeTree
+  ]
+
+freeTree :: TestTree
+freeTree = testCase "free" do
+  Sut.free [cps|
+    (letrec ((x (lambda (r k1) (continue k1 y)))
+             (y (lambda (r k2) (continue k2 x))))
+      (continue x y k3))|] @=? ["k3"]
+  Sut.free' [cps|
+    (letrec ((x (lambda (r k1) (continue k1 y)))
+             (y (lambda (r k2) (continue k2 x))))
+      (continue x y k3))|] @=? ["k3"]
+
+qqTree :: TestTree
+qqTree = testGroup "parser"
+  [ testCase "lambda" do
+      assertEqual "" (Sut.MkLambda ["x","y"] "ktail"
+               (Sut.ExpContinue "ktail" [Sut.ValVar "x"]))
+        [cps|(λ (x y ktail) (continue ktail x))|]
+      assertEqual "" (Sut.MkLambda [] "ktail"
+               (Sut.ExpContinue "ktail" [Sut.ValVar "x"]))
+        [cps|(λ (ktail) (continue ktail x))|]
+  , testCase "kappa" do
+      assertEqual "" (Sut.MkKappa ["x","y"]
+               (Sut.ExpContinue "k123" [Sut.ValVar "x", Sut.ValVar "y"]))
+        [cps|(κ (x y) (continue k123 x y))|]
+  , testCase "application" do
+      assertEqual "" (Sut.ExpApply (Sut.ValVar "f")
+                     [Sut.ValVar "x",Sut.ValVar "y"]
+                     "k")
+        [cps|(f x y k)|]
+      assertEqual "" (Sut.ExpApply (Sut.ValVar "f")
+                     [] "k")
+        [cps|(f k)|]
+  ]

test/Gyehoek/Test/Golden.hs

@@ -0,0 +1,45 @@
+module Gyehoek.Test.Golden (root) where
+
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.Silver
+import Gyehoek.Driver qualified as Driver
+import System.FilePath
+import Data.List (List)
+import Data.Functor ((<&>))
+import System.Directory
+import Data.Function
+import System.Environment.Blank (getEnvDefault)
+import qualified System.Process.Text as PT
+
+
+disabled :: List String
+disabled =
+  [
+  ]
+
+root :: IO TestTree
+root = do
+  all_cases <- listDirectory "golden"
+  let tests = all_cases
+            & filter (`notElem` disabled)
+            & fmap ("golden"</>)
+  testGroup "golden" <$> sequenceA
+    [ executionTests tests
+    ]
+
+executionTests :: List FilePath -> IO TestTree
+executionTests files = do
+  cmd <- getEnvDefault "GYEHOEK_RUNTIME"
+    "runtime/target/debug/gyehoek-runtime"
+  pure $ testGroup "execution" $ files <&> \test ->
+    let testname = takeFileName test
+        scmfile = test </> "source.scm"
+        resultfile = test </> "exec"
+        action = do
+          t <- Driver.lower_e2e scmfile
+          PT.readProcessWithExitCode cmd ["-"] t
+    in goldenVsAction
+       testname
+       resultfile
+       action
+       printProcResult

test/Gyehoek/Test/Sexp.hs

@@ -0,0 +1,56 @@
+module Gyehoek.Test.Sexp
+  ( root
+  , EquivSexp(..)
+  , assertEquiv
+  , equivto
+  )
+  where
+
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit
+import Language.Sexp.Located qualified as SL
+import Language.SexpGrammar ()
+import Gyehoek.Sexp (sx, equivalent)
+import Data.Function (on)
+
+
+root :: IO TestTree
+root = pure . testGroup "sexp" $
+  [ sxTree
+  ]
+
+newtype EquivSexp = MkEquiv SL.Sexp
+  deriving newtype (Show)
+
+instance Eq EquivSexp where
+  MkEquiv x == MkEquiv y = equivalent x y
+
+assertEquiv
+  :: HasCallStack
+  => String -> SL.Sexp -> SL.Sexp -> Assertion
+assertEquiv prefix = assertEqual prefix `on` MkEquiv
+
+equivto = assertEquiv ""
+
+sxTree :: TestTree
+sxTree = testGroup "sx"
+  [ testCase "quotation" do
+      equivto (SL.Symbol "abc") [sx|abc|]
+      equivto (SL.ParenList [SL.Symbol "a", SL.Symbol "b"]) [sx|(a b)|]
+  , testCase "antiquotation" do
+      equivto [sx|123|]
+        let meta = 123 :: Int
+        in [sx|#{meta}|]
+      equivto [sx|(blah (blah blah) blah)|]
+        let meta = [sx|blah|]
+        in [sx|(#{meta} (#{meta} #{meta}) #{meta})|]
+  , testCase "splicing" do
+      equivto [sx|(a b c d e f g)|]
+        let metas = SL.Symbol <$> ["c","d","e"]
+        in [sx|(a b ##{metas} f g)|]
+      equivto [sx|(a (b c d) e f g)|]
+        let
+          e1 = SL.Symbol "c"
+          e2 = SL.Symbol <$> ["e","f"]
+        in [sx|(a (b #{e1} d) ##{e2} g)|]
+  ]

test/Main.hs

@@ -0,0 +1,19 @@
+module Main (main) where
+
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.Silver.Interactive (defaultMain)
+import qualified Gyehoek.Test.Golden
+import qualified Gyehoek.Test.Sexp
+import qualified Gyehoek.Test.CPS.Syntax
+
+
+main :: IO ()
+main = defaultMain =<< root
+
+root :: IO TestTree
+root = testGroup "test" <$> sequenceA
+  [ Gyehoek.Test.Golden.root
+  , Gyehoek.Test.Sexp.root
+  , Gyehoek.Test.CPS.Syntax.root
+  ]
+

u.wat

@@ -0,0 +1,127 @@
+(module
+ (import "gyehoek" "write" (func $gh-write (param (ref eq))))
+ (import "gyehoek" "truthy?" (func $gh-truthy? (param (ref eq)) (result i32)))
+ (type $heap-object (sub (struct (field $hash (mut i32)))))
+ (type $cont-type (func (param i32)))
+ (type $cont-stack-type (array (mut (ref null $cont-type))))
+ (type
+  $closure
+  (sub
+   $heap-object
+   (struct
+    (field $hash (mut i32))
+    (field $code (ref $cont-type)))))
+ (global $cont-stack-top (mut i32) (i32.const 0))
+ (global
+  $cont-stack
+  (ref $cont-stack-type)
+  (array.new_default $cont-stack-type (i32.const 128)))
+ (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)))
+ (global $result (mut (ref null eq)) (ref.null eq))
+ (func
+  $halt
+  (param i32)
+  (global.get $arg-array)
+  (i32.const 0)
+  (array.get $arg-array-type)
+  ref.as_non_null
+  (global.set $result))
+ (func
+  (param i32)
+  (@gyehoek
+   :origin
+   (lambda (x lambda-tail1)
+     (prim (* x x) (kappa (r2) (continue lambda-tail1 r2)))))
+  (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+  (global.get $arg-array)
+  (i32.const 0)
+  (array.get $arg-array-type)
+  ref.as_non_null
+  (local.set 1)
+  (local.get 1)
+  (i31.get_s (ref.cast (ref i31)))
+  (i32.const 1)
+  i32.shr_u
+  (local.get 1)
+  (i31.get_s (ref.cast (ref i31)))
+  (i32.const 1)
+  i32.shr_u
+  i32.mul
+  (i32.const 1)
+  i32.shl
+  ref.i31
+  (local.set 2)
+  (global.get $arg-array)
+  (i32.const 0)
+  (local.get 2)
+  (array.set $arg-array-type)
+  (i32.const 1)
+  (global.get $cont-stack)
+  (global.get $cont-stack-top)
+  (array.get $cont-stack-type)
+  ref.as_non_null
+  (global.get $cont-stack-top)
+  (i32.const 1)
+  i32.sub
+  (global.set $cont-stack-top)
+  (return_call_ref $cont-type))
+ (elem declare funcref (ref.func 3))
+ (func
+  (param i32)
+  (@gyehoek :origin (kappa (x4) (continue halt x4)))
+  (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+  (global.get $arg-array)
+  (i32.const 0)
+  (array.get $arg-array-type)
+  ref.as_non_null
+  (local.set 1)
+  (global.get $arg-array)
+  (i32.const 0)
+  (local.get 1)
+  (array.set $arg-array-type)
+  (return_call $halt (i32.const 1)))
+ (func
+  $scm-entry
+  (param i32)
+  (@gyehoek
+   :origin
+   (letrec ((lambda-body0
+             (lambda (x lambda-tail1)
+               (prim (* x x) (kappa (r2) (continue lambda-tail1 r2))))))
+     (letrec ((r3 (kappa (x4) (continue halt x4))))
+       (lambda-body0 5 r3))))
+  (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+  (i32.const 0)
+  (ref.func 3)
+  (struct.new $closure)
+  (local.set 1)
+  (@gyehoek "push return cont" :idx 4)
+  (array.set $cont-stack-type
+             (global.get $cont-stack)
+             (global.get $cont-stack-top)
+             (ref.func 4))
+  (global.set $cont-stack-top
+              (i32.add (global.get $cont-stack-top)
+                       (i32.const 1)))
+  (@gyehoek "load args")
+  (global.get $arg-array)
+  (i32.const 0)
+  (i32.const 5)
+  (i32.const 1)
+  i32.shl
+  ref.i31
+  (array.set $arg-array-type)
+  (@gyehoek todo (f' (local.get 1)) (ktail 1))
+  (return_call_ref $cont-type
+                   (i32.const 1)
+                   (struct.get $closure $code
+                               (ref.cast (ref $closure) (local.get 1)))))
+ (elem declare funcref (ref.func 4))
+ (func
+  (export "main")
+  (call $scm-entry (i32.const 0))
+  (call $gh-write (ref.as_non_null (global.get $result)))))

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