qq!

.gitea/workflows/build.yaml

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

app/Gyehoek/CPS/Lower.hs

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

app/Gyehoek/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 #-}
+module Main (main) where
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE OrPatterns #-}
-module Main
-  (main)
-  where
 
-import Gyehoek.Options
+import Gyehoek.Driver qualified
-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)
 
 
-main :: IO ()
+main = Gyehoek.Driver.main
-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

cabal.project

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

doc/data-model.org

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

flake.nix

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

golden/arith/exec

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

golden/arith/out.wat

@@ -0,0 +1,47 @@
+(module
+  (type $heap-object (sub (struct (field (mut i32)))))
+  (func
+    (param)
+    (result (ref eq))
+    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+    (i32.const 3)
+    (i32.const 2)
+    i32.shl
+    ref.i31
+    (ref.cast (ref i31))
+    i31.get_s
+    (i32.const 4)
+    (i32.const 2)
+    i32.shl
+    ref.i31
+    (ref.cast (ref i31))
+    i31.get_s
+    i32.mul
+    ref.i31
+    (local.set 0)
+    (i32.const 2)
+    (i32.const 2)
+    i32.shl
+    ref.i31
+    (ref.cast (ref i31))
+    i31.get_s
+    (i32.const 5)
+    (i32.const 2)
+    i32.shl
+    ref.i31
+    (ref.cast (ref i31))
+    i31.get_s
+    i32.mul
+    ref.i31
+    (local.set 1)
+    (local.get 0)
+    (ref.cast (ref i31))
+    i31.get_s
+    (local.get 1)
+    (ref.cast (ref i31))
+    i31.get_s
+    i32.add
+    ref.i31
+    (local.set 2)
+    (local.get 2))
+  (export "main" (func 0)))

golden/if-false/exec

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

golden/if-false/out.wat

@@ -0,0 +1,13 @@
+(module
+  (type (sub (struct (field (mut i32)))))
+  (func
+    (param)
+    (result (ref eq))
+    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+    (i32.const 0)
+    ref.i31
+    (if
+      (result i32)
+      (then (i32.const 777) ref.i31)
+      (else (i32.const 555) ref.i31)))
+  (export "main" (func 0)))

golden/if-false/source.scm

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

golden/if-true/exec

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

golden/if-true/out.wat

@@ -0,0 +1,13 @@
+(module
+  (type (sub (struct (field (mut i32)))))
+  (func
+    (param)
+    (result (ref eq))
+    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+    (i32.const 1)
+    ref.i31
+    (if
+      (result i32)
+      (then (i32.const 777) ref.i31)
+      (else (i32.const 555) ref.i31)))
+  (export "main" (func 0)))

golden/if-true/source.scm

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

golden/lambda/source.scm

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

golden/square/source.scm

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

gyehoek.cabal

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

index.html

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

src/Gyehoek/CPS/Convert.hs

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

src/Gyehoek/CPS/Lower.hs

@@ -0,0 +1,291 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultilineStrings #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE ApplicativeDo #-}
+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
+{- HLINT ignore "Use camelCase" -}
+module Gyehoek.CPS.Lower
+  (lower, lowerProgram) where
+
+import Gyehoek.CPS.Syntax
+import Data.Generics.Labels
+import Gyehoek.Scheme.Syntax qualified as Scm
+import Gyehoek.GenSym
+import Data.List.NonEmpty (NonEmpty((:|)))
+import Data.List (List)
+import Effectful
+import Control.Monad.Cont qualified as Cont
+import Effectful.Writer.Static.Local
+import Data.Text (Text)
+import Data.Vector.Strict (Vector)
+import Control.Lens
+import Data.Foldable
+import Data.HashMap.Strict (HashMap)
+import Numeric.Natural
+import GHC.Generics (Generic)
+import Gyehoek.Scheme.Syntax (Lit(..))
+import Text.Printf
+import qualified Data.Text as T
+import qualified Data.Vector.Strict as V
+import Data.IntMap.Strict (IntMap)
+import Data.String.Interpolate
+import Gyehoek.Wasm qualified as Wasm
+import Gyehoek.Wasm hiding (Expr)
+import Language.Sexp.Located qualified as SL
+import Debug.Pretty.Simple
+import Control.Monad.Fix
+import Language.Sexp.Located (Sexp)
+import Data.Functor.Foldable (cata)
+
+
+data Env = MkEnv
+  { runtime :: Runtime
+  , vars :: Vector Name
+  , kvars :: Vector Name
+  }
+  deriving (Show, Generic)
+
+type instance Index Env = Natural
+type instance IxValue Env = Name
+
+instance Ixed Env where
+  ix i = #vars . ix (fromIntegral i)
+
+data Runtime = MkRuntime
+  { argArrayType :: Idx
+  , argArray :: Idx
+  , contType :: Idx
+  , contStackType :: Idx
+  , contStackTop :: Idx
+  , contStack :: Idx
+  , result :: Idx
+  , halt :: Idx
+  }
+  deriving (Show, Generic)
+
+
+
+-- | @makeSmallFixnum@ emits an expression injecting the i32 on top
+-- of the stack into the SCM unitype.
+-- makeSmallFixnum :: Wasm.Expr
+-- makeSmallFixnum = mconcat
+--   [ ins "i32.const" [sxp @Int 1]
+--   , ins "i32.shl" []
+--   , ins "ref.i31" []
+--   ]
+
+-- | Given an expression @e@ leaving a @ref eq@ atop the stack,
+-- @pushArg rt n e@ sets the nth slot of the arg-passing array to the
+-- result of @e@.
+-- pushArg :: Runtime -> Int -> Wasm.Expr -> Wasm.Expr
+-- pushArg (MkRuntime {argArrayType,argArray}) n e = mconcat
+--   [ ins "global.get" [sxp argArray]
+--   , ins "i32.const" [sxp n]
+--   , e
+--   , ins "array.set" [sxp argArrayType]
+--   ]
+
+-- | Pop the nth arg from the arg-passing array onto the stack.
+-- popArg :: Runtime -> Int -> Wasm.Expr
+-- popArg (MkRuntime {argArrayType,argArray}) n = mconcat
+--   [ ins "global.get" [sxp argArray]
+--   , ins "i32.const" [sxp n]
+--   , ins "array.get" [sxp argArrayType]
+--   , ins "ref.as_non_null" []
+--   ]
+
+
+
+-- lowerVal :: Env -> Val -> Wasm.Expr
+
+-- lowerVal g (ValLit l) =
+--   case l of
+--     LitInt n -> 
+--       ins "i32.const" [sxp n]
+--       <> makeSmallFixnum
+--     LitBool b ->
+--       ins "i32.const" [sxp @Int $ if b then 1 else 0]
+--       <> ins "ref.i31" []
+--     _ -> _
+
+-- lowerVal g (ValVar x) = ins "local.get" [sxp (1+l)]
+--   where
+--     l = V.elemIndex x g.vars ^?! _Just
+
+-- lower' :: (GenMod :> es) => Env -> Exp -> Eff es Wasm.Expr
+
+-- lower' g (Halt [v]) = pure . mconcat $
+--   [ pushArg g.runtime 0 (lowerVal g v)
+--   , ins "return_call" [sxp @Int 1]
+--   ]
+
+-- lower' g (ExpPrim p rs e) =
+--   case p of
+--     PrimAdd x y -> lowerBinOp "i32.add" g x y r e
+--     PrimMul x y -> lowerBinOp "i32.mul" g x y r e
+--   where
+--     r = head rs
+
+-- lower' g (ExpIf c t f) = do
+--   t' <- lower' g t
+--   f' <- lower' g f
+--   pure $ lowerVal g c
+--     <> Wasm.if' (Wasm.result [i32]) t' f'
+
+-- lower' g (ExpContinue k [x]) = pure . mconcat $
+--   [ pushArg rt 0 (lowerVal g x)
+--   , ins "i32.const" [sxp @Int 1] -- nargs
+--   -- get the return continuation.
+--   , ins "global.get" [sxp rt.contStack]
+--   , ins "global.get" [sxp rt.contStackTop]
+--   , ins "array.get" [sxp rt.contStackType]
+--   , ins "ref.as_non_null" []
+--   -- decrement contStackTop, completing the "pop."
+--   , ins "global.get" [sxp rt.contStackTop]
+--   , ins "i32.const" [sxp @Int (1 + l)]
+--   , ins "i32.sub" []
+--   , ins "global.set" [sxp rt.contStackTop]
+--   , ins "return_call_ref" [sxp rt.contType]
+--   ]
+--   where
+--     rt = g.runtime
+--     l = V.elemIndex k g.kvars ^?! _Just
+
+-- lower' g (ExpLet [(r,MkLambda xs ktail m)] e) = do
+--   idx <- defun [i32] [] (replicate 5 scm) \_ -> do
+--     let g' = g & #vars <>~ V.fromList xs
+--                & #kvars <>~ [ktail]
+--     m' <- lower' g' m
+--     pure . mconcat $
+--       [ xs & ifoldMap \n _ ->
+--           popArg g.runtime n <> ins "local.set" [sxp (1+n)]
+--       , m'
+--       ]
+--   declareFuncref idx
+--   let g' = g & #vars <>~ [r]
+--   let n = length g.vars
+--   e' <- lower' g' e
+--   pure . mconcat $
+--     [ ins "ref.func" [sxp idx]
+--     , ins "local.set" [sxp (n+1)]
+--     , e'
+--     ]
+
+-- lower' g e = error . show $ e
+
+-- lowerBinOp
+--   :: (GenMod :> es)
+--   => Text -> Env -> Val -> Val -> Name -> Exp -> Eff es Wasm.Expr
+-- lowerBinOp op g x y r e = do
+--   e' <- lower' g' e
+--   pure . mconcat $
+--     [ lowerVal g x
+--     , ins "ref.cast" [sxp $ ref i31]
+--     , ins "i31.get_s" []
+--     , lowerVal g y
+--     , ins "ref.cast" [sxp $ ref i31]
+--     , ins "i31.get_s" []
+--     , ins op []
+--     , ins "ref.i31" []
+--     , ins "local.set" [sxp (1+n)]
+--     , e'
+--     ]
+--   where
+--     g' = g & #vars <>~ [r]
+--     n = length (g ^. #vars)
+
+
+
+-- scm = ref eq
+
+
+
+-- emitRuntime :: GenMod :> es => Eff es Runtime
+-- emitRuntime = mfix \runtime -> do
+--   heapObjectIdx <- Wasm.deftypeNamed "$heap-object" $ Wasm.sub [] $ Wasm.struct
+--     [ Wasm.mut i32 ]
+--   -- cont stack
+--   contType <- Wasm.deftype $ Wasm.func [i32] []
+--   contStackType <- Wasm.deftype $ array $ mut $ refnull (fromIdx contType)
+--   contStackTop <- Wasm.defglobal (mut i32) $ ins "i32.const" [sxp @Int 0]
+--   contStack <- Wasm.defglobal (ref (Wasm.fromIdx contStackType)) $
+--     ins "i32.const" [sxp @Int 128]
+--     <> ins "array.new_default" [sxp contStackType]
+--   -- arg array
+--   argArrayType <- Wasm.deftype $ Wasm.array $ mut $ refnull eq
+--   argArray <- Wasm.defglobal (ref (Wasm.fromIdx argArrayType)) $
+--     ins "i32.const" [sxp @Int 32]
+--     <> ins "array.new_default" [sxp argArrayType]
+--   -- consIdx <- Wasm.defun _ _ _ _
+--   result <- Wasm.defglobal (mut (refnull eq)) $ ins "ref.null" [sxp eq]
+--   halt <- Wasm.defun [i32] [] (replicate 5 scm) \_ ->
+--     pure . mconcat $
+--       [ popArg runtime 0
+--       , ins "global.set" [sxp result]
+--       ]
+--   pure $ MkRuntime
+--     {argArray,argArrayType
+--     ,contStack,contStackTop,contStackType,contType
+--     ,result,halt}
+--   -- pure $ error "todo"
+
+-- lower :: Exp -> Eff es Text
+-- lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do
+--   runtime <- emitRuntime
+--   let g = MkEnv runtime mempty mempty
+--   scm_entry <- Wasm.defun [i32] [] (replicate 5 scm) \_ ->
+--     lower' g e
+--   main <- Wasm.defun [] [scm] [scm, scm, scm, scm, scm] \_ ->
+--     pure . mconcat $
+--       -- push return cont
+--       [--  ins "ref.func" [sxp halt]
+--       -- make call
+--       ins "i32.const" [sxp @Int 0]
+--       , ins "call" [sxp scm_entry]
+--       , ins "global.get" [sxp runtime.result]
+--       , ins "ref.as_non_null" []
+--       ]
+--   Wasm.export "main" "func" main
+
+-- lowerProgram :: Program -> Eff es Text
+-- lowerProgram (MkProgram e) = lower e
+
+lower = _
+lowerProgram = _
+
+antiquote_example =
+  let
+    metavar :: Integer
+    metavar = 123
+
+    e1 :: Wasm.Expr
+    e1 = [expr|
+      (func $blah (result i32)
+        (i32.const #{metavar}))
+    |]
+
+    e2 :: Wasm.Expr
+    e2 = [expr|
+      (func $blah (result i32)
+        (i32.const 123))
+    |]
+  in (metavar,e1,e2,e1==e2)
+
+antiquote_splicing_example =
+  let
+    metavars :: List Sexp
+    metavars = [sxs'|i32 i64 f64|]
+
+    e1 :: Wasm.Expr
+    e1 = [expr|
+      (func $blah (param ##{metavars}))
+    |]
+
+    e2 :: Wasm.Expr
+    e2 = [expr|
+      (func $blah (param i32 i64 f64))
+    |]
+  in (metavars, e1, e2, e1 == e2)

src/Gyehoek/CPS/Syntax.hs

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

src/Gyehoek/Driver.hs

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

src/Gyehoek/GenSym.hs

@@ -35,3 +35,11 @@ runGenSym = reinterpret (evalStateLocal (0 :: Natural)) \cases
 instance Gen Text where
   gen = fromString . ('x':) . show
   gen' s = (s <>) . fromString . show
+
+instance Gen Natural where
+  gen = id
+  gen' = const id
+
+instance Gen Int where
+  gen = fromIntegral
+  gen' _ = fromIntegral

src/Gyehoek/Options.hs

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

src/Gyehoek/Scheme/Syntax.hs

@@ -1,6 +1,9 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE OrPatterns #-}
@@ -9,10 +12,17 @@ module Gyehoek.Scheme.Syntax
   ( Name(..)
   , Prim(..)
   , Lit(..)
-  , Define(..)
+  , Def(..)
   , Exp(..)
   , Sexp(..)
+  , Program(..)
+  , CommandOrDef(..)
   , primSexpIso
+  , pattern Void
+  , free
+  , qexp
+  , qprog
+  , subst
   )
   where
 
@@ -21,6 +31,7 @@ import Data.List (List)
 import Language.SexpGrammar
   ( SexpIso(..), list, el, (>>>), rest, sym, symbol )
 import Language.SexpGrammar qualified as Sexp
+import Language.Sexp.Located qualified as S
 import Language.SexpGrammar.Generic
 import GHC.Generics
 import Prelude hiding ((.), id)
@@ -28,14 +39,21 @@ import Control.Category
 import Data.List.NonEmpty (NonEmpty ((:|)))
 import Gyehoek.Sexp qualified
 import Gyehoek.GenSym (Gen)
-import Control.Lens (Each)
+import Control.Lens
 import Data.String (IsString)
 import Data.Hashable (Hashable)
+import Control.Lens.Unsound (prismSum)
+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)
 
 
 newtype Name = MkName { getName :: Text }
   deriving newtype (Show, Eq, IsString, Gen, Hashable)
-  deriving stock (Generic)
+  deriving stock (Generic, Data)
 
 data Prim e
   = PrimAdd e e
@@ -51,7 +69,7 @@ data Prim e
   | PrimWrite e
   | PrimZeroP e
   | PrimNewline
-  deriving (Show, Generic, Functor, Foldable, Traversable)
+  deriving (Show, Generic, Functor, Foldable, Traversable, Data)
 
 instance Each (Prim e) (Prim e') e e'
 
@@ -61,30 +79,56 @@ data Lit
   | LitBool Bool
   | LitString Text
   | LitQuote Sexp
-  deriving (Show, Generic)
+  deriving (Show, Generic, Data)
 
-data Define
+pattern Void :: Lit
-  = DefineConstant Name Exp
+pattern Void = LitNil
-  | DefineProcedure Name (List Name) (List Exp)
+
-  deriving (Show, Generic)
+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)
+
+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
+      toeither (Command e) = Left e
+      toeither (Definition d) = Right d
+      go :: Traversal' CommandOrDef (Either Exp Def)
+      go k (Command e) = inj <$> k (Left e)
+      go k (Definition d) = inj <$> k (Right d)
+      go k (Begin xs) = Begin <$> traverse (go k) xs
+
+makeBaseFunctor ''Exp
 
 
 
@@ -124,10 +168,19 @@ instance SexpIso Lit where
   sexpIso = match
     $ With (. sexpIso)
     $ With (. sym "nil")
-    $ With (. sexpIso)
+    $ With (. bool)
     $ With (. sexpIso)
     $ With (. Gyehoek.Sexp.prefixSugar "quote" Sexp.Quote sexpIso)
     $ End
+    where
+      bool :: Sexp.SexpGrammar Bool
+      bool = Sexp.hashed $ Sexp.partialOsi f g
+        where
+          f (S.Symbol ("t";"true")) = Right True
+          f (S.Symbol ("f";"false")) = Right False
+          f _ = Left $ Sexp.expected "bool"
+          g True = S.Symbol "true"
+          g False = S.Symbol "false"
 
 instance SexpIso Sexp where
   sexpIso = match
@@ -136,7 +189,7 @@ instance SexpIso Sexp where
     $ With (\lit -> lit . sexpIso)
     $ End
 
-instance SexpIso Define where
+instance SexpIso Def where
   sexpIso = match
     $ With (. defconst)
     $ With (. defun)
@@ -151,7 +204,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 +216,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
+
+qexp = Gyehoek.Sexp.makeSx $ sexpIso @Exp
+qprog = Gyehoek.Sexp.makeSxs (sexpIso @CommandOrDef) MkProgram
+
+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,357 @@
+{-# 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(..)
+  , parseSexpsWithPos
+  , parseSexpWithPos
+  , parseSexp
+  , sx
+  , sxs
+  , makeSx
+  , makeSxs
+  , toSexp
+  , fromSexp
+  , stripLocation
+  , sx'
+  , sxs'
+  )
+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
+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)
+import qualified Data.Text as T
+import qualified Control.Category
+import Data.Data (Data, Typeable, cast)
+import Language.Haskell.TH.Syntax (lift, Lift)
+import GHC.IsList (fromList)
+import Data.Functor.Foldable (cata)
+import Data.Functor.Classes (Show1(..))
+
+
+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
+
+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)
+
+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
+
+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
+
+metaSexp :: Sexp.Sexp -> Maybe ExpQ
+metaSexp (Unquote x) =
+  Just [| stripLocation . toSexp $ $(varE (mkName (T.unpack x))) |]
+metaSexp (SL.ParenList xs)
+  | (_:_) <- xs ^.. each . _UnquoteSplicing
+  = Just [| stripLocation . toSexp $ SL.ParenList (mconcat $(listE spans)) |]
+  where
+    spans = xs
+      & groupBy \cases
+          (UnquoteSplicing _) _ -> False
+          _ (UnquoteSplicing _) -> False
+          _ _                   -> True
+      & fmap \case
+        [UnquoteSplicing x] ->
+          [| stripLocation <$> toSexps $(varE (mkName (T.unpack x))) |]
+        x -> [| stripLocation <$> x |]
+metaSexp _ = Nothing
+
+-- 뻘짓뻘짓뻘짓뻘짓뻘짓
+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.Modified $(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
+
+extQ :: (Typeable a, Typeable b) => (a -> r) -> (b -> r) -> a -> r
+extQ f g a = maybe (f a) g (cast a)
+
+makeSxs
+  :: Data b
+  => (List a -> b) -> SexpGrammar a -> QuasiQuoter
+makeSxs f g = QuasiQuoter
+  { quoteExp = \str -> do
+      pos <- getPos
+      case parseSexpsWithPos g pos (T.pack str) of
+        Left e -> fail e
+        Right xs -> dataToExpQ (const Nothing `extQ` metaSexp) (f xs)
+  , quotePat = undefined
+  , quoteType = undefined
+  , quoteDec = undefined
+  }
+
+makeSx
+  :: (Data a, Data r)
+  => (a -> r) -> SexpGrammar a -> QuasiQuoter
+makeSx f g = QuasiQuoter
+  { quoteExp = \str -> do
+      pos <- getPos
+      case parseSexpWithPos g pos (T.pack str) of
+        Left e -> fail e
+        Right x -> dataToExpQ (const Nothing `extQ` metaSexp) (f x)
+  , quotePat = undefined
+  , quoteType = undefined
+  , quoteDec = undefined
+  }
+
+sxs = makeSxs id (sexpIso @Sexp)
+sx = makeSx id (sexpIso @Sexp)
+
+sxs' = makeSxs (fmap stripLocation) (sexpIso @Sexp)
+sx' = makeSx stripLocation (sexpIso @Sexp)

src/Gyehoek/Wasm.hs

@@ -0,0 +1,185 @@
+{- HLINT ignore "Use newtype instead of data" -}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeepSubsumption #-}
+{-# LANGUAGE NoFieldSelectors #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE RecordPuns #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE ImpredicativeTypes #-}
+{-# LANGUAGE DerivingVia #-}
+module Gyehoek.Wasm
+  (
+    -- * syntax
+    Module
+  , Idx
+  , Expr
+    -- ** quasiquoters
+  , expr
+  , Gyehoek.Sexp.sx
+  , Gyehoek.Sexp.sxs
+  , Gyehoek.Sexp.sx'
+  , Gyehoek.Sexp.sxs'
+  -- * GenMod effect
+  , GenMod
+  , runGenMod
+  , execGenMod
+  , defineFunction
+  , defineType
+  , defineGlobal
+  , declare
+  )
+  where
+
+import Language.SexpGrammar
+  ( SexpIso(..), list, el, (>>>), rest, sym, symbol, (:-) )
+import Language.SexpGrammar qualified as Sexp
+import Language.SexpGrammar.Generic
+import Data.List (List)
+import GHC.Generics (Generic, Generically(..))
+import Data.Text (Text)
+import Data.String (IsString (fromString))
+import Text.Printf
+import Effectful
+import Numeric.Natural (Natural)
+import Effectful.Dispatch.Dynamic
+import Effectful.State.Dynamic
+import Control.Lens
+import Data.Generics.Labels
+import Data.Vector (Vector)
+import Data.String.Interpolate
+import qualified Data.Vector as V
+import qualified Data.Text as T
+import Effectful.Writer.Dynamic
+import Control.Applicative (Alternative((<|>)))
+import Control.Category qualified as Cat
+import Data.Vector.Lens
+import Data.Either (fromLeft, fromRight)
+import Language.Sexp.Located
+import qualified Gyehoek.Sexp
+import GHC.IsList (IsList(..))
+import Data.Coerce (coerce)
+import qualified Control.Category
+import Data.Functor (void)
+import Language.Haskell.TH.Quote (QuasiQuoter)
+import Data.Data (Data)
+import Data.Functor.Foldable (cata)
+
+
+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
+  Declare :: Sexp -> GenMod m ()
+
+type instance DispatchOf GenMod = Dynamic
+
+defineFunction :: GenMod :> es => Sexp -> Eff es Idx
+defineFunction = send . DefineFunction
+
+defineType :: GenMod :> es => Sexp -> Eff es Idx
+defineType = send . DefineType
+
+defineGlobal :: GenMod :> es => Sexp -> Eff es Idx
+defineGlobal = send . DefineGlobal
+
+declare :: GenMod :> es => Sexp -> Eff es ()
+declare = send . Declare
+
+appendAndIncrement
+  :: State GenModState :> es
+  => LensLike' ((,) _) 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
+    _ (Declare s) -> #mod . #inner <>= V.singleton s
+
+execGenMod :: Eff (GenMod : es) a -> Eff es Module
+execGenMod = fmap snd . runGenMod
+
+
+-- 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
+
+
+-- quasiquoters
+
+expr :: QuasiQuoter
+expr = Gyehoek.Sexp.makeSxs
+  (MkExpr . V.fromList . (each . #inner %~ Gyehoek.Sexp.stripLocation))
+  (sexpIso @Instr)

t.js

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

t.wat

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

t2.wat

@@ -0,0 +1,65 @@
+(module
+ (type $heap-object (sub (struct (field (mut i32)))))
+ (type $open-procedure (func (param i32)))
+ (type $closure (sub $heap-object
+                     (struct (field (mut i32))
+                             (field (ref $open-procedure)))))
+ (type $cont-stack-type (array (mut (ref null $open-procedure))))
+ (type $arg-array-type (array (mut eqref)))
+ (type (func (result (ref eq))))
+ (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)))
+ (global $arg-array (ref $arg-array-type)
+         (array.new_default $arg-array-type (i32.const 32)))
+ (global (mut eqref) (ref.null eq))
+ (elem declare funcref (ref.func 1))
+ (func $halt (param i32)
+       (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+       (global.set 3
+                   (ref.as_non_null
+                    (array.get $arg-array-type
+                               (global.get $arg-array)
+                               (i32.const 0)))))
+ (func $f1 (param i32)
+       (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+       ;; pop arg 0
+       (local.set
+        1
+        (ref.as_non_null
+         (array.get $arg-array-type
+                    (global.get $arg-array)
+                    (i32.const 0))))
+       ;; push arg 0
+       (array.set $arg-array-type
+                  (global.get $arg-array)
+                  (i32.const 0)
+                  (local.get 1))
+       ;; pop continuation
+       (return_call_ref
+        $open-procedure
+        (i32.const 1)
+        (ref.as_non_null (array.get $cont-stack-type
+                                    (global.get $cont-stack)
+                                    (global.get $cont-stack-top)))
+        (global.set $cont-stack-top
+                    (i32.sub
+                     (global.get $cont-stack-top)
+                     (i32.const 1)))))
+ (func $f2 (type $open-procedure) (param i32)
+       (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+       (local.set 1
+                  (struct.new $closure
+                              (i32.const 0)
+                              (ref.func $f1)))
+       (array.set $arg-array-type
+                  (global.get $arg-array)
+                  (i32.const 0)
+                  (local.get 1))
+       (i32.const 1)
+       (return_call $f1))
+ (func $main (export "main") (result (ref eq))
+       (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+       (call $f2 (i32.const 0))
+       (ref.as_non_null
+        (global.get 3))))

test/Main.hs

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

u.wat

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

wasmtime.nix

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

wasmtime.toml

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