fix tests }:3

doc/data-model.org

@@ -15,3 +15,9 @@ XXXX XXXX XXXX XXXX XXXX XXXX XXXX XX00
       zero indicates a 30-bit fixnum /
       in the upper bits
 #+end_example
+
+| type/value | low bits |
+|------------+----------|
+| small int  |        0 |
+| ~false~      |       01 |
+| ~true~       |       11 |

flake.nix

@@ -16,13 +16,11 @@
         "x86_64-darwin" "x86_64-linux"
       ];
 
-
       overlays = [
         haskellNix.overlay
         (final: prev: {
-          gyehoek-wasmtime-wrapper = final.callPackage ./wasmtime.nix {};
-        })
-        (final: prev: {
+          shake-wrapper = final.callPackage ./shake-wrapper.nix {};
+          gyehoek-runtime = final.callPackage ./runtime {};
           gyehoek = final.haskell-nix.project' {
             src = ./.;
             compiler-nix-name = "ghc912";
@@ -30,32 +28,32 @@
               packages.gyehoek.components.tests.test.preCheck =
                 let
                   bin = [
-                    pkgs.gyehoek-wasmtime-wrapper
-                    pkgs.git
+                    pkgs.git # tasty uses git diff
                   ];
                 in ''
-                  # Wasmtime requires a cache in $HOME. This is less
-                  # painful than reconfiguring the cache location.
-                  export HOME=$(mktemp -d)
+                  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; [
                 haskellPackages.cabal-fmt
-                self.packages.${final.stdenv.hostPlatform.system}.shake
-                final.wabt
-                final.nodejs
-                final.wasm-tools
-                final.wac-cli
-                final.guile
-                final.gyehoek-wasmtime-wrapper
+                shake-wrapper
+                wabt
+                nodejs
+                wasm-tools
+                wac-cli
+                guile
+                rust-analyzer
+                wasmtime
               ];
             };
           };
@@ -87,7 +85,7 @@
         hf.packages.${system} // lib.fix (packages: {
           gyehoek = hf.packages.${system}."gyehoek:exe:gyehoek";
           default = packages.gyehoek;
-          shake = pkgs.callPackage ./shake-wrapper.nix {};
+          inherit (pkgs) gyehoek-runtime shake-wrapper;
         }));
 
       devShells = each-system

golden/arith/exec

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

golden/arith/out.wat

@@ -1,47 +1,95 @@
 (module
-  (type $heap-object (sub (struct (field (mut i32)))))
+  (import
+    "gyehoek"
+    "write"
+    (func $gh-write (param (ref eq))))
+  (import
+    "gyehoek"
+    "to-bool"
+    (func $gh-to-bool (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))))
+  (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
-    (param)
-    (result (ref eq))
+    $halt
+    (param i32)
+    (global.get $arg-array)
+    (i32.const 0)
+    (array.get $arg-array-type)
+    ref.as_non_null
+    (global.set $result))
+  (func
+    $scm-entry
+    (param i32)
     (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
     (i32.const 3)
-    (i32.const 2)
+    (i32.const 1)
     i32.shl
     ref.i31
-    (ref.cast (ref i31))
-    i31.get_s
+    (i31.get_s (ref.cast (ref i31)))
+    (i32.const 1)
+    i32.shr_u
     (i32.const 4)
-    (i32.const 2)
+    (i32.const 1)
     i32.shl
     ref.i31
-    (ref.cast (ref i31))
-    i31.get_s
+    (i31.get_s (ref.cast (ref i31)))
+    (i32.const 1)
+    i32.shr_u
     i32.mul
-    ref.i31
-    (local.set 0)
-    (i32.const 2)
-    (i32.const 2)
+    (i32.const 1)
     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
+    (i32.const 2)
+    (i32.const 1)
+    i32.shl
+    ref.i31
+    (i31.get_s (ref.cast (ref i31)))
+    (i32.const 1)
+    i32.shr_u
+    (i32.const 5)
+    (i32.const 1)
+    i32.shl
+    ref.i31
+    (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)
-    (local.get 2))
-  (export "main" (func 0)))
+    (local.get 1)
+    (i31.get_s (ref.cast (ref i31)))
+    (i32.const 1)
+    i32.shr_u
+    (local.get 2)
+    (i31.get_s (ref.cast (ref i31)))
+    (i32.const 1)
+    i32.shr_u
+    i32.add
+    (i32.const 1)
+    i32.shl
+    ref.i31
+    (local.set 3)
+    (global.get $arg-array)
+    (global.get 0)
+    (local.get 3)
+    (array.set $arg-array-type)
+    (return_call $halt (i32.const 1)))
+  (func
+    (export "main")
+    (call $scm-entry (i32.const 0))
+    (call $gh-write (ref.as_non_null (global.get $result)))))

golden/if-false/exec

@@ -1,5 +1,2 @@
 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

@@ -1,13 +1,61 @@
 (module
-  (type (sub (struct (field (mut i32)))))
+  (import
+    "gyehoek"
+    "write"
+    (func $gh-write (param (ref eq))))
+  (import
+    "gyehoek"
+    "to-bool"
+    (func $gh-to-bool (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))))
+  (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
-    (param)
-    (result (ref eq))
-    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+    $halt
+    (param i32)
+    (global.get $arg-array)
     (i32.const 0)
+    (array.get $arg-array-type)
+    ref.as_non_null
+    (global.set $result))
+  (func
+    $scm-entry
+    (param i32)
+    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+    (i32.const 1)
     ref.i31
+    (call $gh-to-bool)
     (if
-      (result i32)
-      (then (i32.const 777) ref.i31)
-      (else (i32.const 555) ref.i31)))
-  (export "main" (func 0)))
+      (then
+        (global.get $arg-array)
+        (global.get 0)
+        (i32.const 777)
+        (i32.const 1)
+        i32.shl
+        ref.i31
+        (array.set $arg-array-type)
+        (return_call $halt (i32.const 1)))
+      (else
+        (global.get $arg-array)
+        (global.get 0)
+        (i32.const 555)
+        (i32.const 1)
+        i32.shl
+        ref.i31
+        (array.set $arg-array-type)
+        (return_call $halt (i32.const 1)))))
+  (func
+    (export "main")
+    (call $scm-entry (i32.const 0))
+    (call $gh-write (ref.as_non_null (global.get $result)))))

golden/if-true/exec

@@ -1,5 +1,2 @@
 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

@@ -1,13 +1,61 @@
 (module
-  (type (sub (struct (field (mut i32)))))
+  (import
+    "gyehoek"
+    "write"
+    (func $gh-write (param (ref eq))))
+  (import
+    "gyehoek"
+    "to-bool"
+    (func $gh-to-bool (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))))
+  (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
-    (param)
-    (result (ref eq))
+    $halt
+    (param i32)
+    (global.get $arg-array)
+    (i32.const 0)
+    (array.get $arg-array-type)
+    ref.as_non_null
+    (global.set $result))
+  (func
+    $scm-entry
+    (param i32)
     (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-    (i32.const 1)
+    (i32.const 3)
     ref.i31
+    (call $gh-to-bool)
     (if
-      (result i32)
-      (then (i32.const 777) ref.i31)
-      (else (i32.const 555) ref.i31)))
-  (export "main" (func 0)))
+      (then
+        (global.get $arg-array)
+        (global.get 0)
+        (i32.const 777)
+        (i32.const 1)
+        i32.shl
+        ref.i31
+        (array.set $arg-array-type)
+        (return_call $halt (i32.const 1)))
+      (else
+        (global.get $arg-array)
+        (global.get 0)
+        (i32.const 555)
+        (i32.const 1)
+        i32.shl
+        ref.i31
+        (array.set $arg-array-type)
+        (return_call $halt (i32.const 1)))))
+  (func
+    (export "main")
+    (call $scm-entry (i32.const 0))
+    (call $gh-write (ref.as_non_null (global.get $result)))))

runtime/.gitignore

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

runtime/Cargo.toml

@@ -0,0 +1,9 @@
+[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"] }
+wasmtime = "46.0.1"

runtime/default.nix

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

runtime/src/gyehoek.rs

@@ -0,0 +1,31 @@
+use wasmtime::*;
+use crate::internal as scm;
+use crate::internal::{Scm,Immediate};
+
+// 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 () {
+        Scm::Immediate (x) => write_immediate (caller, x)
+    }
+}
+
+pub fn truthy_p (caller : Caller<'_, u32>, x : Rooted<EqRef>,) -> u32 {
+    let r = scm::interpret (&caller, x).unwrap ();
+    if let Scm::Immediate (Immediate::Bool (false)) = r {
+        0
+    } else {
+        1
+    }
+}

runtime/src/internal.rs

@@ -0,0 +1,70 @@
+use wasmtime::*;
+
+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 Scm {
+    Immediate (Immediate),
+}
+
+#[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 (store : impl AsContext, x : Rooted<EqRef>) -> Option<Scm> {
+    if let Some (imm) = x.as_i31 (store).unwrap () {
+        Some (Scm::Immediate (interpret_immediate (imm.get_u32 ())?))
+    } else {
+        todo! ()
+    }
+}
+
+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)
+        }
+    }
+}
+
+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,52 @@
+mod gyehoek;
+mod internal;
+
+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", "to-bool", 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/t.wat

@@ -0,0 +1,6 @@
+(module
+ (import "gyehoek" "say-hi" (func $say-hi))
+ (func (export "main")
+       (call $say-hi)
+       (call $say-hi)
+       (call $say-hi)))

src/Gyehoek/CPS/Lower.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE ApplicativeDo #-}
 {-# OPTIONS_GHC -Wno-incomplete-patterns #-}
+{- HLINT ignore "Use camelCase" -}
 module Gyehoek.CPS.Lower
   (lower, lowerProgram) where
 
@@ -14,6 +15,7 @@ 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
@@ -32,14 +34,16 @@ import Data.IntMap.Strict (IntMap)
 import Data.String.Interpolate
 import Gyehoek.Wasm qualified as Wasm
 import Gyehoek.Wasm hiding (Expr)
-import Language.Sexp.Located (pattern ParenList)
+import Language.Sexp.Located qualified as SL
 import Debug.Pretty.Simple
 import Control.Monad.Fix
+import Language.Sexp.Located (Sexp)
+import Data.Functor.Foldable (cata)
+import qualified Gyehoek.Sexp
 
 
 data Env = MkEnv
-  { runtime :: Runtime
-  , vars :: Vector Name
+  { vars :: Vector Name
   , kvars :: Vector Name
   }
   deriving (Show, Generic)
@@ -50,48 +54,48 @@ 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)
+-- 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" []
-  ]
+makeSmallFixnum = [expr|
+    (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 :: 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]
-  ]
+pushArg :: Natural -> Wasm.Expr -> Wasm.Expr
+pushArg n e = [expr|
+    (global.get $arg-array)
+    (global.get #{n})
+    ##{e}
+    (array.set $arg-array-type)
+  |]
 
 -- | 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" []
-  ]
+popArg :: Int -> Wasm.Expr
+popArg n = [expr|
+  (global.get $arg-array)
+  (i32.const #{n})
+  (array.get $arg-array-type)
+  ref.as_non_null
+|]
 
 
 
@@ -99,24 +103,28 @@ 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" []
+    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) = ins "local.get" [sxp (1+l)]
+lowerVal g (ValVar x) = [expr|(local.get #{l})|]
   where
-    l = V.elemIndex x g.vars ^?! _Just
+    l = succ $ 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 (Halt [v]) = pure [expr|
+  ##{arg}
+  (return_call $halt (i32.const 1))
+|]
+  where arg = pushArg 0 (lowerVal g v)
 
 lower' g (ExpPrim p rs e) =
   case p of
@@ -128,123 +136,232 @@ lower' g (ExpPrim p rs e) =
 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'
-    ]
+  let c' = lowerVal g c
+  pure [expr|
+    ##{c'}
+    (call $gh-to-bool)
+    (if (then ##{t'})
+        (else ##{f'}))
+  |]
 
 lower' g e = error . show $ e
 
+-- 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
+  let op' = SL.Symbol op
+  let g' = g & #vars <>~ [r]
+  let n = succ $ length (g ^. #vars)
+  let x' = lowerVal g x
+  let y' = lowerVal g y
   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)
+  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'}
+  |]
 
 
 
-scm = ref eq
+-- scm = ref eq
 
 
 
-emitRuntime :: GenMod :> es => Eff es Runtime
+-- 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"
+
+emitRuntime :: GenMod :> es => Eff es ()
 emitRuntime = mfix \runtime -> do
-  heapObjectIdx <- Wasm.deftypeNamed "$heap-object" $ Wasm.sub [] $ Wasm.struct
-    [ Wasm.mut i32 ]
+  Wasm.emit [wats|
+    (import "gyehoek" "write" (func $gh-write (param (ref eq))))
+    (import "gyehoek" "to-bool" (func $gh-to-bool (param (ref eq))
+                                  (result 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]
+  Wasm.defineType [wat|
+    (type $heap-object (sub (struct (field $hash (mut i32)))))
+  |]
+  Wasm.defineType [wat|
+    (type $cont-type (func (param i32)))
+  |]
+  Wasm.defineType [wat|
+    (type $cont-stack-type (array (mut (ref null $cont-type))))
+  |]
+  Wasm.defineGlobal [wat|
+    (global $cont-stack-top (mut i32) (i32.const 0))
+  |]
+  Wasm.defineGlobal [wat|
+    (global $cont-stack (ref $cont-stack-type)
+            (array.new_default $cont-stack-type (i32.const 128)))
+  |]
   -- 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"
+  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 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
-
+  let g = MkEnv mempty mempty
+  e' <- lower' g e
+  Wasm.defineFunction [wat|
+    (func $scm-entry (param i32)
+      (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
+
+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 :: Wasm.Expr
+    metavars = [expr|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)
+
+antiquote_both_example =
+  let
+    m1 = 123 :: Int
+    ms = [expr|i32 i64|]
+
+    e1 = [expr|
+      a (b #{m1} c) d ##{ms} e
+    |]
+
+    e2 = [expr|
+      a (b 123 c) d i32 i64 e
+    |]
+  in (e1,e2,e1==e2)

src/Gyehoek/CPS/Syntax.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE PatternSynonyms #-}
 module Gyehoek.CPS.Syntax
   ( Val(..)
   , Kappa(..)

src/Gyehoek/Scheme/Syntax.hs

@@ -23,7 +23,6 @@ module Gyehoek.Scheme.Syntax
   , qexp
   , qprog
   , subst
-  , freeVariables
   )
   where
 
@@ -254,13 +253,3 @@ subst f = \e -> cata go e mempty where
   go (ExpLetF _ _) _ = error "todo lol"
   go (ExpLambdaF bs e) bound = e $ insertFrom bs bound
   go e bound = embed $ fmap ($ bound) e
-
--- | Unlawful!
-freeVariables :: Traversal Exp Exp Name Exp
-freeVariables k = \e -> cataA go e mempty where
-  go (ExpVarF x) bound
-    | not (x `HS.member` bound) = k x
-    | otherwise                 = pure $ ExpVar x
-  go (ExpLetF _ _) _ = error "todo lol"
-  go (ExpLambdaF bs e) bound = e $ insertFrom bs bound
-  go e bound = embed <$> traverse ($ bound) e

src/Gyehoek/Sexp.hs

@@ -27,6 +27,7 @@ module Gyehoek.Sexp
   , encodePretty
   , UglySexpIso(..)
   , AsSexpIso(..)
+  , SpliceSexp(..)
   , parseSexpsWithPos
   , parseSexpWithPos
   , parseSexp
@@ -34,11 +35,15 @@ module Gyehoek.Sexp
   , sxs
   , makeSx
   , makeSxs
+  , toSexp
+  , fromSexp
+  , stripLocation
+  , format
   )
-where
+  where
 
 import Data.Text (Text)
-import Language.SexpGrammar as Sexp hiding (toSexp, List, encode, decode, encodeWith, decodeWith, iso, encodePrettyWith, encodePretty)
+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
@@ -51,7 +56,7 @@ import Data.List (List, groupBy)
 import Data.Text.Encoding
 import Data.Either (either)
 import GHC.Generics (Generic)
-import Control.Lens
+import Control.Lens hiding (para)
 import Data.Generics.Labels
 import System.Process
 import GHC.IO.Unsafe (unsafePerformIO)
@@ -62,11 +67,21 @@ 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 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)
+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
 
 
 sexp :: SexpIso a => Iso' a Text
@@ -74,6 +89,9 @@ 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
 
@@ -91,25 +109,31 @@ 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 
+  (_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) (fromSexp sexpIso)
+  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 (fromSexp sexpIso)
+  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) (fromSexp g)
+  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 (fromSexp g)
+  where marshal = join . traverseOf _Right (Sexp.fromSexp g)
 
 nonEmptyGrammar :: Grammar p (NonEmpty x :- t) (List x :- x :- t)
 nonEmptyGrammar = IGB.Iso
@@ -231,21 +255,18 @@ getPos = do
   Loc {loc_filename,loc_start} <- location
   pure $ SL.Position loc_filename (fst loc_start) (snd loc_start)
 
-makeSxs :: Data b => SexpGrammar a -> (List a -> b) -> QuasiQuoter
-makeSxs g f = QuasiQuoter
-  { quoteExp = \str -> do
-      pos <- getPos
-      case parseSexpsWithPos g pos (T.pack str) of
-        Left e -> fail e
-        Right xs -> dataToExpQ (const Nothing) (f xs)
-  , quotePat = undefined
-  , quoteType = undefined
-  , quoteDec = undefined
-  }
+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 =
@@ -262,12 +283,57 @@ instance Each Sexp Sexp Sexp Sexp where
   each k (SL.BraceList xs)              = SL.BraceList <$> traverse k xs
   each _ e@(SL.Atom _; SL.Modified _ _) = pure e
 
-metaSexp :: Sexp.Sexp -> Maybe ExpQ
-metaSexp (Unquote x) =
-  Just [| toSexp $(varE (mkName (T.unpack x))) |]
-metaSexp (SL.ParenList xs)
-  | (_:_) <- xs ^.. each . _UnquoteSplicing
-  = Just [| SL.ParenList (mconcat $(listE spans)) |]
+stripLocation :: Sexp -> Sexp
+stripLocation = cata \case
+  SL.Compose (a SL.:< e) ->
+    SL.Fix . SL.Compose $ SL.dummyPos SL.:< e
+
+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
+
+unquoteSplicing :: List Sexp.Sexp -> Maybe ExpQ
+unquoteSplicing xs
+  | (_:_) <- xs ^.. folded . _UnquoteSplicing
+  = Just [| mconcat $(spans) |]
+  where
+    spans = xs
+      & groupBy \cases
+          (UnquoteSplicing _; Unquote _) _ -> False
+          _ (UnquoteSplicing _; Unquote _) -> False
+          _ _                              -> True
+      & fmap \case
+        [e@(Unquote _)] ->
+          case unquote e of
+            Just x -> [| [$(x)] |]
+            Nothing -> error "unreachable"
+        [UnquoteSplicing x] ->
+          [| stripLocation <$> spliceSexp $(varE (mkName (T.unpack x))) |]
+        x -> [| stripLocation <$> x |]
+      & listE
+unquoteSplicing _ = Nothing
+
+unquoteSplicingRecursive :: List Sexp.Sexp -> ExpQ
+unquoteSplicingRecursive xs = [| mconcat $(spans) |]
   where
     spans = xs
       & groupBy \cases
@@ -275,9 +341,36 @@ metaSexp (SL.ParenList xs)
           _ (UnquoteSplicing _) -> False
           _ _                   -> True
       & fmap \case
-        [UnquoteSplicing x] -> varE (mkName (T.unpack x))
-        x -> lift x
-metaSexp _ = Nothing
+        -- [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 -> [| stripLocation (toSexp $(varE (mkName (T.unpack x)))) |]
+  SL.ParenList xs -> [|SL.ParenList $(unquoteSplicingRecursive xs)|]
+  e -> liftData e
+
+unquote :: Sexp.Sexp -> Maybe ExpQ
+unquote (Unquote x) =
+  Just [| stripLocation . toSexp $ $(varE (mkName (T.unpack x))) |]
+unquote _ = Nothing
+
+_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
@@ -287,10 +380,10 @@ 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 [|Fix|] (lift1 inner)
+  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) = [|Compose $(liftLift (liftLift l) fga)|]
+  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)|]
@@ -304,7 +397,7 @@ instance Lift1 SL.SexpF where
     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)|]
+    SL.ModifiedF p e -> [|SL.ModifiedF $(lift p) $(l e)|]
 
 -- deriving instance Lift a => Lift (SL.SexpF a)
 deriving instance Lift SL.Atom
@@ -314,17 +407,37 @@ 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)
 
-makeSx :: Data a => SexpGrammar a -> QuasiQuoter
-makeSx g = QuasiQuoter
+makeSxs :: Data r => Code Q (List Sexp -> r) -> QuasiQuoter
+makeSxs f = QuasiQuoter
   { quoteExp = \str -> do
       pos <- getPos
-      case parseSexpWithPos g pos (T.pack str) of
+      case readSexpsWithPos pos (T.pack str) of
         Left e -> fail e
-        Right x -> dataToExpQ (const Nothing `extQ` metaSexp) x
+        Right xs -> [| $(unTypeCode f) $e |]
+          where
+            e = dataToExpQ
+              (const Nothing `extQ` metaSexp `extQ` metaSexps)
+              xs
   , quotePat = undefined
   , quoteType = undefined
   , quoteDec = undefined
   }
 
-sxs = makeSxs (sexpIso @Sexp) id
-sx = makeSx (sexpIso @Sexp)
+makeSx :: Data r => Code Q (Sexp -> r) -> QuasiQuoter
+makeSx f = QuasiQuoter
+  { quoteExp = \str -> do
+      pos <- getPos
+      case readSexpWithPos pos (T.pack str) of
+        Left e -> fail e
+        Right x -> [| $(unTypeCode f) $e |]
+          where
+            e = dataToExpQ
+              (const Nothing `extQ` metaSexp `extQ` metaSexps)
+              x
+  , quotePat = undefined
+  , quoteType = undefined
+  , quoteDec = undefined
+  }
+
+sxs = makeSxs [||id||]
+sx = makeSx [||id||]

src/Gyehoek/Wasm.hs

@@ -10,8 +10,28 @@
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE ImpredicativeTypes #-}
 {-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
 module Gyehoek.Wasm
-  ( Module
+  (
+    -- * syntax
+    Module
+  , Idx
+  , Expr
+    -- ** quasiquoters
+  , expr
+  , Gyehoek.Sexp.sx
+  , Gyehoek.Sexp.sxs
+  -- * GenMod effect
+  , GenMod
+  , runGenMod
+  , execGenMod
+  , defineFunction
+  , defineType
+  , defineGlobal
+  , emit
+  , renderModule
+  , wat
+  , wats
   )
   where
 
@@ -30,9 +50,9 @@ import Effectful.Dispatch.Dynamic
 import Effectful.State.Dynamic
 import Control.Lens
 import Data.Generics.Labels
-import Data.Vector (Vector)
+import Data.Vector.Strict (Vector)
 import Data.String.Interpolate
-import qualified Data.Vector as V
+import qualified Data.Vector.Strict as V
 import qualified Data.Text as T
 import Effectful.Writer.Dynamic
 import Control.Applicative (Alternative((<|>)))
@@ -45,18 +65,32 @@ 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)
+import Gyehoek.Sexp (sx)
+import qualified Language.Sexp as SL
+import Data.Foldable (traverse_)
 
 
 newtype Module = MkModule { inner :: Vector Sexp }
   deriving (Show, Generic)
   deriving newtype (Semigroup, Monoid)
 
-newtype Expr = MkExpr { inner :: Vector Sexp }
-  deriving (Show, Generic)
+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)
+  deriving (Generic, Data)
   deriving newtype (Show)
 
 
@@ -68,9 +102,103 @@ 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
+
+defineType :: GenMod :> es => Sexp -> Eff es Idx
+defineType = send . DefineType
+
+defineGlobal :: GenMod :> es => Sexp -> Eff es Idx
+defineGlobal = 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.wat

@@ -1,69 +1,61 @@
 (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)))
+  (import
+    "gyehoek"
+    "write"
+    (func $gh-write (param (ref eq))))
+  (import
+    "gyehoek"
+    "to-bool"
+    (func $gh-to-bool (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))))
+  (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
+    $scm-entry
+    (param i32)
+    (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
+    (i32.const 3)
+    ref.i31
+    (call $gh-to-bool)
+    (if
+      (then
+        (global.get $arg-array)
+        (global.get 0)
+        (i32.const 777)
+        (i32.const 1)
+        i32.shl
+        ref.i31
+        (array.set $arg-array-type)
+        (return_call $halt (i32.const 1)))
+      (else
+        (global.get $arg-array)
+        (global.get 0)
+        (i32.const 555)
+        (i32.const 1)
+        i32.shl
+        ref.i31
+        (array.set $arg-array-type)
+        (return_call $halt (i32.const 1)))))
+  (func
+    (export "main")
+    (call $scm-entry (i32.const 0))
+    (call $gh-write (ref.as_non_null (global.get $result)))))

test/Main.hs

@@ -10,11 +10,13 @@ import Data.List (List)
 import Data.Functor ((<&>))
 import System.Directory
 import Data.Function
+import System.Environment.Blank (getEnvDefault)
 
 
 disabled :: List String
 disabled =
   [ "square"
+  , "lambda"
   ]
 
 main :: IO ()
@@ -26,8 +28,8 @@ goldenTests = do
   let tests = all_cases
             & filter (`notElem` disabled)
             & fmap ("golden"</>)
-  pure $ testGroup "golden"
-    [ watTests tests
+  testGroup "golden" <$> sequenceA
+    [ pure $ watTests tests
     , executionTests tests
     ]
 
@@ -43,15 +45,17 @@ watTests files =
       (Driver.lower_e2e source)
       id
 
-executionTests :: List FilePath -> TestTree
-executionTests files =
-  testGroup "execution" $ files <&> \test ->
+executionTests :: List FilePath -> IO TestTree
+executionTests files = do
+  cmd <- getEnvDefault "GYEHOEK_RUNTIME"
+    "runtime/target/debug/gyehoek-runtime"
+  pure $ testGroup "execution" $ files <&> \test ->
     let wat = test </> "out.wat"
         testname = takeFileName test
         resultfile = test </> "exec"
     in goldenVsProg
        testname
        resultfile
-       "wasmtime"
-       ["--invoke", "main", wat]
-       ""
+       cmd
+       [wat]
+       "" -- stdin