idk

.dir-locals.el

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

doc/data-model.org

@@ -15,9 +15,3 @@ 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 |

doc/index.org

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

flake.lock

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

flake.nix

@@ -7,7 +7,6 @@
       url = "git+https://git.deertopia.net/msyds/sydpkgs";
       inputs.nixpkgs.follows = "nixpkgs";
     };
-    crane.url = "github:ipetkov/crane";
   };
 
   outputs = { self, nixpkgs, sydpkgs, haskellNix, ... }@inputs:
@@ -17,13 +16,13 @@
         "x86_64-darwin" "x86_64-linux"
       ];
 
+
       overlays = [
         haskellNix.overlay
         (final: prev: {
-          shake-wrapper = final.callPackage ./shake-wrapper.nix {};
-          gyehoek-runtime = final.callPackage ./runtime {
-            crane-lib = inputs.crane.mkLib final;
-          };
+          gyehoek-wasmtime-wrapper = final.callPackage ./wasmtime.nix {};
+        })
+        (final: prev: {
           gyehoek = final.haskell-nix.project' {
             src = ./.;
             compiler-nix-name = "ghc912";
@@ -31,32 +30,32 @@
               packages.gyehoek.components.tests.test.preCheck =
                 let
                   bin = [
-                    pkgs.git # tasty uses git diff
+                    pkgs.gyehoek-wasmtime-wrapper
+                    pkgs.git
                   ];
                 in ''
-                  export GYEHOEK_RUNTIME=${lib.getExe final.gyehoek-runtime}
+                  # 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 = [
-                final.gyehoek-runtime
-              ];
+              inputsFrom = [];
               tools = {
                 cabal = {};
                 haskell-language-server = {};
               };
               buildInputs = with final; [
                 haskellPackages.cabal-fmt
-                shake-wrapper
-                wabt
-                nodejs
-                wasm-tools
-                wac-cli
-                guile
-                rust-analyzer
-                wasmtime
+                self.packages.${final.stdenv.hostPlatform.system}.shake
+                final.wabt
+                final.nodejs
+                final.wasm-tools
+                final.wac-cli
+                final.guile
+                final.gyehoek-wasmtime-wrapper
               ];
             };
           };
@@ -88,7 +87,7 @@
         hf.packages.${system} // lib.fix (packages: {
           gyehoek = hf.packages.${system}."gyehoek:exe:gyehoek";
           default = packages.gyehoek;
-          inherit (pkgs) gyehoek-runtime shake-wrapper;
+          shake = pkgs.callPackage ./shake-wrapper.nix {};
         }));
 
       devShells = each-system

golden/apply-twice/source.scm

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

golden/arith/exec

@@ -1,2 +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/false/exec

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

golden/false/source.scm

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

golden/fn-of-fn/exec

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

golden/fn-of-fn/source.scm

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

golden/if-false/exec

@@ -1,2 +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-number/exec

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

golden/if-number/source.scm

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

golden/if-true/exec

@@ -1,2 +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/lambda/exec

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

golden/square/exec

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

golden/true/exec

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

golden/true/source.scm

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

gyehoek.cabal

@@ -25,11 +25,6 @@ common ghcstuffs
   default-extensions:
     BlockArguments
     DeriveGeneric
-    DerivingVia
-    DuplicateRecordFields
-    NoFieldSelectors
-    OrPatterns
-    OverloadedLabels
     OverloadedRecordDot
     OverloadedStrings
     PartialTypeSignatures
@@ -39,8 +34,9 @@ common ghcstuffs
 executable gyehoek
   import:           ghcstuffs, ghcstuffs-dev
   main-is:          Main.hs
+
   build-depends:
-    , base     ^>=4.21.2.0
+    , base                  ^>=4.21.2.0
     , gyehoek
 
   hs-source-dirs:   app
@@ -48,25 +44,25 @@ executable gyehoek
 
 library
   import:           ghcstuffs, ghcstuffs-dev
-  ghc-options:      -fplugin=Effectful.Plugin
+  ghc-options: -fplugin=Effectful.Plugin
 
   -- cabal-fmt: expand src
   exposed-modules:
     Gyehoek.CPS.Convert
     Gyehoek.CPS.Lower
     Gyehoek.CPS.Syntax
-    Gyehoek.Driver
     Gyehoek.GenSym
     Gyehoek.Options
     Gyehoek.Scheme.Syntax
     Gyehoek.Sexp
     Gyehoek.Wasm
+    Gyehoek.Driver
 
   build-depends:
     , base                  ^>=4.21.2.0
     , binary
     , containers
-    , typed-process
+    , cradle
     , effectful
     , effectful-core
     , effectful-plugin
@@ -78,41 +74,30 @@ library
     , megaparsec
     , mtl
     , optparse-applicative
-    , pretty-simple
     , prettyprinter
     , process
     , recursion-schemes
     , sexp-grammar
-    , string-interpolate
     , template-haskell
     , text
     , text-short
     , unordered-containers
     , vector
-    , bytestring
+    , string-interpolate
+    , pretty-simple
 
   hs-source-dirs:   src
   default-language: GHC2024
 
 test-suite test
-  import:           ghcstuffs, ghcstuffs-dev
-  type:             exitcode-stdio-1.0
-  hs-source-dirs:   test
-  main-is:          Main.hs
-  other-modules:
-    Gyehoek.Test.CPS.Syntax
-    Gyehoek.Test.Golden
-    Gyehoek.Test.Sexp
-
-  build-depends:
-    , base
-    , directory
-    , filepath
-    , gyehoek
-    , process-extras
-    , sexp-grammar
-    , tasty
-    , tasty-hunit
-    , tasty-silver
-
-  default-language: GHC2024
+    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>

runtime/.gitignore

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

runtime/Cargo.toml

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

runtime/default.nix

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

runtime/src/gyehoek.rs

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

runtime/src/internal.rs

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

runtime/src/main.rs

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

runtime/src/types.rs

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

src/Gyehoek/CPS/Convert.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE OverloadedLists #-}
-{- HLINT ignore "Use camelCase" -}
 module Gyehoek.CPS.Convert
-  ( convertProgram
+  ( convert
+  , convertProgram
   ) where
 
 import Gyehoek.CPS.Syntax
@@ -12,7 +12,6 @@ import Effectful
 import Control.Monad.Cont qualified as Cont
 import Control.Lens
 import qualified Data.List.NonEmpty as NE
-import qualified Gyehoek.Sexp
 
 
 -- 뻘짓이어라
@@ -22,14 +21,6 @@ telescope
   -> t a -> (t b -> r) -> r
 telescope f = Cont.runCont . traverse (Cont.cont . f)
 
-
-
-pattern Atomic e <-
-  e@( Scm.ExpLambda _ _
-  ; Scm.ExpVar _
-  ; Scm.ExpLit _ )
-
--- | Transform an expression with a meta-continuation.
 convert
   :: forall es. (GenSym :> es)
   => Scm.Exp -> (Val -> Eff es Exp) -> Eff es Exp
@@ -40,24 +31,21 @@ convert (Scm.ExpLit l) k = k $ ValLit l
 convert (Scm.ExpPrim p) k =
   telescope (convert @es) p \p' -> do
     r <- gensym' "r"
-    ExpPrim p' . MkKappa [r] <$> k (ValVar r)
+    ExpPrim p' [r] <$> k (ValVar r)
 
 convert (Scm.ExpLambda xs e) k = do
   f <- gensym' "λ-body"
   ktail <- gensym' "λ-tail"
-  m <- convert e $ \e' -> pure $ ExpContinue ktail [e']
-  ke <- k $ ValVar f
-  pure [cps|
-    (letrec ((#{f} (λ (##{xs} #{ktail}) #{m})))
-      #{ke})
-  |]
+  m <- convert e $ \e' ->
+    pure $ ExpContinue ktail [e']
+  ExpLet [(f, MkLambda xs ktail m)] <$> k (ValVar f)
 
 convert (Scm.ExpApply f xs) k =
   telescope (convert @es) (f:|xs) \(f':|xs') -> do
     r <- gensym' "r"
     x <- gensym' "x"
     m <- k (ValVar x)
-    pure $ ExpLetRec [(r, AbsKappa' [x] m)] $ ExpApply f' xs' r
+    pure $ ExpFix [(r, MkKappa [x] m)] $ ExpApply f' (xs' ++ [ValVar r])
 
 convert (Scm.ExpBegin xs) k = _
 

src/Gyehoek/CPS/Lower.hs

@@ -6,33 +6,40 @@
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE ApplicativeDo #-}
 {-# OPTIONS_GHC -Wno-incomplete-patterns #-}
-{-# LANGUAGE RecursiveDo #-}
-{- HLINT ignore "Use camelCase" -}
 module Gyehoek.CPS.Lower
   (lower, lowerProgram) where
 
 import Gyehoek.CPS.Syntax
-import Data.Generics.Labels ()
+import 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 hiding (op)
+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 Control.Monad.Fix
-import qualified Gyehoek.Sexp
-import Data.Text qualified as T
-import Data.Foldable (fold)
-import Gyehoek.Sexp (encodeOrShow, toSexp)
+import Language.Sexp.Located (pattern ParenList)
 import Debug.Pretty.Simple
+import Control.Monad.Fix
 
 
 data Env = MkEnv
-  { vars :: Vector Name
+  { runtime :: Runtime
+  , vars :: Vector Name
   , kvars :: Vector Name
   }
   deriving (Show, Generic)
@@ -43,308 +50,201 @@ 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)
 
-tonat :: Integral a => a -> Natural
-tonat = fromIntegral
+
 
 -- | @makeSmallFixnum@ emits an expression injecting the i32 on top
 -- of the stack into the SCM unitype.
 makeSmallFixnum :: Wasm.Expr
-makeSmallFixnum = [expr|
-    (@gyehoek "construct small fixnum")
-    (i32.const 1)
-    i32.shl
-    ref.i31
-  |]
+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 :: Natural -> Wasm.Expr -> Wasm.Expr
-pushArg n e = [expr|
-    (@gyehoek "push argument")
-    (global.get $arg-array)
-    (i32.const #{n})
-    ##{e}
-    (array.set $arg-array-type)
-  |]
+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 :: Int -> Wasm.Expr
-popArg n = [expr|
-  (@gyehoek "pop argument")
-  (global.get $arg-array)
-  (i32.const #{n})
-  (array.get $arg-array-type)
-  ref.as_non_null
-|]
+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 :: GenMod :> es => Env -> Val -> Eff es Wasm.Expr
+lowerVal :: Env -> Val -> Wasm.Expr
 
 lowerVal g (ValLit l) =
-  pure $ case l of
-    LitInt n -> [expr|
-      (i32.const #{n})
-      ##{makeSmallFixnum}
-    |]
-    LitBool b -> [expr|
-      (i32.const #{b'})
-      ref.i31
-    |]
-      where b' :: Int = if b then 0b11 else 0b01
+  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) = pure $ [expr|(local.get #{l})|]
+lowerVal g (ValVar x) = ins "local.get" [sxp (1+l)]
   where
-    l = succ $ V.elemIndex x g.vars ^?! _Just
-
--- lowerVal g (ValLambda lam) = do
---   idx <- lowerLambda g lam
---   pure [expr|
---     (i32.const 0)
---     (ref.func #{idx})
---     (struct.new $closure)
---   |]
+    l = V.elemIndex x g.vars ^?! _Just
 
 lower' :: (GenMod :> es) => Env -> Exp -> Eff es Wasm.Expr
 
-lower' g (Halt [v]) = do
-  arg <- pushArg 0 <$> lowerVal g v
-  pure [expr|
-    ##{arg}
-    (return_call $halt (i32.const 1))
-  |]
+lower' g (Halt [v]) = pure . mconcat $
+  [ pushArg g.runtime 0 (lowerVal g v)
+  , ins "return_call" [sxp @Int 1]
+  ]
 
-lower' g e@(ExpPrim p k) =
-  ([expr|(@gyehoek :origin #{origin})|]<>)
-  <$> case p of
-    PrimAdd x y -> lowerBinOp "i32.add" g x y k
-    PrimMul x y -> lowerBinOp "i32.mul" g x y k
-  where origin = encodeOrShow @_ @Text e
+lower' g (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
-  c' <- lowerVal g c
   t' <- lower' g t
   f' <- lower' g f
-  pure [expr|
-    ##{c'}
-    (call $gh-truthy?)
-    (if (then ##{t'})
-        (else ##{f'}))
-  |]
+  pure $ lowerVal g c
+    <> Wasm.if' (Wasm.result [i32]) t' f'
 
-lower' g (ExpLetRec [(r,AbsKappa kap)] e) = do
-  idx <- lowerKappa g kap
-  let g' = g & #kvars <>~ [r]
-  e' <- lower' g' e
-  let origin = encodeOrShow @_ @Text e
-  pure [expr|
-    (@gyehoek :origin #{origin})
-    (@gyehoek "push cont" :idx #{idx})
-    (array.set $cont-stack-type
-               (global.get $cont-stack)
-               (global.get $cont-stack-top)
-               (ref.func #{idx}))
-    (global.set $cont-stack-top
-                (i32.add (global.get $cont-stack-top)
-                         (i32.const 1)))
-    ##{e'}
-  |]
-
-lower' g (ExpLetRec [(r,AbsLambda lam)] e) = do
-  idx <- lowerLambda g lam
-  let g' = g & #vars <>~ [r]
-  let n = succ $ length g.vars
-  e' <- lower' g' e
-  pure [expr|
-    (i32.const 0)
-    (ref.func #{idx})
-    (struct.new $closure)
-    (local.set #{n})
-    ##{e'}
-  |]
-
-lower' g e@(ExpApply f xs ktail) = do
-  let nargs = length xs
-  f' <- lowerVal g f
-  let l = succ $ V.elemIndex ktail g.kvars ^?! _Just
-  args <- fold <$>
-    itraverse (\i -> fmap (pushArg $ tonat i) . lowerVal g) xs
-  let origin = encodeOrShow @_ @Text e
-  pure [expr|
-    (@gyehoek :origin #{origin})
-    (@gyehoek "load args")
-    ##{args}
-    (i32.const 1)
-    ##{f'}
-    (ref.cast (ref $closure))
-    (struct.get $closure $code)
-    (return_call_ref $cont-type)
-    (@gyehoek todo
-     (f' ##{f'})
-     (ktail #{l}))
-  |]
-
-lower' g e@(ExpContinue k xs) = do
-  let nargs = length xs
-  args <- fold <$>
-    itraverse (\i -> fmap (pushArg $ tonat i) . lowerVal g) xs
-  let origin = encodeOrShow @_ @Text e
-  pure [expr|
-    (@gyehoek :origin #{origin})
-    (@gyehoek "push args")
-    ##{args}
-    (@gyehoek "nargs")
-    (i32.const #{nargs})
-    (@gyehoek "pop cont stack")
-    (global.get $cont-stack-top)
-    (i32.const #{l})
-    i32.sub
-    (global.set $cont-stack-top)
-    (global.get $cont-stack)
-    (global.get $cont-stack-top)
-    (array.get $cont-stack-type)
-    ref.as_non_null
-    (return_call_ref $cont-type)
-  |]
+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
-    l = succ $ V.elemIndex k g.kvars ^?! _Just
+    rt = g.runtime
+    l = V.elemIndex k g.kvars ^?! _Just
 
-lower' g e = error $ case Gyehoek.Sexp.encode e of
-  Left _ -> show e
-  Right x -> T.unpack x
+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'
+    ]
 
-lowerKappa :: GenMod :> es => Env -> Kappa -> Eff es Idx
-lowerKappa g e@(MkKappa xs m) = do
-  let g' = g & #vars .~ V.fromList xs
-  m' <- lower' g' m
-  let body = mconcat
-        [ xs & ifoldMap \n _ ->
-            let n' = succ n
-            in popArg n <> [expr|(local.set #{n'})|]
-        , m'
-        ]
-  let origin = encodeOrShow @_ @Text e
-  idx <- Wasm.defineFunction [wat|
-    (func (param i32)
-      (@gyehoek :origin #{origin})
-      (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-      ##{body})
-  |]
-  Wasm.emit [wats|(elem declare funcref (ref.func #{idx}))|]
-  pure idx
-
-lowerLambda :: GenMod :> es => Env -> Lambda -> Eff es Idx
-lowerLambda g e@(MkLambda xs ktail m) = do
-  let g' = g & #vars .~ V.fromList xs
-             & #kvars <>~ [ktail]
-  m' <- lower' g' m
-  let body = mconcat
-        [ xs & ifoldMap \n _ ->
-            let n' = succ n
-            in popArg n <> [expr|(local.set #{n'})|]
-        , m'
-        ]
-  let origin = encodeOrShow @_ @Text e
-  idx <- Wasm.defineFunction [wat|
-    (func (param i32)
-      (@gyehoek :origin #{origin})
-      (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-      ##{body})
-  |]
-  Wasm.emit [wats|(elem declare funcref (ref.func #{idx}))|]
-  pure idx
+lower' g e = error . show $ e
 
 lowerBinOp
   :: (GenMod :> es)
-  => Text -> Env -> Val -> Val -> Kappa -> Eff es Wasm.Expr
-lowerBinOp op g x y (MkKappa [r] e) = do
-  let op' = SL.Symbol op
-  let g' = g & #vars <>~ [r]
-  let n = succ $ length (g ^. #vars)
-  x' <- lowerVal g x
-  y' <- lowerVal g y
+  => Text -> Env -> Val -> Val -> Name -> Exp -> Eff es Wasm.Expr
+lowerBinOp op g x y r e = do
   e' <- lower' g' e
-  pure [expr|
-    ##{x'}
-    (i31.get_s (ref.cast (ref i31)))
-    (i32.const 1)
-    i32.shr_u
-    ##{y'}
-    (i31.get_s (ref.cast (ref i31)))
-    (i32.const 1)
-    i32.shr_u
-    #{op'}
-    ##{makeSmallFixnum}
-    (local.set #{n})
-    ##{e'}
-  |]
+  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)
 
 
 
-emitRuntime :: GenMod :> es => Eff es ()
+scm = ref eq
+
+
+
+emitRuntime :: GenMod :> es => Eff es Runtime
 emitRuntime = mfix \runtime -> do
-  Wasm.defineFunctions [wats|
-    (import "gyehoek" "write" (func $gh-write (param (ref eq))))
-    (import "gyehoek" "truthy?" (func $gh-truthy? (param (ref eq))
-                                  (result i32)))
-  |]
+  heapObjectIdx <- Wasm.deftypeNamed "$heap-object" $ Wasm.sub [] $ Wasm.struct
+    [ Wasm.mut i32 ]
   -- cont stack
-  Wasm.defineTypes [wats|
-    (type $heap-object (sub (struct (field $hash (mut i32)))))
-    (type $cont-type (func (param i32)))
-    (type $cont-stack-type (array (mut (ref null $cont-type))))
-    (type $closure (sub $heap-object
-                        (struct (field $hash (mut i32))
-                                (field $code (ref $cont-type)))))
-  |]
-  Wasm.defineGlobals [wats|
-    (global $cont-stack-top (mut i32) (i32.const 0))
-    (global $cont-stack (ref $cont-stack-type)
-            (array.new_default $cont-stack-type (i32.const 128)))
-  |]
+  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
-  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 ()
+  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 mempty mempty
-  e' <- lower' g e
-  let origin = encodeOrShow @_ @Text e
-  Wasm.defineFunction [wat|
-    (func $scm-entry (param i32)
-      (@gyehoek :origin #{origin})
-      (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-      ##{e'})
-  |]
-  Wasm.defineFunction [wat|
-    (func (export "main")
-      (call $scm-entry (i32.const 0))
-      (call $gh-write (ref.as_non_null (global.get $result))))
-  |]
-  
+  let g = MkEnv runtime mempty mempty
+  scm_entry <- Wasm.defun [i32] [] (replicate 5 scm) \_ ->
+    lower' g e
+  main <- Wasm.defun [] [scm] [scm, scm, scm, scm, scm] \_ ->
+    pure . mconcat $
+      -- push return cont
+      [--  ins "ref.func" [sxp halt]
+      -- make call
+      ins "i32.const" [sxp @Int 0]
+      , ins "call" [sxp scm_entry]
+      , ins "global.get" [sxp runtime.result]
+      , ins "ref.as_non_null" []
+      ]
+  Wasm.export "main" "func" main
+
 lowerProgram :: Program -> Eff es Text
 lowerProgram (MkProgram e) = lower e

src/Gyehoek/CPS/Syntax.hs

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

src/Gyehoek/Driver.hs

@@ -1,33 +1,44 @@
+{-# 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)
+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 System.IO qualified as IO
+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 (pShowNoColor)
-import System.Process.Typed
-import Data.Text.Encoding (encodeUtf8)
-import System.Environment.Blank (getEnvDefault)
-import GHC.Conc (atomically)
-import qualified Data.Text.IO as TIO
-import qualified Data.ByteString.Lazy as BS
+import Text.Pretty.Simple (pShow, pShowNoColor)
 
 
 main :: IO ()
@@ -37,8 +48,8 @@ main = do
 
 
 
--- hPutStr :: FileSystem :> es => Handle -> Text -> Eff es ()
--- hPutStr h = FB.hPutStr h . T.encodeUtf8
+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
@@ -46,8 +57,8 @@ 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
+readFile :: FileSystem :> es => FilePath -> Eff es Text
+readFile f = FS.withFile f FS.ReadMode hGetContents
 
 withFile
   :: (FileSystem :> es)
@@ -56,41 +67,12 @@ withFile "-" FS.ReadMode k = k FS.stdin
 withFile "-" (FS.WriteMode; FS.AppendMode) k = k FS.stdout
 withFile f m k = FS.withFile f m k
 
-fileName :: FilePath -> FilePath
-fileName "-" = "<interactive>"
-fileName e = e
-
 readScm :: FileSystem :> es => FilePath -> Eff es Scm.Program
 readScm f =
   withFile f FS.ReadMode $ \h ->
-    Sexp.parseSexps @Scm.CommandOrDef (fileName f) <$> hGetContents h
+    Sexp.parseSexps @Scm.CommandOrDef f <$> hGetContents h
      >>= either error (pure . Scm.MkProgram)
 
-inspectWasm :: IOE :> es => Text -> Eff es ()
-inspectWasm wat = do
-  pager_cmd <- liftIO $ getEnvDefault "PAGER" "less"
-  let wasmtools_cfg
-        = proc "wasm-tools" ["print", "-pf", "--print-operand-stack"
-                            ,"--color", "always", "-"]
-          -- & setStdin (byteStringInput . view lazy . encodeUtf8 $ wat)
-          -- & setStdout byteStringOutput
-          & setStdin createPipe
-          & setStdout createPipe
-          & setStderr inherit
-  let pager_cfg = proc pager_cmd []
-                & setStdin createPipe
-                & setStdout inherit
-                & setStderr inherit
-  liftIO $ withProcessWait_ wasmtools_cfg \wasmtools -> do
-    TIO.hPutStrLn (getStdin wasmtools) wat
-    IO.hFlush (getStdin wasmtools)
-    IO.hClose (getStdin wasmtools)
-    withProcessWait_ pager_cfg \pager -> do
-      t <- BS.hGetContents (getStdout wasmtools)
-      BS.hPut (getStdin pager) t
-      IO.hFlush (getStdin pager)
-      IO.hClose (getStdin pager)
-
 driver
   :: (GenSym :> es, FileSystem :> es, IOE :> es)
   => Options -> Eff es ()
@@ -102,11 +84,8 @@ driver opts = do
   when opts.dumpCPS do
     hPutStrLn FS.stdout $ Sexp.encodePretty cps ^?! _Right
   wat <- lowerProgram cps
-  if not opts.inspectWasm then
-    withFile opts.output FS.WriteMode \h ->
-      hPutStrLn h wat
-  else
-    inspectWasm wat
+  withFile opts.output FS.WriteMode \h ->
+    hPutStrLn h wat
 
 parse_e2e :: FilePath -> IO Scm.Program
 parse_e2e = runEff . runFileSystem . readScm

src/Gyehoek/Options.hs

@@ -19,7 +19,6 @@ data Options = MkOptions
   -- , dumpQBE :: Maybe FilePath
   dumpCPS :: Bool
   , dumpParsed :: Bool
-  , inspectWasm :: Bool
   , output :: FilePath
   , sourceFile :: FilePath
   }
@@ -50,12 +49,10 @@ parseOutput = strOption
 
 parseDumpCPS = switch (long "dump-cps")
 parseDumpParsed = switch (long "dump-parsed")
-parseInspectWasm = switch $ long "inspect-wasm" <> short 'p'
 
 parser :: Parser Options
 parser = MkOptions
   <$> parseDumpCPS
   <*> parseDumpParsed
-  <*> parseInspectWasm
   <*> parseOutput
   <*> argument str (metavar "FILE")

src/Gyehoek/Scheme/Syntax.hs

@@ -1,9 +1,7 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE OverloadedLabels #-}
-{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE OrPatterns #-}
@@ -19,44 +17,31 @@ module Gyehoek.Scheme.Syntax
   , CommandOrDef(..)
   , primSexpIso
   , pattern Void
-  , free
-  , subst
-  , getName
-  , scm
   )
   where
 
 import Data.Text (Text)
 import Data.List (List)
 import Language.SexpGrammar
-  ( SexpIso(..), list, el, rest, sym, symbol )
+  ( SexpIso(..), list, el, (>>>), rest, sym, symbol )
 import Language.SexpGrammar qualified as Sexp
 import Language.Sexp.Located qualified as S
 import Language.SexpGrammar.Generic
 import GHC.Generics
 import Prelude hiding ((.), id)
 import Control.Category
-import Data.List.NonEmpty (NonEmpty)
+import Data.List.NonEmpty (NonEmpty ((:|)))
 import Gyehoek.Sexp qualified
 import Gyehoek.GenSym (Gen)
 import Control.Lens
 import Data.String (IsString)
 import Data.Hashable (Hashable)
-import Data.Data (Data)
-import Data.Functor.Foldable.TH (makeBaseFunctor)
-import Data.Functor.Foldable hiding (fold)
-import Data.HashSet (HashSet)
-import qualified Data.HashSet as HS
-import Data.Foldable (fold)
-import Language.Haskell.TH.Quote (QuasiQuoter)
+import Control.Lens.Unsound (prismSum)
 
 
-newtype Name = MkName { inner :: Text }
-  deriving newtype (Show, Eq, Ord, IsString, Gen, Hashable)
-  deriving stock (Generic, Data)
-
-getName :: Name -> Text
-getName (MkName x) = x
+newtype Name = MkName { getName :: Text }
+  deriving newtype (Show, Eq, IsString, Gen, Hashable)
+  deriving stock (Generic)
 
 data Prim e
   = PrimAdd e e
@@ -72,7 +57,7 @@ data Prim e
   | PrimWrite e
   | PrimZeroP e
   | PrimNewline
-  deriving (Show, Generic, Functor, Foldable, Traversable, Data, Eq)
+  deriving (Show, Generic, Functor, Foldable, Traversable)
 
 instance Each (Prim e) (Prim e') e e'
 
@@ -82,7 +67,7 @@ data Lit
   | LitBool Bool
   | LitString Text
   | LitQuote Sexp
-  deriving (Show, Generic, Data, Eq)
+  deriving (Show, Generic)
 
 pattern Void :: Lit
 pattern Void = LitNil
@@ -90,7 +75,7 @@ pattern Void = LitNil
 data Def
   = DefConstant Name Exp
   | DefProcedure Name (List Name) (List Exp)
-  deriving (Show, Generic, Data)
+  deriving (Show, Generic)
 
 data Exp
   = ExpLet (NonEmpty (Name, Exp)) Exp
@@ -101,36 +86,36 @@ data Exp
   | ExpLambda (List Name) Exp
   | ExpVar Name
   | ExpApply Exp (List Exp)
-  deriving (Show, Generic, Data)
+  deriving (Show, Generic)
 
 data Sexp
   = SexpCons Sexp Sexp
   | SexpSymbol Text
   | SexpLit Lit
-  deriving (Show, Generic, Data, Eq)
+  deriving (Show, Generic)
 
 data CommandOrDef
   = Command Exp
   | Definition Def
   | Begin (List CommandOrDef)
-  deriving (Show, Generic, Data)
+  deriving (Show, Generic)
 
 data Program = MkProgram
   { commandsAndDefs :: List CommandOrDef
   }
-  deriving (Show, Generic, Data)
+  deriving (Show, Generic)
 
 instance Each Program Program (Either Exp Def) (Either Exp Def) where
   each = #commandsAndDefs . each . go
     where
       inj = either Command Definition
+      toeither (Command e) = Left e
+      toeither (Definition d) = Right d
       go :: Traversal' CommandOrDef (Either Exp Def)
       go k (Command e) = inj <$> k (Left e)
       go k (Definition d) = inj <$> k (Right d)
       go k (Begin xs) = Begin <$> traverse (go k) xs
 
-makeBaseFunctor ''Exp
-
 
 
 instance SexpIso Name where
@@ -185,7 +170,7 @@ instance SexpIso Lit where
 
 instance SexpIso Sexp where
   sexpIso = match
-    $ With (\conss -> conss . Gyehoek.Sexp.todo)
+    $ With (\cons -> cons . Gyehoek.Sexp.todo)
     $ With (\s -> s . symbol)
     $ With (\lit -> lit . sexpIso)
     $ End
@@ -226,31 +211,3 @@ instance SexpIso CommandOrDef where
     $ End
     where
       bgn = list $ el (sym "begin") >>> rest sexpIso
-
-
--- utilities
-
-scm :: QuasiQuoter
-scm = Gyehoek.Sexp.makeSx [|| Gyehoek.Sexp.fromSexp @Exp ||]
-
-free :: Exp -> HashSet Name
-free = cata \case
-  ExpVarF x -> HS.singleton x
-  ExpLetF bs e -> error "todo lol"
-  ExpLambdaF binders vs -> deleteFrom binders vs
-  e -> fold e
-
-deleteFrom :: (Foldable f, Hashable a) => f a -> HashSet a -> HashSet a
-deleteFrom = flip $ foldr HS.delete
-
-insertFrom :: (Foldable f, Hashable a) => f a -> HashSet a -> HashSet a
-insertFrom = flip $ foldr HS.insert
-
-subst :: (Name -> Maybe Exp) -> Exp -> Exp
-subst f = \e -> cata go e mempty where
-  go (ExpVarF x) bound
-    | not (x `HS.member` bound), Just e' <- f x = e'
-    | otherwise                         = ExpVar x
-  go (ExpLetF _ _) _ = error "todo lol"
-  go (ExpLambdaF bs e) bound = e $ insertFrom bs bound
-  go e bound = embed $ fmap ($ bound) e

src/Gyehoek/Sexp.hs

@@ -4,8 +4,6 @@
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TemplateHaskellQuotes #-}
-{-# LANGUAGE OrPatterns #-}
 module Gyehoek.Sexp
   ( let_
   , sexp
@@ -27,26 +25,11 @@ module Gyehoek.Sexp
   , encodePretty
   , UglySexpIso(..)
   , AsSexpIso(..)
-  , SpliceSexp(..)
-  , parseSexpsWithPos
-  , parseSexpWithPos
-  , parseSexp
-  , sx
-  , sxs
-  , makeSx
-  , makeSxs
-  , makeSx'
-  , toSexp
-  , fromSexp
-  , stripLocation
-  , format
-  , equivalent
-  , encodeOrShow
   )
-  where
+where
 
 import Data.Text (Text)
-import Language.SexpGrammar as Sexp hiding (toSexp, List, encode, decode, encodeWith, decodeWith, iso, encodePrettyWith, encodePretty, fromSexp)
+import Language.SexpGrammar as Sexp hiding (List, encode, decode, encodeWith, decodeWith, iso, encodePrettyWith, encodePretty)
 import Language.SexpGrammar qualified as Sexp
 import Language.Sexp qualified as S
 import Language.SexpGrammar.Generic
@@ -54,39 +37,20 @@ 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.List (List)
 import Data.Text.Encoding
 import Data.Either (either)
 import GHC.Generics (Generic)
-import Control.Lens hiding (para)
+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 qualified Language.Sexp.Located as SexpLoc
 import Data.Void (absurd, Void)
 import Data.Coerce (coerce)
 import qualified Data.Map
-import Language.Haskell.TH.Quote
-import Language.Haskell.TH (Quote, location, Loc (..), ExpQ, varE, mkName, listE, Exp, appE, conE, Q, Code, unTypeCode)
-import qualified Data.Text as T
-import qualified Control.Category
-import Data.Data (Data (..), Typeable, cast)
-import Language.Haskell.TH.Syntax (lift, Lift, liftData)
-import GHC.IsList (fromList)
-import Data.Functor.Foldable (cata, para, embed)
-import Data.Functor.Classes (Show1(..))
-import Data.Vector (Vector)
-import Numeric.Natural (Natural)
-import Data.Maybe (fromMaybe)
-import Control.Applicative (Alternative((<|>)))
-import Debug.Pretty.Simple
-import qualified Data.Vector as V
-import qualified Data.Vector.Strict
-import Data.Function (on)
-import Data.String (IsString (fromString))
 
 
 sexp :: SexpIso a => Iso' a Text
@@ -94,9 +58,6 @@ 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
 
@@ -114,31 +75,11 @@ 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) (Sexp.fromSexp sexpIso)
-
-parseSexp :: SexpIso a => FilePath -> Text -> Either String a
-parseSexp f = marshal . SL.parseSexp f . view lazy . encodeUtf8
-  where marshal = join . traverseOf _Right (Sexp.fromSexp sexpIso)
-
-readSexpWithPos :: Position -> Text -> Either String Sexp
-readSexpWithPos pos = SL.parseSexpWithPos pos . view lazy . encodeUtf8
-
-readSexpsWithPos :: Position -> Text -> Either String (List Sexp)
-readSexpsWithPos pos = SL.parseSexpsWithPos pos . view lazy . encodeUtf8
-
-parseSexpsWithPos :: SexpGrammar a -> Position -> Text -> Either String (List a)
-parseSexpsWithPos g pos =
-  marshal . SL.parseSexpsWithPos pos . view lazy . encodeUtf8
-  where marshal = join . traverseOf (_Right . each) (Sexp.fromSexp g)
-
-parseSexpWithPos :: SexpGrammar a -> Position -> Text -> Either String a
-parseSexpWithPos g pos =
-  marshal . SL.parseSexpWithPos pos . view lazy . encodeUtf8
-  where marshal = join . traverseOf _Right (Sexp.fromSexp g)
+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
@@ -242,196 +183,3 @@ instance UglySexpIso Int where uglySexpIso = sexpIso
 instance UglySexpIso Bool where uglySexpIso = sexpIso
 instance UglySexpIso Double where uglySexpIso = sexpIso
 instance UglySexpIso () where uglySexpIso = sexpIso
-
-instance SexpIso Sexp where
-  sexpIso = Control.Category.id
-
--- evil ass orphan instances
-deriving instance (Data a, Data e) => Data (SL.LocatedBy a e)
-deriving instance Data SL.Atom
-deriving instance Data SL.Prefix
-deriving instance Data SL.Position
-deriving instance (Data e) => Data (SL.SexpF e)
-
-
--- Quasiquoter
-
-getPos = do
-  Loc {loc_filename,loc_start} <- location
-  pure $ SL.Position loc_filename (fst loc_start) (snd loc_start)
-
-fromSexp :: SexpIso a => Sexp -> a
-fromSexp = either error id . Sexp.fromSexp sexpIso
-
-fromSexp' :: SexpGrammar a -> Sexp -> a
-fromSexp' g = either error id . Sexp.fromSexp g
-
-toSexp :: SexpIso a => a -> Sexp
-toSexp = either error id . Sexp.toSexp sexpIso
-
-toSexps :: (Foldable f, SexpIso a) => f a -> List Sexp
-toSexps = foldMap \x -> [toSexp x]
-
-pattern Unquote x =
-  SL.Modified Hash (SL.BraceList [SL.Symbol x])
-pattern UnquoteSplicing x =
-  SL.Modified Hash (SL.Modified Hash (SL.BraceList [SL.Symbol x]))
-
-_UnquoteSplicing :: Prism' Sexp.Sexp Text
-_UnquoteSplicing = prism'
-  UnquoteSplicing
-  (\case { UnquoteSplicing x -> Just x ; _ -> Nothing })
-
-instance Each Sexp Sexp Sexp Sexp where
-  each k (SL.ParenList xs)              = SL.ParenList <$> traverse k xs
-  each k (SL.BracketList xs)            = SL.BracketList <$> traverse k xs
-  each k (SL.BraceList xs)              = SL.BraceList <$> traverse k xs
-  each _ e@(SL.Atom _; SL.Modified _ _) = pure e
-
-stripLocation :: Sexp -> Sexp
-stripLocation = cata \case
-  SL.Compose (a SL.:< e) ->
-    SL.Fix . SL.Compose $ SL.dummyPos SL.:< e
-
--- | @('==')@ for 'Sexp's modulo source location — return true if the
--- two sexps are equal in all but 'Position' fields.
-equivalent :: Sexp -> Sexp -> Bool
-equivalent = (==) `on` stripLocation
-
-instance SexpIso Natural where
-  sexpIso = Sexp.integer >>> Sexp.partialOsi f g
-    where
-      f n | n < 0 = Left $ Sexp.unexpected "negative"
-                        <> Sexp.expected "natural"
-          | otherwise = Right $ fromIntegral n
-      g n = fromIntegral n
-
-class SpliceSexp a where
-  spliceSexp :: a -> List Sexp
-
-instance SexpIso a => SpliceSexp (Data.Vector.Strict.Vector a) where
-  spliceSexp = toSexps
-
-instance SexpIso a => SpliceSexp (Vector a) where
-  spliceSexp = toSexps
-
-instance SexpIso a => SpliceSexp (List a) where
-  spliceSexp = toSexps
-
-instance SpliceSexp Sexp where
-  spliceSexp = toListOf each
-
-unquoteSplicingRecursive :: List Sexp.Sexp -> ExpQ
-unquoteSplicingRecursive xs = [| mconcat $(spans) |]
-  where
-    spans = xs
-      & groupBy \cases
-          (UnquoteSplicing _) _ -> False
-          _ (UnquoteSplicing _) -> False
-          _ _                   -> True
-      & fmap \case
-        -- [e@(Unquote _)] ->
-        --   case unquote e of
-        --     Just x -> [| [$(x)] |]
-        --     Nothing -> error "unreachable"
-        [UnquoteSplicing x] ->
-          [| spliceSexp $(varE (mkName (T.unpack x))) |]
-        es -> listE $ unquoteRecursive <$> es
-      & listE
-
-unquoteRecursive :: Sexp.Sexp -> ExpQ
-unquoteRecursive = \case
-  Unquote x -> [| toSexp $(varE (mkName (T.unpack x))) |]
-  SL.ParenList xs -> [|SL.ParenList $(unquoteSplicingRecursive xs)|]
-  e -> liftData e
-
-_ParenList :: Prism' Sexp (List Sexp)
-_ParenList = prism' SL.ParenList \case
-  SL.ParenList xs -> Just xs
-  _ -> Nothing
-
-metaSexps :: List Sexp.Sexp -> Maybe ExpQ
-metaSexps = Just . unquoteSplicingRecursive
-
-metaSexp :: Sexp.Sexp -> Maybe ExpQ
-metaSexp = Just . unquoteRecursive
-
--- 뻘짓뻘짓뻘짓뻘짓뻘짓
-class Lift1 f where
-  liftLift :: Quote m => (a -> m Exp) -> f a -> m Exp
-
-lift1 :: (Lift1 f, Lift a, Quote m) => f a -> m Exp
-lift1 = liftLift lift
-
-instance Lift1 f => Lift (SL.Fix f) where
-  lift (SL.Fix inner) = appE [|SL.Fix|] (lift1 inner)
-
-instance (Lift1 f, Lift1 g) => Lift1 (SL.Compose f g) where
-  liftLift l (SL.Compose fga) = [|SL.Compose $(liftLift (liftLift l) fga)|]
-
-instance Lift a => Lift1 (SL.LocatedBy a) where
-  liftLift l (a SL.:< e) = [|(SL.:<) $(lift a) $(l e)|]
-
-instance Lift1 List where
-  liftLift l xs = listE $ l <$> xs
-
-instance Lift1 SL.SexpF where
-  liftLift l = \case
-    SL.AtomF a -> [|SL.AtomF $(lift a)|]
-    SL.ParenListF es -> [|SL.ParenListF $(liftLift l es)|]
-    SL.BracketListF es -> [|SL.BracketListF $(liftLift l es)|]
-    SL.BraceListF es -> [|SL.BraceListF $(liftLift l es)|]
-    SL.ModifiedF p e -> [|SL.ModifiedF $(lift p) $(l e)|]
-
--- deriving instance Lift a => Lift (SL.SexpF a)
-deriving instance Lift SL.Atom
-deriving instance Lift SL.Position
-deriving instance Lift SL.Prefix
-
-encodeOrShow :: (SexpIso a, Show a, IsString s) => a -> s
-encodeOrShow a = fromString case encode a of
-  Left _ -> show a
-  Right e -> T.unpack e
-
-extQ :: (Typeable a, Typeable b) => (a -> r) -> (b -> r) -> a -> r
-extQ f g a = maybe (f a) g (cast a)
-
-makeSxs :: Data r => Code Q (List Sexp -> r) -> QuasiQuoter
-makeSxs f = QuasiQuoter
-  { quoteExp = \str -> do
-      pos <- getPos
-      case readSexpsWithPos pos (T.pack str) of
-        Left e -> fail e
-        Right xs -> [| $(unTypeCode f) $e |]
-          where
-            e = dataToExpQ
-              (const Nothing `extQ` metaSexp `extQ` metaSexps)
-              xs
-  , quotePat = undefined
-  , quoteType = undefined
-  , quoteDec = undefined
-  }
-
--- | An untyped variant of 'makeSx', useful when the user function is
--- polymorphic in its return value.
-makeSx' :: ExpQ -> QuasiQuoter
-makeSx' f = QuasiQuoter
-  { quoteExp = \str -> do
-      pos <- getPos
-      case readSexpWithPos pos (T.pack str) of
-        Left e -> fail e
-        Right x -> [| $f $e |]
-          where
-            e = dataToExpQ
-              (const Nothing `extQ` metaSexp `extQ` metaSexps)
-              x
-  , quotePat = undefined
-  , quoteType = undefined
-  , quoteDec = undefined
-  }
-
-makeSx :: Data r => Code Q (Sexp -> r) -> QuasiQuoter
-makeSx = makeSx' . unTypeCode
-
-sxs = makeSxs [||id||]
-sx = makeSx [||id||]

src/Gyehoek/Wasm.hs

@@ -1,192 +1,426 @@
 {- HLINT ignore "Use newtype instead of data" -}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeepSubsumption #-}
+{-# LANGUAGE NoFieldSelectors #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE RecordPuns #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE TemplateHaskellQuotes #-}
+{-# LANGUAGE ImpredicativeTypes #-}
+{-# LANGUAGE DerivingVia #-}
 module Gyehoek.Wasm
-  (
-    -- * syntax
-    Module
-  , Idx
-  , Expr
-    -- ** quasiquoters
-  , expr
-  , Gyehoek.Sexp.sx
-  , Gyehoek.Sexp.sxs
-  -- * GenMod effect
-  , GenMod
+  ( defun
+  , rec'
+  , start
   , runGenMod
   , execGenMod
-  , defineFunction
-  , defineType
-  , defineGlobal
-  , emit
   , renderModule
-  , wat
-  , wats
-  , defineFunctions
-  , defineTypes
-  , defineGlobals
+  , Module
+  , Function
+  , Type(..)
+  , Expr
+  , Instr
+  , GenMod
+  , Idx
+  , i32
+  , export
+  , ins
+  , sxp
+  , result
+  , param
+  , if'
+  , ref
+  , eq
+  , i31ref
+  , i31
+  , struct
+  , mut
+  , sub
+  , deftype
+  , namedType
+  , type'
+  , deftypeNamed
+  , defglobal
+  , array
+  , FromIdx(..)
+  , func
+  , refnull
+  , declareFuncref
   )
   where
 
 import Language.SexpGrammar
-  ( SexpIso(..), (>>>) )
+  ( SexpIso(..), list, el, (>>>), rest, sym, symbol, (:-) )
 import Language.SexpGrammar qualified as Sexp
 import Language.SexpGrammar.Generic
 import Data.List (List)
-import GHC.Generics (Generic)
+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.Vector.Strict (Vector)
-import qualified Data.Vector.Strict as V
+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 Language.Haskell.TH.Quote (QuasiQuoter)
-import Data.Data (Data)
-import Gyehoek.Sexp (sx)
-import Data.Foldable (traverse_)
+import Data.Coerce (coerce)
+import qualified Control.Category
+import Data.Functor (void)
 
 
-newtype Module = MkModule { inner :: Vector Sexp }
+data Module = MkModule
+  { types :: Vector RecType
+  , functions :: Vector Function
+  , funcrefs :: Vector Funcref
+  , start :: Maybe Idx
+  , exports :: Vector Export
+  , globals :: Vector Global
+  }
+  deriving (Show, Generic)
+
+instance Semigroup Module where
+  m1 <> m2 = MkModule
+    { types = m1.types <> m2.types
+    , functions = m1.functions <> m2.functions
+    , start = m2.start <|> m1.start
+    , exports = m1.exports <> m2.exports
+    , funcrefs = m1.funcrefs <> m2.funcrefs
+    , globals = m1.globals <> m2.globals
+    }
+
+instance Monoid Module where
+  mempty = MkModule mempty mempty mempty Nothing mempty mempty
+
+newtype Funcref = MkFuncref { inner :: Idx }
+  deriving (Show, Generic)
+
+data Global = MkGlobal
+  { ty :: Type
+  , body :: Expr
+  }
+  deriving (Show, Generic)
+
+newtype RecType = MkRecType { inner :: Vector Type }
+  deriving (Show, Generic)
+
+data Function = MkFunction
+  { params :: List Type
+  , result :: List Type
+  , locals :: List Type
+  , body :: Expr
+  }
+  deriving (Show, Generic)
+
+newtype Export = MkExport { inner :: Sexp }
+  deriving (Show, Generic)
+
+newtype Expr = MkExpr { inner :: Vector Instr }
   deriving (Show, Generic)
   deriving newtype (Semigroup, Monoid)
 
-newtype Expr = MkExpr { inner :: Vector Instr }
-  deriving (Show, Generic, Data, Eq)
-  deriving newtype (Semigroup, Monoid)
+newtype Instr = MkInstr { inner :: Sexp }
+  deriving (Show, Generic)
+
+newtype Type = MkType { inner :: Sexp }
+  deriving (Show, Generic)
+
+data Idx
+  = IdxNumeric Natural
+  | IdxNamed Text
+  deriving (Show, Generic)
+
+data GenMod :: Effect where
+  DefRecType :: List Type -> GenMod m (List Idx)
+  Defun :: List Type -> List Type -> List Type
+        -> (Idx -> m Expr) -> GenMod m Idx
+  Start :: Idx -> GenMod m ()
+  Export :: Text -> Text -> Idx -> GenMod m ()
+  DefGlobal :: Type -> Expr -> GenMod m Idx
+  DeclareFuncref :: Idx -> GenMod m ()
+
+type instance DispatchOf GenMod = Dynamic
+
+export :: (GenMod :> es) => Text -> Text -> Idx -> Eff es ()
+export name ty idx = send $ Export name ty idx
+
+start :: (GenMod :> es) => Idx -> Eff es ()
+start = send . Start
+
+rec' :: (GenMod :> es) => List Type -> Eff es (List Idx)
+rec' = send . DefRecType
+
+deftype :: (GenMod :> es) => Type -> Eff es Idx
+deftype (MkType t) = send (DefRecType [type' t]) <&> \case
+  [x] -> x
+  x -> error $ "unreachable " <> show x
+
+deftypeNamed :: (GenMod :> es) => Text -> Type -> Eff es ()
+deftypeNamed name (MkType t) = void $ send (DefRecType [namedType name t])
+
+defglobal :: (GenMod :> es) => Type -> Expr -> Eff es Idx
+defglobal t e = send $ DefGlobal t e
+
+defun
+  :: (GenMod :> es)
+  => List Type -> List Type -> List Type
+  -> (Idx -> Eff es Expr)
+  -> Eff es Idx
+defun params res locals code = send $ Defun params res locals code
+
+declareFuncref :: GenMod :> es => Idx -> Eff es ()
+declareFuncref = send . DeclareFuncref
+
+-- defun
+--   :: (GenMod :> es)
+--   => List Type -> List Type -> List Type
+--   -> (Idx -> Eff '[GenExp] a)
+--   -> Eff es Idx
+-- defun params result locals code =
+--   send $ Defun params result locals (runPureEff . execWriterLocal . code)
+
+runGenMod :: forall es a. Eff (GenMod : es) a -> Eff es (a, Module)
+runGenMod = 
+  reinterpret (runStateLocal (mempty :: Module)) \cases
+    _ (DefRecType ts) -> state \m ->
+     ( let prev_n = sumOf (#types . each . #inner . to V.length) m
+       in IdxNumeric . fromIntegral <$> [prev_n .. prev_n + length ts - 1]
+     , m & #types <>~ V.singleton (MkRecType (V.fromList ts))
+     )
+    _ (Start idx) -> assign #start (Just idx)
+    _ (Export name ty idx) ->
+       #exports <>= V.singleton e
+      where e = MkExport $ ParenList
+              [ "export", sxp name, ParenList [ "func", sxp idx ] ]
+    env (Defun params result locals code) ->
+      localSeqUnlift env \unlift -> do
+        m <- get
+        -- the least unused function index, computed as the number
+        -- of currently allocated functions.
+        let idx = IdxNumeric . fromIntegral . length $ m.functions
+        -- the body is computed with access to the newly allocated
+        -- index `idx` for the sake of recursive occurences.
+        body <- unlift $ code idx
+        let func = MkFunction {params,result,locals,body}
+        #functions <>= V.singleton func
+        pure idx
+    _ (DefGlobal t e) -> state \m ->
+      let prev_n = IdxNumeric . fromIntegral . V.length $ m.globals
+          m' = m & #globals <>~ V.singleton (MkGlobal t e)
+      in (prev_n, m')
+    _ (DeclareFuncref idx) -> #funcrefs <>= V.singleton (MkFuncref idx)
+
+execGenMod = fmap snd . runGenMod
+
+renderModule :: Module -> Text
+renderModule = (^?! _Right) . Gyehoek.Sexp.encodePretty
+
+ref :: Type -> Type
+ref (MkType x) = MkType . ParenList $ [Symbol "ref", x]
+
+refnull :: Type -> Type
+refnull (MkType x) = MkType . ParenList $ ["ref", "null", x]
+
+sub :: List Idx -> Type -> Type
+sub supers (MkType x) = MkType . ParenList $
+  Symbol "sub" : (sxp <$> supers) ++ [x]
+
+array :: Type -> Type
+array (MkType x) = MkType . ParenList $ [Symbol "array", x]
+
+mut :: Type -> Type
+mut (MkType x) = MkType . ParenList $ [Symbol "mut", x]
+
+struct :: List Type -> Type
+struct xs = MkType . ParenList $
+  Symbol "struct" : (xs ^.. each . #inner . to field)
+  where field x = ParenList [Symbol "field", x]
+
+func :: List Type -> List Type -> Type
+func params results =
+  MkType . ParenList $
+    [ Symbol "func"
+    , wrap "param" params
+    , wrap "result" results
+    ]
+  where
+    wrap s xs = ParenList $ Symbol s : xs ^.. each . #inner
+
+i32, i31ref, eq, i31 :: Type
+i32 = MkType $ Symbol "i32"
+i31ref = MkType $ Symbol "i31ref"
+eq = MkType $ Symbol "eq"
+i31 = MkType $ Symbol "i31"
+
+class FromIdx a where
+  fromIdx :: Idx -> a
+
+instance FromIdx Type where
+  fromIdx (IdxNumeric n) = MkType . Symbol . T.pack . show $ n
+
+
+
+instance SexpIso Idx where
+  sexpIso = match
+    $ With (\numeric -> num >>> numeric)
+    $ With (\named -> name >>> named)
+    $ End
+    where
+      num = Sexp.integer >>> Sexp.partialOsi f g
+        where
+          f n | n < 0 = Left $ Sexp.unexpected "negative"
+                            <> Sexp.expected "natural"
+              | otherwise = Right $ fromIntegral n
+          g n = fromIntegral n
+      l :: Prism' Text Text
+      l = prefixed "$"
+      name = Sexp.symbol >>> Sexp.partialOsi
+        (maybe (Left $ Sexp.expected "$-prefixed sym") Right . preview l)
+        (review l)
+
+instance SexpIso RecType where
+  sexpIso = with \rectype ->
+    Sexp.coproduct
+     [ sexpIso @Type >>> Sexp.partialIso
+       (\x -> [x])
+       (\case [x] -> Right x
+              _ -> Left $ Sexp.expected "a single type")
+     , list (el (sym "rec") >>> rest sexpIso)
+     ]
+    >>> Sexp.iso V.fromList V.toList
+    >>> rectype
+    -- where
+    --   typedef
+    --     :: forall a t. Sexp.Grammar Position (Sexp :- t) (a :- t)
+    --     -> Sexp.Grammar Position (Sexp :- t) (a :- t)
+    --   typedef x = list (el (sym "type") >>> el x)
+
+type' :: Sexp -> Type
+type' e = MkType . ParenList $ [ "type", e ]
+
+namedType :: Text -> Sexp -> Type
+namedType name e = MkType . ParenList $ [ "type", Symbol name, e ]
+
+instance SexpIso Global where
+  sexpIso = with \glob ->
+    list ( el (sym "global")
+         >>> el (sexpIso @Type)
+         >>> restCode
+         )
+    >>> glob
+
+instance SexpIso Instr where
+  sexpIso = Sexp.iso coerce coerce
+
+instance SexpIso Type where
+  sexpIso = Sexp.iso coerce coerce
+
+instance SexpIso Export where
+  sexpIso = Sexp.iso coerce coerce
+
+restCode :: Sexp.Grammar Position (Sexp.List :- t) (Sexp.List :- (Expr :- t))
+restCode =
+  rest (sexpIso @Instr)
+  >>> Sexp.onTail
+           (Sexp.iso
+            (view instrsExpr)
+            (review instrsExpr))
+    where
+      instrsExpr :: Iso' (List Instr) Expr
+      instrsExpr = vector . coerced
+
+instance SexpIso Function where
+  sexpIso = with \func ->
+    list ( el (sym "func")
+       >>> el (list $ el (sym "param") >>> rest (sexpIso @Type))
+       >>> el (list $ el (sym "result") >>> rest (sexpIso @Type))
+       >>> el (list $ el (sym "local") >>> rest (sexpIso @Type))
+       >>> restCode
+         )
+     >>> func
+
+instance SexpIso Module where
+  sexpIso = Sexp.partialOsi (const $ Left mempty) \m ->
+    ParenList $
+      [ Symbol "module" ]
+      <> (m ^.. #types . each . to sxp)
+      <> (m ^.. #globals . each . to sxp)
+      <> (m ^.. #funcrefs . each . to sxp)
+      <> (m ^.. #functions . each . to sxp)
+      <> (m ^.. #exports . each . to sxp)
+
+instance SexpIso Funcref where
+  sexpIso = with \funcref ->
+    list ( el (sym "elem")
+         >>> el (sym "declare")
+         >>> el (sym "funcref")
+         >>> el (list $ el (sym "ref.func") >>> el (sexpIso @Idx))
+         )
+    >>> funcref
+
+instance SexpIso Sexp where
+  sexpIso = Control.Category.id
+
+instance Each Expr Expr Instr Instr where
+  each = #MkExpr . each
+
+sxp :: HasCallStack => SexpIso a => a -> Sexp
+sxp e = either error id . Sexp.toSexp sexpIso $ e
+
+ins :: Text -> List Sexp -> Expr
+ins op [] = [ MkInstr $ Symbol op ]
+ins op xs = [ MkInstr . ParenList $ Symbol op : xs ]
+
+instance IsString Sexp where
+  fromString = Symbol . T.pack
 
 instance IsList Expr where
   type Item Expr = Instr
   fromList = MkExpr . V.fromList
-  toList = V.toList . view #inner
+  toList e = V.toList e.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
+data ResultType = MkResultType
+  { params :: List Type
+  , result :: List Type
   }
-  deriving (Show, Generic)
+  deriving stock (Generic)
+  deriving (Semigroup, Monoid)
+    via Generically ResultType
 
-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
-    }
+param :: List Type -> ResultType
+param ts = MkResultType ts mempty
 
-instance Monoid GenModState where
-  mempty = MkGenModState
-    { mod = mempty
-    , funcs = 0
-    , types = 0
-    , globals = 0
-    }
+result :: List Type -> ResultType
+result ts = MkResultType mempty ts
 
-data GenMod :: Effect where
-  DefineFunction :: Sexp -> GenMod m Idx
-  DefineType :: Sexp -> GenMod m Idx
-  DefineGlobal :: Sexp -> GenMod m Idx
-  Emit :: Sexp -> GenMod m ()
+resultTypeSexp :: ResultType -> List Sexp
+resultTypeSexp rt =
+  f "param" (coerce <$> rt.params) <> f "result" (coerce <$> rt.result)
+  where
+    f :: Text -> List Sexp -> List Sexp
+    f _ [] = []
+    f kw s = [ ParenList $ Symbol kw : s ]
 
-type instance DispatchOf GenMod = Dynamic
+-- resultSexp :: ResultType -> Sexp
+-- resultSexp rt = ParenList $ Symbol "param" : (coerce <$> rt.result)
 
-defineFunction :: GenMod :> es => Sexp -> Eff es Idx
-defineFunction = send . DefineFunction
-
-defineFunctions :: GenMod :> es => List Sexp -> Eff es (List Idx)
-defineFunctions = traverse (send . DefineFunction)
-
-defineType :: GenMod :> es => Sexp -> Eff es Idx
-defineType = send . DefineType
-
-defineTypes :: GenMod :> es => List Sexp -> Eff es (List Idx)
-defineTypes = traverse (send . DefineType)
-
-defineGlobal :: GenMod :> es => Sexp -> Eff es Idx
-defineGlobal = send . DefineGlobal
-
-defineGlobals :: GenMod :> es => List Sexp -> Eff es (List Idx)
-defineGlobals = traverse (send . DefineGlobal)
-
-emit :: GenMod :> es => List Sexp -> Eff es ()
-emit = traverse_ (send . Emit)
-
-appendAndIncrement
-  :: State GenModState :> es
-  => LensLike' ((,) Natural) GenModState Natural
-  -> Sexp
-  -> Eff es Idx
-appendAndIncrement l s =
-  state \st -> st
-    & #mod . #inner <>~ V.singleton s
-    & l <<%~ succ
-    & _1 %~ MkIdx
-
-runGenMod :: Eff (GenMod : es) a -> Eff es (a, Module)
-runGenMod =
-  let run = (mapped . _2 %~ view #mod) . runStateLocal (mempty @GenModState)
-  in reinterpret run \cases
-    _ (DefineFunction s) -> appendAndIncrement #funcs s
-    _ (DefineType s) -> appendAndIncrement #types s
-    _ (DefineGlobal s) -> appendAndIncrement #globals s
-    _ (Emit s) -> #mod . #inner <>= V.singleton s
-
-execGenMod :: Eff (GenMod : es) a -> Eff es Module
-execGenMod = fmap snd . runGenMod
-
-renderModule :: Module -> Text
-renderModule (MkModule ss) = Gyehoek.Sexp.format [sx|
-  (module ##{ss})
-|]
-
-
--- SexpIso instances
-
-instance SexpIso Idx where
-  sexpIso = with \idx ->
-    Sexp.integer >>> Sexp.partialOsi f g
-    >>> idx
-    where
-      f n | n < 0 = Left $ Sexp.unexpected "negative"
-                        <> Sexp.expected "natural"
-          | otherwise = Right $ fromIntegral n
-      g = fromIntegral
-
-instance SexpIso Instr where
-  sexpIso = with id
-
-instance Gyehoek.Sexp.SpliceSexp Expr where
-  spliceSexp = toListOf $ #inner . each . #inner
-
-
--- quasiquoters
-
-expr :: QuasiQuoter
-expr = Gyehoek.Sexp.makeSxs
-  [||MkExpr . V.fromList . (each . #inner %~ Gyehoek.Sexp.stripLocation)
-   . fmap (Gyehoek.Sexp.fromSexp @Instr) ||]
-
-wat :: QuasiQuoter
-wat = Gyehoek.Sexp.makeSx [|| id ||]
-
-wats :: QuasiQuoter
-wats = Gyehoek.Sexp.makeSxs [|| id ||]
+if' :: ResultType -> Expr -> Expr -> Expr
+if' rt t f = MkExpr . V.singleton . MkInstr . ParenList $
+  [ Symbol "if" ]
+  <> resultTypeSexp rt
+  <> [ ParenList $ Symbol "then" : (t ^.. each . to sxp) ]
+  <> [ ParenList $ Symbol "else" : (f ^.. each . to sxp) ]

t.js

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

t.scm

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

t.wat

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

test/Gyehoek/Test/CPS/Syntax.hs

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

test/Gyehoek/Test/Golden.hs

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

test/Gyehoek/Test/Sexp.hs

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

test/Main.hs

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

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