pass continuations as arguments, use normal stack

continue takes var
2026-08-24 23:41:02 -06:00 · 2026-08-24 10:41:19 -06:00 · 2026-08-24 09:54:19 -06:00 · 2026-08-24 06:58:16 -06:00
65 changed files with 1071 additions and 2584 deletions
@@ -9,9 +9,6 @@
      . (progn (defun apply-cabal-fmt-h ()
                 (haskell-mode-buffer-apply-command "cabal-fmt"))
               (add-hook 'before-save-hook #'apply-cabal-fmt-h nil t)))))
- (scheme-mode
-  . ((eval . (dolist (s '(kappa κ prim))
-               (put s 'scheme-indent-function 1)))))
 (nil
  . ((eval
      . (progn (defun display-ansi ()
@@ -8,5 +8,4 @@ dist-newstyle
 *.tix
 .direnv
 result
-play/
-trace.html
+play/
@@ -132,34 +132,3 @@ multiple ~env-ref~ calls could probably be replaced with a primitive that loads
                                 $code)
                     1))))
 #+end_src
-
-** example
-
-#+begin_src scheme
-  (λ (n m ktail)
-    (letrec ((f (λ (x ktail-0) (+ x n ktail-0)))
-             (g (λ (y ktail-1) (+ y g ktail-1))))
-      (prim (cons f g) ktail)))
-#+end_src
-
-#+begin_src scheme
-  (λ (n m ktail)
-    (letrec ((f-code (λ (x ktail-0)
-                       (prim (env-get 2)
-                         (κ (n)
-                           (+ x n ktail-0)))))
-             (g-code (λ (y ktail-1)
-                       (prim (env-get 3)
-                         (κ (m)
-                           (+ y m ktail-1))))))
-      (letrec ((with-closure-code
-                (κ (f g)
-                  (prim (get-env 0)
-                    (κ (ktail)
-                      (prim cons f g ktail))))))
-        (prim (make-shared-closure (with-closure-code)
-                                   ktail)
-          (κ (with-closure)
-            (prim (make-shared-closure (f-code g-code) n m)
-              with-closure))))))
-#+end_src
@@ -1,9 +0,0 @@
-#+title: on libraries
-
-R⁷RS leaves it unspecified how exactly libraries correspond to files:
-
-#+begin_quote
-Programs and libraries are typically stored in files, although in some implementations they can be entered interactively into a running Scheme system. Other paradigms are possible. Implementations which store libraries in files should document the mapping from the name of a library to its location in the file system.
-#+end_quote
-
-thus the implementation of ~define-library~ is open to much interpretation. we could possibly define libraries as first-class objects, or deal with them statically. the former case is appealing to me, as it could massively simplify interactive use.
@@ -1,100 +0,0 @@
-* rationale?
-
-previously, the VM's stack was used for storing local variables across blocks; a Scheme procedure was split into several low-level routines (one for the procedure itself and one for each continuation), and the stack was used as a communication channel for these separate routines. in contrast, registers were local to each routine. this aligns with Wasm's model of functions pretty well, with Wasm /locals/ acting as the VM's /registers/, and a global mutable stack serving as fallback.
-
-this worked quite well until it became time to implement ~call/cc~.
-
-we are considering making the following alterations to the VM:
- explicitly segment the stack into frames.
- passing procedures and return addresses on the stack.
- new instructions:
-  + ~(tail-call /n/)~
-  + ~(call /n/)~
-  + ~(load /r/ /n/)~
-  + ~(return /n/)~
-
-* scratchpad
-
-#+begin_src scheme
-  (letrec ((fac (λ (n)
-                (if (zero? n)
-                    1
-                    (* n (fac (- n 1)))))))
-  (fac 3))
-#+end_src
-
-#+begin_src scheme
-  (λ (ktail0)
-  (letrec ((fac
-            (λ (n ktail1)
-              (zero?
-               n
-               (κ (x0)
-                  (if x0
-                      (continue ktail1 1)
-                      (- n 1
-                         (κ (x1)
-                            (fac x1
-                                 (κ (x2)
-                                    (* n x2 ktail1)))))))))))
-    (fac 3)))
-#+end_src
-
-#+begin_example
-n ktail1
-| |
-| | x0
-| | |
-| | ^
-| |
-| | x1
-| | |
-| | ^
-| | 
-| | x2
-| | |
-^ ^ ^
-#+end_example
-
-#+begin_src scheme
-  (define $fac-c0
-    (pop! %x0 0) ; [ x0 $fac-c0 n $fac ktail1 ]
-    (if %x0 ; [ $fac-c0 n $fac ktail1 ]
-        ;; every variable but `ktail1' is dead so we pop them all.
-        ;; this probably means that `if' should take two continuations
-        ;; rather than two blocks.
-        (then (push! 1) ; [ $fac-c0 n $fac ktail1 ]
-              (return 1)) ; [ 1 $fac-c0 n $fac ktail1 ]
-        (else (load %n 1) ; [ $fac-c0 n $fac ktail1 ]
-              (prim %x1 (- %n 1)) ; [ $fac-c0 n $fac ktail1 ]
-              (push! $fac-c1) ; [ $fac-c0 n $fac ktail1 ]
-              (push! $fac) ; [ $fac-c1 $fac-c0 n $fac ktail1 ]
-              (push! %x1) ; [ $fac $fac-c1 $fac-c0 n $fac ktail1 ]
-              (call 1) ; [ x1 $fac $fac-c1 $fac-c0 n $fac ktail1 ]
-              )))
-
-  (define $fac-c1
-    (pop! %x2) ; [ x2 $fac-c1 $fac-c0 n $fac ktail1 ]
-    (load %n 3) ; [ $fac-c1 $fac-c0 n $fac ktail1 ]
-    (prim %x3 (* %n %x2))
-    (push! %x3) ; [ $fac-c1 $fac-c0 n $fac ktail1 ]
-    (return 1) ; [ x3 $fac-c1 $fac-c0 n $fac ktail1 ]
-    )
-
-  (define $fac
-    (load %ktail1 2) ; [ n $fac ktail1 ]
-    (load %n 0) ; [ n $fac ktail1 ]
-    (push! $fac-c0) ; [ n $fac ktail1 ]
-    (push! $zero?) ; [ $fac-c0 n $fac ktail1 ]
-    (push! %n) ; [ $zero? $fac-c0 n $fac ktail1 ]
-    (call 1) ; [ n $zero? $fac-c0 n $fac ktail1 ]
-    )
-
-  (define $start
-    (push! $fac) ; [ $start ktail0 ]
-    (push! 3) ; [ $fac $start ktail0 ]
-    (tail-call 1) ; [ 3 $fac $start ktail0 ]
-    ;; ↑ `tail-call' knows how to dispose of the caller's stack frame.
-    )
-#+end_src
-
@@ -55,7 +55,7 @@
                nodejs
                wasm-tools
                wac-cli
-                gauche
+                guile
                rust-analyzer
                wasmtime
                # bashInteractive is necessary to work around an
@@ -1 +0,0 @@
-(begin 123 456) ; => 456
@@ -1,2 +0,0 @@
-ret > ExitSuccess
-out > #t
@@ -1,12 +0,0 @@
-(letrec ((iter (λ (n f)
-                 (if (zero? n)
-                     #f
-                     (begin (f n)
-                            (iter (- n 1) f))))))
-  (call/cc
-   (λ (k)
-     (iter 10 (λ (n)
-                ;; i don't feel like implementing (= n 5) right now lmfao
-                (if (zero? (- n 5))
-                    (k #t)
-                    #f))))))
@@ -1,2 +0,0 @@
-ret > ExitSuccess
-out > #t
@@ -1,4 +0,0 @@
-(call/cc
- (λ (k)
-   (begin (k #t)
-          #f)))
@@ -1,2 +0,0 @@
-ret > ExitSuccess
-out > #t
@@ -1,5 +0,0 @@
-;; confer ../callcc-early-exit-4
-(letrec ((app (λ (f x)
-                (begin (f x)
-                       #f))))
-  (call/cc (λ (k) (app k #t))))
@@ -1,2 +0,0 @@
-ret > ExitSuccess
-out > #t
@@ -1,5 +0,0 @@
-;; confer ../callcc-early-exit-3
-(letrec ((app (λ (f x)
-                (begin (f x)
-                       #f))))
-  (call/cc (λ (k) (app (λ (x) (k x)) #t))))
@@ -1,2 +0,0 @@
-ret > ExitSuccess
-out > #t
@@ -1,4 +0,0 @@
-(call/cc
- (λ (k)
-   (begin ((λ () (k #t)))
-          #f)))
@@ -1,2 +0,0 @@
-ret > ExitSuccess
-out > 12
@@ -1,4 +0,0 @@
-(* 2 (call/cc
-      (λ (k)
-        (begin (k 6)
-               3))))
@@ -1,2 +0,0 @@
-ret > ExitSuccess
-out > 456
@@ -1,2 +0,0 @@
-ret > ExitSuccess
-out > 155
@@ -1,10 +0,0 @@
-(letrec ((factorial (λ (n)
-                      (if (zero? n)
-                          1
-                          (* n (factorial (- n 1)))))))
-  (letrec ((sum-of-factorials
-            (λ (n)
-              (if (zero? n)
-                  0
-                  (+ (factorial n) (sum-of-factorials (- n 1)))))))
-    (+ 2 (sum-of-factorials 5))))
@@ -1,2 +0,0 @@
-ret > ExitSuccess
-out > (6 . 7)
@@ -1 +0,0 @@
-(cons 6 7)
@@ -1,2 +0,0 @@
-ret > ExitSuccess
-out > (456 . 123)
@@ -1,2 +0,0 @@
-(let ((p (cons 123 456)))
-  (cons (cdr p) (car p)))
@@ -1,2 +0,0 @@
-ret > ExitSuccess
-out > 123
@@ -1 +0,0 @@
-123
@@ -1,2 +0,0 @@
-ret > ExitSuccess
-out > (0 . (1 . (4 . (9 . (16 . ())))))
@@ -1,7 +0,0 @@
-(letrec ((my-map (λ (f l)
-                   (if (pair? l)
-                       (cons (f (car l))
-                             (my-map f (cdr l)))
-                       (list)))))
-  (my-map (λ (x) (* x x))
-          (list 0 1 2 3 4)))
@@ -60,17 +60,14 @@ library
    Gyehoek.CPS.Close
    Gyehoek.CPS.Convert
    Gyehoek.CPS.Eval
-    Gyehoek.CPS.Hoist
+    Gyehoek.CPS.Stackify
    Gyehoek.CPS.Syntax
    Gyehoek.Driver
    Gyehoek.GenSym
    Gyehoek.Jalmot
-    Gyehoek.Language
    Gyehoek.Lift1
    Gyehoek.Options
    Gyehoek.Prelude
-    Gyehoek.Scheme.Expand
-    Gyehoek.Scheme.Expand.Old
    Gyehoek.Scheme.Syntax
    Gyehoek.Sexp
    Gyehoek.Sexp.Grammar
@@ -79,6 +76,9 @@ library
    Gyehoek.Sexp.QQ
    Gyehoek.Sexp.Read
    Gyehoek.Sexp.Syntax
+    Gyehoek.Stack.Lower
+    Gyehoek.Stack.Syntax
+    Gyehoek.Stack.VM
    Gyehoek.Wasm

  build-depends:
@@ -99,7 +99,6 @@ library
    , hashable
    , invertible-grammar
    , lens
-    , lucid
    , megaparsec
    , mtl
    , optparse-applicative
@@ -107,21 +106,16 @@ library
    , pretty-simple
    , prettyprinter
    , prettyprinter-ansi-terminal
-    , prettyprinter-lucid
    , process
    , recursion-schemes
    , scientific
    , string-interpolate
-    , tardis
    , template-haskell
    , text
    , text-short
    , typed-process
    , unordered-containers
    , vector
-    , witherable
-    , semialign
-    , these

  hs-source-dirs:   src
  default-language: GHC2024
@@ -136,11 +130,14 @@ test-suite test
  -- cabal-fmt: expand test -Main
  other-modules:
    Gyehoek.Test.CPS.Eval
+    Gyehoek.Test.CPS.Stackify
    Gyehoek.Test.CPS.Syntax
+    Gyehoek.Test.Golden
    Gyehoek.Test.Scheme.Syntax
    Gyehoek.Test.Sexp.Print
    Gyehoek.Test.Sexp.QQ
    Gyehoek.Test.Sexp.Read
+    Gyehoek.Test.Stack.VM
    Gyehoek.TestUtil
    Root

@@ -168,10 +165,7 @@ test-suite doctest
  import:             ghcstuffs, ghcstuffs-dev
  type:               exitcode-stdio-1.0
  hs-source-dirs:     test
-  build-depends:
-    , base
-    , gyehoek
-
+  build-depends:      base
  default-extensions: CPP
  main-is:            doctest.hs

@@ -1,11 +0,0 @@
-(define-syntax if-not
-  (syntax-rules ()
-    ((_ c t f) (if (not c) t f))
-    ((_ c t) (if (not c) t))))
-
-(write (macroexpand-1 '(if-not #t 123 456)))
-
-(define (main)
-  (let loop ((datum (read)))
-    (unless (eof-object? datum)
-      ())))
@@ -4,52 +4,38 @@ module Gyehoek.CPS.Close
  ) where

 import Gyehoek.CPS.Syntax
-import Data.List (nub)
 import Gyehoek.GenSym
 import Gyehoek.Prelude
-import Debug.Pretty.Simple
-import Gyehoek.Sexp qualified as S
-import Data.HashSet.Lens
-import Data.Traversable


-genCodeName :: GenSym :> es => Name -> Eff es Name
-genCodeName f = gensym' @Name $ f ^. _Wrapped' . to (<> "-code")
-
-bindEnv :: List Name -> Exp -> Exp
-bindEnv frees m = [cps|
-  (builtin (get-env) (κ #{frees} #{m}))
-|]
-
-close1 :: forall es. GenSym :> es => Exp -> Eff es Exp
-close1 = \case
-  lr@(ExpLetRec bs e) -> do
-    let boundNames = bs ^.. each . _1
-    let boundNames' = setOf each boundNames
-    let frees = bs
-          & foldMapOf
-            (each . _2)
-            (freeWithBound' boundNames')
-          & nub
-    env_cont_l <- gensym' @Name "env-cont"
-    e_l <- gensym' @Name "letrec-body-cont"
-    bs' <- for bs \(f,ab) -> do
-      f_code_l <- genCodeName f
-      pure ( f_code_l
-           , ab & absBody %~ bindEnv (boundNames ++ frees)
-           )
-    let codes = bs' ^.. each . _1 . to MkLabel
+close :: GenSym :> es => Exp -> Eff es Exp
+close = transformM \case
+  ExpLetRec [(f, AbsLambda lam@(MkLambda bs kb m))] e -> do
+    f_code <- gensym' @Name $ f ^. _Wrapped'. to (<> "-code")
+    -- it would probably be most sane to generate a symbol for `env`,
+    -- but we're reusing the lambda binding so we don't have to
+    -- explicitly substitute recursive calls.
+    let frees = freeWithBound' [f] lam
+    let m' = ifoldr
+             (\n x q -> [cps|(prim (env-ref #{f} #{n})
+                                (κ (#{x}) #{q}))|])
+             m frees
    pure [cps|
-      (letrec #{bs'}
-        (builtin (make-shared-closure #{codes} #{frees})
-          (κ #{boundNames}
-            #{e})))
+      (letrec ((#{f_code} (λ (#{f} ##{bs} #{kb})
+                            #{m'})))
+        (prim (make-closure ($ #{f_code}) ##{frees})
+          (κ (#{f}) #{e})))
+    |]
+
+  ExpApply f xs ktail -> do
+    code <- gensym' @Name "code"
+    pure [cps|
+      (prim (env-code #{f})
+        (κ (#{code})
+          (#{code} #{f} ##{xs} #{ktail})))
    |]

  e -> pure e

-close :: forall es. GenSym :> es => Exp -> Eff es Exp
-close = transformM close1
-
 closeProgram :: GenSym :> es => Program -> Eff es Program
 closeProgram = traverseOf (#body . #body) close
@@ -12,7 +12,6 @@ import Data.List.NonEmpty (NonEmpty((:|)))
 import Control.Monad.Cont qualified as Cont
 import qualified Data.List.NonEmpty as NE
 import Gyehoek.Prelude
-import Debug.Pretty.Simple


 -- 뻘짓이어라
@@ -24,73 +23,66 @@ telescope f = Cont.runCont . traverse (Cont.cont . f)



-one :: a -> List a
-one a = [a]
-
-oneOrUndefined :: List Val -> Val
-oneOrUndefined = \case
-  [x] -> x
-  _ -> ValImm ImmUndefined
-
-convert1 :: (GenSym :> es) => Scm.Exp -> (Val -> Eff es Exp) -> Eff es Exp
-convert1 e k = convert e (k . oneOrUndefined)
-
 -- | Transform an expression with a meta-continuation.
 convert
  :: forall es. (GenSym :> es)
-  => Scm.Exp -> (List Val -> Eff es Exp) -> Eff es Exp
+  => Scm.Exp -> (Val -> Eff es Exp) -> Eff es Exp

-convert (Scm.ExpVar x) k = k [ValVar x]
-convert (Scm.ExpLit l) k = k . one . ValImm $ case l of
+convert (Scm.ExpVar x) k = k $ ValVar x
+convert (Scm.ExpLit l) k = k . ValImm $ case l of
  LitInt n -> ImmInt n
  LitBool b -> ImmBool b
  _ -> _

-convert (Scm.ExpBuiltin p) k =
-  telescope (convert1 @es) p \p' -> do
-    r_l <- gensym' "r"
-    m <- k [ValVar r_l]
+-- special case: call/cc is desugared during cps-conversion...
+convert (Scm.ExpPrim (PrimCallCC withcc)) k = do
+  convert withcc \withcc' -> do
+    cc <- gensym' @Name "cc"
+    r <- gensym' "r"
+    m <- k $ ValVar r
+    ccish <- gensym' @Name "cc-ish"
+    x <- gensym' @Name "x"
    pure [cps|
-      (builtin #{p'} (κ (#{r_l}) #{m}))
+      (letrec ((#{cc} (κ (#{r}) #{m})))
+        (letrec ((#{ccish} (λ (#{x} _) (continue #{cc} #{x}))))
+          (#{withcc'} #{ccish} #{cc})))
    |]

+-- ...while all other prims are left as-is for later stages to
+-- handle..
+convert (Scm.ExpPrim p) k =
+  telescope (convert @es) p \p' -> do
+    r <- gensym' "r"
+    ExpPrim p' . MkKappa [r] <$> k (ValVar r)
+
 convert (Scm.ExpLambda xs e) k = do
  f <- gensym' "lambda-body"
  lam <- convertLambda xs e
-  ke <- k [ValVar f]
+  ke <- k $ ValVar f
  pure [cps|
    (letrec ((#{f} #{lam}))
      #{ke})
  |]

 convert (Scm.ExpApply f xs) k =
-  telescope (convert1 @es) (f:|xs) \(f':|xs') -> do
-    r <- gensym' @Name "r"
+  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' (KexpVar r)
+    m <- k (ValVar x)
+    pure $ ExpLetRec [(r, AbsKappa' [x] m)] $ ExpApply f' xs' r

-convert (Scm.ExpBegin xs) k = telescope (convert @es) xs (k . NE.last)
+convert (Scm.ExpBegin xs) k = _

-convert (Scm.ExpIf c t (Just f)) k =
-  convert1 c \c' -> do
-    t_l <- gensym' @Name "truthy-cont"
-    f_l <- gensym' @Name "falsey-cont"
-    t' <- convert t k
-    f' <- convert f k
-    pure [cps|
-      (letrec ((#{t_l} (κ () #{t'}))
-               (#{f_l} (κ () #{f'})))
-        (if #{c'} #{t_l} #{f_l}))
-    |]
+convert (Scm.ExpIf c t f) k =
+  convert c \c' ->
+    ExpIf c' <$> convert t k <*> convert f k

 -- let-bindings are desugared into continuation calls whose parameters
 -- are the left-hand sides and whose arguments are the right-hand
 -- sides.
 convert (Scm.ExpLet bs e) k =
  let rhss = bs ^.. each . _2
-  in telescope (convert1 @es) rhss \rhss' -> do
+  in telescope (convert @es) rhss \rhss' -> do
    e' <- convert e k
    kbody <- gensym' @Name "let-body"
    let bs' = bs ^.. each . _1
@@ -113,15 +105,15 @@ convertLambda
  => List Name -> Scm.Exp -> Eff es Lambda
 convertLambda bs m = do
  ktail <- gensym' "lambda-tail"
-  m' <- convert1 m $ pure . ExpContinue (ValVar ktail) . (:[])
+  m' <- convert m $ pure . ExpContinue (ValVar ktail) . (:[])
  pure [cps|(λ (##{bs} #{ktail}) #{m'})|]

 convertProgram :: forall es. (GenSym :> es) => Scm.Program -> Eff es Program
 convertProgram p = do
  ktail <- gensym' "start-ktail"
-  m <- telescope (convert1 @es) (p ^.. each . _Left)
+  m <- telescope (convert @es) (p ^.. each . _Left)
        (pure . ExpContinue (ValVar ktail))
  pure . MkProgram $ MkLambda [] ktail m

 convertExp :: forall es. (GenSym :> es) => Scm.Exp -> Eff es Exp
-convertExp e = convert e (pure . Halt)
+convertExp e = convert e (pure . Halt1)
@@ -1,303 +1,86 @@
 {-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE OverloadedLists #-}
 module Gyehoek.CPS.Eval
  ( evalProgram
  , module Gyehoek.CPS.Syntax
  , evalExp
-  , eGrammar
  ) where

-import Gyehoek.CPS.Syntax hiding (Hob(..), Obj(..), cont)
-import Gyehoek.Sexp qualified as S
-import Control.Lens hiding (assign)
-import Data.Maybe (fromMaybe, isJust)
+import Gyehoek.CPS.Syntax
+import Control.Lens
+import Data.Maybe (fromMaybe)
 import Text.Show.Functions ()
 import qualified Data.HashMap.Strict as H
-import Gyehoek.Prelude hiding (assign)
-import Debug.Pretty.Simple
-import Gyehoek.Jalmot
-import Control.Monad.Cont
-import Gyehoek.Sexp qualified as S
-import GHC.Generics (Generically(..))
-import Gyehoek.Sexp ((:-)(..))
-import Data.List (nub, mapAccumR, compareLength)
-import Data.HashSet.Lens (setOf)
-import Data.IntMap.Strict (IntMap)
-import Data.IntMap.Strict qualified as IM
-import Data.Monoid
-import Control.Monad.State
-import Data.Traversable (for)
-import Data.Foldable (traverse_, foldrM)
+import Gyehoek.Prelude


-newtype Loc = MkLoc { getLoc :: Int }
-  deriving stock (Generic, Data)
-  deriving newtype (Show, Eq, Ord, Enum)
-
-data Store = MkStore
-  { nextLoc :: Loc
-  , heap :: IntMap E
+data Env = MkEnv
+  { vars :: HashMap Name Obj
+  , labels :: HashMap Name (Env, Abs)
  }
-  deriving stock (Show, Generic)
-
-type instance Index Store = Loc
-type instance IxValue Store = E
-
-instance Ixed Store where ix (MkLoc j) = #heap . ix j
-instance At Store where at (MkLoc j) = #heap . at j
-
-emptyStore :: Store
-emptyStore = MkStore
-  { nextLoc = MkLoc 0
-  , heap = mempty
-  }
-
-newtype Env = MkEnv { getEnv :: HashMap Name Loc }
-  deriving stock (Show, Generic, Data)
-  deriving newtype (Semigroup, Monoid)
-
-emptyEnv :: Env
-emptyEnv = mempty
-
-type instance Index Env = Name
-type instance IxValue Env = Loc
-
-instance Ixed Env where ix j = #getEnv . ix j
-instance At Env where at j = #getEnv . at j
-
-update :: Loc -> E -> Store -> Store
-update (MkLoc loc) v = #heap %~ IM.alter f loc
-  where
-    f (Just _) = Just v
-    f Nothing = error "segfault lol"
-
-updates :: Foldable f => f (Loc, E) -> Store -> Store
-updates = alaf Endo foldMap (uncurry update)
-
-fetch :: Loc -> M r E
-fetch (MkLoc loc) = gets (^?! #heap . ix loc)
-
-new :: M r Loc
-new = state \st -> (st.nextLoc, st & #nextLoc %~ succ)
-
-new' :: E -> M r Loc
-new' e = state \st ->
-  ( st.nextLoc
-  , st & #nextLoc %~ succ & at st.nextLoc ?~ e
-  )
-
-defines :: Traversable t => t (Name, E) -> M Answer Env
-defines = alaf Ap foldMap \(name,e) -> do
-  l <- new' e
-  pure $ bind name l
-
-var :: HasCallStack => Env -> Name -> M Answer Loc
-var g x = case g ^. at x of
-  Just l -> pure l
-  Nothing -> wrong [i|unbound variable #{x}|]
-
-type CmdCont = Store -> Answer
-type ExpCont = List E -> CmdCont
-
-type M r = ContT r (State Store)
-
-data Answer
-  = AnswerValues (List E)
-  | AnswerError AJalmot
  deriving (Show, Generic)

-data Mutability
-  = Mut
-  | NoMut
-  deriving (Show, Generic, Data, Eq)
+eval :: Env -> Exp -> List Obj

-wrong :: Text -> M Answer a
-wrong s = ContT \_ -> pure . AnswerError . EvalError $ s
+eval g (Halt xs) = evalVal g <$> xs

-orWrong
-  :: Getting (First a) s a
-  -> Text -> s -> M Answer a
-orWrong p msg s = case getFirst . getConst $ p (Const . First . Just) s of
-  Nothing -> wrong msg
-  Just x -> pure x
+eval g (ExpContinue ((^?! #ValVar) -> k) xs) =
+  case g ^. #labels . at k of
+    Just (h, AbsKappa' bs m) -> eval h' m
+      where h' = h & #vars <>~ envOfBinds bs (evalVal g <$> xs)
+    _ -> error [i|not a kappa: #{k}|]

-bind :: Name -> Loc -> Env
-bind k = MkEnv . H.singleton k
+eval g (ExpApply ((^?! #ValVar) -> f) xs ktail) =
+  case g ^?! #labels . at f of
+    Just (h,AbsLambda' bs kb m) -> eval h' m
+      where h' = h & #vars <>~ envOfBinds bs (evalVal g <$> xs)
+                   & #labels . at kb .~ (g ^. #labels . at ktail)
+    Nothing -> error [i|undefined label: #{f}|]

-extends :: Foldable f => f (Name, Loc) -> Env -> Env
-extends xs g = g <> foldMap (uncurry bind) xs
+eval g (ExpLetRec [(b, ab)] e) = eval g' e
+  where g' = g & #labels . at b ?~ (g,ab)

-assign :: Loc -> E -> M Answer ()
-assign l e = do
-  use (at l) >>= \case
-    Just _ -> at l ?= e
-    Nothing -> wrong [i|#{e}에서 #{l}이라는 주소는 없다|]
-
-
-
-- | The denotation of an expressed value.
-data E
-  = ESymbol Text
-  | ECharacter Char
-  | EInt Int
-  | EBool Bool
-  | EUndefined
-  | EUnspecified
-  | ENull
-  | EPair Mutability Loc Loc
-  | EVec Mutability (List Loc)
-  | EString Mutability (List Loc)
-  | EProcedure Procedure
-  deriving stock (Show, Generic)
-
-type Procedure = List E -> DynPoints -> M Answer (List E)
-
-eGrammar :: Store -> S.DatumGrammar E
-eGrammar st = S.partialOsi (const . Left $ mempty) go
+eval g (ExpPrim p (MkKappa bs e)) = case evalVal g <$> p of
+  PrimAdd x y -> arithBinop (+) x y
+  PrimMul x y -> arithBinop (*) x y
+  PrimSub x y -> arithBinop (-) x y
+  PrimDiv x y -> arithBinop div x y
+  _ -> error [i|unhandled prim: #{p}|]
  where
-    gofetch x = go $ st ^?! ix x
-    go = \case
-      ESymbol s -> S.Symbol s
-      ECharacter c -> S.Character c
-      EInt n -> S.Number (fromIntegral n)
-      EBool b -> S.Boolean b
-      EUndefined -> S.Unreadable "#<undefined>"
-      EUnspecified -> S.Unreadable "#<unspecified>"
-      EProcedure _ -> S.Unreadable "#<procedure>"
-      ENull -> S.List []
-      EPair _mut car cdr -> S.DotList [gofetch car] (gofetch cdr)
-      EVec _mut xs -> S.Vector . fmap gofetch $ xs
-      EString _mut xs -> S.String _
+    ret rs = eval
+        (g & #vars <>~ envOfBinds bs rs)
+        e
+    arithBinop f (ObjImm (ImmInt x)) (ObjImm (ImmInt y)) =
+      ret [ObjImm . ImmInt $ f x y]
+    arithBinop _ x y = error [i|bad arith: #{x}, #{y}|]

-data DynPoints = MkDynPoints
-  deriving (Generic, Data)
+eval _ e = error [i|unimplemented case: #{e}|]

-
+envOfBinds bs xs = foldMap (uncurry H.singleton) (zip bs xs)

-truthy :: E -> Bool
-truthy (EBool False) = False
-truthy _ = True
+evalVal :: Env -> Val -> Obj
+evalVal g = \case
+  ValVar x -> fromMaybe (error [i|unbound: #{x}|]) $ g ^?! #vars . at x
+  ValImm x -> ObjImm x

-
+emptyEnv :: Env
+emptyEnv = MkEnv
+  { vars = mempty
+  -- a kinda silly hack to make sure `halt` is handled correctly when
+  -- it appears as the tail continuation of an application. the
+  -- special case of `eval` responsible for `halt` only covers terms
+  -- of the form `(continue $halt xs …)`; other terms such as
+  -- `($some-fn xs $halt)` just see an undefined label `$halt`.
+  , labels = H.singleton "halt"
+    ( emptyEnv
+    , AbsKappa' ["h0"] $ Halt [ValVar "h0"]
+    )
+  }

-evalVal :: Env -> Val -> M Answer E
+evalExp :: Exp -> List Obj
+evalExp = eval emptyEnv

-evalVal g (ValVar x) = var g x >>= fetch
-
-evalVal g (ValImm imm) = case imm of
-  ImmLabel (MkLabel l) -> var g l >>= fetch
-  ImmInt n -> pure $ EInt n
-  ImmBool b -> pure $ EBool b
-  ImmUndefined -> pure EUndefined
-
-evalKexp :: Env -> Kexp -> M Answer E
-evalKexp g (KexpVar x) = var g x >>= fetch
-evalKexp g (KexpKappa kap) = evalAbs g (AbsKappa kap)
-
-evalAbs :: Env -> Abs -> M Answer E
-evalAbs g (MkAbs formals ktail e) = pure . EProcedure $ \xs dps ->
-  let
-    formals' = formals ++ foldMap (:[]) ktail
-    lformals = length formals'
-    lxs = length xs
-  in if lformals /= lxs
-  then wrong [i|함수는 #{lformals}개의 인자를 필요로 하는데 #{lxs}개 받았다.|]
-  else do
-    ls <- xs & traverse new'
-    let g' = g & extends (zip formals' ls)
-    eval g' dps e
-
-eval :: Env -> DynPoints -> Exp -> M Answer (List E)
-
-eval g dps (ExpJump f xs ktail) = do
-  f' <- evalVal g f
-  xs' <- traverse (evalVal g) xs
-  ktail' <- traverse (evalKexp g) (ktail ^.. _Just)
-  case f' of
-    EProcedure p -> p (xs' ++ ktail') dps
-    _ -> wrong "bad procedure"
-
-eval g dps (ExpLetRec bs e) = do
-  ls <- for bs . const $ new' EUndefined
-  let g' = g & extends (zip (bs ^.. each . _1) ls)
-  bs' <- forOf (each . _2) bs (evalAbs g')
-  traverse_ (uncurry assign) $ zip ls (bs' ^.. each . _2)
-  eval g' dps e
-
-eval g dps (ExpBuiltin (BuiltinCallCC withcc) k) = do
-  withcc' <- evalVal g withcc >>= orWrong #_EProcedure
-    [i|call/cc: 함수가 아닌 것을 받았다|]
-  k' <- evalKexp g k
-  kproc <- orWrong #_EProcedure [i|call/cc: 몰라...|] k'
-  let cc = EProcedure \xs dps -> case unsnoc xs of
-        Just (xs',_) -> kproc xs' dps
-        Nothing -> wrong [i|call/cc: 잘못하는데!|]
-  withcc' [cc,k'] dps
-
-eval g dps (ExpBuiltin p k) = do
-  p' <- evalBuiltin g dps =<< traverse (evalVal g) p
-  evalKexp g k >>= \case
-    EProcedure fp -> fp p' dps
-    _ -> wrong [i|prim(#{p})의 계속을 나쁘다|]
-
-eval g dps (ExpIf c t f) = do
-  c' <- evalVal g c
-  let b = if truthy c' then t else f
-  var g b >>= fetch >>= \case
-    EProcedure fp -> fp [] dps
-    _ -> wrong [i|if의 계속을 나쁘다|]
-
-eval g dps e = error [i|unimplemented #{e}|]
-
-evalBuiltin :: Env -> DynPoints -> Builtin E -> M Answer (List E)
-evalBuiltin g dps = \case
-  BuiltinAdd x y -> arith2 (+) x y
-  BuiltinMul x y -> arith2 (*) x y
-  BuiltinSub x y -> arith2 (-) x y
-  BuiltinDiv x y -> arith2 div x y
-  BuiltinZeroP x -> pure1 . EBool . isJust $ x ^? #EInt . only 0
-  BuiltinCons x y -> pcons x y >>= pure1
-  BuiltinCar p -> cr p _2
-  BuiltinCdr p -> cr p _3
-  BuiltinPairP p -> pure1 . EBool . maybe False (const True) $
-    p ^? #_EPair
-  BuiltinValues xs -> pure xs
-  BuiltinList xs -> foldrM pcons ENull xs >>= pure1
-  p -> wrong [i|prim(#{p})은 벌써 나지 않다|]
-  where
-    pure1 x = pure [x]
-    pcons x y = do
-      (x',y') <- traverseOf both new' (x,y)
-      pure $ EPair Mut x' y'
-    arith2 f (EInt x) (EInt y) = pure [EInt $ f x y]
-    arith2 f x y = wrong [i|나쁜 인자: #{x}, #{y}|]
-    cr p l = orWrong (#_EPair . l) [i|car/cdr는 pair을 받지 않다|] p
-      >>= fmap (:[]) . fetch
-
-
-
-evalExp :: Jalmot :> es => Exp -> Eff es _
-evalExp e = _
-
-evalProgram :: Jalmot :> es => Program -> Eff es (List S.Datum)
-evalProgram (MkProgram lam) = case run (pure . AnswerValues) of
-  (AnswerError jm, _) -> throwError jm
-  (AnswerValues vs, st) -> traverse (S.toDatum $ eGrammar st) vs
-  where
-    run f = (`runState` emptyStore) . (`runContT` f) $ do
-      g <- setup
-      eval g MkDynPoints (ExpLetRec
-        [("_start",AbsLambda lam)]
-        (ExpApply (ValVar "_start") [] (KexpVar "halt")))
-
-
-
-setup :: M Answer Env
-setup = defines @List
-  [ ("halt", EProcedure prim_halt)
-  ]
-
-prim_halt :: Procedure
-prim_halt xs _dps = ContT \_ -> pure $ AnswerValues xs
+evalProgram :: Program -> List Obj
+evalProgram (MkProgram lam) = eval emptyEnv [cps|
+  (letrec ((start #{lam}))
+    (apply start halt))
+|]
@@ -1,24 +0,0 @@
-module Gyehoek.CPS.Hoist
-  ( hoistProgram
-  ) where
-
-import Gyehoek.CPS.Syntax
-import Gyehoek.Prelude
-import qualified Data.HashMap.Strict as H
-import Effectful.Writer.Static.Local
-import Data.Foldable
-
-
-type Hoist = Writer (HashMap Label Abs)
-
-hoist :: Hoist :> es => Exp -> Eff es Exp
-hoist = transformM \case
-  ExpLetRec bs m -> do
-    traverse_ (\(k,v) -> tell $ H.singleton (MkLabel k) v) bs
-    pure m
-  e -> pure e
-
-hoistProgram :: Program -> Eff es HoistedProgram
-hoistProgram p = do
-  (body,bindings) <- runWriter $ traverseOf #body hoist p.body
-  pure $ MkHoistedProgram {body,bindings}
@@ -0,0 +1,156 @@
+{-# LANGUAGE OverloadedLists #-}
+module Gyehoek.CPS.Stackify
+  ( stackifyProgram
+  , module Gyehoek.CPS.Syntax
+  ) where
+
+import Gyehoek.CPS.Syntax
+import Gyehoek.Stack.Syntax qualified as Stk
+import Data.Sequence (Seq)
+import Data.Sequence qualified as Seq
+import Gyehoek.GenSym
+import Effectful.Writer.Static.Shared
+import Data.Foldable
+import qualified Data.HashMap.Strict as H
+import Data.List (elemIndex, nub)
+import Data.Text qualified as T
+import Gyehoek.Prelude
+import Debug.Pretty.Simple
+import qualified Gyehoek.Sexp as S
+
+
+type Stackify = Writer Stk.Program
+
+runStackify :: Eff (Stackify : es) a -> Eff es (a, Stk.Program)
+runStackify = runWriter
+
+live :: Free a => Env -> a -> List Name
+-- TODO: free' should return an OSet lol
+live g e = nub (free' e) & filter \x ->
+  x `H.member` g.bound
+  -- && not (x `elem` g.contStack)
+
+data BlockBuilder
+  = Code (List Stk.Instr) BlockBuilder
+  | Tail Stk.Tail
+  deriving (Show, Generic)
+
+buildBlock :: BlockBuilder -> Stk.Block
+buildBlock = go [] where
+  go acc (Code xs bb) = go (acc ++ xs) bb
+  go acc (Tail t) = Stk.MkBlock acc t
+
+emitRoutine :: Stackify :> es => Stk.Routine -> Eff es ()
+emitRoutine rt = tell [rt]
+
+stackify
+  :: (GenSym :> es, Stackify :> es)
+  => Env -> Exp -> Eff es BlockBuilder
+
+stackify g (ExpLetRec [(f, kap@(AbsKappa' xs m))] e) = do
+  let vs = (f, Stk.ValLabel f) : (bindReg <$> xs)
+  let ls = live g kap
+  m' <- stackify (g & #bound <>~ H.fromList (vs ++ (bindReg <$> ls))) m
+  emitRoutine $
+    Stk.MkRoutine f xs . buildBlock $
+      -- pop in the opposite order we push
+      Code [Stk.Pop x | x <- reverse ls] m'
+  let g' = g & #bound . at f ?~ Stk.ValLabel f
+             & #liveness . at f ?~ ls
+  stackify g' e
+
+stackify g (ExpLetRec [(f, AbsLambda lam)] e) = do
+  emitRoutine =<< stackifyLambda g f lam
+  stackify (g & #bound . at f ?~ Stk.ValLabel f) e
+
+stackify g (ExpIf c t f) = do
+  let c' = stackifyVal g c
+  t' <- buildBlock <$> stackify g t
+  f' <- buildBlock <$> stackify g f
+  pure . Tail $ Stk.If c' t' f'
+
+stackify g (ExpApply f xs ktail) = pure $
+    Code [ Stk.Push (Stk.ValReg l) | l <- ls ] $
+    Tail (Stk.TailCall (stackifyVal g f) (k : (stackifyVal g <$> xs)))
+  where
+    k = var g ktail
+    ls = fold $ (k ^? #ValImm . #ImmLabel)
+      >>= \klbl -> g ^. #liveness . at klbl
+
+stackify g e@(ExpContinue k xs) = do
+  pure $
+    Code [ Stk.Push (Stk.ValReg l) | l <- ls ] $
+    Tail (Stk.TailCall k' (stackifyVal g <$> xs))
+  where
+    k' = stackifyVal g k
+    ls = fold $ (k' ^? #ValImm . #ImmLabel)
+      >>= \klbl -> g ^. #liveness . at klbl
+
+stackify g (ExpPrim p (MkKappa [x] e)) = do
+  e' <- stackify (g & #bound . at x ?~ Stk.ValReg x) e
+  pure $
+    Code [ Stk.Prim x (stackifyVal g <$> p) ] e'
+
+stackify _ e = error [i|unimplemented exp: #{e}|]
+
+-- affine
+_ValName :: Traversal' Val Name
+_ValName = failing #ValVar (#ValImm . #ImmLabel)
+
+stackifyLambda
+  :: (Stackify :> es, GenSym :> es)
+  => Env -> Name -> Lambda -> Eff es Stk.Routine
+stackifyLambda g name (MkLambda xs k m) = do
+  let vs = [ (x, Stk.ValReg x) | x <- k:xs ]
+  m' <- stackify (g & #bound <>~ H.fromList vs) m
+  pure $ Stk.MkRoutine name (k:xs) (buildBlock m')
+
+stackifyVal :: Env -> Val -> Stk.Val
+stackifyVal g = \case
+  ValImm imm -> Stk.ValImm imm
+  ValVar v -> var g v
+  v -> error [i|unimplemented val: #{v}|]
+
+var :: Env -> Name -> Stk.Val
+var g v = case g ^. #bound . at v of
+  Just x -> x
+  Nothing -> Stk.ValLabel v
+
+bindReg :: Name -> (Name, Stk.Val)
+bindReg x = (x, Stk.ValReg x)
+
+
+
+data Env = MkEnv
+  { bound :: HashMap Name Stk.Val
+  -- | for each locally-bound continuation @k@, @liveness@ has an
+  -- entry @(k,ls)@ where @ls@ is the sequence of registers @k@
+  -- expects to find saved on the stack.
+  , liveness :: HashMap Name (List Name)
+  }
+  deriving (Show, Generic)
+
+emptyEnv :: Env
+emptyEnv = MkEnv mempty mempty
+
+
+
+stackifyProgram :: GenSym :> es => Program -> Eff es Stk.Program
+stackifyProgram (MkProgram lam) = do
+  let g = emptyEnv
+  (start,p) <- runStackify $ stackifyLambda g "start" lam
+  pure $ p <> [ start ]
+
+letfn :: Program
+letfn = [cps|
+(λ (start-ktail0)
+  (letrec ((lambda-body1
+            (λ (x lambda-tail2)
+              (prim (* x x) (κ (r3) (continue lambda-tail2 r3))))))
+    (letrec ((let-body6
+              (κ (square)
+                (letrec ((r4 (κ (x5) (continue start-ktail0 x5))))
+                  (square 4 r4)))))
+      (continue let-body6 lambda-body1))))
+|]
+
@@ -10,22 +10,18 @@ module Gyehoek.CPS.Syntax
  , Kappa(..)
  , Lambda(..)
  , Exp(..)
-  , Kexp(..)
  , ExpF(..)
  , Name(..)
-  , Builtin(..)
+  , Prim(..)
  , Program(..)
-  , HoistedProgram(..)
  , Lit(..)
  , Imm(..)
  , Obj(..)
  , Hob(..)
-  , Label(..)
-  , Reg(..)
  , pattern Halt
  , pattern Halt1
  , _MkKappa
-  , _ExpBuiltin
+  , _ExpPrim
  , _ExpLetRec
  , _ExpApply
  , _AbsLambda'
@@ -40,17 +36,11 @@ module Gyehoek.CPS.Syntax
  , Abs(..)
  , Free(..)
  , pattern ValLabel
-  , pattern ObjLabel
-  , absBody
-  , pattern MkAbs
-  , _MkAbs
-  , unhoist
-  , pattern ExpJump
-  , _ExpJump
+  , labelName -- don't like that this is part of the api
  )
  where

-import Gyehoek.Scheme.Syntax (Name (..), Builtin(..), builtinDatumIso, Lit(..))
+import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primDatumIso, Lit(..))
 import Gyehoek.Sexp qualified as S
 import Control.Category
 import Prelude hiding ((.), id)
@@ -62,12 +52,6 @@ import Gyehoek.Prelude hiding (op)
 import Gyehoek.Sexp (Datum)
 import Gyehoek.Sexp (G, (:-)(..))
 import qualified Data.InvertibleGrammar.Base as IG
-import Gyehoek.GenSym (Gen)
-import Data.String (IsString)
-import Control.Applicative
-import qualified Data.HashMap.Strict as H
-import GHC.Records (HasField (..))
-import Data.Bifunctor

 -- Data types

@@ -76,24 +60,13 @@ data Val
  | ValVar Name
  deriving (Show, Generic, Data, Eq)

-pattern ValLabel :: Label -> Val
+pattern ValLabel :: Name -> Val
 pattern ValLabel x = ValImm (ImmLabel x)

-newtype Label = MkLabel { inner :: Name }
-  deriving stock (Generic, Data)
-  deriving newtype (Show, Eq, Gen, IsString, Hashable)
-  deriving anyclass (NFData, Wrapped)
-
-newtype Reg = MkReg { inner :: Name }
-  deriving stock (Generic, Data)
-  deriving newtype (Show, Eq, Gen, IsString, Hashable)
-  deriving anyclass (NFData, Wrapped)
-
 data Imm
  = ImmInt Int
  | ImmBool Bool
-  | ImmLabel Label
-  | ImmUndefined
+  | ImmLabel Name
  deriving stock (Show, Generic, Data, Eq)
  deriving anyclass (NFData)

@@ -103,14 +76,9 @@ data Obj
  deriving stock (Show, Generic, Data, Eq)
  deriving anyclass (NFData)

-pattern ObjLabel l = ObjImm (ImmLabel l)
-
 -- | a heap object.
 data Hob
-  = HobClosure { label :: Label, env :: List Obj }
-  -- should a continuation have a label, or an Obj?
-  | HobContinuation { cont :: Obj, stack :: NonEmpty (List Obj) }
-  | HobPair Obj Obj
+  = HobClosure { label :: Name, env :: List Obj }
  deriving stock (Show, Generic, Data, Eq)
  deriving anyclass (NFData)

@@ -125,60 +93,24 @@ data Abs
  | AbsLambda Lambda
  deriving (Show, Generic, Data, Eq)

-pattern AbsKappa' :: List Name -> Exp -> Abs
+pattern AbsKappa' :: [Name] -> Exp -> Abs
 pattern AbsKappa' xs e = AbsKappa (MkKappa xs e)

-pattern AbsLambda' :: List Name -> Name -> Exp -> Abs
+pattern AbsLambda' :: [Name] -> Name -> Exp -> Abs
 pattern AbsLambda' xs e ktail = AbsLambda (MkLambda xs e ktail)

-{-# COMPLETE AbsKappa', AbsLambda' #-}
-
-_MkAbs :: Iso' Abs (List Name, Maybe Name, Exp)
-_MkAbs = iso
-  (\case
-    AbsKappa' xs e -> (xs,Nothing,e)
-    AbsLambda' xs ktail e -> (xs,Just ktail,e))
-  (\(xs,ktail,e) -> case ktail of
-    Just k -> AbsLambda' xs k e
-    Nothing -> AbsKappa' xs e)
-
-pattern MkAbs :: List Name -> Maybe Name -> Exp -> Abs
-pattern MkAbs xs ktail body <- (view _MkAbs -> (xs,ktail,body))
-  where MkAbs xs ktail body = review _MkAbs (xs,ktail,body)
-
-{-# COMPLETE MkAbs #-}
-
-_ExpJump :: Prism' Exp (Val, List Val, Maybe Kexp)
-_ExpJump = prism'
-  (\(f,xs,ktail) -> case ktail of
-    Just k -> ExpApply f xs k
-    Nothing -> ExpContinue f xs)
-  \case
-    ExpApply f xs ktail -> Just (f,xs,Just ktail)
-    ExpContinue f xs -> Just (f,xs,Nothing)
-    _ -> Nothing
-
-pattern ExpJump :: Val -> List Val -> Maybe Kexp -> Exp
-pattern ExpJump f xs ktail <- (preview _ExpJump -> Just (f,xs,ktail))
-  where ExpJump f xs ktail = review _ExpJump (f,xs,ktail)
-
 data Exp
-  = ExpBuiltin (Builtin Val) Kexp
+  = ExpPrim (Prim Val) Kappa
  | ExpLetRec { binders :: List (Name, Abs), body :: Exp }
  | ExpContinue Val (List Val)
-  | ExpIf Val Name Name
+  | ExpIf Val Exp Exp
  | ExpApply
    { op :: Val
    , args :: List Val
-    , cont :: Kexp
+    , cont :: Name
    }
  deriving (Show, Generic, Data, Eq)

-data Kexp
-  = KexpVar Name
-  | KexpKappa Kappa
-  deriving (Show, Generic, Data, Eq)
-
 pattern Halt :: List Val -> Exp
 pattern Halt xs = ExpContinue (ValLabel "halt") xs

@@ -193,22 +125,6 @@ data Program = MkProgram
  }
  deriving (Show, Generic, Data)

-data HoistedProgram = MkHoistedProgram
-  { bindings :: HashMap Label Abs
-  , body :: Lambda
-  }
-  deriving stock (Show, Generic, Data)
-
-type instance Index HoistedProgram = Label
-type instance IxValue HoistedProgram = Abs
-
-instance Ixed HoistedProgram where ix j = #bindings . ix j
-
-instance At HoistedProgram where at j = #bindings . at j
-
-instance Each HoistedProgram HoistedProgram Abs Abs where
-  each = #bindings . each
-
 makePrisms ''Kappa
 makePrisms ''Exp
 makeFieldsId ''Exp
@@ -232,21 +148,6 @@ _AbsLambda' = prism'

 instance Plated Exp where plate = uniplate

-absBody :: Lens' Abs Exp
-absBody = lens
-  (\case
-    AbsLambda lam -> lam.body
-    AbsKappa kap -> kap.body)
-  (\cases
-    (AbsLambda lam) b -> AbsLambda $ lam & #body .~ b
-    (AbsKappa kap) b -> AbsKappa $ kap & #body .~ b)
-
-unhoist :: HoistedProgram -> Program
-unhoist p =
-  MkProgram $ p.body & body %~ ExpLetRec
-    (p ^.. #bindings . itraversed . withIndex
-      . to (\(MkLabel l, ab) -> (l,ab)))
-

 -- DatumIso instances

@@ -266,44 +167,26 @@ instance S.DatumIso Imm where
  datumIso = S.match
    $ S.With (. S.int)
    $ S.With (. S.datumIso)
-    $ S.With (. S.datumIso)
-    $ S.With (. S.unreadable (const "#<undefined>"))
+    $ S.With (. labelName)
    $ S.End

-instance S.DatumIso Label where
-  datumIso = S.with \g -> S.coproduct
-    [ S.decorate S.SynConstant >>> S.datumIso @Name >>> S.prismIso
-          (S.expected "label")
-          (prefixed @Name "$")
-    , S.list $ S.el (S.sym "$") >>> S.el (S.datumIso @Name)
-    ]
-    >>> g
-
-instance S.DatumIso Reg where
-  datumIso = S.with \g ->
-    S.decorate S.SynVariable >>> S.datumIso @Name >>> S.prismIso
-      (S.expected "register")
-      (prefixed @Name "%")
-    >>> g
+labelName :: S.DatumGrammar Name
+labelName = S.coproduct
+  [ S.decorate S.SynConstant >>> S.datumIso @Name >>> S.prismIso
+        (S.expected "label")
+        (prefixed @Name "$")
+  , S.list $ S.el (S.sym "$") >>> S.el (S.datumIso @Name)
+  ]

 instance S.DatumIso Hob where
  datumIso = S.match
    $ S.With (. closure)
-    $ S.With (. cont)
-    $ S.With (. conspair)
    $ S.End
    where
-      conspair = S.dottedList (S.el S.datumIso) S.datumIso
      -- closures can be printed, but not parsed.
-      closure :: G (Datum :- t) (List Obj :- Label :- t)
+      closure :: G (Datum :- t) (List Obj :- Name :- t)
      closure = IG.Flip $ IG.PartialIso
-        (\(env:-code:-t) -> S.Unreadable [i|\#<procedure $#{code}>|] :- t)
-        (const . Left $ mempty)
-      cont :: G (Datum :- t) (NonEmpty (List Obj) :- _ :- t)
-      cont = IG.Flip $ IG.PartialIso
-        (\(_ :- l :- t) -> 
-          let x = S.encodeOrShow' @Text S.datumIso l
-          in S.Unreadable [i|\#<continuation #{x}>|] :- t)
+        (\(env:-code:-t) -> [S.sx|(<closure> #{code} ##{env})|] :- t)
        (const . Left $ mempty)

 instance S.DatumIso Lambda where
@@ -335,7 +218,7 @@ instance S.DatumIso Abs where

 instance S.DatumIso Exp where
  datumIso = S.match
-    $ S.With (. builtin)
+    $ S.With (. prim)
    $ S.With (. letrec)
    $ S.With (. continue)
    $ S.With (. if_)
@@ -350,56 +233,35 @@ instance S.DatumIso Exp where
      if_ = S.ifLike "if"
        S.datumIso S.datumIso S.datumIso
      app :: forall t.
-        G (Datum :- t) (Kexp :- List Val :- Val :- t)
-      app = S.list $
-        S.flipped (S.PartialIso
-          (\(S.MkListContext ctx :- t) ->
-            case ctx of
-              f:kexp:xs -> S.MkListContext (f : snoc xs kexp) :- t
-              _ -> error "unreachable")
-          (\(S.MkListContext ctx :- t) ->
-            case unsnoc ctx of
-              Just (f:xs,kexp) -> Right $ S.MkListContext (f:kexp:xs) :- t
-              _ -> Left $ S.expected "continuation arg"))
-        >>> S.el (S.datumIso @Val)
-        >>> S.el (S.datumIso @Kexp)
+        G (Datum :- t) (Name :- ([Val] :- (Val :- t)))
+      app = S.list $ S.el (S.datumIso @Val)
+        -- >>> S.flipped Gyehoek.Datum.nonEmptyGrammar
        >>> S.rest (S.datumIso @Val)
-        >>> S.onTail S.swap
-      builtin = S.list $
-        S.el (S.decorate S.SynBuiltin >>> S.sym "builtin")
-        >>> S.el (builtinDatumIso id (S.datumIso @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"
+                      ))
+      -- prim = S.headTagged2 "prim"
+      --   (primDatumIso id (S.datumIso @Val))
+      --   (S.datumIso @Kappa)
+      prim = S.list $
+        S.el (S.decorate S.SynBuiltin >>> S.sym "prim")
+        >>> S.el (primDatumIso id (S.datumIso @Val))
        >>> S.el S.datumIso

-instance S.DatumIso Kexp where
-  datumIso = S.match
-    $ S.With (S.datumIso @Name >>>)
-    $ S.With (S.datumIso @Kappa >>>)
-    $ S.End
-
 instance S.DatumIso Program where
  datumIso = S.with \prog -> S.datumIso @Lambda >>> prog

-- the printed representation is pretty dishonest in its current
-- state. consider the following hoisted program:
-- 
--  (letrec ((k (κ () (continue start-ktail 123))))
--    (λ (start-ktail)
--      (continue k)))
-- 
-- here, `start-ktail` is bound in `k`, but the printed representation
-- fails to reflect that.
-instance S.DatumIso HoistedProgram where
-  datumIso = S.with \prog ->
-    S.letLike "letrec"
-      (S.datumIso @Label) (S.datumIso @Abs) (S.datumIso @Lambda)
-    >>> S.onTail (S.iso H.fromList H.toList)
-    >>> prog
-

 -- quasiquoters

 class Data a => CPS a where
-  toCPS :: HasCallStack => Datum -> a
+  toCPS :: Datum -> a

 instance CPS Exp where toCPS = S.fromDatumUnsafe S.datumIso
 instance CPS Val where toCPS = S.fromDatumUnsafe S.datumIso
@@ -407,7 +269,6 @@ instance CPS Kappa where toCPS = S.fromDatumUnsafe S.datumIso
 instance CPS Lambda where toCPS = S.fromDatumUnsafe S.datumIso
 instance CPS Abs where toCPS = S.fromDatumUnsafe S.datumIso
 instance CPS Program where toCPS = S.fromDatumUnsafe S.datumIso
-instance CPS HoistedProgram where toCPS = S.fromDatumUnsafe S.datumIso

 cps :: S.QuasiQuoter
 cps = S.makeSx' [| toCPS |]
@@ -430,8 +291,7 @@ class Free a where
  freeWithBound :: HashSet Name -> a -> HashSet Name
  freeWithBound bound = HS.fromList . freeWithBound' bound

-  -- | Free variables given in the same left-to-right order they
-  -- appear.
+  -- | Free variables given in the order of their appearance.
  free' :: a -> List Name
  free' = freeWithBound' mempty

@@ -441,21 +301,11 @@ instance Free Abs where
  freeWithBound' bound (AbsKappa kap) = freeWithBound' bound kap
  freeWithBound' bound (AbsLambda lam) = freeWithBound' bound lam

-mif :: Alternative f => (a -> Bool) -> a -> f a
-mif p a
-  | p a = pure a
-  | otherwise = empty
-
-instance Free Kexp where
-  freeWithBound' bound = \case
-    KexpVar x -> mif (`notElem` bound) x
-    KexpKappa kap -> freeWithBound' bound kap
-
 instance Free Exp where
  freeWithBound' bound = \case
-    ExpBuiltin p k ->
-      (p ^.. folded . #ValVar . filtered (`notElem` bound))
-      ++ freeWithBound' bound k
+    ExpPrim p k ->
+      p & toListOf (folded . #ValVar . filtered (`notElem` bound))
+        & (<> freeWithBound' bound k)
    ExpLetRec bs m ->
      foldMapOf (each . _2) (freeWithBound' bound') bs
      <> freeWithBound' bound' m
@@ -463,10 +313,10 @@ instance Free Exp where
    ExpContinue k xs -> filter (`notElem` bound) ((k:xs) ^.. each . #ValVar)
    ExpIf c t f ->
      (c ^.. #ValVar . filtered (`notElem` bound))
-      <> mif (`notElem` bound) t <> mif (`notElem` bound) f
+      <> freeWithBound' bound t <> freeWithBound' bound f
    ExpApply f xs k ->
      (f:xs) ^.. (each . #ValVar . filtered (`notElem` bound))
-      <> freeWithBound' bound k
+      <> (k ^.. filtered (`notElem` bound))

 instance Free Kappa where
  freeWithBound' bound (MkKappa xs m) =
@@ -1,5 +1,5 @@
 module Gyehoek.Driver
-  (main, convert_e2e, parse_e2e, readScm, eval_cps1_e2e, eval_cps2_e2e)
+  (main, lower_e2e, convert_e2e, parse_e2e, readScm, eval_e2e)
  where

 import Gyehoek.Options
@@ -17,6 +17,7 @@ import qualified Data.Text.Encoding as T
 import System.IO (Handle)
 import System.IO qualified as IO
 import Gyehoek.CPS.Convert
+import Gyehoek.Stack.Lower
 import Gyehoek.CPS.Eval qualified as CPS
 import Control.Monad
 import Text.Pretty.Simple (pShowNoColor)
@@ -24,14 +25,16 @@ import System.Process.Typed
 import System.Environment.Blank (getEnvDefault)
 import qualified Data.Text.IO as TIO
 import qualified Data.ByteString.Lazy as BS
+import Gyehoek.CPS.Stackify (stackifyProgram)
+import Gyehoek.Stack.VM (eval, writeObj, Obj)
 import qualified Data.Text as T
+import Gyehoek.Stack.Syntax qualified as Stk
 import Gyehoek.CPS.Close (closeProgram)
 import Control.Lens.Extras (is)
 import Control.Arrow ((>>>))
 import Gyehoek.Prelude
 import Gyehoek.Jalmot
 import qualified Gyehoek.Sexp as S
-import Gyehoek.CPS.Hoist (hoistProgram)


 main :: IO ()
@@ -115,20 +118,27 @@ driver opts = do
    hPutStrLn FS.stdout . view strict . pShowNoColor $ scm
  cps <- convertProgram scm
  when opts.dumpCPS do
-     S.writeDatum cps
+     hPutStrLn FS.stdout =<< S.encodeWith S.datumIso cps
  closedCps <- closeProgram cps
  when opts.dumpClosed do
-    S.writeDatum closedCps
-  hoistedCps <- hoistProgram closedCps
-  when opts.dumpHoisted do
-    S.writeDatum hoistedCps
+    hPutStrLn FS.stdout =<< S.encodeWith S.datumIso closedCps
  let rt_is p = is (_Just . p) opts.runtime
-  when (rt_is #HigherOrderCPS) do
-    CPS.evalProgram cps
-      >>= S.writeData
+  dumpOrRun opts.dumpStackified (rt_is #Stackify)
+    (stackifyProgram closedCps)
+    (hPutStrLn FS.stdout <=< S.encodeDataWith S.dataIso)
+    (eval >>> fmap writeObj
+         >>> T.unwords
+         >>> hPutStrLn FS.stdout)
  when (rt_is #CPS) do
-    CPS.evalProgram closedCps
-      >>= S.writeData
+    closedCps
+      & CPS.evalProgram
+      & fmap writeObj
+      & T.unwords
+      & hPutStrLn FS.stdout
+  -- dumpOrRun opts.inspectWasm (rt_is #Wasm)
+  --   (lowerProgram cps)
+  --   inspectWasm
+  --   (\wat -> withFile opts.output FS.WriteMode \h -> hPutStrLn h wat)

 parse_e2e :: FilePath -> IO Scm.Program
 parse_e2e = runJalmotIO . runFileSystem . readScm
@@ -137,18 +147,12 @@ convert_e2e :: FilePath -> IO CPS.Program
 convert_e2e = runJalmotIO . runFileSystem . runGenSym
  . (closeProgram <=< convertProgram <=< readScm)

-eval_cps1_e2e :: FilePath -> IO Text
-eval_cps1_e2e fp = runJalmotIO . runFileSystem . runGenSym $
-  readScm fp
-   >>= convertProgram
-   >>= closeProgram
-   >>= CPS.evalProgram
-   >>= pure . S.encodeOrShowData' S.dataIso
+lower_e2e :: FilePath -> IO Text
+lower_e2e =
+  runJalmotIO . runFileSystem . runGenSym
+  . (lowerProgram <=< closeProgram <=< convertProgram <=< readScm)

-eval_cps2_e2e :: FilePath -> IO Text
-eval_cps2_e2e fp = runJalmotIO . runFileSystem . runGenSym $
-  readScm fp
-   >>= convertProgram
-   -- >>= closeProgram
-   >>= CPS.evalProgram
-   >>= pure . S.encodeOrShowData' S.dataIso
+eval_e2e :: FilePath -> IO (List Obj)
+eval_e2e fp = runJalmotIO . runFileSystem . runGenSym $ do
+  stk <- stackifyProgram <=< closeProgram <=< convertProgram <=< readScm $ fp
+  pure . eval $ stk
@@ -8,7 +8,6 @@ module Gyehoek.Jalmot
  , runJalmotIO
  , runJalmotIOE
  , runJalmotUnsafe
-  , runJalmotCS
  )
  where

@@ -30,8 +29,6 @@ deriving instance Data p => Data (Grammar.ErrorMessage p)
 data AJalmot
  = ReaderError (ParseErrorBundle Text Void)
  | GrammarError (Grammar.ErrorMessage Ann)
-  | VMError Text
-  | EvalError Text
  deriving (Show, Generic, Data)

 data AJalmotCS = MkAJalmotCS !CallStack !AJalmot
@@ -42,9 +39,6 @@ type Jalmot = Error AJalmot
 runJalmot :: Eff (Jalmot : es) a -> Eff es (Either (CallStack, AJalmot) a)
 runJalmot = runError

-runJalmotCS :: Eff (Jalmot : es) a -> Eff es (Either AJalmotCS a)
-runJalmotCS = (mapped . _Left %~ uncurry MkAJalmotCS) . runError
-
 runJalmotIOE :: IOE :> es => Eff (Jalmot : es) a -> Eff es a
 runJalmotIOE eff =
  runJalmot eff >>= \case
@@ -66,8 +60,6 @@ instance Exception AJalmot where
        pretty err
        & layoutPretty defaultLayoutOptions
        & renderString
-    VMError err -> [i|#{err}|]
-    EvalError err -> [i|#{err}|]

 instance Exception AJalmotCS where
  backtraceDesired = const False
@@ -1,4 +0,0 @@
-module Gyehoek.Language
-  (
-  ) where
-
@@ -13,13 +13,14 @@ import Data.Foldable
 import Gyehoek.Prelude hiding (argument)


-data Runtime = Wasm | CPS | HigherOrderCPS
+data Runtime = Stackify | Wasm | CPS
  deriving (Show, Generic, Eq)

 data Language
  = LanguageScheme
  | LanguageCPS
  | LanguageClosed
+  | LanguageStackified
  | LanguageWasm
  deriving (Show, Generic, Eq)

@@ -27,30 +28,29 @@ data Options = MkOptions
  { dumpClosed :: Bool
  , dumpCPS :: Bool
  , dumpParsed :: Bool
-  , dumpHoisted :: Bool
-  , noColour :: Bool
+  , dumpStackified :: Bool
  , runtime :: Maybe Runtime
  , inspectWasm :: Bool
  , output :: FilePath
  , sourceFile :: FilePath
  , sourceLanguage :: Language
-  , targetLanguage :: Language
  }
  deriving (Show, Generic)

-languageValues = ["scheme","cps","closed","wasm"]
+languageValues = ["scheme","cps","closed","stackified","wasm"]
 languageReader = maybeReader \case
  "scheme" -> Just LanguageScheme
  "cps" -> Just LanguageCPS
  "closed" -> Just LanguageClosed
+  "stackified" -> Just LanguageStackified
  "wasm" -> Just LanguageWasm
  _ -> Nothing

 runtimeValues = ["stackify","wasm","cps","none"]
 runtimeReader = maybeReader \case
+  "stackify" -> Just (Just Stackify)
  "wasm" -> Just (Just Wasm)
-  "cps1" -> Just (Just CPS)
-  ("cps";"higher-order-cps") -> Just (Just HigherOrderCPS)
+  "cps" -> Just (Just CPS)
  "none" -> Just Nothing
  _ -> Nothing

@@ -58,19 +58,15 @@ parser :: Parser Options
 parser = do
  dumpClosed <- switch (long "dump-closed")
  dumpCPS <- switch (long "dump-cps")
+  dumpStackified <- switch (long "dump-stackified")
  dumpParsed <- switch (long "dump-parsed")
-  dumpHoisted <- switch (long "dump-hoisted")
-  noColour <- switch . fold $
-    [ long "no-colour"
-    , long "no-color"
-    ]
  inspectWasm <- switch $ long "inspect-wasm" <> short 'p'
  runtime <- option runtimeReader . fold $
    [ long "runtime"
    , short 'R'
-    , value (Just HigherOrderCPS)
+    , value (Just Stackify)
    , completeWith runtimeValues
-    , showDefaultWith $ const "higher-order-cps"
+    , showDefaultWith $ const "stackify"
    , metavar "RUNTIME"
    ]
  sourceLanguage <- option languageReader . fold $
@@ -81,14 +77,6 @@ parser = do
    , showDefaultWith $ const "scheme"
    , metavar "LANGUAGE"
    ]
-  targetLanguage <- option languageReader . fold $
-    [ long "target"
-    , short 'T'
-    , value LanguageCPS
-    , completeWith languageValues
-    , showDefaultWith $ const "cps"
-    , metavar "LANGUAGE"
-    ]
  output <- strOption . fold $
    [ long "output"
    , short 'o'
@@ -19,7 +19,6 @@ module Gyehoek.Prelude
  , (>>>)
  , (>=>)
  , (<=<)
-  , wrappedIso
  ) where

 import Control.Lens hiding (List, (:<))
@@ -41,5 +40,4 @@ import Data.List.NonEmpty (NonEmpty((:|)))
 import Numeric.Natural (Natural)
 import Control.Category ((>>>))
 import Control.Monad
-import Data.Generics.Wrapped (Wrapped(..))

@@ -1,536 +0,0 @@
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE TypeFamilies #-}
-module Gyehoek.Scheme.Expand
-  (
-  ) where
-
-import Gyehoek.Sexp.Syntax
-import Gyehoek.Sexp qualified as S
-import Gyehoek.Prelude
-import Gyehoek.Scheme.Syntax hiding (Prim(..))
-import Gyehoek.Scheme.Syntax qualified as Scm
-import qualified Data.HashSet as HS
-import qualified Data.HashMap.Strict as H
-import Data.Foldable
-import Data.These
-import Data.Zip
-import Prelude hiding (filter, zip, mapMaybe)
-import qualified Data.List.NonEmpty as NE
-import Data.Monoid (Ap(Ap, getAp))
-import Gyehoek.Sexp.Grammar.Base ((:-)(..))
-import Control.Lens.Extras (is)
-import Control.Applicative (Alternative(..))
-import Gyehoek.GenSym
-import Data.HashSet.Lens (setOf)
-import Data.List (sort)
-import GHC.Exts (IsList(..))
-import Gyehoek.Jalmot
-import Data.Maybe (isNothing)
-import Data.Kind (Type)
-import Data.Traversable (for, mapAccumR)
-import Effectful.State.Dynamic
-import Witherable
-import Data.Semigroup (Arg(..))
-import Data.Ord (Down(..))
-import qualified Data.Scientific as Sci
-
-
-data Bind
-  = BindLexical { symbol :: Name, identity :: Natural }
-  | BindGlobal { symbol :: Name }
-  deriving stock (Generic, Eq, Show)
-  deriving anyclass (Hashable)
-
-newtype Scope = MkScope { identity :: Natural }
-  deriving stock (Show, Generic, Eq, Ord)
-  deriving anyclass (Hashable)
-  deriving newtype (Gen)
-
-type ScopeSet = HashSet Scope
-
-data Formals
-  = FormalsFixed (List Name)
-  | FormalsRest (List Name) Name
-  deriving (Show, Generic)
-
-data PrimLambda e = MkPrimLambda Formals (List e)
-  deriving (Show, Generic, Functor, Foldable, Traversable)
-data PrimLet e = MkPrimLet (Maybe Name) (List (Name, e)) (List e)
-  deriving (Show, Generic, Functor, Foldable, Traversable)
-data PrimIf e = MkPrimIf e e (Maybe e)
-  deriving (Show, Generic, Functor, Foldable, Traversable)
-data PrimLetSyntax e = MkPrimLetSyntax (List (Name, e)) (List e)
-  deriving (Show, Generic, Functor, Foldable, Traversable)
-
-data Prim e
-  = PrimLambda (PrimLambda e)
-  | PrimLet (PrimLet e)
-  | PrimIf (PrimIf e)
-  | PrimLetSyntax (PrimLetSyntax e)
-  | PrimSyntaxRules Trans
-  deriving (Show, Generic)
-
-data Key = MkKey Name (HashSet Scope)
-  deriving stock (Show, Generic, Eq)
-  deriving anyclass (Hashable)
-
-
-
-instance S.DatumIso Scope where
-  datumIso = S.with (S.datumIso >>>)
-
-hashSetGrammar
-  :: forall a. (Hashable a, Ord a)
-  => S.DatumGrammar a -> S.DatumGrammar (HashSet a)
-hashSetGrammar g =
-  S.list (S.rest g)
-  >>> S.iso HS.fromList (sort . HS.toList)
-
-instance S.DatumIso Key where
-  datumIso = S.with \g ->
-    S.list
-      ( S.el (S.symBuiltin "@")
-      >>> S.el (S.datumIso @Name)
-      >>> S.el (hashSetGrammar S.datumIso)
-      )
-    >>> g
-
-instance S.DatumIso Formals where
-  datumIso = S.match
-    $ S.With (fixed >>>)
-    $ S.With (rest >>>)
-    $ S.End
-    where
-      fixed :: S.G (Datum :- t) (List Name :- t)
-      fixed = S.list $ S.rest $ S.datumIso @Name
-      rest :: S.G (Datum :- t) (Name :- List Name :- t)
-      rest = S.coproduct
-        [ S.dottedList (S.rest $ S.datumIso @Name) (S.datumIso @Name)
-        , S.datumIso @Name >>> S.onTail (S.push [] null (const mempty))
-        ]
-
-optEl
-  :: S.G (S.Datum :- t) (a :- t)
-  -> S.G (S.ListContext :- t) (S.ListContext :- Maybe a :- t)
-optEl g =
-  S.coproduct
-    [ S.el g >>> S.onTail (S.partialIso Just \case
-      Nothing -> Left mempty
-      Just x -> Right x)
-    , S.onTail $ S.push Nothing isNothing (const mempty)
-    ]
-
-anykw :: Text -> S.G (Datum :- t) t
-anykw s = S.Flip $ S.PartialIso
-  (\t -> adorn SynBuiltin (Symbol s) :- t)
-  \case
-    (Symbol _ :- t) -> Right t
-    _ -> Left $ S.expected "symbol"
-
-prim_if :: S.DatumIso e => S.DatumGrammar (PrimIf e)
-prim_if = S.with \g ->
-  S.listWithIndentation (NSpecial 1)
-    (S.el (anykw "if")
-    >>> S.el S.datumIso
-    >>> S.el S.datumIso
-    >>> optEl S.datumIso)
-  >>> g
-
-prim_lambda :: S.DatumIso e => S.DatumGrammar (PrimLambda e)
-prim_lambda = S.with \g ->
-  S.lambdaLike (anykw "λ") (S.datumIso @Formals) (S.rest S.datumIso)
-  >>> g
-
-prim_let
-  :: forall e. S.DatumIso e => S.DatumGrammar (PrimLet e)
-prim_let = S.with \g ->
-  (S.listWithIndentation (NSpecial 1) $
-    S.el (anykw "let")
-    >>> optEl (S.datumIso @Name)
-    >>> S.el (S.list $ S.rest $ S.datumIso @(Name,e))
-    >>> S.rest S.datumIso)
-  >>> g
-
-prim_let_syntax :: S.DatumIso e => S.DatumGrammar (PrimLetSyntax e)
-prim_let_syntax = S.with \g ->
-  (S.listWithIndentation (NSpecial 1) $
-    S.el (anykw "let-syntax")
-    >>> S.el (S.list $ S.rest $ S.datumIso)
-    >>> S.rest S.datumIso)
-  >>> g
-
-instance S.DatumIso Bind where
-  datumIso = S.match
-    $ S.With (\g ->
-      S.list (S.el (S.symBuiltin "L") >>> S.el S.datumIso >>> S.el S.datumIso)
-      >>> g)
-    $ S.With (\g ->
-      S.list (S.el (S.symBuiltin "G") >>> S.el S.datumIso)
-      >>> g)
-    $ S.End
-
-
-
-{- |
-
-* Examples
-
->>> :set -XTemplateHaskellQuotes
->>> pat = S.makeSx [|| S.fromDatumUnsafe @Pat S.datumIso ||]
->>> match [] [pat|(x . y)|] [S.sx|(1 2 . 2)|]
-Nothing
->>> match [] [pat|(x . y)|] [S.sx|(1 . 2)|]
-Just
-...
->>> match ["=>"] [pat|(x => y)|] [S.sx|(1 => 2)|]
-Just
-...
->>> match ["=>"] [pat|(x => y)|] [S.sx|(1 -> 2)|]
-Nothing
-}
-match :: Foldable f
-  => f Text
-  -- ^ Literal keywords
-  -> Pat
-  -> Datum
-  -> Maybe (HashMap Name Datum)
-match kws p = getAp . match' p where
-
-  match' :: Pat -> Datum -> Ap Maybe (HashMap Name Datum)
-  
-  match' PatWildcard _ = pure mempty
-  
-  match' (PatVar x) e
-    | coerce x `elem` kws = case e of
-      Symbol x' | coerce x == x' -> pure mempty
-      _                          -> empty
-    | otherwise = pure $ H.singleton x e
-  
-  match' (PatList ps Nothing Nothing) (List es) = matches ps es
-  
-  match' (PatList ps (Just []) Nothing) (List es) = do
-    let (ps',p) = ps ^?! _Snoc
-    (r,rest) <- fold $ alignWith f ps' es
-    rest' <- rest
-      & fmap (fmap (fmap (:[])) . match' p)
-      & foldr (liftA2 $ H.unionWith (<>)) mempty
-      & fmap (fmap List)
-    pure $ r <> rest'
-    where
-      f (These a b) = (,[]) <$> match' a b
-      f (This a) = empty
-      f (That b) = pure (mempty,[b])
-  
-  match' (PatList ps Nothing (Just p)) (DotList es e) =
-    matches (p:|ps) (NE.cons e es)
-  
-  match' _ _ = _
-  
-  matchPrefix
-    :: (Semialign f, Foldable f)
-    => f Pat -> f Datum -> Ap Maybe (HashMap Name Datum, List Datum)
-  matchPrefix ps es = fold $ alignWith f ps es
-    where
-      f (These a b) = (,[]) <$> match' a b
-      f (This a) = empty
-      f (That b) = pure (mempty,[b])
-  
-  matches
-    :: (Semialign f, Foldable f)
-    => f Pat -> f Datum -> Ap Maybe (HashMap Name Datum)
-  matches ps es = fold $ alignWith matchThese ps es
-  
-  matchThese (These a b) = match' a b
-  matchThese _ = empty
-
-
-
-- | this hashmap is "curried" since we often want to traverse the
-- entire set of scopes associated with a given symbol.
-newtype SymTable = MkSymTable
-  { curried :: HashMap Name (HashMap (HashSet Scope) Bind) }
-  deriving (Show, Generic)
-
-type instance Index SymTable = Name
-type instance IxValue SymTable = HashMap (HashSet Scope) Bind
-instance Ixed SymTable where ix j = #curried . ix j
-instance At SymTable where at j = #curried . at j
-
-instance Semigroup SymTable where
-  MkSymTable c1 <> MkSymTable c2 = MkSymTable $ H.unionWith (<>) c1 c2
-
-instance Monoid SymTable where mempty = MkSymTable mempty
-
-type Expand es = (State SymTable :> es, GenSym :> es)
-
-runExpand :: SymTable -> Eff (State SymTable : GenSym : es) a -> Eff es (a, SymTable)
-runExpand tab = runGenSym . runStateLocal tab
-
-testExpand :: Datum -> IO (CommandOrDef, SymTable)
-testExpand = runJalmotIO . runExpand (symTableOfEnv env_scheme_base)
-  . expand env_scheme_base mempty
-
-- | denotations
-data Denot
-  = DenotVar
-  | DenotMacro Trans
-  | DenotPrim Name
-  | DenotSyntax Datum
-  | DenotKeyword Name
-  deriving stock (Show, Generic)
-
-newtype Env = MkEnv { names :: HashMap Bind Denot }
-  deriving stock (Show, Generic)
-  deriving newtype (Semigroup, Monoid)
-
-- | @(environment '(scheme base))@
-env_scheme_base :: Env
-env_scheme_base = MkEnv . fromList . fold $
-  [ [ (BindGlobal p, DenotPrim p) | p <- prims ]
-  , [ (BindGlobal "λ", DenotPrim "lambda")
-    ]
-  ]
-  where
-    prims =
-      [ "if"
-      , "lambda"
-      , "let"
-      , "let-syntax"
-      ]
-
-symTableOfEnv :: Env -> SymTable
-symTableOfEnv = ifoldMapOf (#names . itraversed) \cases
-  b@(BindGlobal n) d -> binding n mempty b
-
-type instance IxValue Env = Denot
-type instance Index Env = Bind
-
-instance Ixed Env where ix j = #names . ix j
-instance At Env where at j = #names . at j
-
-err :: Jalmot :> es => Text -> Eff es a
-err = throwError . EvalError
-
-run :: S.DatumGrammar a -> Datum -> Maybe a
-run g = preview #_Right . runPureEff . runJalmot . S.fromDatum g
-
-parsePrim :: S.DatumIso e => Name -> Datum -> Maybe (Prim e)
-parsePrim primname d = case primname of
-  "let" -> PrimLet <$> run prim_let d
-  "let-syntax" -> PrimLetSyntax <$> run prim_let_syntax d
-  "lambda" -> PrimLambda <$> run prim_lambda d
-  "if" -> PrimIf <$> run prim_if d
-
-emit :: (Monoid m, State m :> es) => m -> Eff es ()
-emit x = modify (<> x)
-
-binding :: Name -> HashSet Scope -> Bind -> SymTable
-binding sym scopes = MkSymTable . H.singleton sym . H.singleton scopes
-
-envOfVar :: Bind -> Env
-envOfVar = MkEnv . flip H.singleton DenotVar
-
-gensymLexical :: GenSym :> es => Name -> Eff es Bind
-gensymLexical symbol = do
-  identity <- gensym
-  pure $ BindLexical {symbol,identity}
-
-lookupSymbol
-  :: forall es. (State SymTable :> es, Jalmot :> es)
-  => Env -> HashSet Scope -> Name -> Eff es (Bind, Denot)
-lookupSymbol g scopes x = do
-  ss <- fmap fold . preuse @SymTable @(Eff es) $ ix x
-  case nearest (MkKey x scopes) (H.keys ss) of
-    [] -> err [i|심벌 #{x}는 정의되지 않다|]
-    (_:_:_) -> err [i|심벌 #{x}는 모호하다|]
-    [s] | Just b <- ss ^? ix s
-        , Just d <- g ^? ix b -> pure (b,d)
-        | otherwise -> error "unreachable"
-
-{- | Given a 'Key' and a collection of 'ScopeSet's, filter that
-collection down to the largest subsets of the 'Key'\'s scope set.
-This is our analogue of the lexical scoping rule which chooses the
-"nearest" binding of a variable when shadowing occurs.
-
-  - If no qualifying subsets are found, the name is not in scope.
-  - If one subset is found, we're on the happy path!
-  - If more than one subset is found, we're on the rarest and
-    saddest path: the reference is ambiguous.
-
-* Examples
-
-> (let ((x {A} 123))
->   (λ (x {A,B})
->     (let ((y {A,B,C} 456))
->       x {A,B,C})))
-    
->>> :seti -XOverloadedLists
->>> :{
-nearest
-  (MkKey "x" [MkScope 0, MkScope 1, MkScope 2])
-  [ [MkScope 0]
-  , [MkScope 0, MkScope 1] ]
-:}
-}
-nearest :: (Traversable f, Filterable f) => Key -> f ScopeSet -> List ScopeSet
-nearest (MkKey symbol scopes) =
-  mapMaybe (\x ->
-    if x `HS.isSubsetOf` scopes
-    then Just . Down $ Arg (length x) x
-    else Nothing)
-  -- 나쁨. 안 좋다. 안 좋아하야.
-  >>> Data.Foldable.toList >>> sort
-  >>> foldr (\cases
-    x [] -> [x]
-    x acc@(y:_) -> case x `compare` y of
-      LT -> acc
-      EQ -> x:acc
-      GT -> [x])
-    []
-  >>> fmap (\(Down (Arg _ x)) -> x)
-
-expand
-  :: (Expand es, Jalmot :> es)
-  => Env -> ScopeSet -> Datum -> Eff es CommandOrDef
-
-expand g scopes datum@(List (Symbol s : es)) = do
-  let s' = MkName s
-  (_,denot) <- lookupSymbol g scopes s'
-  case denot of
-    DenotVar -> Command . ExpApply (ExpVar s')
-      <$> traverse (expandAsExp g scopes) es
-    DenotPrim x -> expandPrim g scopes x datum
-    DenotMacro trans -> expandMacro g scopes trans datum
-
-- 신기하지 않은 경우들
-expand g scopes datum = case datum of
-  List (x:xs) -> Command <$> (ExpApply <$> go x <*> traverse go xs)
-  Symbol s -> pure . Command . ExpVar . MkName $ s
-  Boolean b -> lit $ LitBool b
-  Number (Sci.floatingOrInteger -> Right n) -> lit $ LitInt n
-  where
-    go = expandAsExp g scopes
-    lit = pure . Command . ExpLit
-
-expandMacro
-  :: (Expand es, Jalmot :> es)
-  => Env -> ScopeSet -> Trans -> Datum -> Eff es CommandOrDef
-expandMacro g scopes trans datum = _
-
-expandPrim 
-  :: (Expand es, Jalmot :> es)
-  => Env -> ScopeSet -> Name -> Datum -> Eff es CommandOrDef
-expandPrim g scopes primName datum
-  | Just prim <- parsePrim @Datum primName datum
-  = case prim of
-    PrimLetSyntax (MkPrimLetSyntax bs [body]) -> do
-      scopes' <- flip HS.insert scopes <$> gensym
-      (rhss,g') <- (_2 %~ (g<>) . fold) . Prelude.unzip <$> for bs \(x,trans) ->
-        expandAsExp g scopes trans >>= \case
-          ExpSyntaxRules trans' ->
-            (trans',) <$> bindLexical scopes' x (DenotMacro trans')
-          e -> err [i|syntax-rules를 원하는데 이것 받는다: #{e}|]
-      Command <$> (ExpLetSyntax
-        (zip (bs ^.. each . _1) rhss)
-        <$> expandAsExp g' scopes' body
-        )
-    PrimLet (MkPrimLet Nothing bs [body]) -> do
-      scopes' <- flip HS.insert scopes <$> gensym
-      g' <- (g<>) . fold <$> for (bs ^.. each . _1) \x ->
-        bindLexical scopes' x DenotVar
-      Command <$> (ExpLet
-        <$> traverseOf (each . _2) (expandAsExp g scopes) bs
-        <*> expandAsExp g scopes' body)
-    PrimLambda (MkPrimLambda (FormalsFixed xs) [body]) -> do
-      scopes' <- flip HS.insert scopes <$> gensym
-      g' <- (g<>) . fold <$> for xs \x -> bindLexical scopes' x DenotVar
-      Command . ExpLambda xs <$> expandAsExp g' scopes' body
-    PrimIf (MkPrimIf c t f) ->
-      Command <$> (ExpIf
-        <$> expandAsExp g scopes c
-        <*> expandAsExp g scopes t
-        <*> traverse (expandAsExp g scopes) f
-        )
-  | otherwise = err [i|prim #{primName}에 잘못한 신택스: #{datum}|]
-
-expandAsExp
-  :: (Expand es, Jalmot :> es)
-  => Env -> ScopeSet -> Datum -> Eff es Exp
-expandAsExp g scopes d = expand g scopes d >>= intoExp
-
-bindLexical :: Expand es => ScopeSet -> Name -> Denot -> Eff es Env
-bindLexical scopes symbol denot = do
-  identity <- gensym
-  let bind = BindLexical {symbol,identity}
-  modify (<> binding symbol scopes bind)
-  pure $ MkEnv (H.singleton bind denot)
-
-intoExp :: Jalmot :> es => CommandOrDef -> Eff es Exp
-intoExp (Command e) = pure e
-intoExp (Begin es) = traverse intoExp es >>= \case
-  [] -> err "begin expression은 빔"
-  (x:xs) -> pure . ExpBegin $ x NE.:| xs
-
-
-
-trans_when :: Trans
-trans_when = MkTrans
-  { ellipsis = "..."
-  , keywords = []
-  , rules =
-    [ MkRule
-      (PatList
-        [ PatVar "when"
-        , PatVar "test"
-        , PatVar "body" ]
-        (Just [])
-        Nothing)
-      (TemList
-        [ El $ TemVar "if"
-        , El $ TemVar "test"
-        , El $ TemList
-          [ El $ TemVar "begin"
-          , Ellipsis $ TemVar "body"
-          ]
-          Nothing
-        ]
-        Nothing)
-    ]
-  }
-
-trans_and :: Trans
-trans_and = MkTrans
-  { ellipsis = "..."
-  , keywords = []
-  , rules =
-    [ MkRule
-        (PatList
-          [PatVar "and"]
-          Nothing
-          Nothing)
-        (TemLit (LitBool True))
-    , MkRule
-        (PatList
-          [PatVar "and", PatVar "x"]
-          Nothing
-          Nothing)
-        (TemVar "x")
-    , MkRule
-        (PatList
-          [PatVar "and", PatVar "x", PatVar "y"]
-          (Just [])
-          Nothing)
-        (TemList
-          [ El (TemVar "if")
-          , El (TemVar "x")
-          , El (TemList
-              [ El (TemVar "and")
-              , Ellipsis (TemVar "y")
-              ]
-              Nothing)
-          , El . TemLit . LitBool $ False
-          ]
-          Nothing)
-    ]
-  }
@@ -1,536 +0,0 @@
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE TypeFamilies #-}
-module Gyehoek.Scheme.Expand.Old
-  (
-  ) where
-
-import Gyehoek.Sexp.Syntax
-import Gyehoek.Sexp qualified as S
-import Gyehoek.Prelude
-import Gyehoek.Scheme.Syntax hiding (Prim(..))
-import Gyehoek.Scheme.Syntax qualified as Scm
-import qualified Data.HashSet as HS
-import qualified Data.HashMap.Strict as H
-import Data.Foldable
-import Data.These
-import Data.Zip
-import Prelude hiding (filter, zip, mapMaybe)
-import qualified Data.List.NonEmpty as NE
-import Data.Monoid (Ap(Ap, getAp))
-import Gyehoek.Sexp.Grammar.Base ((:-)(..))
-import Control.Lens.Extras (is)
-import Control.Applicative (Alternative(..))
-import Gyehoek.GenSym
-import Data.HashSet.Lens (setOf)
-import Data.List (sort)
-import GHC.Exts (IsList(..))
-import Gyehoek.Jalmot
-import Data.Maybe (isNothing)
-import Data.Kind (Type)
-import Data.Traversable (for, mapAccumR)
-import Effectful.State.Dynamic
-import Witherable
-import Data.Semigroup (Arg(..))
-import Data.Ord (Down(..))
-import qualified Data.Scientific as Sci
-
-
-data Bind
-  = BindLexical { symbol :: Name, identity :: Natural }
-  | BindGlobal { symbol :: Name }
-  deriving stock (Generic, Eq, Show)
-  deriving anyclass (Hashable)
-
-newtype Scope = MkScope { identity :: Natural }
-  deriving stock (Show, Generic, Eq, Ord)
-  deriving anyclass (Hashable)
-  deriving newtype (Gen)
-
-type ScopeSet = HashSet Scope
-
-data Formals
-  = FormalsFixed (List Name)
-  | FormalsRest (List Name) Name
-  deriving (Show, Generic)
-
-data PrimLambda e = MkPrimLambda Formals (List e)
-  deriving (Show, Generic, Functor, Foldable, Traversable)
-data PrimLet e = MkPrimLet (Maybe Name) (List (Name, e)) (List e)
-  deriving (Show, Generic, Functor, Foldable, Traversable)
-data PrimIf e = MkPrimIf e e (Maybe e)
-  deriving (Show, Generic, Functor, Foldable, Traversable)
-data PrimLetSyntax e = MkPrimLetSyntax (List (Name, e)) (List e)
-  deriving (Show, Generic, Functor, Foldable, Traversable)
-
-data Prim e
-  = PrimLambda (PrimLambda e)
-  | PrimLet (PrimLet e)
-  | PrimIf (PrimIf e)
-  | PrimLetSyntax (PrimLetSyntax e)
-  | PrimSyntaxRules Trans
-  deriving (Show, Generic)
-
-data Key = MkKey Name (HashSet Scope)
-  deriving stock (Show, Generic, Eq)
-  deriving anyclass (Hashable)
-
-
-
-instance S.DatumIso Scope where
-  datumIso = S.with (S.datumIso >>>)
-
-hashSetGrammar
-  :: forall a. (Hashable a, Ord a)
-  => S.DatumGrammar a -> S.DatumGrammar (HashSet a)
-hashSetGrammar g =
-  S.list (S.rest g)
-  >>> S.iso HS.fromList (sort . HS.toList)
-
-instance S.DatumIso Key where
-  datumIso = S.with \g ->
-    S.list
-      ( S.el (S.symBuiltin "@")
-      >>> S.el (S.datumIso @Name)
-      >>> S.el (hashSetGrammar S.datumIso)
-      )
-    >>> g
-
-instance S.DatumIso Formals where
-  datumIso = S.match
-    $ S.With (fixed >>>)
-    $ S.With (rest >>>)
-    $ S.End
-    where
-      fixed :: S.G (Datum :- t) (List Name :- t)
-      fixed = S.list $ S.rest $ S.datumIso @Name
-      rest :: S.G (Datum :- t) (Name :- List Name :- t)
-      rest = S.coproduct
-        [ S.dottedList (S.rest $ S.datumIso @Name) (S.datumIso @Name)
-        , S.datumIso @Name >>> S.onTail (S.push [] null (const mempty))
-        ]
-
-optEl
-  :: S.G (S.Datum :- t) (a :- t)
-  -> S.G (S.ListContext :- t) (S.ListContext :- Maybe a :- t)
-optEl g =
-  S.coproduct
-    [ S.el g >>> S.onTail (S.partialIso Just \case
-      Nothing -> Left mempty
-      Just x -> Right x)
-    , S.onTail $ S.push Nothing isNothing (const mempty)
-    ]
-
-anykw :: Text -> S.G (Datum :- t) t
-anykw s = S.Flip $ S.PartialIso
-  (\t -> adorn SynBuiltin (Symbol s) :- t)
-  \case
-    (Symbol _ :- t) -> Right t
-    _ -> Left $ S.expected "symbol"
-
-prim_if :: S.DatumIso e => S.DatumGrammar (PrimIf e)
-prim_if = S.with \g ->
-  S.listWithIndentation (NSpecial 1)
-    (S.el (anykw "if")
-    >>> S.el S.datumIso
-    >>> S.el S.datumIso
-    >>> optEl S.datumIso)
-  >>> g
-
-prim_lambda :: S.DatumIso e => S.DatumGrammar (PrimLambda e)
-prim_lambda = S.with \g ->
-  S.lambdaLike (anykw "λ") (S.datumIso @Formals) (S.rest S.datumIso)
-  >>> g
-
-prim_let
-  :: forall e. S.DatumIso e => S.DatumGrammar (PrimLet e)
-prim_let = S.with \g ->
-  (S.listWithIndentation (NSpecial 1) $
-    S.el (anykw "let")
-    >>> optEl (S.datumIso @Name)
-    >>> S.el (S.list $ S.rest $ S.datumIso @(Name,e))
-    >>> S.rest S.datumIso)
-  >>> g
-
-prim_let_syntax :: S.DatumIso e => S.DatumGrammar (PrimLetSyntax e)
-prim_let_syntax = S.with \g ->
-  (S.listWithIndentation (NSpecial 1) $
-    S.el (anykw "let-syntax")
-    >>> S.el (S.list $ S.rest $ S.datumIso)
-    >>> S.rest S.datumIso)
-  >>> g
-
-instance S.DatumIso Bind where
-  datumIso = S.match
-    $ S.With (\g ->
-      S.list (S.el (S.symBuiltin "L") >>> S.el S.datumIso >>> S.el S.datumIso)
-      >>> g)
-    $ S.With (\g ->
-      S.list (S.el (S.symBuiltin "G") >>> S.el S.datumIso)
-      >>> g)
-    $ S.End
-
-
-
-{- |
-
-* Examples
-
->>> :set -XTemplateHaskellQuotes
->>> pat = S.makeSx [|| S.fromDatumUnsafe @Pat S.datumIso ||]
->>> match [] [pat|(x . y)|] [S.sx|(1 2 . 2)|]
-Nothing
->>> match [] [pat|(x . y)|] [S.sx|(1 . 2)|]
-Just
-...
->>> match ["=>"] [pat|(x => y)|] [S.sx|(1 => 2)|]
-Just
-...
->>> match ["=>"] [pat|(x => y)|] [S.sx|(1 -> 2)|]
-Nothing
-}
-match :: Foldable f
-  => f Text
-  -- ^ Literal keywords
-  -> Pat
-  -> Datum
-  -> Maybe (HashMap Name Datum)
-match kws p = getAp . match' p where
-
-  match' :: Pat -> Datum -> Ap Maybe (HashMap Name Datum)
-  
-  match' PatWildcard _ = pure mempty
-  
-  match' (PatVar x) e
-    | coerce x `elem` kws = case e of
-      Symbol x' | coerce x == x' -> pure mempty
-      _                          -> empty
-    | otherwise = pure $ H.singleton x e
-  
-  match' (PatList ps Nothing Nothing) (List es) = matches ps es
-  
-  match' (PatList ps (Just []) Nothing) (List es) = do
-    let (ps',p) = ps ^?! _Snoc
-    (r,rest) <- fold $ alignWith f ps' es
-    rest' <- rest
-      & fmap (fmap (fmap (:[])) . match' p)
-      & foldr (liftA2 $ H.unionWith (<>)) mempty
-      & fmap (fmap List)
-    pure $ r <> rest'
-    where
-      f (These a b) = (,[]) <$> match' a b
-      f (This a) = empty
-      f (That b) = pure (mempty,[b])
-  
-  match' (PatList ps Nothing (Just p)) (DotList es e) =
-    matches (p:|ps) (NE.cons e es)
-  
-  match' _ _ = _
-  
-  matchPrefix
-    :: (Semialign f, Foldable f)
-    => f Pat -> f Datum -> Ap Maybe (HashMap Name Datum, List Datum)
-  matchPrefix ps es = fold $ alignWith f ps es
-    where
-      f (These a b) = (,[]) <$> match' a b
-      f (This a) = empty
-      f (That b) = pure (mempty,[b])
-  
-  matches
-    :: (Semialign f, Foldable f)
-    => f Pat -> f Datum -> Ap Maybe (HashMap Name Datum)
-  matches ps es = fold $ alignWith matchThese ps es
-  
-  matchThese (These a b) = match' a b
-  matchThese _ = empty
-
-
-
-- | this hashmap is "curried" since we often want to traverse the
-- entire set of scopes associated with a given symbol.
-newtype SymTable = MkSymTable
-  { curried :: HashMap Name (HashMap (HashSet Scope) Bind) }
-  deriving (Show, Generic)
-
-type instance Index SymTable = Name
-type instance IxValue SymTable = HashMap (HashSet Scope) Bind
-instance Ixed SymTable where ix j = #curried . ix j
-instance At SymTable where at j = #curried . at j
-
-instance Semigroup SymTable where
-  MkSymTable c1 <> MkSymTable c2 = MkSymTable $ H.unionWith (<>) c1 c2
-
-instance Monoid SymTable where mempty = MkSymTable mempty
-
-type Expand es = (State SymTable :> es, GenSym :> es)
-
-runExpand :: SymTable -> Eff (State SymTable : GenSym : es) a -> Eff es (a, SymTable)
-runExpand tab = runGenSym . runStateLocal tab
-
-testExpand :: Datum -> IO (CommandOrDef, SymTable)
-testExpand = runJalmotIO . runExpand (symTableOfEnv env_scheme_base)
-  . expand env_scheme_base mempty
-
-- | denotations
-data Denot
-  = DenotVar
-  | DenotMacro Trans
-  | DenotPrim Name
-  | DenotSyntax Datum
-  | DenotKeyword Name
-  deriving stock (Show, Generic)
-
-newtype Env = MkEnv { names :: HashMap Bind Denot }
-  deriving stock (Show, Generic)
-  deriving newtype (Semigroup, Monoid)
-
-- | @(environment '(scheme base))@
-env_scheme_base :: Env
-env_scheme_base = MkEnv . fromList . fold $
-  [ [ (BindGlobal p, DenotPrim p) | p <- prims ]
-  , [ (BindGlobal "λ", DenotPrim "lambda")
-    ]
-  ]
-  where
-    prims =
-      [ "if"
-      , "lambda"
-      , "let"
-      , "let-syntax"
-      ]
-
-symTableOfEnv :: Env -> SymTable
-symTableOfEnv = ifoldMapOf (#names . itraversed) \cases
-  b@(BindGlobal n) d -> binding n mempty b
-
-type instance IxValue Env = Denot
-type instance Index Env = Bind
-
-instance Ixed Env where ix j = #names . ix j
-instance At Env where at j = #names . at j
-
-err :: Jalmot :> es => Text -> Eff es a
-err = throwError . EvalError
-
-run :: S.DatumGrammar a -> Datum -> Maybe a
-run g = preview #_Right . runPureEff . runJalmot . S.fromDatum g
-
-parsePrim :: S.DatumIso e => Name -> Datum -> Maybe (Prim e)
-parsePrim primname d = case primname of
-  "let" -> PrimLet <$> run prim_let d
-  "let-syntax" -> PrimLetSyntax <$> run prim_let_syntax d
-  "lambda" -> PrimLambda <$> run prim_lambda d
-  "if" -> PrimIf <$> run prim_if d
-
-emit :: (Monoid m, State m :> es) => m -> Eff es ()
-emit x = modify (<> x)
-
-binding :: Name -> HashSet Scope -> Bind -> SymTable
-binding sym scopes = MkSymTable . H.singleton sym . H.singleton scopes
-
-envOfVar :: Bind -> Env
-envOfVar = MkEnv . flip H.singleton DenotVar
-
-gensymLexical :: GenSym :> es => Name -> Eff es Bind
-gensymLexical symbol = do
-  identity <- gensym
-  pure $ BindLexical {symbol,identity}
-
-lookupSymbol
-  :: forall es. (State SymTable :> es, Jalmot :> es)
-  => Env -> HashSet Scope -> Name -> Eff es (Bind, Denot)
-lookupSymbol g scopes x = do
-  ss <- fmap fold . preuse @SymTable @(Eff es) $ ix x
-  case nearest (MkKey x scopes) (H.keys ss) of
-    [] -> err [i|심벌 #{x}는 정의되지 않다|]
-    (_:_:_) -> err [i|심벌 #{x}는 모호하다|]
-    [s] | Just b <- ss ^? ix s
-        , Just d <- g ^? ix b -> pure (b,d)
-        | otherwise -> error "unreachable"
-
-{- | Given a 'Key' and a collection of 'ScopeSet's, filter that
-collection down to the largest subsets of the 'Key'\'s scope set.
-This is our analogue of the lexical scoping rule which chooses the
-"nearest" binding of a variable when shadowing occurs.
-
-  - If no qualifying subsets are found, the name is not in scope.
-  - If one subset is found, we're on the happy path!
-  - If more than one subset is found, we're on the rarest and
-    saddest path: the reference is ambiguous.
-
-* Examples
-
-> (let ((x {A} 123))
->   (λ (x {A,B})
->     (let ((y {A,B,C} 456))
->       x {A,B,C})))
-    
->>> :seti -XOverloadedLists
->>> :{
-nearest
-  (MkKey "x" [MkScope 0, MkScope 1, MkScope 2])
-  [ [MkScope 0]
-  , [MkScope 0, MkScope 1] ]
-:}
-}
-nearest :: (Traversable f, Filterable f) => Key -> f ScopeSet -> List ScopeSet
-nearest (MkKey symbol scopes) =
-  mapMaybe (\x ->
-    if x `HS.isSubsetOf` scopes
-    then Just . Down $ Arg (length x) x
-    else Nothing)
-  -- 나쁨. 안 좋다. 안 좋아하야.
-  >>> Data.Foldable.toList >>> sort
-  >>> foldr (\cases
-    x [] -> [x]
-    x acc@(y:_) -> case x `compare` y of
-      LT -> acc
-      EQ -> x:acc
-      GT -> [x])
-    []
-  >>> fmap (\(Down (Arg _ x)) -> x)
-
-expand
-  :: (Expand es, Jalmot :> es)
-  => Env -> ScopeSet -> Datum -> Eff es CommandOrDef
-
-expand g scopes datum@(List (Symbol s : es)) = do
-  let s' = MkName s
-  (_,denot) <- lookupSymbol g scopes s'
-  case denot of
-    DenotVar -> Command . ExpApply (ExpVar s')
-      <$> traverse (expandAsExp g scopes) es
-    DenotPrim x -> expandPrim g scopes x datum
-    DenotMacro trans -> expandMacro g scopes trans datum
-
-- 신기하지 않은 경우들
-expand g scopes datum = case datum of
-  List (x:xs) -> Command <$> (ExpApply <$> go x <*> traverse go xs)
-  Symbol s -> pure . Command . ExpVar . MkName $ s
-  Boolean b -> lit $ LitBool b
-  Number (Sci.floatingOrInteger -> Right n) -> lit $ LitInt n
-  where
-    go = expandAsExp g scopes
-    lit = pure . Command . ExpLit
-
-expandMacro
-  :: (Expand es, Jalmot :> es)
-  => Env -> ScopeSet -> Trans -> Datum -> Eff es CommandOrDef
-expandMacro g scopes trans datum = _
-
-expandPrim 
-  :: (Expand es, Jalmot :> es)
-  => Env -> ScopeSet -> Name -> Datum -> Eff es CommandOrDef
-expandPrim g scopes primName datum
-  | Just prim <- parsePrim @Datum primName datum
-  = case prim of
-    PrimLetSyntax (MkPrimLetSyntax bs [body]) -> do
-      scopes' <- flip HS.insert scopes <$> gensym
-      (rhss,g') <- (_2 %~ (g<>) . fold) . Prelude.unzip <$> for bs \(x,trans) ->
-        expandAsExp g scopes trans >>= \case
-          ExpSyntaxRules trans' ->
-            (trans',) <$> bindLexical scopes' x (DenotMacro trans')
-          e -> err [i|syntax-rules를 원하는데 이것 받는다: #{e}|]
-      Command <$> (ExpLetSyntax
-        (zip (bs ^.. each . _1) rhss)
-        <$> expandAsExp g' scopes' body
-        )
-    PrimLet (MkPrimLet Nothing bs [body]) -> do
-      scopes' <- flip HS.insert scopes <$> gensym
-      g' <- (g<>) . fold <$> for (bs ^.. each . _1) \x ->
-        bindLexical scopes' x DenotVar
-      Command <$> (ExpLet
-        <$> traverseOf (each . _2) (expandAsExp g scopes) bs
-        <*> expandAsExp g scopes' body)
-    PrimLambda (MkPrimLambda (FormalsFixed xs) [body]) -> do
-      scopes' <- flip HS.insert scopes <$> gensym
-      g' <- (g<>) . fold <$> for xs \x -> bindLexical scopes' x DenotVar
-      Command . ExpLambda xs <$> expandAsExp g' scopes' body
-    PrimIf (MkPrimIf c t f) ->
-      Command <$> (ExpIf
-        <$> expandAsExp g scopes c
-        <*> expandAsExp g scopes t
-        <*> traverse (expandAsExp g scopes) f
-        )
-  | otherwise = err [i|prim #{primName}에 잘못한 신택스: #{datum}|]
-
-expandAsExp
-  :: (Expand es, Jalmot :> es)
-  => Env -> ScopeSet -> Datum -> Eff es Exp
-expandAsExp g scopes d = expand g scopes d >>= intoExp
-
-bindLexical :: Expand es => ScopeSet -> Name -> Denot -> Eff es Env
-bindLexical scopes symbol denot = do
-  identity <- gensym
-  let bind = BindLexical {symbol,identity}
-  modify (<> binding symbol scopes bind)
-  pure $ MkEnv (H.singleton bind denot)
-
-intoExp :: Jalmot :> es => CommandOrDef -> Eff es Exp
-intoExp (Command e) = pure e
-intoExp (Begin es) = traverse intoExp es >>= \case
-  [] -> err "begin expression은 빔"
-  (x:xs) -> pure . ExpBegin $ x NE.:| xs
-
-
-
-trans_when :: Trans
-trans_when = MkTrans
-  { ellipsis = "..."
-  , keywords = []
-  , rules =
-    [ MkRule
-      (PatList
-        [ PatVar "when"
-        , PatVar "test"
-        , PatVar "body" ]
-        (Just [])
-        Nothing)
-      (TemList
-        [ El $ TemVar "if"
-        , El $ TemVar "test"
-        , El $ TemList
-          [ El $ TemVar "begin"
-          , Ellipsis $ TemVar "body"
-          ]
-          Nothing
-        ]
-        Nothing)
-    ]
-  }
-
-trans_and :: Trans
-trans_and = MkTrans
-  { ellipsis = "..."
-  , keywords = []
-  , rules =
-    [ MkRule
-        (PatList
-          [PatVar "and"]
-          Nothing
-          Nothing)
-        (TemLit (LitBool True))
-    , MkRule
-        (PatList
-          [PatVar "and", PatVar "x"]
-          Nothing
-          Nothing)
-        (TemVar "x")
-    , MkRule
-        (PatList
-          [PatVar "and", PatVar "x", PatVar "y"]
-          (Just [])
-          Nothing)
-        (TemList
-          [ El (TemVar "if")
-          , El (TemVar "x")
-          , El (TemList
-              [ El (TemVar "and")
-              , Ellipsis (TemVar "y")
-              ]
-              Nothing)
-          , El . TemLit . LitBool $ False
-          ]
-          Nothing)
-    ]
-  }
@@ -10,22 +10,16 @@
 {-# LANGUAGE OrPatterns #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE ViewPatterns #-}
 module Gyehoek.Scheme.Syntax
  ( Name(..)
-  , Builtin(..)
+  , Prim(..)
  , Lit(..)
  , Def(..)
  , Exp(..)
  , ExpF(..)
  , Program(..)
  , CommandOrDef(..)
-  , Trans(..)
-  , Rule(..)
-  , Pat(..)
-  , Tem(..)
-  , El(..)
-  , builtinDatumIso
+  , primDatumIso
  , free
  , subst
  , getName
@@ -57,10 +51,8 @@ import qualified Effectful.FileSystem.IO.ByteString as FB
 import qualified Data.Set.Ordered as O
 import Gyehoek.Sexp.Grammar qualified as Sexp
 import Gyehoek.Sexp.Grammar qualified as S
-import Gyehoek.Sexp.Grammar (DatumIso, G, DataIso, (:-)((:-)))
+import Gyehoek.Sexp.Grammar (DatumIso, DataIso)
 import Gyehoek.Prelude
-import Control.Lens.Extras (is)
-import qualified Data.Scientific as Sci


 newtype Name = MkName { inner :: Text }
@@ -74,36 +66,28 @@ instance Prefixed Name where
 getName :: Name -> Text
 getName (MkName x) = x

-data Builtin e
-  = BuiltinAdd e e
-  | BuiltinSub e e
-  | BuiltinMul e e
-  | BuiltinDiv e e
-  | BuiltinCons e e
-  | BuiltinCar e
-  | BuiltinCdr e
-  | BuiltinImmediateP e
-  | BuiltinConsP e
-  | BuiltinIntegerP e
-  | BuiltinWrite e
-  | BuiltinZeroP e
-  | BuiltinNewline
-  | BuiltinMakeClosure { code :: e, env :: List e }
-  | BuiltinMakeSharedClosure { codes :: List e, env :: List e }
-  | BuiltinGetEnv
-  | BuiltinEnv
-  | BuiltinEnvRef Int
-  | BuiltinCallCC e
-  | BuiltinCaptureCC
-  | BuiltinInvokeCC e (List e)
-  | BuiltinValues (List e)
-  | BuiltinCallWithValues e e
-  | BuiltinPairP e
-  | BuiltinList (List e)
+data Prim e
+  = PrimAdd e e
+  | PrimSub e e
+  | PrimMul e e
+  | PrimDiv e e
+  | PrimCons e e
+  | PrimCar e
+  | PrimCdr e
+  | PrimImmediateP e
+  | PrimConsP e
+  | PrimIntegerP e
+  | PrimWrite e
+  | PrimZeroP e
+  | PrimNewline
+  | PrimMakeClosure { code :: e, env :: List e }
+  | PrimEnvRef e Int
+  | PrimEnvCode e
+  | PrimCallCC e
  deriving stock (Show, Generic, Functor, Foldable, Traversable, Data, Eq)
  deriving anyclass (NFData)

-instance Each (Builtin e) (Builtin e') e e'
+instance Each (Prim e) (Prim e') e e'

 data Lit
  = LitInt Int
@@ -118,79 +102,19 @@ data Def
  deriving stock (Show, Generic, Data)
  deriving anyclass (NFData)

-data Formals a
-  = FormalsFixed (List a)
-  | FormalsVar (List a) a
-  deriving stock (Show, Generic, Data, Functor, Foldable, Traversable)
-  deriving anyclass (NFData)
-
 data Exp
  = ExpLet (List (Name, Exp)) Exp
-  | ExpLetSyntax (List (Name, Trans)) Exp
  | ExpLetRec (List (Name, Exp)) Exp
-  | ExpBuiltin (Builtin Exp)
-  | ExpBegin (NonEmpty Exp)
-  | ExpIf Exp Exp (Maybe Exp)
+  | ExpPrim (Prim Exp)
+  | ExpBegin (List Exp)
+  | ExpIf Exp Exp Exp
  | ExpLit Lit
  | ExpLambda (List Name) Exp
  | ExpVar Name
-  | ExpSyntaxRules Trans
  | ExpApply Exp (List Exp)
  deriving stock (Show, Generic, Data)
  deriving anyclass (NFData)

-data Trans = MkTrans
-  { ellipsis :: Name
-  , keywords :: List Name
-  , rules :: List Rule
-  }
-  deriving stock (Show, Generic, Data)
-  deriving anyclass (NFData)
-
-data Rule = MkRule
-  { rhs :: Pat
-  , lhs :: Tem
-  }
-  deriving (Show, Generic, Data)
-  deriving anyclass (NFData)
-
-data Pat
-  = PatWildcard
-  | PatVar Name
-  | PatList
-    { init :: List Pat
-    , ellipsis :: Maybe (List Pat)
-    , tail :: Maybe Pat
-    }
-  -- | PatVec
-  --   { init :: List Pat
-  --   , ellipsis :: Maybe (List Pat)
-  --   }
-  deriving (Show, Generic, Data)
-  deriving anyclass (NFData)
-
-data Tem
-  -- | @(⟨element⟩ …)@
-  -- @(⟨element⟩ ⟨element⟩ … . ⟨element⟩)@
-  = TemList
-    { init :: List El
-    , tail :: Maybe Tem
-    }
-  -- | @(⟨ellipsis⟩ ⟨template⟩)@
-  | TemTrail Tem
-  | TemLit Lit
-  | TemVar Name
-  deriving (Show, Generic, Data)
-  deriving anyclass (NFData)
-
-data El
-  -- | @⟨template⟩ ⟨ellipsis⟩@
-  = Ellipsis Tem
-  -- | @⟨template⟩@
-  | El Tem
-  deriving (Show, Generic, Data)
-  deriving anyclass (NFData)
-
 data CommandOrDef
  = Command Exp
  | Definition Def
@@ -198,37 +122,8 @@ data CommandOrDef
  deriving stock (Show, Generic, Data)
  deriving anyclass (NFData)

-newtype LibName = MkLibName { inner :: NonEmpty Name }
-  deriving stock (Show, Generic, Data)
-  deriving anyclass (NFData)
-
-data ImportSet
-  = ImportLib LibName
-  | ImportOnly ImportSet (NonEmpty Name)
-  | ImportExcept ImportSet (NonEmpty Name)
-  | ImportPrefix ImportSet Name
-  | ImportRename ImportSet (NonEmpty (Name, Name))
-  deriving stock (Show, Generic, Data)
-  deriving anyclass (NFData)
-
-newtype ImportDecl = MkImportDecl (NonEmpty ImportSet)
-  deriving stock (Show, Generic, Data)
-  deriving anyclass (NFData)
-
-data LibDecl
-  deriving stock (Show, Generic, Data)
-  deriving anyclass (NFData)
-
-data Lib = MkLib
-  { name :: LibName
-  , decls :: List LibDecl
-  }
-  deriving stock (Show, Generic, Data)
-  deriving anyclass (NFData)
-
-data Program = MkProgram
-  { imports :: List ImportDecl
-  , commandsAndDefs :: List CommandOrDef
+newtype Program = MkProgram
+  { commandsAndDefs :: List CommandOrDef
  }
  deriving stock (Show, Generic, Data)
  deriving anyclass (NFData)
@@ -251,10 +146,10 @@ instance DatumIso Name where
    >>> S.symbol
    >>> S.iso coerce coerce

-builtinDatumIso
+primDatumIso
  :: (Text -> Text)
-  -> S.DatumGrammar a -> S.DatumGrammar (Builtin a)
-builtinDatumIso namefn a = S.match
+  -> S.DatumGrammar a -> S.DatumGrammar (Prim a)
+primDatumIso namefn a = S.match
    $ S.With (. ht2 "+")
    $ S.With (. ht2 "-")
    $ S.With (. ht2 "*")
@@ -267,32 +162,22 @@ builtinDatumIso namefn a = S.match
    $ S.With (. ht1 "integer?")
    $ S.With (. ht1 "write")
    $ S.With (. ht1 "zero?")
-    $ S.With (. ht0 "newline")
+    $ S.With (. nullop "newline")
    $ S.With (. ht1' "make-closure")
-    $ S.With (. S.headTagged2 (namefn "make-shared-closure")
-      (S.list $ S.rest a)
-      (S.list $ S.rest a))
-    $ S.With (. ht0 "get-env")
-    $ S.With (. ht0 "env")
-    $ S.With (. S.headTagged1 (namefn "env-ref") S.int)
+    $ S.With (. S.headTagged2 (namefn "env-ref") a S.int)
+    $ S.With (. ht1 "env-code")
    $ S.With (. ht1 "call/cc")
-    $ S.With (. ht0 "capture/cc")
-    $ S.With (. ht1' "invoke/cc")
-    $ S.With (. ht0' "values")
-    $ S.With (. ht2 "call-with-values")
-    $ S.With (. ht1 "pair?")
-    $ S.With (. ht0' "list")
    $ S.End
    where
      idn = S.el . S.sym . namefn
-      ht0 s = S.list $ idn s
+      nullop s = S.list $ idn s
      ht1 s = S.headTagged1 (namefn s) a
      ht2 s = S.headTagged2 (namefn s) a a
      ht1' s = S.headTagged1' (namefn s) a a
-      ht0' s = S.headTagged0' (namefn s) a

-instance DatumIso a => DatumIso (Builtin a) where
-  datumIso = builtinDatumIso id S.datumIso
+instance DatumIso a => DatumIso (Prim a) where
+  -- datumIso = primDatumIso ("prim:"<>) datumIso
+  datumIso = primDatumIso id S.datumIso

 instance DatumIso Lit where
  datumIso = S.match
@@ -313,203 +198,30 @@ instance DatumIso Def where
        >>> S.el args >>> S.rest S.datumIso
      args = S.list $ S.el S.datumIso >>> S.rest S.datumIso
  
-instance DatumIso Trans where
-  datumIso = S.with \g ->
-    S.listWithIndentation
-      (S.NSpecial 1)
-      ( S.el (S.symBuiltin "syntax-rules")
-      >>> S.Iso (\(ctx:-t) -> ctx:-"...":-t) (\(ctx:-_:-t) -> ctx:-t)
-      >>> S.el (S.list $ S.rest (S.datumIso @Name))
-      >>> S.rest (S.datumIso @Rule)
-      )
-    >>> g
-
 instance DatumIso Exp where
  datumIso = S.match
    $ S.With (. S.letLike "let" S.datumIso S.datumIso S.datumIso)
-    $ S.With (letsyntax >>>)
    $ S.With (. S.letLike "letrec" S.datumIso S.datumIso S.datumIso)
    $ S.With (. S.datumIso)
-    $ S.With (. begin)
-    $ S.With (. if_)
+    $ S.With (. S.beginLike "begin" S.datumIso)
+    $ S.With (. S.ifLike "if" S.datumIso S.datumIso S.datumIso)
    $ S.With (. S.datumIso)
    $ S.With (. lam)
    $ S.With (. S.datumIso)
-    $ S.With (. S.datumIso)
    $ S.With (\app -> app . S.list (S.el S.datumIso >>> S.rest S.datumIso))
    $ S.End
    where
-      letsyntax = S.listWithIndentation (S.NSpecial 1) $
-        S.el (S.symBuiltin "let-syntax")
-        >>> S.el (S.list $ S.rest $ S.datumIso)
-        >>> S.el S.datumIso
      lam = S.lambdaLike S.lambdaKeyword S.datumIso (S.el S.datumIso)
-      if_ = S.ifLike "if" S.datumIso S.datumIso $ S.datumIso @Exp >>> S.iso
-        Just
-        \case
-          Just x -> x
-          Nothing -> error "안 괜찮다ㅠㅠ"
-      begin :: forall t. G (S.Datum :- t) (NonEmpty Exp :- t)
-      begin = S.beginLike "begin" $
-        S.el (S.datumIso @Exp) >>> S.rest (S.datumIso @Exp)
-        >>> S.onTail (S.Iso
-          (\(xs:-x:-t) -> (x:|xs):-t)
-          (\((x:|xs):-t) -> xs:-x:-t))
-
-instance S.DatumIso Rule where
-  datumIso = S.with \g ->
-    S.list (S.el S.datumIso >>> S.el S.datumIso) >>> g
-
-instance S.DatumIso Pat where
-  datumIso = S.match
-    $ S.With (S.sym "_" >>>)
-    $ S.With (S.datumIso >>>)
-    $ S.With (lst >>>)
-    $ S.End
-    where
-      lst :: S.G (S.Datum :- t) (Maybe Pat :- Maybe (List Pat) :- List Pat :- t)
-      lst = S.coproduct
-        [ S.list $
-            ellipsis
-            >>> S.onTail (S.push Nothing (is _Nothing) (const mempty))
-        , S.dottedList
-            ellipsis
-            ( S.datumIso @Pat
-              >>> S.partialIso Just (maybe (Left mempty) Right) )
-        ]
-      ellipsis =
-        S.restData split
-            >>> S.onTail
-              ( S.onHead (S.traversed . S.traversed . S.sealed $
-                S.datumIso @Pat)
-              >>> S.onTail (S.onHead . S.traversed . S.sealed $
-                S.datumIso @Pat)
-              )
-      split
-        :: forall t. S.G (List S.Datum :- t)
-            (Maybe (List S.Datum) :- List S.Datum :- t)
-      split = S.Iso
-        (\(ps0:-t) ->
-          let (ps,ell) = splitEllipsis ps0
-          in ell :- ps :- t)
-        (\(ell:-ps:-t) -> (ps ++ foldMap ([S.Symbol "..."]++) ell) :- t)
-
-splitEllipsis :: List S.Datum -> (List S.Datum, Maybe (List S.Datum))
-splitEllipsis [] = ([], Nothing)
-splitEllipsis (S.Symbol "..." : xs) = ([], Just xs)
-splitEllipsis (x:xs) = splitEllipsis xs & _1 %~ (x:)
-
-instance S.DataIso El where
-  dataIso = S.match
-    $ S.With (ellipsis >>>)
-    $ S.With (noellipsis >>>)
-    $ S.End
-    where
-      ellipsis = S.recontextualise $
-        S.el (S.datumIso @Tem) >>> S.el (S.sym "...")
-      noellipsis = S.recontextualise $ S.el (S.datumIso @Tem)
-
-instance S.DatumIso Tem where
-  datumIso = S.match
-    $ S.With (lst >>>)
-    $ S.With (trail >>>)
-    $ S.With (S.datumIso @Lit >>>)
-    $ S.With (S.datumIso @Name >>>)
-    $ S.End
-    where
-      trail = S.list $ S.el (S.sym "...") >>> S.el (S.datumIso @Tem)
-
-      lst :: S.G (S.Datum :- t) (Maybe Tem :- List El :- t)
-      lst = S.coproduct
-        [ S.list els
-          >>> (S.push Nothing (is _Nothing) (const mempty))
-        , S.dottedList els $
-            S.datumIso @Tem
-            >>> S.partialIso Just (maybe (Left mempty) Right)
-        ]
-      els :: S.G (S.ListContext :- t) (S.ListContext :- List El :- t)
-      els =
-        S.iso
-          (\(S.MkListContext ds) -> affixEllipses ds)
-          (S.MkListContext . foldMap \(d,b) ->
-            d : if b then [S.Symbol "..."] else [])
-        >>> S.onHead (S.traversed . S.sealed $
-          S.flipped S.pair
-          >>> S.onTail (S.datumIso @Tem)
-          >>> S.pair
-          >>> S.iso
-            (\(t,b) -> if b then Ellipsis t else El t)
-            (\case
-              Ellipsis t -> (t,True)
-              El t -> (t,False)))
-        >>> S.push (S.MkListContext [])
-          (\(S.MkListContext xs) -> null xs)
-          (const mempty)
-      affixEllipses :: List S.Datum -> List (S.Datum, Bool)
-      affixEllipses (x : S.Symbol "..." : xs) = (x,True) : affixEllipses xs
-      affixEllipses (x : xs) = (x,False) : affixEllipses xs
-      affixEllipses [] = []
-

 instance DatumIso CommandOrDef where
  datumIso = S.match
    $ S.With (\_Command -> _Command . S.datumIso)
    $ S.With (\_Definition -> _Definition . S.datumIso)
-    $ S.With (\_Begin -> _Begin . S.beginLike "begin" (S.rest S.datumIso))
+    $ S.With (\_Begin -> _Begin . S.beginLike "begin" S.datumIso)
    $ S.End

-instance DatumIso LibName where
-  datumIso = S.with \g ->
-    S.list (S.restData $ S.nonEmptyData comp)
-    >>> g
-    where
-      comp = S.partialOsi
-        (\case
-          S.Symbol s -> Right $ MkName s
-          S.Number (Sci.floatingOrInteger @Double @Int -> Right n)
-            | n > 0 -> Right $ MkName [i|#{n}|]
-          _ -> Left $ S.expected "library name part"
-          )
-        \(MkName s) -> S.Symbol s
-
-instance DatumIso ImportSet where
-  datumIso = S.match
-    $ S.With (S.datumIso @LibName >>>)
-    $ S.With (imp "only" >>>)
-    $ S.With (imp "except" >>>)
-    $ S.With (imp' "prefix" >>>)
-    $ S.With (imp "rename" >>>)
-    $ S.End
-    where
-      imp s = S.list $ S.el (S.symBuiltin s)
-        >>> S.el S.datumIso >>> S.restData S.dataIso
-      imp' s = S.list $
-        S.el (S.symBuiltin s)
-        >>> S.el S.datumIso
-        >>> S.el S.datumIso
-
-instance DatumIso ImportDecl where
-  datumIso = S.with \decl ->
-    S.list (S.el (S.symBuiltin "import") >>> S.restData S.dataIso)
-    >>> decl
-
 instance DataIso Program where
-  dataIso = S.with \g ->
-    splitG
-    >>> S.onHead (S.sealed S.dataIso)
-    >>> S.onTail (S.onHead . S.sealed $ S.dataIso)
-    >>> g
-    where
-      isImport = \case
-        S.List (S.Symbol "import" : _) -> True
-        _ -> False
-      splitG :: G (List S.Datum :- t) (List S.Datum :- List S.Datum :- t)
-      splitG = S.Iso
-        (\(xs:-t) ->
-          let (ys,zs) = span isImport xs
-          in zs :- ys :- t
-        )
-        \(zs:-ys:-t) -> (ys ++ zs) :- t
+  dataIso = S.dataIso @(List CommandOrDef) >>> S.iso coerce coerce


 -- utilities
@@ -15,7 +15,6 @@ module Gyehoek.Sexp.Grammar
  , encodeDataTest
  , encodeDataTestColour
  , encodeOrShow'
-  , encodeOrShowData'
  , decodeDataWith
  , encodeDataWith'
  , decodeTest
@@ -29,8 +28,6 @@ module Gyehoek.Sexp.Grammar
  , fromDatumUnsafe
  , Control.Category.id
  , fromDataUnsafe
-  , writeDatum
-  , writeData
  )
  where

@@ -48,8 +45,6 @@ import qualified Control.Category
 import qualified Data.Vector as V
 import Data.String (IsString (fromString))
 import qualified Data.Text as T
-import System.Environment (lookupEnv)
-import Data.Foldable (toList)


 toDatum :: Jalmot :> es => DatumGrammar a -> a -> Eff es Datum
@@ -64,21 +59,19 @@ toData g =
  >>> runGrammar noAnn
  >>> either (throwError . GrammarError) pure

-fromDatum :: (HasCallStack, Jalmot :> es) => DatumGrammar a -> Datum -> Eff es a
+fromDatum :: Jalmot :> es => DatumGrammar a -> Datum -> Eff es a
 fromDatum g =
  forward (sealed g)
  >>> runGrammar noAnn
  >>> either (throwError . GrammarError) pure

-fromDatumUnsafe :: HasCallStack => DatumGrammar a -> Datum -> a
+fromDatumUnsafe :: DatumGrammar a -> Datum -> a
 fromDatumUnsafe g = runJalmotUnsafe . fromDatum g

-fromDataUnsafe :: HasCallStack => DataGrammar a -> List Datum -> a
+fromDataUnsafe :: DataGrammar a -> List Datum -> a
 fromDataUnsafe g = runJalmotUnsafe . fromData g

-fromData
-  :: (HasCallStack, Jalmot :> es)
-  => DataGrammar a -> List Datum -> Eff es a
+fromData :: Jalmot :> es => DataGrammar a -> List Datum -> Eff es a
 fromData g =
  forward (sealed g)
  >>> runGrammar noAnn
@@ -131,39 +124,6 @@ encodeOrShow' g x = fromString $
    Left _ -> show x
    Right t -> T.unpack t

-encodeOrShow :: (IsString s, Show a) => DatumGrammar a -> a -> s
-encodeOrShow g x = fromString $
-  case runPureEff . runJalmot . encodeWith g $ x of
-    Left _ -> show x
-    Right t -> T.unpack t
-
-encodeOrShowData' :: (IsString s, Show a) => DataGrammar a -> a -> s
-encodeOrShowData' g x = fromString $
-  case runPureEff . runJalmot . encodeDataWith' g $ x of
-    Left _ -> show x
-    Right t -> T.unpack t
-
-encodeOrShowData :: (IsString s, Show a) => DataGrammar a -> a -> s
-encodeOrShowData g x = fromString $
-  case runPureEff . runJalmot . encodeDataWith g $ x of
-    Left _ -> show x
-    Right t -> T.unpack t
-
-useColour :: IO Bool
-useColour = maybe True (const False) <$> lookupEnv "NO_COLOR"
-
-writeDatum :: (Show a, DatumIso a, MonadIO m) => a -> m ()
-writeDatum x = do
-  c <- liftIO useColour 
-  let f = if c then encodeOrShow else encodeOrShow'
-  liftIO . TIO.putStrLn . f datumIso $ x
-
-writeData :: (Show a, DataIso a, MonadIO m) => a -> m ()
-writeData x = do
-  c <- liftIO useColour 
-  let f = if c then encodeOrShowData else encodeOrShowData'
-  liftIO . TIO.putStrLn . f dataIso $ x
-
 class DatumIso a where
  datumIso :: DatumGrammar a

@@ -179,14 +139,6 @@ instance DatumIso Bool where datumIso = boolean

 instance DatumIso Int where datumIso = int

-instance DatumIso Natural where
-  datumIso = int
-    >>> partialOsi
-      (\x -> if x < 0
-        then Left $ expected "non-negative integer" <> unexpected [i|#{x}|]
-        else Right $ fromIntegral x)
-      fromIntegral
-
 instance DatumIso Datum where datumIso = Control.Category.id

 instance DatumIso a => DataIso (List a) where
@@ -196,8 +148,5 @@ instance DatumIso a => DataIso (V.Vector a) where
  dataIso = iso fromList V.toList
    >>> (onHead . traversed . sealed $ datumIso @a)

-instance DatumIso a => DataIso (NonEmpty a) where
-  dataIso = nonEmptyData datumIso
-
 instance (DatumIso a, DatumIso b) => DatumIso (a, b) where
  datumIso = with \tup2 -> list (el datumIso >>> el datumIso) >>> tup2
@@ -9,7 +9,7 @@ module Gyehoek.Sexp.Grammar.Base
  , DatumGrammar
  , DataGrammar
  , Grammar
-  , ListContext(..)
+  , ListContext
  , (:-)((:-))
  -- * lists
  , list
@@ -17,7 +17,6 @@ module Gyehoek.Sexp.Grammar.Base
  , el
  , rest
  , restData
-  , nonEmptyData
  , headTagged0'
  , headTagged0
  , headTagged1'
@@ -32,9 +31,6 @@ module Gyehoek.Sexp.Grammar.Base
  , number
  , integer
  , int
-  , unreadable
-  -- ** symbols
-  , symBuiltin
  -- * TODO: sort lol
  , prismIso
  , isoIso, decorate
@@ -44,7 +40,7 @@ module Gyehoek.Sexp.Grammar.Base
  , lambdaLike
  , lambdaKeyword
  , kappaKeyword
-  , beginLike, headTagged2', dottedList, reifyContext, recontextualise, decontextualise
+  , beginLike, headTagged2'
  ) where

 import Data.InvertibleGrammar
@@ -52,15 +48,13 @@ import Data.InvertibleGrammar.Base
 import Data.InvertibleGrammar.Base as Re
  ( Grammar(..))
 import Data.InvertibleGrammar.Combinators
-import Gyehoek.Prelude hiding (flipped, traversed, iso, cons, coerced, Iso, Simple, simple)
+import Gyehoek.Prelude hiding (iso, cons, coerced, Iso, Simple, simple)
 import Gyehoek.Sexp.Syntax hiding (position)
 import Gyehoek.Sexp.Print (printDatum')
 import Data.Scientific (Scientific)
 import qualified Data.Scientific as Sci
 import qualified Data.Text as T
 import Control.Monad.RWS (modify)
-import qualified Data.List.NonEmpty as NE
-import Data.Foldable (toList)


 -- $setup
@@ -110,39 +104,6 @@ list
  -> G (Datum :- t) t'
 list = listWithIndentation Ordinary

-- |
-- >>> let grammar = with \g -> dottedList (el int) int >>> g
-- >>> decodeTest @(Int,Int) grammar "(1 . 2)"
-- ( 1
-- , 2
-- )
-- >>> let grammar = with \g -> dottedList (el int >>> el int) int >>> g
-- >>> decodeTest @(Int,Int,Int) grammar "(1 2 . 3)"
-- ( 1
-- , 2
-- , 3
-- )
-dottedList
-  :: forall t t' t''. G (ListContext :- t) (ListContext :- t')
-  -> G (Datum :- t') t''
-  -> G (Datum :- t) t''
-dottedList g final = begin >>> Dive (onTail (g >>> end) >>> final)
-  where
-    begin = locate >>> Flip (PartialIso
-      (\(x:-MkListContext xs:-t) -> case NE.nonEmpty xs of
-          Just xs' -> DotList xs' x :- t
-          Nothing -> error "fuck")
-      (\case
-          DotList xs x :- t -> Right $ x :- MkListContext (NE.toList xs) :- t
-          _ -> Left $ expected "dotted list"))
-    end :: Grammar Ann (ListContext :- t') t'
-    end = Flip $ PartialIso
-      (\t -> MkListContext [] :- t)
-      (\(MkListContext lst :- t) ->
-         case lst of
-           [] -> Right t
-           d:_ -> Left $ unexpectedDatum d)
-
 listWithIndentation
  :: Indentation
  -> G (ListContext :- t) (ListContext :- t')
@@ -169,33 +130,6 @@ el
  -> G (ListContext :- t) (ListContext :- t')
 el g = coerced (Flip cons >>> onTail g >>> Step)

-reifyContext :: G (ListContext :- t) (List Datum :- t)
-reifyContext = iso coerce coerce
-
-decontextualise
-  :: G (List Datum :- t) (List Datum :- t')
-  -> G (ListContext :- t) t'
-decontextualise g = reifyContext >>> g >>> end
-  where
-    end = Flip $ PartialIso
-      (\t -> [] :- t)
-      (\(lst :- t) ->
-         case lst of
-           [] -> Right t
-           d:_ -> Left $ unexpectedDatum d)
-
-recontextualise
-  :: G (ListContext :- t) (ListContext :- t')
-  -> G (List Datum :- t) t'
-recontextualise g = flipped reifyContext >>> g >>> end
-  where
-    end = Flip $ PartialIso
-      (\t -> MkListContext [] :- t)
-      (\(MkListContext lst :- t) ->
-         case lst of
-           [] -> Right t
-           d:_ -> Left $ unexpectedDatum d)
-
 -- | matches the remainder of a list as repetition of a given
 -- grammar.
 --
@@ -262,21 +196,13 @@ rest g =
 -- >>> encodeTest dataRestGrammar $ MkExample [1,2,3] "end"
 -- (1 2 3 end)
 restData
-  :: G (List Datum :- t) t'
-  -> G (ListContext :- t) (ListContext :- t')
+  :: G (List Datum :- t) (a :- t)
+  -> G (ListContext :- t) (ListContext :- a :- t)
 restData g =
  iso coerce coerce
  >>> g
  >>> push (MkListContext []) (const True) mempty

-nonEmptyData :: DatumGrammar a -> DataGrammar (NonEmpty a)
-nonEmptyData g = partialOsi
-    (\case
-      [] -> Left $ expected "non-empty sequence"
-      x:xs -> Right $ x:|xs)
-    toList
-  >>> (onHead . traversed . sealed $ g)
-
 snoced
  :: Snoc s s a a
  => Grammar p (s :- a :- t) (s :- t)
@@ -428,7 +354,7 @@ letLike
  :: Text
  -> (forall t. G (Datum :- t) (a :- t))
  -> (forall t. G (Datum :- t) (b :- t))
-  -> G (Datum :- List (a, b) :- t1) t2
+  -> G (Datum :- (List (a, b) :- t1)) t2
  -> G (Datum :- t1) t2
 letLike kw name rhs e = listWithIndentation (NSpecial 1) $
  el (symBuiltin kw) >>> el bindings >>> el e
@@ -455,19 +381,11 @@ kappaKeyword = coproduct [ sym "κ", sym "kappa" ]

 beginLike
  :: Text
-  -> G (ListContext :- t) (ListContext :- t')
-  -> G (Datum :- t) t'
+  -> DatumGrammar a
+  -> G (Datum :- t) (List a :- t)
 beginLike kw g =
  listWithIndentation (NSpecial 0) $
-    el (symBuiltin kw) >>> g
-
-- | define a printed syntax for an object which cannot be read.
-unreadable
-  :: (t -> Text)
-  -> G (Datum :- t) t
-unreadable f = Flip $ PartialIso
-  (\t -> Unreadable (f t) :- t)
-  (const $ Left mempty)
+    el (symBuiltin kw) >>> rest g

 isoIso :: Iso' s a -> Grammar p (s :- t) (a :- t)
 isoIso l = iso (view l) (review l)
@@ -4,26 +4,21 @@ module Gyehoek.Sexp.Print
  , printDatum'
  , printData
  , printData'
-  , htmlDatum
-  , htmlData
  ) where

 import Gyehoek.Sexp.Syntax
-import Prettyprinter
+import Data.Text.Prettyprint.Doc
 import Data.Functor.Foldable
 import qualified Control.Comonad.Trans.Cofree as F
 import Prettyprinter.Util
 import Gyehoek.Prelude hiding (Simple, (:<))
-import Data.Foldable (traverse_, toList)
+import Data.Foldable (traverse_)
 import qualified Prettyprinter.Render.Terminal as ANSI
 import System.IO (stdout)
 import Prettyprinter.Render.Terminal (Color(..), color, italicized, AnsiStyle, bold, colorDull)
 import Prettyprinter.Render.Text (renderStrict)
 import qualified Data.Scientific as Sci
 import Data.List (intersperse)
-import Lucid
-import Prettyprinter.Render.Util.SimpleDocTree (treeForm)
-import Prettyprinter.Lucid (renderHtml)


 printDatum' :: Datum -> Text
@@ -36,31 +31,6 @@ printDatum' =
      { layoutPageWidth = AvailablePerLine 80 1.0
      }

-htmlDatum :: Datum -> Html ()
-htmlDatum =
-  prettyDatum 0
-  >>> layoutPretty opts
-  >>> treeForm
-  >>> fmap highlightHtml
-  >>> renderHtml
-  where
-    opts = LayoutOptions
-      { layoutPageWidth = AvailablePerLine 80 1.0
-      }
-
-htmlData :: Foldable f => f Datum -> Html ()
-htmlData =
-  foldr f mempty
-  >>> layoutPretty opts
-  >>> treeForm
-  >>> fmap highlightHtml
-  >>> renderHtml
-  where
-    f x y = prettyDatum 0 x <> hardline <> hardline <> y
-    opts = LayoutOptions
-      { layoutPageWidth = AvailablePerLine 80 1.0
-      }
-
 printDatum :: Datum -> Text
 printDatum = printDatumW 80

@@ -74,7 +44,7 @@ printDatumW :: Int -> Datum -> Text
 printDatumW w =
  prettyDatum 0
  >>> layoutSmart opts
-  >>> reAnnotateS highlightAnsi
+  >>> reAnnotateS highlight
  >>> ANSI.renderStrict
  where
    opts = LayoutOptions
@@ -84,13 +54,6 @@ printDatumW w =
 prettyDatum :: Int -> Datum -> Doc Syn
 prettyDatum depth datum = case datum of
  Simple simp -> annotate (datum ^. syntax) $ prettySimple depth simp
-  DotList xs x ->
-    pparen depth . group . align $
-      vsep [ vsep (prettyDatum (depth+1) <$> toList xs)
-           , "."
-           , prettyDatum (depth+1) x
-           ]
-      
  List' indent xs ->
    case indent of
      NSpecial n | keyword:args <- xs ->
@@ -124,14 +87,13 @@ prettySimple depth = \case
    & annotate SynConstant
  SimpleString s -> annotate SynString $ viaShow s
  SimpleSymbol s -> pretty s
-  SimpleUnreadable s -> pretty s

 putDoc :: Doc Syn -> IO ()
 putDoc = ANSI.renderIO stdout
-  . reAnnotateS highlightAnsi . layoutSmart defaultLayoutOptions . (<>"\n")
+  . reAnnotateS highlight . layoutSmart defaultLayoutOptions . (<>"\n")

-highlightAnsi :: Syn -> AnsiStyle
-highlightAnsi = \case
+highlight :: Syn -> AnsiStyle
+highlight = \case
  (SynBuiltin; SynMacro) -> color Magenta <> italicized <> bold
  SynProcedure -> color Blue
  SynConstant -> color Yellow
@@ -139,16 +101,3 @@ highlightAnsi = \case
  _ -> mempty
  where
    rainbow = cycle [Red,Yellow,Green,Blue,Magenta,Cyan]
-
-highlightHtml :: Syn -> Html () -> Html ()
-highlightHtml syn = span_ [class_ synClass]
-  where
-    synClass = case syn of
-      SynBuiltin -> "syn-builtin"
-      SynMacro -> "syn-macro"
-      SynConstant -> "syn-constant"
-      SynString -> "syn-string"
-      SynProcedure -> "syn-procedure"
-      SynVariable -> "syn-variable"
-      SynNone -> "syn-none"
-      SynParen n -> [i|syn-paren-#{mod n 5}|]
@@ -29,7 +29,6 @@ module Gyehoek.Sexp.Syntax
  , indentation
  , adorn
  , indentWith
-  , pattern Unreadable
  , pattern Bytevector
  , pattern Symbol
  , pattern String
@@ -39,7 +38,6 @@ module Gyehoek.Sexp.Syntax
  , Ann(..)
  , noAnn
  , ann
-  , dat
  , pattern List'
  , position
  , stripAnn
@@ -81,7 +79,6 @@ data Simple
  | SimpleString Text
  | SimpleSymbol Text
  | SimpleBytevector ByteString
-  | SimpleUnreadable Text
  deriving stock (Show, Eq, Data, Generic, Lift)
  deriving anyclass (NFData)

@@ -153,22 +150,12 @@ deriveEq1 ''CompoundF
 deriveShow1 ''DatumF
 deriveEq1 ''DatumF

-
--- optics
-
-- affine
-cdr :: Traversal' Datum Datum
-cdr k (a :< CompoundF (ListF ind xs)) = _
-

 --- modification and extraction of annotations

 ann :: Lens' Datum Ann
 ann = _extract

-dat :: Lens' Datum (DatumF Datum)
-dat = _unwrap
-
 syntax :: Lens' Datum Syn
 syntax = ann . #syntax

@@ -243,7 +230,6 @@ pattern Character a = Simple (SimpleCharacter a)
 pattern String a = Simple (SimpleString a)
 pattern Symbol a = Simple (SimpleSymbol a)
 pattern Bytevector a = Simple (SimpleBytevector a)
-pattern Unreadable a = Simple (SimpleUnreadable a)


 --- Lift1 instances
@@ -0,0 +1,29 @@
+module Gyehoek.Stack.Lower
+  ( lowerProgram
+  ) where
+
+import Gyehoek.Stack.Syntax
+import Gyehoek.Wasm qualified as Wasm
+import Gyehoek.Prelude
+import Gyehoek.Wasm (wat, watM)
+
+
+lowerRoutine :: Routine -> Wasm.Function
+lowerRoutine rt = _
+
+lowerBlock :: Block -> Wasm.Expr
+lowerBlock = _
+
+lowerInstr :: Instr -> Wasm.Expr
+lowerInstr = \case
+  -- PopCont ktail -> [wat|
+    
+  -- |]
+
+lowerProgram :: Program -> Eff es Wasm.Module
+lowerProgram p = pure [watM|
+  (module
+    ##{rs})
+|]
+  where
+    rs = p ^.. #routines . each . to lowerRoutine
@@ -0,0 +1,143 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE DeriveAnyClass #-}
+module Gyehoek.Stack.Syntax
+  ( Program(..)
+  , Routine(..)
+  , Instr(..)
+  , Block(..)
+  , Tail(..)
+  , Val(..)
+  , Lit(..)
+  , Obj(..)
+  , Imm(..)
+  , Hob(..)
+  , Prim(..)
+  , Name
+  , pattern ValLabel
+  , stkP
+  ) where
+
+import Control.Lens
+import qualified Gyehoek.Sexp as S
+import Gyehoek.Scheme.Syntax (Name(..), Lit(..), Prim(..))
+import GHC.Exts (IsList(..))
+import Data.List (intersperse)
+import Gyehoek.CPS.Syntax (Imm(..), Obj(..), Hob(..), labelName)
+import Gyehoek.Prelude
+import Gyehoek.Sexp ((:-)((:-)))
+
+
+newtype Program = MkProgram
+  { routines :: HashMap Name Routine
+  }
+  deriving stock (Show, Generic, Data)
+  deriving newtype (Semigroup, Monoid)
+  deriving anyclass (NFData)
+
+instance IsList Program where
+  type Item Program = Routine
+  fromList rs = MkProgram
+    { routines = fromList [ (r.label, r) | r <- rs ]
+    }
+  toList = toListOf $ #routines . each
+
+data Routine = MkRoutine
+  { label :: Name
+  , params :: List Name
+  , start :: Block
+  }
+  deriving stock (Show, Generic, Data)
+  deriving anyclass (NFData)
+
+data Block = MkBlock
+  { code :: List Instr
+  , tail :: Tail
+  }
+  deriving stock (Show, Generic, Data)
+  deriving anyclass (NFData)
+
+data Tail
+  = TailCall Val (List Val)
+  | PushCall Val Val (List Val)
+  | If Val Block Block
+  deriving stock (Show, Generic, Data)
+  deriving anyclass (NFData)
+
+data Instr
+  = Pop Name
+  | Push Val
+  | Prim Name (Prim Val)
+  deriving stock (Show, Generic, Data)
+  deriving anyclass (NFData)
+
+data Val
+  = ValReg Name
+  | ValImm Imm
+  deriving stock (Show, Generic, Data, Eq)
+  deriving anyclass (NFData)
+
+pattern ValLabel :: Name -> Val
+pattern ValLabel x = ValImm (ImmLabel x)
+
+
+--- sexp work
+
+pure []
+
+instance S.DatumIso Instr where
+  datumIso = S.match
+    $ S.With (S.headTagged1 "pop!" regName >>>)
+    $ S.With (S.headTagged1 "push!" S.datumIso >>>)
+    $ S.With (S.headTagged2 "prim" regName S.datumIso >>>)
+    $ S.End
+    where
+
+instance S.DataIso Block where
+  dataIso = S.with \g ->
+    S.flipped S.snoced
+    >>> S.onHead (S.traversed $ S.sealed S.datumIso)
+    >>> S.onTail (S.datumIso @Tail)
+    >>> S.swap
+    >>> g
+
+instance S.DatumIso Tail where
+  datumIso = S.match
+    $ S.With (S.headTagged1' "tail-call" S.datumIso S.datumIso >>>)
+    $ S.With (S.headTagged2' "push-call" S.datumIso S.datumIso S.datumIso >>>)
+    $ S.With (if_ >>>)
+    $ S.End
+    where
+      if_ = S.ifLike "if" (S.datumIso @Val) (branch "then") (branch "else")
+      branch :: Text -> S.DatumGrammar Block
+      branch s =
+        S.listWithIndentation (S.NSpecial 0) $
+            S.el (S.decorate S.SynBuiltin >>> S.sym s)
+            >>> S.restData (S.dataIso @Block)
+
+instance S.DatumIso Val where
+  datumIso = S.match
+    $ S.With (regName >>>)
+    $ S.With (S.datumIso >>>)
+    $ S.End
+
+instance S.DatumIso Routine where
+  datumIso = S.with \rout ->
+      S.listWithIndentation (S.NSpecial 1)
+       ( S.el (S.decorate S.SynBuiltin >>> S.sym "define")
+       >>> S.el (S.list $ S.el labelName >>> S.rest regName)
+       >>> S.restData (S.dataIso @Block)
+       )
+      >>> rout
+
+regName :: S.DatumGrammar Name
+regName = S.decorate S.SynVariable >>> S.datumIso @Name >>> S.prismIso
+  (S.expected "register")
+  (prefixed @Name "%")
+
+instance S.DataIso Program where
+  dataIso = S.dataIso @(List Routine) >>> S.iso fromList toList
+
+stkP :: S.QuasiQuoter
+stkP = S.makeSxs [|| S.fromDataUnsafe (S.dataIso @Program) ||]
@@ -0,0 +1,170 @@
+{-# LANGUAGE ViewPatterns #-}
+module Gyehoek.Stack.VM
+  ( VM(..)
+  , Env(..)
+  , eval
+  , trace
+  , module Gyehoek.Stack.Syntax
+  , writeObj
+  ) where
+
+import Gyehoek.Stack.Syntax
+import Control.Lens
+import qualified Data.HashMap.Strict as H
+import Data.List (unfoldr)
+import Gyehoek.Prelude
+
+
+data VM = MkVM
+  { stack :: List Obj
+  , code :: List Instr
+  , tail :: Tail
+  , registers :: HashMap Name Obj
+  , stdout :: Text
+  , result :: Maybe (List Obj)
+  }
+  deriving (Show, Generic)
+
+data Env = MkEnv
+  { labels :: HashMap Name Routine
+  }
+  deriving (Show, Generic)
+
+step :: Env -> VM -> VM
+step g vm = case vm ^. #code of
+  c:cs -> stepI g (vm & #code .~ cs) c
+  [] -> stepT g vm vm.tail
+
+stepI :: Env -> VM -> Instr -> VM
+
+stepI e vm (Push v) = vm & #stack %~ (evalVal e vm v :)
+
+stepI e vm (Prim r p) = case evalVal e vm <$> p of
+  PrimZeroP x -> case x of
+    ObjImm (ImmInt n) -> ret . ObjImm . ImmBool $ n == 0
+    _ -> error [i|bad arg to zero?: #{x}|]
+  PrimAdd x y -> arith_binop (+) x y
+  PrimMul x y -> arith_binop (*) x y
+  PrimSub x y -> arith_binop (-) x y
+  PrimDiv x y -> arith_binop div x y
+  PrimMakeClosure f env ->
+    case f of
+      ObjImm (ImmLabel l) -> ret . ObjHob $ HobClosure l env
+      _ -> error [i|expected label, got #{f}|]
+  PrimEnvCode env ->
+    case env of
+      ObjHob (HobClosure l _) -> ret . ObjImm . ImmLabel $ l
+      _ -> error [i|expected closure, got #{env}|]
+  PrimEnvRef env n ->
+    case env of
+      ObjHob (HobClosure _ xs) -> ret $ xs ^?! ix n
+      _ -> error [i|expected closure, got #{env}|]
+  x -> error [i|unimplemented prim: #{p}|]
+  where
+    ret v = vm & #registers . at r ?~ v
+    arith_binop op (ObjImm (ImmInt x)) (ObjImm (ImmInt y)) =
+      ret $ ObjImm (ImmInt (op x y))
+    arith_binop _ x y = error [i|bad arith: #{x}, #{y}|]
+
+stepI e vm (Pop r) = case vm ^. #stack of
+  [] -> error "empty stack"
+  (x:xs) -> vm & #registers . at r ?~ x
+               & #stack .~ xs
+
+stepI e vm ins = error [i|unimplemented instruction: #{ins}|]
+
+stepT :: Env -> VM -> Tail -> VM
+
+stepT g vm (TailCall f xs) =
+  case evalToLabel g vm f of
+    "halt" -> vm & #result ?~ fmap (evalVal g vm) xs
+    l -> vm & #code .~ rt.start.code
+            & #tail .~ rt.start.tail
+            & #registers .~
+              fmap (evalVal g vm) (H.fromList $ rt.params `zip` xs)
+      where
+        rt = case g ^. #labels . at l of
+          Nothing -> error [i|undefined label: #{l}|]
+          Just x -> x
+
+stepT g vm (PushCall k f xs) =
+  _
+
+stepT g vm (If c t f) = vm & #code .~ branch.code & #tail .~ branch.tail
+  where
+    branch = case evalVal g vm c of
+      ObjImm (ImmBool False) -> f
+      _ -> t
+
+evalToLabel e vm v =
+  case evalVal e vm v of
+    ObjImm (ImmLabel x) -> x
+    x -> error [i|not a label: #{x}|]
+
+evalVal :: Env -> VM -> Val -> Obj
+evalVal e vm = \case
+  ValImm imm -> ObjImm imm
+  ValReg r -> case vm ^. #registers . at r of
+    Just x -> x
+    Nothing -> error [i|undefined register: #{r}|]
+
+initialVM :: VM
+initialVM = MkVM
+  { stack = []
+  , code = []
+  , tail = TailCall (ValLabel "start") [ValLabel "halt"]
+  , registers = mempty
+  , stdout = ""
+  , result = Nothing
+  }
+
+initialEnv :: Program -> Env
+initialEnv p = MkEnv
+  { labels = p.routines
+  }
+
+loop :: (a -> Either b a) -> a -> b
+loop f a = case f a of
+  Right a' -> loop f a'
+  Left b -> b
+
+eval :: Program -> List Obj
+eval p = initialVM & loop \vm -> case vm ^. #result of
+  Nothing -> Right $ step (initialEnv p) vm
+  Just rs -> Left rs
+
+trace :: Program -> List VM
+trace p = initialVM & unfoldr \vm ->
+    case vm.result of
+      Just _ -> Nothing
+      Nothing -> Just (vm, step e vm)
+  where e = initialEnv p
+
+writeObj :: Obj -> Text
+writeObj (ObjImm im) = case im of
+  ImmInt n -> [i|#{n}|]
+  ImmBool True -> "#t"
+  ImmBool False -> "#f"
+  ImmLabel l -> "#<procedure>"
+writeObj (ObjHob h) = case h of
+  HobClosure code env -> "#<procedure>"
+
+blah = [stkP|
+(define ($lambda-body0-code7 %lambda-tail1 %lambda-body0 %x)
+  (prim %r2 (* %x %x))
+  (tail-call %lambda-tail1 %r2))
+
+(define ($r3 %x4)
+  (pop! %main-ktail)
+  (tail-call %main-ktail %x4))
+
+(define ($main %main-ktail)
+  (prim %lambda-body0 (make-closure $lambda-body0-code7))
+  (tail-call $let-body5 %lambda-body0))
+
+(define ($let-body5 %square)
+  (pop! %main-ktail)
+  (prim %code6 (env-code %square))
+  (push! %main-ktail)
+  (tail-call %code6 $r3 %square 4))
+|]
@@ -1,3 +1,4 @@
+{- HLINT ignore "Use newtype instead of data" -}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE TemplateHaskellQuotes #-}
@@ -1,4 +0,0 @@
-(import (scheme eval))
-
-(eval '(λ (x) x)
-      (environment))
@@ -5,75 +5,50 @@ import Test.Tasty.HUnit
 import Gyehoek.CPS.Syntax (cps, Obj(..), Hob(..), Imm(..))
 import Gyehoek.CPS.Eval qualified as Sut
 import Data.List (List)
-import Test.Tasty.ExpectedFailure (ignoreTestBecause, expectFail)
-import System.Directory (listDirectory)
-import Test.Tasty.Silver
-import System.FilePath
-import Control.Exception
-import qualified Gyehoek.Driver as Driver
-import Control.DeepSeq (($!!))
-import System.Exit (ExitCode(..))
-import qualified Data.Text as T
-import Data.Function (applyWhen)
-import Gyehoek.Prelude


-brokenEvalTests :: List String
-brokenEvalTests =
-  []
-  -- [ "adder"
-  -- , "apply2"
-  -- , "apply-twice"
-  -- , "arith"
-  -- , "begin-1"
-  -- , "callcc-constant"
-  -- , "callcc-discard"
-  -- , "callcc-early-exit-1"
-  -- , "callcc-early-exit-2"
-  -- , "callcc-early-exit-3"
-  -- , "callcc-early-exit-4"
-  -- , "callcc-early-exit-5"
-  -- , "callcc-early-exit-6"
-  -- , "callcc-nested-1"
-  -- , "callcc-nested-2"
-  -- , "complicated-1"
-  -- , "cons-1"
-  -- , "factorial"
-  -- , "false"
-  -- , "fn-of-fn"
-  -- , "if-false"
-  -- , "if-number"
-  -- , "if-true"
-  -- , "lambda"
-  -- , "letrec-fn"
-  -- , "let-fn"
-  -- , "lit-int"
-  -- , "square"
-  -- , "true"
-  -- ]
+test_cpsInterpreter = testGroup "cps interpreter" $
+  [ primitives
+  , testCase "halt with constant" do
+      evalsTo [ObjImm (ImmInt 123)] [cps|
+        (continue halt 123)
+      |]
+  , testCase "identity cont" do
+      evalsTo [ObjImm (ImmInt 154)] [cps|
+        (letrec ((id (κ (x)
+                       (continue halt x))))
+          (continue id 154))
+      |]
+  , testCase "identity function" do
+      evalsTo [ObjImm (ImmInt 456)] [cps|
+        (letrec ((id (λ (x ktail)
+                       (continue ktail x))))
+          (id 456 halt))
+      |]
+  , testCase "square" do
+      evalsTo [ObjImm (ImmInt 81)] [cps|
+        (letrec ((square (λ (x ktail)
+                           (prim (* x x)
+                             (κ (r) (continue ktail r))))))
+          (square 9 halt))
+      |]
+  ]

-test_eval :: IO TestTree
-test_eval = do
-  cs <- listDirectory "golden/exec"
-      <&> fmap ("golden/exec" </>)
-  pure $ testGroup "cps interpreter"
-    [ testGroup "higher-order" $ cpsCase Driver.eval_cps2_e2e <$> cs
-    -- , testGroup "first-order" $ cpsCase Driver.eval_cps1_e2e <$> cs
+evalsTo :: HasCallStack => List Obj -> Sut.Exp -> Assertion
+evalsTo rs e = Sut.evalExp e @?= rs
+
+primitives = testGroup "primitives"
+  [ testGroup "arith"
+    [ testCase "basic 1" do
+        evalsTo [ObjImm (ImmInt 20)] [cps|
+          (prim (* 4 5)
+            (κ (x) (continue halt x)))
+          |]
+    , testCase "basic 2" do
+        evalsTo [ObjImm (ImmInt 35)] [cps|
+          (prim (* 2 16)
+            (κ (x) (prim (+ x 3)
+                      (κ (r) (continue halt r)))))
+          |]
    ]
-
-maybeBroken name broken = applyWhen (name `elem` broken) expectFail
-
-cpsCase :: (FilePath -> IO Text) -> FilePath -> TestTree
-cpsCase f test =
-  maybeBroken testName brokenEvalTests $
-    goldenVsAction testName resultFile action printProcResult
-  where
-    testName = takeFileName test
-    resultFile = test </> "exec"
-    sourceFile = test </> "source.scm"
-    action = catch @SomeException
-      (do r <- f sourceFile
-          pure $!! ( ExitSuccess
-                   , r
-                   , "" ))
-      \e -> pure (ExitFailure 1, "", T.pack $ displayException e)
+  ]
@@ -0,0 +1,89 @@
+module Gyehoek.Test.CPS.Stackify where
+
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit
+import qualified Gyehoek.CPS.Stackify as Sut
+import Gyehoek.Stack.VM as Stk
+import Gyehoek.CPS.Syntax (cps)
+import Gyehoek.CPS.Syntax qualified as CPS
+import Gyehoek.GenSym (runGenSym)
+import Effectful
+import Gyehoek.Prelude
+
+
+test_stackify =
+  [ trivialReturn
+  , tailCall
+  , prim
+  , condition
+  , procedure
+  ]
+
+evalsTo :: List Obj -> Sut.Exp -> Assertion
+evalsTo rs e = Stk.eval e' @?= rs
+  where
+    e' = e & CPS.MkLambda [] "_ktail"
+      & CPS.MkProgram
+      & Sut.stackifyProgram & runGenSym & runPureEff
+
+trivialReturn = testGroup "trivial return"
+  [ testCase "return int" do
+      evalsTo [ObjImm (ImmInt 4)]
+        [cps|(continue halt 4)|]
+  , testCase "return bool" do
+      evalsTo [ObjImm (ImmBool True)]
+        [cps|(continue halt #t)|]
+      evalsTo [ObjImm (ImmBool False)]
+        [cps|(continue halt #f)|]
+  ]
+
+tailCall = testGroup "tail call"
+  [ testCase "square" do
+      evalsTo [ObjImm (ImmInt 16)]
+        [cps|(letrec ((square (λ (x ktail)
+                                (prim (* x x)
+                                  (κ (x0) (continue ktail x0))))))
+               (square 4 halt))|]
+  ]
+
+prim = testGroup "prim"
+  [ testCase "multiply" do
+      evalsTo [ObjImm (ImmInt 20)]
+        [cps|(prim (* 4 5)
+               (κ (x) (continue halt x)))|]
+  , testCase "add" do
+      evalsTo [ObjImm (ImmInt 9)]
+        [cps|(prim (+ 4 5)
+               (κ (x) (continue halt x)))|]
+  -- , testGroup "call/cc"
+  --   [ testCase "trivial" do
+  --       evalsTo [ObjImm (ImmInt 123)]
+  --         [cps|(letrec ((f (λ (cc ktail) (continue cc 123))))
+  --                (prim (call/cc f)))|]
+  --   ]
+  ]
+
+condition = testCase "if" do
+  evalsTo [ObjImm (ImmInt 123)]
+    [cps|(if #t (continue halt 123) (continue halt 456))|]
+  evalsTo [ObjImm (ImmInt 456)]
+    [cps|(if #f (continue halt 123) (continue halt 456))|]
+
+procedure = testGroup "procedure"
+  [ testCase "factorial" do
+      evalsTo [ObjImm (ImmInt 720)]
+        [cps|(letrec ((fac (λ (n ktail)
+                             (prim (zero? n)
+                               (κ (x0)
+                                 (if x0
+                                   (continue ktail 1)
+                                   (prim (- n 1)
+                                     (κ (x1)
+                                       (letrec ((fac-k0
+                                                  (κ (x2)
+                                                    (prim (* n x2)
+                                                      (κ (x3)
+                                                        (continue ktail x3))))))
+                                         (fac x1 fac-k0))))))))))
+               (fac 6 halt))|]
+  ]
@@ -46,9 +46,9 @@ qq = testGroup "parser"
  , testCase "application" do
      assertEqual "" (Sut.ExpApply (Sut.ValVar "f")
                     [Sut.ValVar "x",Sut.ValVar "y"]
-                     (Sut.KexpVar "k"))
+                     "k")
        [cps|(f x y k)|]
      assertEqual "" (Sut.ExpApply (Sut.ValVar "f")
-                     [] (Sut.KexpVar "k"))
+                     [] "k")
        [cps|(f k)|]
  ]
@@ -0,0 +1,87 @@
+module Gyehoek.Test.Golden 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
+import Control.Exception (SomeException (SomeException), Exception (..), catch)
+import Gyehoek.Stack.VM (writeObj)
+import Data.Text qualified as T
+import System.Exit (ExitCode(..))
+import Test.Tasty.ExpectedFailure (expectFail, ignoreTestBecause)
+import Control.DeepSeq (($!!))
+import Text.Pretty.Simple (pShow, pShowNoColor)
+import Control.Lens (strict, view)
+import Gyehoek.Sexp.Read qualified as Read
+import Effectful
+
+
+brokenWasmTests :: List String
+brokenWasmTests =
+  [
+  ]
+
+brokenStackifyTests :: List String
+brokenStackifyTests =
+  []
+  -- [ "adder"
+  -- , "let-fn"
+  -- , "callcc-nested1" -- requires closure-conversion
+  -- ]
+
+test_root :: IO TestTree
+test_root = do
+  all_cases <- listDirectory "golden/exec"
+  let tests = all_cases
+            & fmap ("golden/exec"</>)
+  testGroup "execution" <$> sequenceA
+    [ ignoreTestBecause "wasm codegen is on the backburner"
+      <$> wasmTests tests
+    , stackifyTests tests
+    ]
+
+maybeBroken name broken = applyWhen (name `elem` broken) expectFail
+
+wasmTests :: List FilePath -> IO TestTree
+wasmTests files = do
+  cmd <- getEnvDefault "GYEHOEK_WASM_RUNTIME"
+    "runtime/target/debug/gyehoek-wasm-runtime"
+  pure $ testGroup "wasm" $ 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 maybeBroken testname brokenWasmTests $
+      goldenVsAction
+       testname
+       resultfile
+       action
+       printProcResult
+
+stackifyTests :: List FilePath -> IO TestTree
+stackifyTests files = do
+  pure $ testGroup "stackified" $ files <&> \test ->
+    let testname = takeFileName test
+        scmfile = test </> "source.scm"
+        resultfile = test </> "exec"
+        action =
+          catch @SomeException
+            (do rs <- Driver.eval_e2e scmfile
+                pure $!! ( ExitSuccess
+                     , T.unwords . fmap writeObj $ rs
+                     , "" ))
+            \e -> pure (ExitFailure 1, "", T.pack $ displayException e)
+    in maybeBroken testname brokenStackifyTests $
+     goldenVsAction
+       testname
+       resultfile
+       action
+       printProcResult
@@ -0,0 +1,75 @@
+{-# LANGUAGE OverloadedLists #-}
+module Gyehoek.Test.Stack.VM where
+
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit
+import Gyehoek.Stack.Syntax
+import Gyehoek.Stack.VM qualified as Sut
+import Data.List (List)
+
+
+evalsTo :: List Obj -> Program -> Assertion
+evalsTo rs p = Sut.eval p @?= rs
+
+test_root = testGroup "stack machine"
+  [ testCase "lit int" do
+      evalsTo [ObjImm (ImmInt 3)] [stkP|
+        (define ($start %ktail)
+          (tail-call %ktail 3))
+      |]
+  , testCase "return constant" do
+      evalsTo [ObjImm (ImmInt 123)] [stkP|
+        (define ($start %ktail)
+          (tail-call $silly %ktail))
+        (define ($silly %ktail)
+          (tail-call %ktail 123))
+      |]
+  , testCase "identity continuation" do
+      evalsTo [ObjImm (ImmInt 45)] [stkP|
+        (define ($start %ktail)
+          (push! %ktail)
+          (tail-call $id 45))
+        (define ($id %x)
+          (pop! %ktail)
+          (tail-call %ktail %x))
+      |]
+  , testCase "identity function" do
+      evalsTo [ObjImm (ImmInt 45)] [stkP|
+        (define ($start %ktail)
+          (tail-call $id 45 %ktail))
+        (define ($id %x %ktail)
+          (tail-call %ktail %x))
+      |]
+  , testCase "square" do
+      evalsTo [ObjImm (ImmInt 16)] [stkP|
+        (define ($start %ktail)
+          (tail-call $square 4 %ktail))
+        (define ($square %x %ktail)
+          (prim %x2 (* %x %x))
+          (tail-call %ktail %x2))
+      |]
+  , testCase "factorial" do
+      let hsfac (n :: Int) = foldr (*) (1) [1..n]
+      let fac (n :: Int) = [stkP|
+            (define ($fac %n %ktail)
+              (prim %x0 (zero? %n))
+              (if %x0
+                (then (tail-call %ktail 1))
+                (else (push! %n)
+                      (push! %ktail)
+                      (prim %x1 (- %n 1))
+                      (tail-call $fac %x1 $fac-k0))))
+            (define ($fac-k0 %x2)
+              (pop! %ktail)
+              (pop! %n)
+              (prim %x3 (* %x2 %n))
+              (tail-call %ktail %x3))
+            (define ($start %ktail)
+              (tail-call $fac #{n} %ktail))
+          |]
+      evalsTo [ObjImm (ImmInt 1)] $ fac 0
+      evalsTo [ObjImm (ImmInt 1)] $ fac 1
+      evalsTo [ObjImm (ImmInt 720)] $ fac 6
+      -- 20 is the greatest `n` for which n! ≤ maxBount @Int
+      evalsTo [ObjImm (ImmInt 2432902008176640000)] $ fac 20
+  ]
Author	SHA1	Message	Date
msyds	9c3820379e	pass continuations as arguments, use normal stack build / build (push) Successful in 1m41s Details	2026-08-24 23:41:02 -06:00
msyds	b5c823f5fe	continue takes var	2026-08-24 10:41:19 -06:00
msyds	f6bc2947ef	build / build (push) Failing after 11m35s Details	2026-08-24 09:54:19 -06:00
msyds	1b5c93b030		2026-08-24 06:58:16 -06:00