stupid

wip: call/cc = capture/cc × invoke/cc
2026-08-30 10:31:46 -06:00 · 2026-08-30 05:39:13 -06:00 · 2026-08-30 03:33:51 -06:00
66 changed files with 1774 additions and 2618 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 ()
@@ -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,19 +0,0 @@
 #+title: on libraries
 * libraries and the file system
 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.
 * semantics of declaration order
 mercifully, R⁷RS is similarly ambiguous when it comes to the significance of declaration order. the authors note explicitly example two equally acceptable approaches:
 #+begin_quote
 One possible implementation of libraries is as follows: _After all cond-expand library declarations are expanded, a new environment is constructed for the library consisting of all imported bindings._ The expressions from all begin, include and include-ci library declarations are expanded in that environment in the order in which they occur in the library. _Alternatively, cond-expand and import declarations may be processed in left to right order interspersed with the processing of other declarations_, with the environment growing as imported bindings are added to it by each import declaration.
 #+end_quote
@@ -55,7 +55,7 @@
                nodejs
                wasm-tools
                wac-cli
-                gauche
+                guile
                rust-analyzer
                wasmtime
                # bashInteractive is necessary to work around an
@@ -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)))
@@ -1,4 +1,4 @@
 [0;31m([0m[0;95;1;3mbegin[0m
-  책을
+  [0m책을[0m
-  더
+  [0m더[0m
-  먹으세요~![0;31m)[0m
+  [0m먹으세요~![0m[0;31m)[0m
@@ -1,4 +1,4 @@
 [0;31m([0m[0;95;1;3mbegin[0m
-  책을
+  [0m책을[0m
-  더
+  [0m더[0m
-  먹으세요~![0;31m)[0m
+  [0m먹으세요~![0m[0;31m)[0m
@@ -1,5 +1,5 @@
 [0;31m([0m[0;95;1;3mlambda[0m
-    [0;33m([0m어간
+    [0;33m([0m[0m어간[0m
-     어미[0;33m)[0m
+     [0m어미[0m[0;33m)[0m
-  [0;33m([0mdisplay
+  [0;33m([0m[0mdisplay[0m
-   꾸깃[0;33m)[0m[0;31m)[0m
+   [0m꾸깃[0m[0;33m)[0m[0;31m)[0m
@@ -1,2 +1,2 @@
-[0;31m([0m[0;95;1;3mlambda[0m [0;33m([0m어간 어미[0;33m)[0m
+[0;31m([0m[0;95;1;3mlambda[0m [0;33m([0m[0m어간[0m [0m어미[0m[0;33m)[0m
-  [0;33m([0mdisplay 꾸깃[0;33m)[0m[0;31m)[0m
+  [0;33m([0m[0mdisplay[0m [0m꾸깃[0m[0;33m)[0m[0;31m)[0m
@@ -1,4 +1,4 @@
-[0;31m([0m가
+[0;31m([0m[0m가[0m
- 나
+ [0m나[0m
- 다
+ [0m다[0m
- 라[0;31m)[0m
+ [0m라[0m[0;31m)[0m
@@ -1 +1 @@
-[0;31m([0m가 나 다 라[0;31m)[0m
+[0;31m([0m[0m가[0m [0m나[0m [0m다[0m [0m라[0m[0;31m)[0m
@@ -1,5 +1,6 @@
 [ MkAnn
-    { position = Just
+    { syntax = SynNone
    , position = Just
        ( SourcePos
            { sourceName = "golden/read/bool/source.scm"
            , sourceLine = Pos 1
@@ -8,7 +9,8 @@
        )
    } :< SimpleF ( SimpleBoolean True )
 , MkAnn
-    { position = Just
+    { syntax = SynNone
    , position = Just
        ( SourcePos
            { sourceName = "golden/read/bool/source.scm"
            , sourceLine = Pos 1
@@ -17,7 +19,8 @@
        )
    } :< SimpleF ( SimpleBoolean True )
 , MkAnn
-    { position = Just
+    { syntax = SynNone
    , position = Just
        ( SourcePos
            { sourceName = "golden/read/bool/source.scm"
            , sourceLine = Pos 1
@@ -26,7 +29,8 @@
        )
    } :< SimpleF ( SimpleBoolean False )
 , MkAnn
-    { position = Just
+    { syntax = SynNone
    , position = Just
        ( SourcePos
            { sourceName = "golden/read/bool/source.scm"
            , sourceLine = Pos 1
@@ -1,5 +1,6 @@
 [ MkAnn
-    { position = Just
+    { syntax = SynNone
    , position = Just
        ( SourcePos
            { sourceName = "golden/read/decimal/source.scm"
            , sourceLine = Pos 1
@@ -9,7 +10,8 @@
    } :< SimpleF
    ( SimpleNumber 45.0 )
 , MkAnn
-    { position = Just
+    { syntax = SynNone
    , position = Just
        ( SourcePos
            { sourceName = "golden/read/decimal/source.scm"
            , sourceLine = Pos 1
@@ -19,7 +21,8 @@
    } :< SimpleF
    ( SimpleNumber 5667.0 )
 , MkAnn
-    { position = Just
+    { syntax = SynNone
    , position = Just
        ( SourcePos
            { sourceName = "golden/read/decimal/source.scm"
            , sourceLine = Pos 1
@@ -1,5 +1,6 @@
 [ MkAnn
-    { position = Just
+    { syntax = SynNone
    , position = Just
        ( SourcePos
            { sourceName = "golden/read/list-dot-flat/source.scm"
            , sourceLine = Pos 1
@@ -10,7 +11,8 @@
    ( DotListF
        (
            ( MkAnn
-                { position = Just
+                { syntax = SynNone
                , position = Just
                    ( SourcePos
                        { sourceName = "golden/read/list-dot-flat/source.scm"
                        , sourceLine = Pos 1
@@ -21,7 +23,8 @@
                ( SimpleSymbol "가" )
            ) :|
            [ MkAnn
-                { position = Just
+                { syntax = SynNone
                , position = Just
                    ( SourcePos
                        { sourceName = "golden/read/list-dot-flat/source.scm"
                        , sourceLine = Pos 1
@@ -31,7 +34,8 @@
                } :< SimpleF
                ( SimpleSymbol "나" )
            , MkAnn
-                { position = Just
+                { syntax = SynNone
                , position = Just
                    ( SourcePos
                        { sourceName = "golden/read/list-dot-flat/source.scm"
                        , sourceLine = Pos 1
@@ -43,7 +47,8 @@
            ]
        )
        ( MkAnn
-            { position = Just
+            { syntax = SynNone
            , position = Just
                ( SourcePos
                    { sourceName = "golden/read/list-dot-flat/source.scm"
                    , sourceLine = Pos 1
@@ -1,5 +1,6 @@
 [ MkAnn
-    { position = Just
+    { syntax = SynNone
    , position = Just
        ( SourcePos
            { sourceName = "golden/read/list-flat/source.scm"
            , sourceLine = Pos 1
@@ -7,9 +8,10 @@
            }
        )
    } :< CompoundF
-    ( ListF StyleData
+    ( ListF Ordinary
        [ MkAnn
-            { position = Just
+            { syntax = SynNone
            , position = Just
                ( SourcePos
                    { sourceName = "golden/read/list-flat/source.scm"
                    , sourceLine = Pos 1
@@ -19,7 +21,8 @@
            } :< SimpleF
            ( SimpleSymbol "가" )
        , MkAnn
-            { position = Just
+            { syntax = SynNone
            , position = Just
                ( SourcePos
                    { sourceName = "golden/read/list-flat/source.scm"
                    , sourceLine = Pos 1
@@ -29,7 +32,8 @@
            } :< SimpleF
            ( SimpleSymbol "나" )
        , MkAnn
-            { position = Just
+            { syntax = SynNone
            , position = Just
                ( SourcePos
                    { sourceName = "golden/read/list-flat/source.scm"
                    , sourceLine = Pos 1
@@ -39,7 +43,8 @@
            } :< SimpleF
            ( SimpleSymbol "다" )
        , MkAnn
-            { position = Just
+            { syntax = SynNone
            , position = Just
                ( SourcePos
                    { sourceName = "golden/read/list-flat/source.scm"
                    , sourceLine = Pos 1
@@ -49,7 +54,8 @@
            } :< SimpleF
            ( SimpleSymbol "라" )
        , MkAnn
-            { position = Just
+            { syntax = SynNone
            , position = Just
                ( SourcePos
                    { sourceName = "golden/read/list-flat/source.scm"
                    , sourceLine = Pos 1
@@ -59,7 +65,8 @@
            } :< SimpleF
            ( SimpleNumber 1.0 )
        , MkAnn
-            { position = Just
+            { syntax = SynNone
            , position = Just
                ( SourcePos
                    { sourceName = "golden/read/list-flat/source.scm"
                    , sourceLine = Pos 1
@@ -69,7 +76,8 @@
            } :< SimpleF
            ( SimpleNumber 2.0 )
        , MkAnn
-            { position = Just
+            { syntax = SynNone
            , position = Just
                ( SourcePos
                    { sourceName = "golden/read/list-flat/source.scm"
                    , sourceLine = Pos 1
@@ -1,5 +1,6 @@
 [ MkAnn
-    { position = Just
+    { syntax = SynNone
    , position = Just
        ( SourcePos
            { sourceName = "golden/read/list/source.scm"
            , sourceLine = Pos 1
@@ -10,7 +11,8 @@
    ( DotListF
        (
            ( MkAnn
-                { position = Just
+                { syntax = SynNone
                , position = Just
                    ( SourcePos
                        { sourceName = "golden/read/list/source.scm"
                        , sourceLine = Pos 1
@@ -21,7 +23,8 @@
                ( SimpleSymbol "a" )
            ) :|
            [ MkAnn
-                { position = Just
+                { syntax = SynNone
                , position = Just
                    ( SourcePos
                        { sourceName = "golden/read/list/source.scm"
                        , sourceLine = Pos 1
@@ -31,7 +34,8 @@
                } :< SimpleF
                ( SimpleSymbol "b" )
            , MkAnn
-                { position = Just
+                { syntax = SynNone
                , position = Just
                    ( SourcePos
                        { sourceName = "golden/read/list/source.scm"
                        , sourceLine = Pos 1
@@ -39,9 +43,10 @@
                        }
                    )
                } :< CompoundF
-                ( ListF StyleData
+                ( ListF Ordinary
                    [ MkAnn
-                        { position = Just
+                        { syntax = SynNone
                        , position = Just
                            ( SourcePos
                                { sourceName = "golden/read/list/source.scm"
                                , sourceLine = Pos 1
@@ -51,7 +56,8 @@
                        } :< SimpleF
                        ( SimpleSymbol "c" )
                    , MkAnn
-                        { position = Just
+                        { syntax = SynNone
                        , position = Just
                            ( SourcePos
                                { sourceName = "golden/read/list/source.scm"
                                , sourceLine = Pos 1
@@ -65,7 +71,8 @@
            ]
        )
        ( MkAnn
-            { position = Just
+            { syntax = SynNone
            , position = Just
                ( SourcePos
                    { sourceName = "golden/read/list/source.scm"
                    , sourceLine = Pos 1
@@ -73,9 +80,10 @@
                    }
                )
            } :< CompoundF
-            ( ListF StyleData
+            ( ListF Ordinary
                [ MkAnn
-                    { position = Just
+                    { syntax = SynNone
                    , position = Just
                        ( SourcePos
                            { sourceName = "golden/read/list/source.scm"
                            , sourceLine = Pos 1
@@ -85,7 +93,8 @@
                    } :< SimpleF
                    ( SimpleSymbol "가" )
                , MkAnn
-                    { position = Just
+                    { syntax = SynNone
                    , position = Just
                        ( SourcePos
                            { sourceName = "golden/read/list/source.scm"
                            , sourceLine = Pos 1
@@ -96,7 +105,8 @@
                    ( DotListF
                        (
                            ( MkAnn
-                                { position = Just
+                                { syntax = SynNone
                                , position = Just
                                    ( SourcePos
                                        { sourceName = "golden/read/list/source.scm"
                                        , sourceLine = Pos 1
@@ -108,7 +118,8 @@
                            ) :| []
                        )
                        ( MkAnn
-                            { position = Just
+                            { syntax = SynNone
                            , position = Just
                                ( SourcePos
                                    { sourceName = "golden/read/list/source.scm"
                                    , sourceLine = Pos 1
@@ -120,7 +131,8 @@
                        )
                    )
                , MkAnn
-                    { position = Just
+                    { syntax = SynNone
                    , position = Just
                        ( SourcePos
                            { sourceName = "golden/read/list/source.scm"
                            , sourceLine = Pos 1
@@ -1,5 +1,6 @@
 [ MkAnn
-    { position = Just
+    { syntax = SynNone
    , position = Just
        ( SourcePos
            { sourceName = "golden/read/meta-expression/source.scm"
            , sourceLine = Pos 1
@@ -1,5 +1,6 @@
 [ MkAnn
-    { position = Just
+    { syntax = SynNone
    , position = Just
        ( SourcePos
            { sourceName = "golden/read/meta-splice-expression/source.scm"
            , sourceLine = Pos 1
@@ -1,5 +1,6 @@
 [ MkAnn
-    { position = Just
+    { syntax = SynNone
    , position = Just
        ( SourcePos
            { sourceName = "golden/read/meta-splice-variable/source.scm"
            , sourceLine = Pos 1
@@ -1,5 +1,6 @@
 [ MkAnn
-    { position = Just
+    { syntax = SynNone
    , position = Just
        ( SourcePos
            { sourceName = "golden/read/meta-variable/source.scm"
            , sourceLine = Pos 1
@@ -1,61 +1,7 @@
-[ MkAnn
+[ SynNone :< SimpleF
    { position = Just
        ( SourcePos
            { sourceName = "golden/read/peculiar-identifier-dot/source.scm"
            , sourceLine = Pos 1
            , sourceColumn = Pos 1
            }
        )
    } :< SimpleF
    ( SimpleSymbol "..." )
 , MkAnn
    { position = Just
        ( SourcePos
            { sourceName = "golden/read/peculiar-identifier-dot/source.scm"
            , sourceLine = Pos 2
            , sourceColumn = Pos 1
            }
        )
    } :< SimpleF
    ( SimpleSymbol ".." )
-, MkAnn
+, SynNone :< SimpleF
    { position = Just
        ( SourcePos
            { sourceName = "golden/read/peculiar-identifier-dot/source.scm"
            , sourceLine = Pos 3
            , sourceColumn = Pos 1
            }
        )
    } :< SimpleF
    ( SimpleSymbol ".abc" )
-, MkAnn
+, SynNone :< SimpleF
    { position = Just
        ( SourcePos
            { sourceName = "golden/read/peculiar-identifier-dot/source.scm"
            , sourceLine = Pos 4
            , sourceColumn = Pos 1
            }
        )
    } :< SimpleF
    ( SimpleSymbol "....abcc" )
 , MkAnn
    { position = Just
        ( SourcePos
            { sourceName = "golden/read/peculiar-identifier-dot/source.scm"
            , sourceLine = Pos 5
            , sourceColumn = Pos 1
            }
        )
    } :< SimpleF
    ( SimpleSymbol ".++-" )
 , MkAnn
    { position = Just
        ( SourcePos
            { sourceName = "golden/read/peculiar-identifier-dot/source.scm"
            , sourceLine = Pos 6
            , sourceColumn = Pos 1
            }
        )
    } :< SimpleF
    ( SimpleSymbol ".-" )
 ]
@@ -1,6 +1 @@
-...
+.. .abc ....abcc
 ..
 .abc
 ....abcc
 .++-
 .-
@@ -1,5 +1,6 @@
 [ MkAnn
-    { position = Just
+    { syntax = SynNone
    , position = Just
        ( SourcePos
            { sourceName = "golden/read/peculiar-identifier-sign/source.scm"
            , sourceLine = Pos 1
@@ -9,7 +10,8 @@
    } :< SimpleF
    ( SimpleSymbol "+" )
 , MkAnn
-    { position = Just
+    { syntax = SynNone
    , position = Just
        ( SourcePos
            { sourceName = "golden/read/peculiar-identifier-sign/source.scm"
            , sourceLine = Pos 1
@@ -18,54 +20,4 @@
        )
    } :< SimpleF
    ( SimpleSymbol "-" )
 , MkAnn
    { position = Just
        ( SourcePos
            { sourceName = "golden/read/peculiar-identifier-sign/source.scm"
            , sourceLine = Pos 3
            , sourceColumn = Pos 1
            }
        )
    } :< SimpleF
    ( SimpleSymbol "+." )
 , MkAnn
    { position = Just
        ( SourcePos
            { sourceName = "golden/read/peculiar-identifier-sign/source.scm"
            , sourceLine = Pos 3
            , sourceColumn = Pos 4
            }
        )
    } :< SimpleF
    ( SimpleSymbol "+.." )
 , MkAnn
    { position = Just
        ( SourcePos
            { sourceName = "golden/read/peculiar-identifier-sign/source.scm"
            , sourceLine = Pos 3
            , sourceColumn = Pos 8
            }
        )
    } :< SimpleF
    ( SimpleSymbol "-." )
 , MkAnn
    { position = Just
        ( SourcePos
            { sourceName = "golden/read/peculiar-identifier-sign/source.scm"
            , sourceLine = Pos 3
            , sourceColumn = Pos 11
            }
        )
    } :< SimpleF
    ( SimpleSymbol "-...abc" )
 , MkAnn
    { position = Just
        ( SourcePos
            { sourceName = "golden/read/peculiar-identifier-sign/source.scm"
            , sourceLine = Pos 3
            , sourceColumn = Pos 19
            }
        )
    } :< SimpleF
    ( SimpleSymbol "-abc.." )
 ]
@@ -1,3 +1 @@
 + -
 +. +.. -. -...abc -abc..
@@ -1,5 +1,6 @@
 [ MkAnn
-    { position = Just
+    { syntax = SynNone
    , position = Just
        ( SourcePos
            { sourceName = "golden/read/string/source.scm"
            , sourceLine = Pos 1
@@ -1,5 +1,6 @@
 [ MkAnn
-    { position = Just
+    { syntax = SynNone
    , position = Just
        ( SourcePos
            { sourceName = "golden/read/typical-identifier-token/source.scm"
            , sourceLine = Pos 1
@@ -9,7 +10,8 @@
    } :< SimpleF
    ( SimpleSymbol "abc" )
 , MkAnn
-    { position = Just
+    { syntax = SynNone
    , position = Just
        ( SourcePos
            { sourceName = "golden/read/typical-identifier-token/source.scm"
            , sourceLine = Pos 1
@@ -19,7 +21,8 @@
    } :< SimpleF
    ( SimpleString "xyz" )
 , MkAnn
-    { position = Just
+    { syntax = SynNone
    , position = Just
        ( SourcePos
            { sourceName = "golden/read/typical-identifier-token/source.scm"
            , sourceLine = Pos 2
@@ -29,7 +32,8 @@
    } :< SimpleF
    ( SimpleSymbol "수학" )
 , MkAnn
-    { position = Just
+    { syntax = SynNone
    , position = Just
        ( SourcePos
            { sourceName = "golden/read/typical-identifier-token/source.scm"
            , sourceLine = Pos 2
@@ -37,9 +41,10 @@
            }
        )
    } :< CompoundF
-    ( ListF StyleData
+    ( ListF Ordinary
        [ MkAnn
-            { position = Just
+            { syntax = SynNone
            , position = Just
                ( SourcePos
                    { sourceName = "golden/read/typical-identifier-token/source.scm"
                    , sourceLine = Pos 2
@@ -1,5 +1,6 @@
 [ MkAnn
-    { position = Just
+    { syntax = SynNone
    , position = Just
        ( SourcePos
            { sourceName = "golden/read/typical-identifier/source.scm"
            , sourceLine = Pos 1
@@ -9,7 +10,8 @@
    } :< SimpleF
    ( SimpleSymbol "abc" )
 , MkAnn
-    { position = Just
+    { syntax = SynNone
    , position = Just
        ( SourcePos
            { sourceName = "golden/read/typical-identifier/source.scm"
            , sourceLine = Pos 1
@@ -19,7 +21,8 @@
    } :< SimpleF
    ( SimpleSymbol "bala-hwa$" )
 , MkAnn
-    { position = Just
+    { syntax = SynNone
    , position = Just
        ( SourcePos
            { sourceName = "golden/read/typical-identifier/source.scm"
            , sourceLine = Pos 1
@@ -29,7 +32,8 @@
    } :< SimpleF
    ( SimpleSymbol "x!!!" )
 , MkAnn
-    { position = Just
+    { syntax = SynNone
    , position = Just
        ( SourcePos
            { sourceName = "golden/read/typical-identifier/source.scm"
            , sourceLine = Pos 1
@@ -39,7 +43,8 @@
    } :< SimpleF
    ( SimpleSymbol "z" )
 , MkAnn
-    { position = Just
+    { syntax = SynNone
    , position = Just
        ( SourcePos
            { sourceName = "golden/read/typical-identifier/source.scm"
            , sourceLine = Pos 1
@@ -49,7 +54,8 @@
    } :< SimpleF
    ( SimpleSymbol "z123" )
 , MkAnn
-    { position = Just
+    { syntax = SynNone
    , position = Just
        ( SourcePos
            { sourceName = "golden/read/typical-identifier/source.scm"
            , sourceLine = Pos 1
@@ -59,7 +65,8 @@
    } :< SimpleF
    ( SimpleSymbol "나는너무졸리다" )
 , MkAnn
-    { position = Just
+    { syntax = SynNone
    , position = Just
        ( SourcePos
            { sourceName = "golden/read/typical-identifier/source.scm"
            , sourceLine = Pos 1
@@ -69,7 +76,8 @@
    } :< SimpleF
    ( SimpleSymbol "學" )
 , MkAnn
-    { position = Just
+    { syntax = SynNone
    , position = Just
        ( SourcePos
            { sourceName = "golden/read/typical-identifier/source.scm"
            , sourceLine = Pos 3
@@ -79,7 +87,8 @@
    } :< SimpleF
    ( SimpleSymbol "車室." )
 , MkAnn
-    { position = Just
+    { syntax = SynNone
    , position = Just
        ( SourcePos
            { sourceName = "golden/read/typical-identifier/source.scm"
            , sourceLine = Pos 5
@@ -26,7 +26,6 @@ common ghcstuffs
  ghc-options:
    -Wall -fdefer-type-errors -fno-show-valid-hole-fits
    -fdefer-out-of-scope-variables -threaded
    -Wno-name-shadowing -Wno-partial-type-signatures
  default-extensions:
    BlockArguments
@@ -55,25 +54,21 @@ executable gyehoek
 library
  import:           ghcstuffs, ghcstuffs-dev
  ghc-options:      -fplugin=Effectful.Plugin
  -- build-tool-depends: retrie:retrie
  -- cabal-fmt: expand src
  exposed-modules:
    Gyehoek.CPS.Close
    Gyehoek.CPS.Convert
    Gyehoek.CPS.Eval
-    Gyehoek.CPS.Hoist
+    Gyehoek.CPS.Stackify
    Gyehoek.CPS.Syntax
    Gyehoek.Driver
    Gyehoek.Language
    Gyehoek.GenSym
    Gyehoek.Jalmot
    Gyehoek.Language
    Gyehoek.Language.Common
    Gyehoek.Lift1
    Gyehoek.Options
    Gyehoek.Prelude
    Gyehoek.Scheme.Expand
    Gyehoek.Scheme.Expand.Old
    Gyehoek.Scheme.Syntax
    Gyehoek.Sexp
    Gyehoek.Sexp.Grammar
@@ -82,6 +77,9 @@ library
    Gyehoek.Sexp.QQ
    Gyehoek.Sexp.Read
    Gyehoek.Sexp.Syntax
    Gyehoek.Stack.Lower
    Gyehoek.Stack.Syntax
    Gyehoek.Stack.VM
    Gyehoek.Wasm
  build-depends:
@@ -102,7 +100,6 @@ library
    , hashable
    , invertible-grammar
    , lens
    , lucid
    , megaparsec
    , mtl
    , optparse-applicative
@@ -110,21 +107,18 @@ library
    , pretty-simple
    , prettyprinter
    , prettyprinter-ansi-terminal
    , prettyprinter-lucid
    , process
    , recursion-schemes
    , scientific
    , semialign
    , string-interpolate
    , tardis
    , template-haskell
    , text
    , text-short
    , these
    , typed-process
    , unordered-containers
    , vector
-    , witherable
+    , lucid
    , prettyprinter-lucid
  hs-source-dirs:   src
  default-language: GHC2024
@@ -139,11 +133,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
@@ -174,7 +171,6 @@ test-suite doctest
  build-depends:
    , base
    , gyehoek
  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)
      ())))
@@ -7,49 +7,32 @@ 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
+close :: GenSym :> es => Exp -> Eff es Exp
-genCodeName f = gensym' @Name $ f ^. _Wrapped' . to (<> "-code")
+close = transformM \case
-
+  ExpLetRec [(f, AbsLambda lam@(MkLambda bs kb m))] e -> do
-bindEnv :: List Name -> Exp -> Exp
+    f_code <- gensym' @Name $ f ^. _Wrapped' . to (<> "-code")
-bindEnv frees m = [cps|
+    -- it would probably be most sane to generate a symbol for `env`,
-  (builtin (get-env) (κ #{frees} #{m}))
+    -- but we're reusing the lambda binding so we don't have to
-|]
+    -- explicitly substitute recursive calls.
-
+    let frees = nub $ free' lam
-close1 :: forall es. GenSym :> es => Exp -> Eff es Exp
+    let m' = ifoldr
-close1 = \case
+             (\n x q ->
-  lr@(ExpLetRec bs e) -> do
+               let p = if x == f then PrimEnv @Val else PrimEnvRef n
-    let boundNames = bs ^.. each . _1
+               in [cps|
-    let boundNames' = setOf each boundNames
+                 (prim #{p}
-    let frees = bs
+                   (κ (#{x}) #{q}))
-          & foldMapOf
+             |])
-            (each . _2)
+             m frees
            (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
    pure [cps|
-      (letrec #{bs'}
+      (letrec ((#{f_code} (λ (##{bs} #{kb})
-        (builtin (make-shared-closure #{codes} #{frees})
+                            #{m'})))
-          (κ #{boundNames}
+        (prim (make-closure #{f_code} ##{frees})
-            #{e})))
+          (κ (#{f}) #{e})))
    |]
  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
@@ -46,13 +46,29 @@ convert (Scm.ExpLit l) k = k . one . ValImm $ case l of
  LitBool b -> ImmBool b
  _ -> _
-convert (Scm.ExpBuiltin p) k =
+-- special case: call/cc is desugared during cps-conversion...
 -- convert (Scm.ExpPrim (PrimCallCC withcc)) k = do
 --   convert1 withcc \withcc' -> do
 --     cc_l <- gensym' @Name "cc"
 --     r1_l <- gensym' @Name "r"
 --     r2_l <- gensym' @Name "r"
 --     ccish_l <- gensym' @Name "ccish"
 --     reified_cc_l <- gensym' @Name "reified-cc"
 --     m <- k [ValVar r1_l]
 --     pure [cps|
 -- (letrec ((#{cc_l} (κ (#{r1_l})
 --                      #{m})))
 --   (prim (capture/cc)
 --        (κ (#{reified_cc_l})
 --           (#{withcc'} #{reified_cc_l} #{cc_l}))))
 --     |]
 -- ...while all other prims are left as-is for later stages to
 -- handle..
 convert (Scm.ExpPrim p) k =
  telescope (convert1 @es) p \p' -> do
-    r_l <- gensym' "r"
+    r <- gensym' "r"
-    m <- k [ValVar r_l]
+    ExpPrim p' . MkKappa [r] <$> k [ValVar r]
    pure [cps|
      (builtin #{p'} (κ (#{r_l}) #{m}))
    |]
 convert (Scm.ExpLambda xs e) k = do
  f <- gensym' "lambda-body"
@@ -65,25 +81,17 @@ convert (Scm.ExpLambda xs e) k = do
 convert (Scm.ExpApply f xs) k =
  telescope (convert1 @es) (f:|xs) \(f':|xs') -> do
-    r <- gensym' @Name "r"
+    r <- gensym' "r"
    x <- gensym' "x"
    m <- k [ValVar x]
    pure $ ExpLetRec [(r, AbsKappa' [x] m)] $
-      ExpApply f' xs' (KexpVar r)
+      ExpApply f' xs' r
 convert (Scm.ExpBegin xs) k = telescope (convert @es) xs (k . NE.last)
-convert (Scm.ExpIf c t (Just f)) k =
+convert (Scm.ExpIf c t f) k =
-  convert1 c \c' -> do
+  convert1 c \c' ->
-    t_l <- gensym' @Name "truthy-cont"
+    ExpIf c' <$> convert t k <*> convert f k
    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}))
    |]
 -- let-bindings are desugared into continuation calls whose parameters
 -- are the left-hand sides and whose arguments are the right-hand
@@ -1,303 +1,99 @@
 {-# 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.CPS.Syntax
-import Gyehoek.Sexp qualified as S
+import Control.Lens
-import Control.Lens hiding (assign)
+import Data.Maybe (fromMaybe)
 import Data.Maybe (fromMaybe, isJust)
 import Text.Show.Functions ()
 import qualified Data.HashMap.Strict as H
-import Gyehoek.Prelude hiding (assign)
+import Gyehoek.Prelude
 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)
-newtype Loc = MkLoc { getLoc :: Int }
+data Env = MkEnv
-  deriving stock (Generic, Data)
+  { vars :: HashMap Name Obj
-  deriving newtype (Show, Eq, Ord, Enum)
+  , labels :: HashMap Name (Env, Abs)
 data Store = MkStore
  { nextLoc :: Loc
  , heap :: IntMap E
  }
  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
+eval :: Env -> Exp -> List Obj
  = Mut
  | NoMut
  deriving (Show, Generic, Data, Eq)
-wrong :: Text -> M Answer a
+eval g (Halt xs) = evalVal g <$> xs
 wrong s = ContT \_ -> pure . AnswerError . EvalError $ s
-orWrong
+eval g (ExpContinue k xs) =
-  :: Getting (First a) s a
+  case g ^. #labels . at k' of
-  -> Text -> s -> M Answer a
+    Just (h, AbsKappa' bs m) -> eval h' m
 orWrong p msg s = case getFirst . getConst $ p (Const . First . Just) s of
  Nothing -> wrong msg
  Just x -> pure x
 bind :: Name -> Loc -> Env
 bind k = MkEnv . H.singleton k
 extends :: Foldable f => f (Name, Loc) -> Env -> Env
 extends xs g = g <> foldMap (uncurry bind) xs
 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
      where
-    gofetch x = go $ st ^?! ix x
+        h' = h & #vars <>~ envOfBinds bs (evalVal g <$> xs)
-    go = \case
+    _ -> error [i|not a kappa: #{k}|]
      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 _
 data DynPoints = MkDynPoints
  deriving (Generic, Data)
 truthy :: E -> Bool
 truthy (EBool False) = False
 truthy _ = True
 evalVal :: Env -> Val -> M Answer E
 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]
+    k' = case evalVal g k of
-    pcons x y = do
+      ObjImm (ImmLabel x) -> x
-      (x',y') <- traverseOf both new' (x,y)
+      x -> error [i|expected label, got #{x}|]
      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
-
+eval g (ExpApply f xs ktail) =
-
+  case g ^?! #labels . at f' of
-evalExp :: Jalmot :> es => Exp -> Eff es _
+    Just (h,AbsLambda' bs kb m) -> eval h' m
-evalExp e = _
+      where h' = h & #vars <>~ envOfBinds bs (evalVal g <$> xs)
-
+                   & #labels . at kb .~ (g ^. #labels . at ktail)
-evalProgram :: Jalmot :> es => Program -> Eff es (List S.Datum)
+    Nothing -> error [i|undefined label: #{f}|]
 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
+    f' = case evalVal g f of
-      g <- setup
+      ObjImm (ImmLabel x) -> x
-      eval g MkDynPoints (ExpLetRec
+      x -> error [i|expected label, got #{x}|]
        [("_start",AbsLambda lam)]
        (ExpApply (ValVar "_start") [] (KexpVar "halt")))
-
+eval g (ExpLetRec [(b, ab)] e) = eval g' e
  where g' = g & #labels . at b ?~ ab
-setup :: M Answer Env
+eval g (ExpPrim p (MkKappa bs e)) = case evalVal g <$> p of
-setup = defines @List
+  PrimAdd x y -> arithBinop (+) x y
-  [ ("halt", EProcedure prim_halt)
+  PrimMul x y -> arithBinop (*) x y
-  ]
+  PrimSub x y -> arithBinop (-) x y
  PrimDiv x y -> arithBinop div x y
  PrimMakeClosure x env -> ret [ObjHob (HobClosure lbl env) ]
    where
      lbl = case x of
        ObjImm (ImmLabel l) -> l
        _ -> error [i|expected label, got #{x}|]
  _ -> error [i|unhandled prim: #{p}|]
  where
    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}|]
-prim_halt :: Procedure
+eval _ e = error [i|unimplemented case: #{e}|]
-prim_halt xs _dps = ContT \_ -> pure $ AnswerValues xs
+
 envOfBinds bs xs = foldMap (uncurry H.singleton) (zip bs xs)
 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" $
     AbsKappa' ["h0"] $ Halt [ValVar "h0"]
  }
 evalExp :: Exp -> List Obj
 evalExp = eval emptyEnv
 evalProgram :: Program -> List Obj
 evalProgram (MkProgram lam) = eval emptyEnv [cps|
  (letrec ((start #{lam}))
    (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,200 @@
 {-# 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 `elem` 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, AbsKappa kap)] e) = do
  kap' <- stackifyKappa g kap
  emitRoutine . Stk.MkRoutine (MkLabel f) . buildBlock $ kap'
  stackify g e
 stackify g (ExpLetRec [(f, AbsLambda lam)] e) = do
  lam' <- stackifyLambda g (MkLabel f) lam
  emitRoutine lam'
  stackify g 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) = do
  pure $
    Code [ Stk.Push $ stackifyVal g (ValVar ktail)
         , Stk.Push $ stackifyVal g f
         ] $
    Code (pushArgs g xs) $
    Tail (Stk.Call (length xs))
 stackify g e@(ExpContinue k xs)
  | isn't (#_ValVar . only g.tail) k = pure $
    Code [ Stk.Push (stackifyVal g k) ] $
    Code (pushArgs g xs) $
    Tail $ Stk.TailCall (length xs)
  | otherwise = pure $
    Code (pushArgs g xs) $
    Tail (Stk.Return (length xs))
 stackify g (ExpPrim (PrimCallCC withcc) cc) = do
  cc' <- stackifyKappa g cc
  cc_l <- gensym' @Label "cc"
  emitRoutine . Stk.MkRoutine cc_l . buildBlock $ cc'
  pure $
    Code [ Stk.Push $ stackifyVal g withcc
         , Stk.Push $ stackifyVal g (ValLabel cc_l)
         ] $
    Tail Stk.CallCC
 stackify g (ExpPrim p kap) = do
  kap' <- stackifyKappa g kap
  pure $ Code [ Stk.Prim (stackifyVal g <$> p) ] kap'
 stackify _ e = error [i|unimplemented exp: #{e}|]
 loadArgs :: List Name -> List Stk.Instr
 loadArgs = imapOf itraversed \n x -> Stk.Load (MkReg x) n
 pushArgs :: Env -> List Val -> List Stk.Instr
 pushArgs g args = [ Stk.Push $ stackifyVal g x | x <- reverse args ]
 -- affine
 _ValName :: Traversal' Val Name
 _ValName = failing #_ValVar (#_ValImm . #_ImmLabel . #_MkLabel)
 stackifyKappa
  :: (Stackify :> es, GenSym :> es)
  => Env -> Kappa
  -> Eff es BlockBuilder
 stackifyKappa g (MkKappa xs m) = do
  let g' = g & #bound <>:~ xs
  Code (loadArgs g'.bound)
    <$> stackify g' m
 stackifyLambda
  :: (Stackify :> es, GenSym :> es)
  => Env -> Label -> Lambda
  -> Eff es Stk.Routine
 stackifyLambda g name (MkLambda xs k m) = do
  m' <- stackify (g & #bound .~ xs & #tail .~ k) m
  pure $
    Stk.MkRoutine name . buildBlock $
    Code (loadArgs xs) $
    Code [Stk.Load (MkReg k) (length xs + 1)] m'
 stackifyVal :: Env -> Val -> Stk.Val
 stackifyVal g = \case
  ValImm imm -> Stk.ValImm imm
  ValVar v -> case regOf g v of
    Just r -> Stk.ValReg r
    Nothing -> Stk.ValLabel (MkLabel v)
  v -> error [i|unimplemented val: #{v}|]
 regOf :: Env -> Name -> Maybe Reg
 regOf g x
  | x `elem` g.bound || x == g.tail = Just . MkReg $ x
  | otherwise                       = Nothing
 data Env = MkEnv
  -- | `bound` tracks the stack lifetime of bound variables.
  { bound :: List Name
  -- | 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 Label (List Name)
  , tail :: Name
  }
  deriving (Show, Generic)
 emptyEnv :: Env
 emptyEnv = MkEnv
  { bound = mempty
  , liveness = mempty
  , tail = "halt"
  }
 stackifyProgram :: GenSym :> es => Program -> Eff es Stk.Program
 stackifyProgram (MkProgram lam) = do
  let g = emptyEnv
  (_,p) <- runStackify $ emitRoutine =<< stackifyLambda g "start" lam
  pure p
 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))))
 |]
 blah :: Program
 blah = [cps|
 (λ (ktail0)
          (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)))
 |]
@@ -5,19 +5,15 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {- HLINT ignore "Avoid lambda using `infix`" -}
 {- HLINT ignore "Redundant $" -}
 module Gyehoek.CPS.Syntax
  ( Val(..)
  , Kappa(..)
  , Lambda(..)
  , Exp(..)
  , Kexp(..)
  , ExpF(..)
  , Name(..)
-  , Builtin(..)
+  , Prim(..)
  , Program(..)
  , HoistedProgram(..)
  , Lit(..)
  , Imm(..)
  , Obj(..)
@@ -27,7 +23,7 @@ module Gyehoek.CPS.Syntax
  , pattern Halt
  , pattern Halt1
  , _MkKappa
-  , _ExpBuiltin
+  , _ExpPrim
  , _ExpLetRec
  , _ExpApply
  , _AbsLambda'
@@ -43,16 +39,10 @@ module Gyehoek.CPS.Syntax
  , Free(..)
  , pattern ValLabel
  , pattern ObjLabel
  , absBody
  , pattern MkAbs
  , _MkAbs
  , unhoist
  , pattern ExpJump
  , _ExpJump
  )
  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)
@@ -61,12 +51,11 @@ import Data.Monoid (Endo)
 import Data.Functor.Foldable.TH
 import Data.Data.Lens (uniplate)
 import Gyehoek.Prelude hiding (op)
-import Gyehoek.Sexp (G, (:-)(..), Datum)
+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
 -- Data types
@@ -102,7 +91,6 @@ data Obj
  deriving stock (Show, Generic, Data, Eq)
  deriving anyclass (NFData)
 pattern ObjLabel :: Label -> Obj
 pattern ObjLabel l = ObjImm (ImmLabel l)
 -- | a heap object.
@@ -125,60 +113,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
@@ -188,27 +140,11 @@ pattern Halt1 x = ExpContinue (ValLabel "halt") [x]
 data Def = DefConstant Name Exp
  deriving (Show, Generic, Data)
-newtype Program = MkProgram
+data Program = MkProgram
  { body :: Lambda
  }
  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 +168,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
@@ -272,7 +193,7 @@ instance S.DatumIso Imm where
 instance S.DatumIso Label where
  datumIso = S.with \g -> S.coproduct
-    [ S.datumIso @Name >>> S.prismIso
+    [ 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)
@@ -281,7 +202,7 @@ instance S.DatumIso Label where
 instance S.DatumIso Reg where
  datumIso = S.with \g ->
-    S.datumIso @Name >>> S.prismIso
+    S.decorate S.SynVariable >>> S.datumIso @Name >>> S.prismIso
      (S.expected "register")
      (prefixed @Name "%")
    >>> g
@@ -335,66 +256,45 @@ 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_)
    $ S.With (. app)
    $ S.End
    where
-      continue = S.listWithStyle (S.StyleSyntax 1) $
+      continue = S.list $
-        S.el (S.sym "continue")
+        S.el (S.decorate S.SynBuiltin >>> S.sym "continue")
-        >>> S.el S.datumIso
+        >>> S.el (S.decorate S.SynProcedure >>> S.datumIso)
        >>> S.rest S.datumIso
      letrec = S.letLike "letrec" S.datumIso S.datumIso S.datumIso
      if_ = S.ifLike "if"
        S.datumIso S.datumIso S.datumIso
      app :: forall t.
-        G (Datum :- t) (Kexp :- List Val :- Val :- t)
+        G (Datum :- t) (Name :- ([Val] :- (Val :- t)))
-      app = S.list $
+      app = S.list $ S.el (S.datumIso @Val)
-        S.flipped (S.PartialIso
+        -- >>> S.flipped Gyehoek.Datum.nonEmptyGrammar
          (\(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)
        >>> S.rest (S.datumIso @Val)
-        >>> S.onTail S.swap
+        -- >>> _
-      builtin = S.listWithStyle (S.StyleSyntax 1) $
+        >>> S.onTail (S.flipped $ IG.PartialIso
-        S.el (S.sym "builtin")
+                      (\(karg :- args :- op :- t) ->
-        >>> S.el (builtinDatumIso id (S.datumIso @Val))
+                         (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
@@ -407,16 +307,21 @@ 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 |]
 deleteFrom :: (Foldable f, Hashable a) => f a -> HashSet a -> HashSet a
 deleteFrom = flip $ foldr HS.delete
 insertFrom :: (Foldable f, Hashable a) => f a -> HashSet a -> HashSet a
 insertFrom = flip $ foldr HS.insert
 toHashSetOf :: Hashable a => Getting (Endo (HashSet a)) s a -> s -> HashSet a
 toHashSetOf l = foldrOf l HS.insert mempty
 class Free a where
  free :: a -> HashSet Name
  free = freeWithBound mempty
@@ -424,8 +329,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
+  -- | Free variables given in the order of their appearance.
  -- appear.
  free' :: a -> List Name
  free' = freeWithBound' mempty
@@ -435,21 +339,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 ->
+    ExpPrim p k ->
-      (p ^.. folded . #ValVar . filtered (`notElem` bound))
+      p & toListOf (folded . #ValVar . filtered (`notElem` bound))
-      ++ freeWithBound' bound k
+        & (<> freeWithBound' bound k)
    ExpLetRec bs m ->
      foldMapOf (each . _2) (freeWithBound' bound') bs
      <> freeWithBound' bound' m
@@ -457,10 +351,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, traceEval)
 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,29 @@ 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
+    hPutStrLn FS.stdout =<< S.encodeWith S.datumIso closedCps
  hoistedCps <- hoistProgram closedCps
  when opts.dumpHoisted do
    S.writeDatum hoistedCps
  let rt_is p = is (_Just . p) opts.runtime
-  when (rt_is #HigherOrderCPS) do
+  dumpOrRun opts.dumpStackified (rt_is #Stackify)
-    CPS.evalProgram cps
+    (stackifyProgram closedCps)
-      >>= S.writeData
+    (hPutStrLn FS.stdout <=< S.encodeDataWith S.dataIso)
    (eval >=> fmap writeObj
         >>> T.unwords
         >>> hPutStrLn FS.stdout)
  when (rt_is #CPS) do
-    CPS.evalProgram closedCps
+    closedCps
-      >>= S.writeData
+      & 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)
  when opts.traceStackified do
    stackifyProgram closedCps >>= traceEval
 parse_e2e :: FilePath -> IO Scm.Program
 parse_e2e = runJalmotIO . runFileSystem . readScm
@@ -137,18 +149,12 @@ convert_e2e :: FilePath -> IO CPS.Program
 convert_e2e = runJalmotIO . runFileSystem . runGenSym
  . (closeProgram <=< convertProgram <=< readScm)
-eval_cps1_e2e :: FilePath -> IO Text
+lower_e2e :: FilePath -> IO Text
-eval_cps1_e2e fp = runJalmotIO . runFileSystem . runGenSym $
+lower_e2e =
-  readScm fp
+  runJalmotIO . runFileSystem . runGenSym
-   >>= convertProgram
+  . (lowerProgram <=< closeProgram <=< convertProgram <=< readScm)
   >>= closeProgram
   >>= CPS.evalProgram
   >>= pure . S.encodeOrShowData' S.dataIso
-eval_cps2_e2e :: FilePath -> IO Text
+eval_e2e :: FilePath -> IO (List Obj)
-eval_cps2_e2e fp = runJalmotIO . runFileSystem . runGenSym $
+eval_e2e fp = runJalmotIO . runFileSystem . runGenSym $ do
-  readScm fp
+  stk <- stackifyProgram <=< closeProgram <=< convertProgram <=< readScm $ fp
-   >>= convertProgram
+  eval stk
   -- >>= closeProgram
   >>= CPS.evalProgram
   >>= pure . S.encodeOrShowData' S.dataIso
@@ -31,7 +31,6 @@ data AJalmot
  = ReaderError (ParseErrorBundle Text Void)
  | GrammarError (Grammar.ErrorMessage Ann)
  | VMError Text
  | EvalError Text
  deriving (Show, Generic, Data)
 data AJalmotCS = MkAJalmotCS !CallStack !AJalmot
@@ -67,7 +66,6 @@ instance Exception AJalmot where
        & layoutPretty defaultLayoutOptions
        & renderString
    VMError err -> [i|#{err}|]
    EvalError err -> [i|#{err}|]
 instance Exception AJalmotCS where
  backtraceDesired = const False
@@ -1,62 +0,0 @@
 {-# LANGUAGE DeriveAnyClass #-}
 module Gyehoek.Language.Common
  (
  -- * Syntax
    Lib(..)
  , LibName(..)
  , Exports
  , Imports
  , ExternName(..)
  , Name(..)
  ) where
 import Gyehoek.Prelude
 import Data.String (IsString)
 import Gyehoek.GenSym (Gen)
 import qualified Gyehoek.Sexp as S
 -- | R⁷RS 라이프러리의 표현.
 data Lib name body = MkLib
  { name :: LibName
  , exports :: Exports name
  , imports :: Imports name
  }
  deriving (Show)
 newtype LibName = MkLibName { getLibName :: NonEmpty Text }
  deriving stock (Show, Generic, Data, Eq)
  deriving anyclass (NFData, Hashable)
 -- | A map whose keys are names of library definitions and whose
 -- values are the names they are exported as. An @⟨identifier⟩@ @x@
 -- corresponds to an entry @(⟨identifier⟩, ⟨identifier⟩)@, while a
 -- @(rename ⟨identifier₁⟩ ⟨identifier₂⟩)@ form corresponds to an entry
 -- @(⟨identifier₁⟩, ⟨identifier₂⟩)@.
 type Exports name = HashMap name ExternName
 -- | A map whose keys are symbols to be brought into the library's
 -- environment and whose values are pairs of the library in which the
 -- symbol is defined and the name the symbol is exported as.
 type Imports name = HashMap name (LibName, ExternName)
 -- | Representation of an identifier at the library boundary. While
 -- 'Name's are used within a compilation unit and may be decorated
 -- with additional structure and metadata, they are exported as
 -- 'ExternName's, which are essentially just plain strings.
 newtype ExternName = MkExternName { getExternName :: Text }
  deriving newtype (Show)
 newtype Name = MkName { inner :: Text }
  deriving newtype (Show, Eq, Ord, IsString, Gen, Hashable)
  deriving stock (Generic, Data)
  deriving anyclass (Wrapped, NFData)
 instance Prefixed Name where
  prefixed (MkName s) = _Wrapped' . prefixed @Text s . from _Wrapped'
 --- DatumIsos
 instance S.DatumIso Name where
  datumIso = S.symbol >>> S.iso coerce coerce
@@ -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,30 @@ data Options = MkOptions
  { dumpClosed :: Bool
  , dumpCPS :: Bool
  , dumpParsed :: Bool
-  , dumpHoisted :: Bool
+  , dumpStackified :: Bool
-  , noColour :: Bool
+  , traceStackified :: 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" -> Just (Just CPS)
  ("cps";"higher-order-cps") -> Just (Just HigherOrderCPS)
  "none" -> Just Nothing
  _ -> Nothing
@@ -58,19 +59,16 @@ 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")
+  traceStackified <- switch (long "trace-stackified")
  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 +79,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'
@@ -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.sym "@")
      >>> 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.listWithStyle (StyleSyntax 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.listWithStyle (StyleSyntax 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.listWithStyle (StyleSyntax 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.sym "L") >>> S.el S.datumIso >>> S.el S.datumIso)
      >>> g)
    $ S.With (\g ->
      S.list (S.el (S.sym "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.sym "@")
      >>> 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.listWithStyle (StyleSyntax 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.listWithStyle (StyleSyntax 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.listWithStyle (StyleSyntax 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.sym "L") >>> S.el S.datumIso >>> S.el S.datumIso)
      >>> g)
    $ S.With (\g ->
      S.list (S.el (S.sym "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,24 +10,16 @@
 {-# LANGUAGE OrPatterns #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE ViewPatterns #-}
 {- HLINT ignore "Avoid lambda using `infix`" -}
 {- HLINT ignore "Redundant $" -}
 module Gyehoek.Scheme.Syntax
  ( Name(..)
-  , Builtin(..)
+  , Prim(..)
  , Lit(..)
  , Def(..)
  , Exp(..)
  , ExpF(..)
  , Program(..)
  , CommandOrDef(..)
-  , Trans(..)
+  , primDatumIso
  , Rule(..)
  , Pat(..)
  , Tem(..)
  , El(..)
  , builtinDatumIso
  , free
  , subst
  , getName
@@ -38,6 +30,8 @@ module Gyehoek.Scheme.Syntax
  )
  where
 import Data.List (intersperse)
 import Effectful
 import Prelude hiding ((.), id)
 import Control.Category
 import Gyehoek.Sexp qualified as GS
@@ -50,12 +44,15 @@ import Data.Functor.Foldable hiding (fold)
 import qualified Data.HashSet as HS
 import Data.Foldable (fold, toList)
 import Language.Haskell.TH.Quote (QuasiQuoter)
 import Effectful.FileSystem (runFileSystem)
 import qualified Effectful.FileSystem.IO as FS
 import qualified Data.Text.Encoding as T
 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.Prelude
 import Control.Lens.Extras (is)
 import qualified Data.Scientific as Sci
 newtype Name = MkName { inner :: Text }
@@ -69,36 +66,32 @@ instance Prefixed Name where
 getName :: Name -> Text
 getName (MkName x) = x
-data Builtin e
+data Prim e
-  = BuiltinAdd e e
+  = PrimAdd e e
-  | BuiltinSub e e
+  | PrimSub e e
-  | BuiltinMul e e
+  | PrimMul e e
-  | BuiltinDiv e e
+  | PrimDiv e e
-  | BuiltinCons e e
+  | PrimCons e e
-  | BuiltinCar e
+  | PrimCar e
-  | BuiltinCdr e
+  | PrimCdr e
-  | BuiltinImmediateP e
+  | PrimImmediateP e
-  | BuiltinConsP e
+  | PrimConsP e
-  | BuiltinIntegerP e
+  | PrimIntegerP e
-  | BuiltinWrite e
+  | PrimWrite e
-  | BuiltinZeroP e
+  | PrimZeroP e
-  | BuiltinNewline
+  | PrimNewline
-  | BuiltinMakeClosure { code :: e, env :: List e }
+  | PrimMakeClosure { code :: e, env :: List e }
-  | BuiltinMakeSharedClosure { codes :: List e, env :: List e }
+  | PrimEnv
-  | BuiltinGetEnv
+  | PrimEnvRef Int
-  | BuiltinEnv
+  | PrimCallCC e
-  | BuiltinEnvRef Int
+  | PrimCaptureCC
-  | BuiltinCallCC e
+  | PrimInvokeCC e (List e)
-  | BuiltinCaptureCC
+  | PrimValues (List e)
-  | BuiltinInvokeCC e (List e)
+  | PrimCallWithValues e e
  | BuiltinValues (List e)
  | BuiltinCallWithValues e e
  | BuiltinPairP e
  | BuiltinList (List 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
@@ -113,79 +106,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)
+  | ExpPrim (Prim Exp)
  | ExpBegin (NonEmpty Exp)
-  | ExpIf Exp Exp (Maybe 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
@@ -193,37 +126,8 @@ data CommandOrDef
  deriving stock (Show, Generic, Data)
  deriving anyclass (NFData)
-newtype LibName = MkLibName { inner :: NonEmpty Name }
+newtype Program = MkProgram
-  deriving stock (Show, Generic, Data)
+  { commandsAndDefs :: List CommandOrDef
  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
  }
  deriving stock (Show, Generic, Data)
  deriving anyclass (NFData)
@@ -242,12 +146,14 @@ makeBaseFunctor ''Exp
 instance DatumIso Name where
-  datumIso = S.symbol >>> S.iso coerce coerce
+  datumIso = S.decorate S.SynVariable
    >>> S.symbol
    >>> S.iso coerce coerce
-builtinDatumIso
+primDatumIso
  :: (Text -> Text)
-  -> S.DatumGrammar a -> S.DatumGrammar (Builtin a)
+  -> S.DatumGrammar a -> S.DatumGrammar (Prim a)
-builtinDatumIso namefn a = S.match
+primDatumIso namefn a = S.match
    $ S.With (. ht2 "+")
    $ S.With (. ht2 "-")
    $ S.With (. ht2 "*")
@@ -262,10 +168,6 @@ builtinDatumIso namefn a = S.match
    $ S.With (. ht1 "zero?")
    $ S.With (. ht0 "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 (. ht1 "call/cc")
@@ -273,8 +175,6 @@ builtinDatumIso namefn a = S.match
    $ 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
@@ -284,8 +184,8 @@ builtinDatumIso namefn a = S.match
      ht1' s = S.headTagged1' (namefn s) a a
      ht0' s = S.headTagged0' (namefn s) a
-instance DatumIso a => DatumIso (Builtin a) where
+instance DatumIso a => DatumIso (Prim a) where
-  datumIso = builtinDatumIso id S.datumIso
+  datumIso = primDatumIso id S.datumIso
 instance DatumIso Lit where
  datumIso = S.match
@@ -306,42 +206,20 @@ 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.listWithStyle
      (S.StyleSyntax 1)
      ( S.el (S.sym "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.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.listWithStyle (S.StyleSyntax 1) $
        S.el (S.sym "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)
@@ -349,101 +227,6 @@ instance DatumIso Exp where
          (\(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)
@@ -451,58 +234,8 @@ instance DatumIso CommandOrDef where
    $ S.With (\_Begin -> _Begin . S.beginLike "begin" (S.rest 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.sym s)
        >>> S.el S.datumIso >>> S.restData S.dataIso
      imp' s = S.list $
        S.el (S.sym s)
        >>> S.el S.datumIso
        >>> S.el S.datumIso
 instance DatumIso ImportDecl where
  datumIso = S.with \decl ->
    S.list (S.el (S.sym "import") >>> S.restData S.dataIso)
    >>> decl
 instance DataIso Program where
-  dataIso = S.with \g ->
+  dataIso = S.dataIso @(List CommandOrDef) >>> S.iso coerce coerce
    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
 -- 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
@@ -131,39 +126,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 +141,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 +150,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
@@ -1,4 +1,3 @@
 {- HLINT ignore "Avoid lambda" -}
 -- | cribbed from sexp-grammar:Language.SexpGrammar.Base
 module Gyehoek.Sexp.Grammar.Base
  ( module Gyehoek.Sexp.Syntax
@@ -9,21 +8,20 @@ module Gyehoek.Sexp.Grammar.Base
  , Grammar(..)
  , DatumGrammar
  , DataGrammar
-  , ListContext(..)
+  , Grammar
  , ListContext
  , (:-)((:-))
  -- * lists
  , list
-  , listWithStyle
+  , listWithIndentation
  , el
  , rest
  , restData
  , nonEmptyData
  , headTagged0'
  , headTagged0
  , headTagged1'
  , headTagged1
  , headTagged2
  , headTagged2'
  -- * atoms
  , simple
  , string
@@ -36,29 +34,29 @@ module Gyehoek.Sexp.Grammar.Base
  , unreadable
  -- * TODO: sort lol
  , prismIso
-  , isoIso
+  , isoIso, decorate
  , snoced
  , letLike
  , ifLike
  , lambdaLike
  , lambdaKeyword
  , kappaKeyword
-  , beginLike
+  , beginLike, headTagged2', dottedList
  , dottedList
  , reifyContext, recontextualise, decontextualise, redecorate
  ) where
 import Data.InvertibleGrammar
 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
@@ -87,6 +85,14 @@ locate =
    (\(_ :- t) -> t)
    (\t -> noAnn :- t)
 modifyAnn :: (Ann -> Ann) -> G (Datum :- t) (Datum :- t)
 modifyAnn f = Iso
  (\(d:-t) -> (d & ann %~ f) :- t)
  (\(d:-t) -> (d & ann %~ f) :- t)
 decorate :: Syn -> G (Datum :- t) (Datum :- t)
 decorate s = modifyAnn $ #syntax .~ s
 newtype ListContext = MkListContext { inner :: List Datum }
 unexpectedSimple :: Simple -> Mismatch
@@ -98,7 +104,7 @@ unexpectedDatum = unexpected . printDatum'
 list
  :: G (ListContext :- t) (ListContext :- t')
  -> G (Datum :- t) t'
-list = listWithStyle StyleData
+list = listWithIndentation Ordinary
 -- |
 -- >>> let grammar = with \g -> dottedList (el int) int >>> g
@@ -133,11 +139,11 @@ dottedList g final = begin >>> Dive (onTail (g >>> end) >>> final)
           [] -> Right t
           d:_ -> Left $ unexpectedDatum d)
-listWithStyle
+listWithIndentation
-  :: Style
+  :: Indentation
  -> G (ListContext :- t) (ListContext :- t')
  -> G (Datum :- t) t'
-listWithStyle ind g = begin >>> Dive (g >>> end)
+listWithIndentation ind g = begin >>> Dive (g >>> end)
  where
    begin = locate >>> partialOsi
      (\case
@@ -159,33 +165,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.
 --
@@ -252,21 +231,13 @@ rest g =
 -- >>> encodeTest dataRestGrammar $ MkExample [1,2,3] "end"
 -- (1 2 3 end)
 restData
-  :: G (List Datum :- t) t'
+  :: G (List Datum :- t) (a :- t)
-  -> G (ListContext :- t) (ListContext :- 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)
@@ -368,36 +339,33 @@ int = integer >>> iso fromIntegral fromIntegral
 -- high-level combinators
 redecorate :: Style -> G (Datum :- t) t' -> G (Datum :- t) t'
 redecorate sty g = iso (styleWith sty) (styleWith sty) >>> g
 headTagged0 :: Text -> G (Datum :- t) t
-headTagged0 s = listWithStyle StyleCode $ el (sym s)
+headTagged0 s = list $ el (symProcedure s)
 headTagged0' :: Text -> DatumGrammar a -> G (Datum :- t) (List a :- t)
-headTagged0' s gt = listWithStyle StyleCode $ el (sym s) >>> rest gt
+headTagged0' s gt = list $ el (symProcedure s) >>> rest gt
 headTagged1 :: Text -> DatumGrammar a -> G (Datum :- t) (a :- t)
-headTagged1 s g1 = listWithStyle StyleCode $ el (sym s) >>> el g1
+headTagged1 s g1 = list $ el (symProcedure s) >>> el g1
 headTagged1'
  :: Text
  -> DatumGrammar a -> DatumGrammar b
  -> G (Datum :- t) (List b :- a :- t)
-headTagged1' s g1 gt = list $ el (sym s) >>> el g1 >>> rest gt
+headTagged1' s g1 gt = list $ el (symProcedure s) >>> el g1 >>> rest gt
 headTagged2
  :: Text
  -> DatumGrammar a -> DatumGrammar b
  -> G (Datum :- t) (b :- a :- t)
-headTagged2 s g1 g2 = listWithStyle StyleCode $ el (sym s) >>> el g1 >>> el g2
+headTagged2 s g1 g2 = list $ el (symProcedure s) >>> el g1 >>> el g2
 headTagged2'
  :: Text
  -> DatumGrammar a -> DatumGrammar b -> DatumGrammar c
  -> G (Datum :- t) (List c :- b :- a :- t)
 headTagged2' s g1 g2 gt =
-  listWithStyle StyleCode $ el (sym s) >>> el g1 >>> el g2 >>> rest gt
+  list $ el (symProcedure s) >>> el g1 >>> el g2 >>> rest gt
 ifLike
  -- | keyword
@@ -410,17 +378,21 @@ ifLike
  -> DatumGrammar c
  -> G (Datum :- t) (c :- b :- a :- t)
 ifLike kw c t f =
-  listWithStyle (StyleSyntax 1) $
+  listWithIndentation (NSpecial 1) $
-    el (sym kw) >>> el c >>> el t >>> el f
+    el (symBuiltin kw) >>> el c >>> el t >>> el f
 symBuiltin, symProcedure :: Text -> G (Datum :- t) t
 symBuiltin s = decorate SynBuiltin >>> sym s
 symProcedure s = decorate SynProcedure >>> sym s
 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 = listWithStyle (StyleSyntax 1) $
+letLike kw name rhs e = listWithIndentation (NSpecial 1) $
-  el (sym kw) >>> el bindings >>> el e
+  el (symBuiltin kw) >>> el bindings >>> el e
  where
    bindings = list $ rest binding
    binding :: G (Datum :- t) ((_, _) :- t)
@@ -431,8 +403,8 @@ lambdaLike
  -> G (Datum :- t1) (a :- t2)
  -> G (ListContext :- a :- t2) (ListContext :- t3)
  -> G (Datum :- t1) t3
-lambdaLike kw formals body = listWithStyle (StyleSyntax 1) $
+lambdaLike kw formals body = listWithIndentation (NSpecial 1) $
-  el kw
+  el (decorate SynBuiltin >>> kw)
  >>> el formals
  >>> body
@@ -447,8 +419,8 @@ beginLike
  -> G (ListContext :- t) (ListContext :- t')
  -> G (Datum :- t) t'
 beginLike kw g =
-  listWithStyle (StyleSyntax 0) $
+  listWithIndentation (NSpecial 0) $
-    el (sym kw) >>> g
+    el (symBuiltin kw) >>> g
 -- | define a printed syntax for an object which cannot be read.
 unreadable
@@ -1,4 +1,3 @@
 {-# OPTIONS_GHC -Wno-incomplete-patterns #-}
 module Gyehoek.Sexp.Print
  ( printDatum
  , printDatumW
@@ -7,34 +6,26 @@ module Gyehoek.Sexp.Print
  , printData'
  , htmlDatum
  , htmlData
  , putDoc
  ) where
 import Gyehoek.Sexp.Syntax
 import Prettyprinter
-import Gyehoek.Prelude hiding (Simple)
+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 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)
 import Data.Foldable (toList)
 import qualified Data.Scientific as Sci
 data Syn
  = SynSyntax
  | SynProcedure
  | SynParen Int
  | SynString
  | SynConstant
  | SynVariable
  | SynNone
  deriving (Show, Read, Data, Generic, Eq)
 printDatum' :: Datum -> Text
 printDatum' =
  prettyDatum 0
@@ -92,7 +83,7 @@ printDatumW w =
 prettyDatum :: Int -> Datum -> Doc Syn
 prettyDatum depth datum = case datum of
-  Simple simp -> prettySimple depth simp
+  Simple simp -> annotate (datum ^. syntax) $ prettySimple depth simp
  DotList xs x ->
    pparen depth . group . align $
      vsep [ vsep (prettyDatum (depth+1) <$> toList xs)
@@ -100,21 +91,19 @@ prettyDatum depth datum = case datum of
           , prettyDatum (depth+1) x
           ]
-  List' sty xs -> case sty of
+  List' indent xs ->
-    StyleSyntax n | keyword:args <- xs ->
+    case indent of
      NSpecial n | keyword:args <- xs ->
        let (specialArgs,body) = splitAt n args
        in pparen depth . nest 2 . vsep $
            [ group . nest 2 . hcat $
-            [ annotate SynSyntax $ prettyDatum (depth+1) keyword
+              [ prettyDatum (depth+1) keyword
              , if null specialArgs then mempty else softline
              , hsep $ prettyDatum (depth+1) <$> specialArgs
              ]
            , vsep $ prettyDatum (depth+1) <$> body
            ]
-    StyleCode | f:args <- xs -> pparen depth $
+      Ordinary; NSpecial _ -> pparen depth $
      group . align . vsep . (_head %~ annotate SynProcedure) $
        prettyDatum (depth+1) <$> xs
    StyleData; StyleSyntax _; StyleCode -> pparen depth $
        group . align . vsep $
          prettyDatum (depth+1) <$> xs
  _ -> error [i|unimplemented: #{datum}|]
@@ -122,11 +111,15 @@ prettyDatum depth datum = case datum of
 pparen depth = enclose (delim depth "(") (delim depth ")")
 delim depth = annotate (SynParen depth)
 delimited :: Int -> Doc Syn -> Doc Syn -> List (Doc Syn) -> Doc Syn
 delimited depth open close =
  encloseSep (delim depth open) (delim depth close) softline
 prettySimple :: Int -> Simple -> Doc Syn
 prettySimple depth = \case
  SimpleBoolean b -> annotate SynConstant $ if b then "#t" else "#f"
-  SimpleNumber n -> n
+  SimpleNumber n ->
-    & Sci.floatingOrInteger @Double @Integer
+    Sci.floatingOrInteger n
    & either viaShow viaShow
    & annotate SynConstant
  SimpleString s -> annotate SynString $ viaShow s
@@ -139,7 +132,7 @@ putDoc = ANSI.renderIO stdout
 highlightAnsi :: Syn -> AnsiStyle
 highlightAnsi = \case
-  SynSyntax -> color Magenta <> italicized <> bold
+  (SynBuiltin; SynMacro) -> color Magenta <> italicized <> bold
  SynProcedure -> color Blue
  SynConstant -> color Yellow
  SynParen n -> colorDull $ rainbow ^?! ix n
@@ -151,7 +144,8 @@ highlightHtml :: Syn -> Html () -> Html ()
 highlightHtml syn = span_ [class_ synClass]
  where
    synClass = case syn of
-      SynSyntax -> "syn-builtin"
+      SynBuiltin -> "syn-builtin"
      SynMacro -> "syn-macro"
      SynConstant -> "syn-constant"
      SynString -> "syn-string"
      SynProcedure -> "syn-procedure"
@@ -1,4 +1,3 @@
 {-# LANGUAGE ApplicativeDo #-}
 module Gyehoek.Sexp.Read
  ( readFile
  , readString
@@ -21,7 +20,6 @@ import qualified Data.Text as T
 import Data.Char (GeneralCategory(..), generalCategory)
 import Data.Scientific (Scientific)
 import Gyehoek.Jalmot
 import Data.Foldable
 readFile :: (Jalmot :> es, IOE :> es) => FilePath -> Eff es (List Datum)
@@ -106,51 +104,18 @@ verb = L.symbol sc
 identifier :: P Text
 identifier = label "identifier" . lexeme . choice $
-  [ typical
+  [ typical-- , delimited, peculiar
  -- , delimited
  , peculiar
  ]
  where
    typical = T.cons <$> initial <*> subsequent
      where
        subsequent = takeWhileP Nothing \c ->
          isInitial c ||
          c `hasCategory` [SpacingCombiningMark, EnclosingMark, DecimalNumber]
          || c == '.' || c == '@' || c == '+' || c == '-'
        initial = satisfy isInitial
    delimited = _
-    peculiar = peculiarSign <|> peculiarDot
+    peculiar = _
    -- peculiarSign과 R⁷RS의 이 production 새 개들은 같음:
    --   ⟨explicit sign⟩
    --   ⟨explicit sign⟩ ⟨sign subsequent⟩ ⟨subsequent⟩*
    --   ⟨explicit sign⟩ . ⟨dot subsequent⟩ ⟨subsequent⟩*
    -- 같음:
    --   ⟨explicit sign⟩
    --     ((⟨sign subsequent⟩ | . ⟨dot subsequent⟩) ⟨subsequent⟩*)?
    peculiarSign = do
      sign <- explicitSign
      r <- fold <$> optional do
        neck <- choice
          [ T.singleton <$> signSubsequent
          , T.cons <$> single '.' <*> (T.singleton <$> dotSubsequent)
          ]
        subs <- subsequent
        pure $ neck <> subs
      pure $ T.cons sign r
    -- . ⟨dot subsequent⟩ ⟨subsequent⟩*
    peculiarDot = do
      dot <- single '.'
      dotSub <- dotSubsequent
      subs <- subsequent
      pure $ T.cons dot $ T.cons dotSub subs
    dotSubsequent = single '.' <|> signSubsequent
      <?> "dot subsequent"
    explicitSign = (satisfy \c -> c == '+' || c == '-')
      <?> "explicit sign"
    signSubsequent = initial <|> explicitSign <|> satisfy (=='@')
      <?> "sign subsequent"
    hasCategory c xs = generalCategory c `elem` xs
    isInitial c = (c `hasCategory`
@@ -242,7 +207,7 @@ simpleDatum = choice
  , SimpleNumber <$> try number
  -- , SimpleCharacter <$> character
  , SimpleString <$> string
-  , SimpleSymbol <$> try symbol
+  , SimpleSymbol <$> symbol
  -- , SimpleBytevector <$> bytevector
  ]
@@ -254,9 +219,9 @@ compoundDatum = choice
 list :: P Compound
 list = label "list" . between lparen rparen $ do
  optional datum >>= \case
-    Nothing -> pure $ ListF StyleData []
+    Nothing -> pure $ ListF Ordinary []
    Just x -> do
      xs <- many datum
      optional (dot *> datum) >>= \case
-        Nothing -> pure $ ListF StyleData (x:xs)
+        Nothing -> pure $ ListF Ordinary (x:xs)
        Just y -> pure $ DotListF (x:|xs) y
@@ -1,7 +1,6 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE ApplicativeDo #-}
 {- HLINT ignore "Use newtype instead of data" -}
 module Gyehoek.Sexp.Syntax
  ( DatumF(..)
  , Simple(..)
@@ -14,7 +13,8 @@ module Gyehoek.Sexp.Syntax
  , Cofree((:<))
  , Fix(..)
  , Compound
-  , Style(..)
+  , Indentation(..)
  , Syn(..)
  , pattern Simple
  , pattern Compound
  , pattern Labeled
@@ -25,8 +25,10 @@ module Gyehoek.Sexp.Syntax
  , pattern Vector
  , pattern DotList
  , pattern Gyehoek.Sexp.Syntax.List
-  , style
+  , syntax
-  , styleWith
+  , indentation
  , adorn
  , indentWith
  , pattern Unreadable
  , pattern Bytevector
  , pattern Symbol
@@ -37,16 +39,15 @@ module Gyehoek.Sexp.Syntax
  , Ann(..)
  , noAnn
  , ann
  , dat
  , pattern List'
  , position
  , stripAnn
  ) where
-import Language.Haskell.TH.Syntax (Lift (lift))
+import Language.Haskell.TH.Syntax (Lift (lift), liftData)
 import Data.Scientific (Scientific)
 import Data.ByteString (ByteString)
-import Gyehoek.Prelude hiding (Simple)
+import Gyehoek.Prelude hiding ((:<), Simple)
 import Text.Megaparsec.Pos (SourcePos(..), sourcePosPretty)
 import Control.Comonad.Cofree (Cofree((:<)), _extract, _unwrap)
 import Data.Fix (Fix (..))
@@ -67,9 +68,7 @@ data DatumF a
  | CompoundF (CompoundF a)
  | LabeledF Label a
  | LabelRefF Label
  -- | Should not be used outside of the "Gyehoek.Sexp.QQ" implementation.
  | MetaF Text
  -- | Should not be used outside of the "Gyehoek.Sexp.QQ" implementation.
  | MetaSpliceF Text
  deriving stock (Show, Eq, Data, Generic, Lift, Functor, Foldable, Traversable)
  deriving anyclass (NFData)
@@ -86,7 +85,7 @@ data Simple
  deriving anyclass (NFData)
 data CompoundF a
-  = ListF Style (List a)
+  = ListF Indentation (List a)
  | DotListF (NonEmpty a) a
  | VectorF (List a)
  | AbbrevF Prefix a
@@ -94,12 +93,7 @@ data CompoundF a
  deriving anyclass (NFData)
 data Prefix
-  = Quote -- ^ @'@
+  = Quote | Backtick | Comma | CommaAt
  | Backtick -- ^ @`@
  | Comma -- ^ @,@
  | CommaAt -- ^ @,\@@
  | PoundQuote -- ^ @#'@
  | PoundBacktick -- ^ @#`@
  deriving stock (Show, Eq, Data, Generic, Lift)
  deriving anyclass (NFData)
@@ -120,21 +114,33 @@ newtype Label = MkLabel Natural
 type Datum = Cofree DatumF Ann
 type Compound = CompoundF Datum
-data Style
+data Indentation
-  = StyleSyntax Int
+  = NSpecial Int
-  | StyleCode
+  | Ordinary
  | StyleData
  deriving stock (Data, Eq, Generic, Show, Lift, Read)
  deriving anyclass (NFData)
 data Syn
  = SynMacro
  | SynBuiltin
  | SynProcedure
  | SynParen Int
  | SynString
  | SynConstant
  | SynVariable
  | SynNone
  deriving (Show, Read, Data, Generic, Eq, Lift)
 data Ann = MkAnn
-  { position :: Maybe SourcePos
+  { syntax :: Syn
  , position :: Maybe SourcePos
  }
  deriving (Show, Data, Eq, Generic)
 noAnn :: Ann
 noAnn = MkAnn
-  { position = Nothing
+  { syntax = SynNone
  , position = Nothing
  }
 -- requisite of the Pretty instance for invertible-grammar's error type.
@@ -152,21 +158,23 @@ deriveEq1 ''DatumF
 ann :: Lens' Datum Ann
 ann = _extract
-dat :: Lens' Datum (DatumF Datum)
+syntax :: Lens' Datum Syn
-dat = _unwrap
+syntax = ann . #syntax
 position :: Lens' Datum (Maybe SourcePos)
 position = ann . #position
-- affine
+indentation :: Traversal' Datum Indentation
-style :: Traversal' Datum Style
+indentation k (syn :< CompoundF (ListF ind xs)) = do
 style k (syn :< CompoundF (ListF ind xs)) = do
  ind' <- k ind
  pure $ syn :< CompoundF (ListF ind' xs)
-style k a = pure a
+indentation k a = pure a
-styleWith :: Style -> Datum -> Datum
+adorn :: Syn -> Datum -> Datum
-styleWith = set style
+adorn = set syntax
 indentWith :: Indentation -> Datum -> Datum
 indentWith = set indentation
 stripAnn :: Datum -> Fix DatumF
 stripAnn = hoist tailF
@@ -200,9 +208,9 @@ pattern Meta x <- _ :< MetaF x
 pattern List :: List Datum -> Datum
 pattern List a <- _ :< CompoundF (ListF _ a)
-  where List a = noAnn :< CompoundF (ListF StyleData a)
+  where List a = noAnn :< CompoundF (ListF Ordinary a)
-pattern List' :: Style -> List Datum -> Datum
+pattern List' :: Indentation -> List Datum -> Datum
 pattern List' ind a <- _ :< CompoundF (ListF ind a)
  where List' ind a = noAnn :< CompoundF (ListF ind a)
@@ -218,25 +226,12 @@ pattern Abbrev :: Prefix -> Datum -> Datum
 pattern Abbrev p a <- _ :< CompoundF (AbbrevF p a)
  where Abbrev p a = noAnn :< CompoundF (AbbrevF p a)
 pattern Boolean :: Bool -> Datum
 pattern Boolean a = Simple (SimpleBoolean a)
 pattern Number :: Scientific -> Datum
 pattern Number a = Simple (SimpleNumber a)
 pattern Character :: Char -> Datum
 pattern Character a = Simple (SimpleCharacter a)
 pattern String :: Text -> Datum
 pattern String a = Simple (SimpleString a)
 pattern Symbol :: Text -> Datum
 pattern Symbol a = Simple (SimpleSymbol a)
 pattern Bytevector :: ByteString -> Datum
 pattern Bytevector a = Simple (SimpleBytevector a)
 pattern Unreadable :: Text -> Datum
 pattern Unreadable a = Simple (SimpleUnreadable a)
@@ -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,150 @@
 {-# LANGUAGE TemplateHaskellQuotes #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE DeriveAnyClass #-}
 module Gyehoek.Stack.Syntax
  ( Program(..)
  , Routine(..)
  , Instr(..)
  , Block(..)
  , Tail(..)
  , Val(..)
  , Lit(..)
  , Obj(..)
  , Imm(..)
  , Hob(..)
  , Prim(..)
  , Name(..)
  , Reg(..)
  , Label(..)
  , pattern ValLabel
  , pattern ObjLabel
  , 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(..), pattern ObjLabel, Reg, Label)
 import Gyehoek.Prelude
 import Gyehoek.Sexp ((:-)((:-)))
 newtype Program = MkProgram
  { routines :: HashMap Label 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 :: Label
  , 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
  -- | call the procedure at stack index `n` supplied with `n`
  -- arguments on top of the stack, then return by calling the
  -- continuation at stack index `n+1`.
  = TailCall Int
  | Call Int
  | If Val Block Block
  | Return Int
  | CallCC
  deriving stock (Show, Generic, Data)
  deriving anyclass (NFData)
 data Instr
  = Pop Reg
  | Push Val
  | Load Reg Int
  | Prim (Prim Val)
  deriving stock (Show, Generic, Data)
  deriving anyclass (NFData)
 data Val
  = ValReg Reg
  | ValImm Imm
  deriving stock (Show, Generic, Data, Eq)
  deriving anyclass (NFData)
 pattern ValLabel :: Label -> Val
 pattern ValLabel x = ValImm (ImmLabel x)
 --- sexp work
 pure []
 instance S.DatumIso Instr where
  datumIso = S.match
    $ S.With (S.headTagged1 "pop!" S.datumIso >>>)
    $ S.With (S.headTagged1 "push!" S.datumIso >>>)
    $ S.With (S.headTagged2 "load" S.datumIso S.datumIso >>>)
    $ S.With (S.headTagged1 "prim" 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.With (S.headTagged1 "call" S.datumIso >>>)
    $ S.With (if_ >>>)
    $ S.With (S.headTagged1 "return" S.datumIso >>>)
    $ S.With (S.headTagged0 "call/cc" >>>)
    $ S.End
    where
      -- if_ = S.ifLike "if" (S.datumIso @Val) S.datumIso S.datumIso
      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 (S.datumIso >>>)
    $ 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.datumIso @Label)
       >>> S.restData (S.dataIso @Block)
       )
      >>> rout
 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,521 @@
 {-# LANGUAGE ViewPatterns, MultilineStrings #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE DeriveAnyClass #-}
 module Gyehoek.Stack.VM
  ( VM(..)
  , Env(..)
  , eval
  , trace
  , module Gyehoek.Stack.Syntax
  , writeObj
  , traceEval
  ) where
 import Gyehoek.Stack.Syntax
 import Control.Lens
 import qualified Data.HashMap.Strict as H
 import Data.List (unfoldr, intersperse, compareLength)
 import Gyehoek.Prelude
 import qualified Data.List.NonEmpty as NE
 import Lucid
 import Data.Foldable (traverse_)
 import qualified Gyehoek.Sexp as S
 import Gyehoek.Jalmot
 import Text.Pretty.Simple (pStringNoColor, pShowNoColor)
 import Effectful.State.Static.Local (runState, evalState, get)
 import Data.Traversable
 import Control.Applicative (Alternative(..))
 import Gyehoek.Sexp.Print (htmlData)
 import Control.DeepSeq (deepseq, ($!!))
 import Gyehoek.Sexp.Print (htmlData, htmlDatum)
 import Control.DeepSeq (deepseq, ($!!))
 import Data.String (fromString)
 import Data.Monoid (First)
 import GHC.Stack (popCallStack)
 import Data.Maybe (fromMaybe)
 -- | non-essential information maintained only to aide in debugging.
 data DebugVM = MkDebugVM
  { activeRoutine :: Label
  }
  deriving (Show, Generic)
 newtype Frame = MkFrame { locals :: List Obj }
  deriving stock (Show, Generic)
 -- affine
 returnAddress :: Traversal' Frame Obj
 returnAddress = #locals . _last
 -- affine
 activeProcedure :: Traversal' Frame Obj
 activeProcedure = #locals . _init . _last
 newtype Stack = MkStack { frames :: NonEmpty Frame }
  deriving stock (Show, Generic)
 data VM = MkVM
  { stack :: Stack
  , code :: List Instr
  , tail :: Tail
  , registers :: HashMap Reg Obj
  , stdout :: Text
  , result :: Maybe (List Obj)
  , debug :: DebugVM
  }
  deriving (Show, Generic)
 type instance Index Frame = Int
 type instance IxValue Frame = Obj
 instance Ixed Frame where
  ix j = wrappedIso . ix j
 instance Cons Frame Frame Obj Obj where
  _Cons = prism'
    (\(x,MkFrame xs) -> MkFrame (x:xs))
    \case
      MkFrame (x:xs) -> Just (x, MkFrame xs)
      MkFrame [] -> Nothing
 instance Each Frame Frame Obj Obj where each = wrappedIso . each
 instance Each Stack Stack Frame Frame where each = wrappedIso . each
 pushes :: Foldable f => f Obj -> Frame -> Frame
 pushes = flip $ foldr cons
 _NonEmpty :: Iso (NonEmpty a) (NonEmpty b) (a, List a) (b, List b)
 _NonEmpty = iso
  (\(x:|xs) -> (x,xs))
  (\(x,xs) -> x:|xs)
 pushFrame :: Frame -> Stack -> Stack
 pushFrame f (MkStack xs) = MkStack $ NE.cons f xs
 activeFrame :: Lens' VM Frame
 activeFrame = #stack . #frames . _NonEmpty . _1
 data Env = MkEnv
  { labels :: HashMap Label Routine
  }
  deriving (Show, Generic)
 step :: Jalmot :> es => Env -> VM -> Eff es VM
 step g vm = case vm ^. #code of
  c:cs -> stepI g (vm & #code .~ cs) c
  [] -> stepT g vm vm.tail
 vmerror :: (HasCallStack, Jalmot :> es) => Text -> Eff es a
 vmerror = throwError . VMError
 stepI :: Jalmot :> es => Env -> VM -> Instr -> Eff es VM
 stepI e vm (Load r j) = do
  x <- expectOf [i|object at index #{j}|] (activeFrame . ix j) vm
  pure $ vm & #registers . at r ?~ x
 stepI e vm (Push v) = traverseOf activeFrame push vm
  where push xs = cons <$> evalVal e vm v <*> pure xs
 stepI g vm (Prim p) = stepP g vm p
 stepI e vm (Pop r) = case vm ^? activeFrame . _Cons of
  Nothing -> vmerror "empty stack"
  Just (x,xs) -> pure $ vm & #registers . at r ?~ x
               & activeFrame .~ xs
 stepI e vm ins = vmerror [i|unimplemented instruction: #{ins}|]
 stepT :: Jalmot :> es => Env -> VM -> Tail -> Eff es VM
 stepT g vm tc@(Call nargs) = do
  (args,f,ret,frm) <- parseCall nargs (vm ^. activeFrame)
    & expectOf [i|bad call: #{show tc}|] _Just
  rt <- getRoutine g f
  let newFrame = MkFrame $ args ++ [f,ret]
  pure $ vm
    & jumpToRoutine rt
    & activeFrame .~ frm
    -- it is not essential we clear the registers, but it'll
    -- make bugs more obvious.
    & #registers .~ mempty
    & #stack %~ \stk ->
      case f of
        ObjHob (HobContinuation {stack}) ->
          coerce $ stack & _NonEmpty . _1 <>:~ (args ++ [f])
        _ -> pushFrame newFrame stk
 stepT g vm tc@(Return nret) = do
  (xs,_) <- splitAtExact nret (vm ^. activeFrame . #locals)
    & expectOf [i|bad return: #{show tc}|] _Just
  expectOf [i|no return addr|] (activeFrame . returnAddress) vm >>= \case
    ObjLabel "halt" -> pure $ vm & #result ?~ xs
    ra -> do
      rt <- getRoutine g ra
      vm & traverseOf #stack (fmap snd . popFrame)
         & mapped . activeFrame %~ pushes xs
         & mapped %~ jumpToRoutine rt
         -- it is not essential we clear the registers, but it'll make
         -- bugs more obvious.
         & mapped . #registers .~ mempty
 stepT g vm tc@(TailCall nargs) = do
  (args,f,ra) <- parseTailCall nargs (vm ^. activeFrame)
    & expectOf [i|bad call: #{show tc}|] _Just
  case f of
    ObjLabel "halt" -> pure $ vm & #result ?~ args
    _ -> do
      rt <- getRoutine g f
      let newFrame = MkFrame $ args ++ [f, ra]
      pure $ vm
        & jumpToRoutine rt
        -- replace the active frame; don't push a new one.
        & activeFrame .~ newFrame
        -- it is not essential we clear the registers, but it'll make
        -- bugs more obvious.
        & #registers .~ mempty
 stepT g vm (If c t f) = do
  branch <- evalVal g vm c <&> \case
      ObjImm (ImmBool False) -> f
      _ -> t
  pure $ jumpToBlock branch vm
 stepT g vm CallCC = do
  (cc,withcc,frm) <- parseCallCC (vm ^. activeFrame)
    & expectOf "bad call/cc" _Just
  let stk = vm.stack & #frames . _NonEmpty . _1 .~ frm
  let reified_cc = ObjHob $ HobContinuation cc (coerce stk)
  let newFrame = MkFrame [reified_cc, withcc, cc]
  rt <- getRoutine g withcc
  pure $ vm
    & jumpToRoutine rt
    -- replace the active frame; don't push a new one.
    & activeFrame .~ newFrame
    -- it is not essential we clear the registers, but it'll make
    -- bugs more obvious.
    & #registers .~ mempty
 stepP :: Jalmot :> es => Env -> VM -> Prim Val -> Eff es VM
 stepP g vm p = traverse (evalVal g vm) p >>= \case
  PrimZeroP x -> case x of
    ObjImm (ImmInt n) -> ret1 . ObjImm . ImmBool $ n == 0
    _ -> vmerror [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) -> ret1 . ObjHob $ HobClosure l env
      _ -> vmerror [i|expected label, got #{f}|]
  PrimEnv -> do
    x <- vm & expectOf "expected closure" (activeFrame . activeProcedure)
    ret1 x
  PrimEnvRef n -> do
    (label,env) <- vm & expectOf "expected closure"
        (activeFrame . activeProcedure . #_ObjHob . #_HobClosure) 
    x <- env & expectOf "expected upval" (ix n)
    ret1 x
  PrimCons x y -> ret1 $ ObjHob $ HobPair x y
  PrimCar x -> case x of
      ObjHob (HobPair car _) -> ret1 car
      _ -> vmerror [i|expected pair, got ${x}|]
  PrimCdr x -> case x of
      ObjHob (HobPair _ cdr) -> ret1 cdr
      _ -> vmerror [i|expected pair, got ${x}|]
  -- PrimCaptureCC -> do
  --   label <- vm & expectOf [i|bad stack, no return addr|]
  --     (activeFrame . returnAddress . #_ObjImm . #_ImmLabel)
  --   ret1 . ObjHob $ HobContinuation { label }
  x -> vmerror [i|unimplemented prim: #{p}|]
  where
    ret vs = pure $ vm & activeFrame . #locals <>:~ vs
    ret1 v = ret [v]
    arith_binop op (ObjImm (ImmInt x)) (ObjImm (ImmInt y)) =
      ret1 $ ObjImm (ImmInt (op x y))
    arith_binop _ x y = vmerror [i|bad arith: #{x}, #{y}|]
 popFrame :: (HasCallStack, Jalmot :> es) => Stack -> Eff es (Frame, Stack)
 popFrame stk = case stk ^. #frames . to NE.uncons of
  (_, Nothing) -> vmerror "no frame to pop"
  (f, Just fs) -> pure (f, stk & #frames .~ fs)
 jumpToBlock :: Block -> VM -> VM
 jumpToBlock b vm = vm
  & #code .~ b.code
  & #tail .~ b.tail
 jumpToRoutine :: Routine -> VM -> VM
 jumpToRoutine rt vm = vm
  & jumpToBlock rt.start
  & #debug . #activeRoutine .~ rt.label
 getLabel :: Obj -> Maybe Label
 getLabel = \case
  ObjHob (HobClosure {label}) -> Just label
  ObjHob (HobContinuation {cont}) -> getLabel cont
  ObjImm (ImmLabel label) -> Just label
  x -> Nothing
 getRoutine :: (HasCallStack, Jalmot :> es) => Env -> Obj -> Eff es Routine
 getRoutine g f = do
  l <- getLabel f & expectOf [i|no label for #{f}|] _Just
  case g ^. #labels . at l of
    Just rt -> pure rt
    Nothing -> vmerror [i|undefined label #{l}|]
 expectOf
  :: (HasCallStack, Jalmot :> es)
  => Text -> Getting (First a) s a -> s -> Eff es a
 expectOf msg l = maybe (vmerror msg) pure . preview l
 evalToLabel :: Jalmot :> es => Env -> VM -> Val -> Eff es Label
 evalToLabel e vm v =
  evalVal e vm v >>= \case
    ObjImm (ImmLabel x) -> pure x
    x -> vmerror [i|not a label: #{x}|]
 evalVal :: Jalmot :> es => Env -> VM -> Val -> Eff es Obj
 evalVal e vm = \case
  ValImm imm -> pure $ ObjImm imm
  ValReg r -> case vm ^. #registers . at r of
    Just x -> pure x
    Nothing -> vmerror [i|undefined register: #{r}|]
 splitAtExact :: Int -> List a -> Maybe (List a, List a)
 splitAtExact n xs = case compareLength xs n of
  (EQ;GT) -> Just $ splitAt n xs
  LT -> Nothing
 takeExact :: Int -> List a -> Maybe (List a)
 takeExact n xs = case compareLength xs n of
  (EQ;GT) -> Just $ take n xs
  LT -> Nothing
 parseCallCC :: Frame -> Maybe (Obj, Obj, Frame)
 parseCallCC frm = do
  ([cc,withcc],ys) <- splitAtExact 2 (frm ^. #locals)
  pure (cc,withcc,MkFrame ys)
 parseCall :: Int -> Frame -> Maybe (List Obj, Obj, Obj, Frame)
 parseCall nargs frm = do
  (xs,ys) <- splitAtExact (nargs+2) (frm ^. #locals)
  let (xs',[f,ret]) = splitAt nargs xs
  pure (xs',f,ret,MkFrame ys)
 parseTailCall :: Int -> Frame -> Maybe (List Obj, Obj, Obj)
 parseTailCall nargs frm = do
  (xs,_) <- splitAtExact (nargs+1) (frm ^. #locals)
  let (xs',f) = xs ^?! _Snoc
  pure (xs',f,frm ^?! returnAddress)
 initialVM :: VM
 initialVM = MkVM
  { stack = MkStack . NE.singleton . MkFrame $
    [ ObjLabel "start"
    , ObjLabel "<nowhere at all>"
    , ObjLabel "halt"
    ]
  , tail = TailCall 0
  , code = []
  , registers = mempty
  , stdout = ""
  , result = Nothing
  , debug = MkDebugVM
    { activeRoutine = "<nowhere>"
    }
  }
 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
 loopM :: Monad m => (a -> m (Either b a)) -> a -> m b
 loopM f a = f a >>= \case
  Right a' -> loopM f a'
  Left b -> pure b
 eval :: Jalmot :> es => Program -> Eff es (List Obj)
 eval p = initialVM & loopM \vm -> case vm ^. #result of
  Nothing -> Right <$> step (initialEnv p) vm
  Just rs -> pure . Left $ rs
 data Trace
  = Step { vm :: VM, next :: Trace }
  | StepToSuccess { vm :: VM, result :: List Obj }
  | StepToFailure { vm :: VM, err :: AJalmotCS }
  deriving (Show)
 trace :: Program -> Trace
 trace p = go (initialEnv p) initialVM
  where
    go g vm =
      case vm.result of
        Just rs -> StepToSuccess vm rs
        Nothing ->
          case runPureEff . runJalmotCS $ step g vm of
            Left err -> StepToFailure vm err
            Right vm' -> Step vm (go g vm')
 writeObj :: Obj -> Text
 writeObj = runJalmotUnsafe . S.encodeWith' S.datumIso
 traceEval :: IOE :> es => Program -> Eff es ()
 traceEval p = do
  let t = trace p
  liftIO . renderToFile "trace.html" . ppDoc p $ t
 ppDoc :: Program -> Trace -> Html ()
 ppDoc p t =
  html_ do
    head_ do
      title_ "stackify trace"
      style_ """
        pre {
          max-width: 95vw;
          overflow: scroll;
        }
        table {
          max-width: 95vw;
        }
        tbody > tr:nth-of-type(even) {
            background-color: rgb(237 238 242);
        }
        .loc {
            font-size: 0.8rem;
        }
        .syn-builtin, .syn-macro {
            color: purple;
            font-style: italic;
            font-weight: bold;
        }
        .syn-constant {
            color: olive;
        }
        .syn-procedure {
            color: teal;
        }
        td pre {
          display: inline
        }
        .syn-paren-0 { color: maroon; }
        .syn-paren-1 { color: olive; }
        .syn-paren-2 { color: green; }
        .syn-paren-3 { color: navy; }
        .syn-paren-4 { color: purple; }
        .stack-frame
        { display: inline-flex
        ; flex-direction: row
        ; column-gap: 0.5em
        }
      """
    body_ do
      details_ do
        summary_ "stack code"
        pre_ $ code_ do
          htmlData . runJalmotUnsafe . S.toData S.dataIso $ p
      ppTrace t
 ppTrace :: Trace -> Html ()
 ppTrace trace =
  table_ do
    thead_ $ tr_ do
      traverse_ (th_ [scope_ "col"])
        ["routine","next instruction","stack frame"]
    tbody_ do
      go trace
  where
    go :: Trace -> Html ()
    go = \case
      Step vm next -> ppVM vm >> go next
      StepToSuccess vm rs -> do
        tr_ [class_ "trace-result"] do
          td_ do
            details_ do
              summary_ "result"
              pre_ do
                code_ . toHtml . pShowNoColor $ vm
          td_ [colspan_ "2"] do
            sequence_ . intersperse " | " $ code_ . ppDatum <$> rs
      StepToFailure vm err -> do
        ppVM vm
        tr_ [class_ "trace-failure"] do
          td_ [colspan_ "3"] do
            details_ do
              summary_ "error"
              pre_ do
                samp_ do
                  fromString $ displayException err
 ppVM :: VM -> Html ()
 ppVM vm = do
  tr_ do
    td_ do
      details_ do
        summary_ do
          var_ [class_ "loc"] do
            vm ^. #debug . #activeRoutine . to ppDatum
        pre_ do
          code_ . toHtml . pShowNoColor $ vm
    td_ do
      code_ curi
    td_ do
      ppStack vm.stack
  where
    curi = vm ^?! failing (#code . _head . to ppDatum) (#tail . to ppDatum)
 ppStack :: Stack -> Html ()
 ppStack stk = do
  span_ [class_ "stack"] do
    stk ^.. each
      & fmap ppFrame
      & intersperse " | "
      & sequence_
 ppFrame :: Frame -> Html ()
 ppFrame frm = do
  span_ [class_ "stack-frame"] do
    sequence_ $ frm ^.. #locals . each . to ppDatum
 ppData :: S.DataIso a => a -> Html ()
 ppData = htmlData . runJalmotUnsafe . S.toData S.dataIso
 ppDatum :: S.DatumIso a => a -> Html ()
 ppDatum = htmlDatum . runJalmotUnsafe . S.toDatum S.datumIso
 fac (n :: Int) = [stkP|
 (define $start
  (push! $fac)
  (push! #{n})
  (tail-call 1))
 (define $fac
  (load %n 0)
  (prim %x0 (zero? %n))
  (if %x0
      (then (push! 1)
            (return 1))
      (else (prim %x1 (- %n 1))
            (push! $fac-c0)
            (push! $fac)
            (push! %x1)
            (call 1))))
 (define $fac-c0
  (pop! %x2)
  (pop! %n)
  (prim %x3 (* %n %x2))
  (push! %x3)
  (return 1))
 |]
@@ -1,3 +1,4 @@
 {- HLINT ignore "Use newtype instead of data" -}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE TemplateHaskellQuotes #-}
@@ -1,4 +1,5 @@
-(import (scheme eval))
+((λ ()
-
+   (* 2 (call/cc
-(eval '(λ (x) x)
+         (λ (k)
-      (environment))
+           (begin (k 6)
                  3))))))
@@ -5,75 +5,53 @@ 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 Test.Tasty.ExpectedFailure (ignoreTestBecause)
 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
+test_cpsInterpreter =
-brokenEvalTests =
+  ignoreTestBecause "i forgorrrr" $
-  []
+  testGroup "cps interpreter" $
-  -- [ "adder"
+  [ primitives
-  -- , "apply2"
+  , testCase "halt with constant" do
-  -- , "apply-twice"
+      evalsTo [ObjImm (ImmInt 123)] [cps|
-  -- , "arith"
+        (continue halt 123)
-  -- , "begin-1"
+      |]
-  -- , "callcc-constant"
+  , testCase "identity cont" do
-  -- , "callcc-discard"
+      evalsTo [ObjImm (ImmInt 154)] [cps|
-  -- , "callcc-early-exit-1"
+        (letrec ((id (κ (x)
-  -- , "callcc-early-exit-2"
+                       (continue halt x))))
-  -- , "callcc-early-exit-3"
+          (continue id 154))
-  -- , "callcc-early-exit-4"
+      |]
-  -- , "callcc-early-exit-5"
+  , testCase "identity function" do
-  -- , "callcc-early-exit-6"
+      evalsTo [ObjImm (ImmInt 456)] [cps|
-  -- , "callcc-nested-1"
+        (letrec ((id (λ (x ktail)
-  -- , "callcc-nested-2"
+                       (continue ktail x))))
-  -- , "complicated-1"
+          (id 456 halt))
-  -- , "cons-1"
+      |]
-  -- , "factorial"
+  , testCase "square" do
-  -- , "false"
+      evalsTo [ObjImm (ImmInt 81)] [cps|
-  -- , "fn-of-fn"
+        (letrec ((square (λ (x ktail)
-  -- , "if-false"
+                           (prim (* x x)
-  -- , "if-number"
+                             (κ (r) (continue ktail r))))))
-  -- , "if-true"
+          (square 9 halt))
-  -- , "lambda"
+      |]
  -- , "letrec-fn"
  -- , "let-fn"
  -- , "lit-int"
  -- , "square"
  -- , "true"
  -- ]
 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
  ]
-maybeBroken name broken = applyWhen (name `elem` broken) expectFail
+evalsTo :: HasCallStack => List Obj -> Sut.Exp -> Assertion
 evalsTo rs e = Sut.evalExp e @?= rs
-cpsCase :: (FilePath -> IO Text) -> FilePath -> TestTree
+primitives = testGroup "primitives"
-cpsCase f test =
+  [ testGroup "arith"
-  maybeBroken testName brokenEvalTests $
+    [ testCase "basic 1" do
-    goldenVsAction testName resultFile action printProcResult
+        evalsTo [ObjImm (ImmInt 20)] [cps|
-  where
+          (prim (* 4 5)
-    testName = takeFileName test
+            (κ (x) (continue halt x)))
-    resultFile = test </> "exec"
+          |]
-    sourceFile = test </> "source.scm"
+    , testCase "basic 2" do
-    action = catch @SomeException
+        evalsTo [ObjImm (ImmInt 35)] [cps|
-      (do r <- f sourceFile
+          (prim (* 2 16)
-          pure $!! ( ExitSuccess
+            (κ (x) (prim (+ x 3)
-                   , r
+                      (κ (r) (continue halt r)))))
-                   , "" ))
+          |]
-      \e -> pure (ExitFailure 1, "", T.pack $ displayException e)
+    ]
  ]
@@ -0,0 +1,95 @@
 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
 import Gyehoek.Jalmot
 test_stackify =
  [ trivialReturn
  , tailCall
  , prim
  , condition
  , procedure
  ]
 evalsTo :: HasCallStack => List Obj -> Sut.Program -> Assertion
 evalsTo rs e = runJalmotUnsafe (Stk.eval e') @?= rs
  where
    e' = e & Sut.stackifyProgram & runGenSym & runPureEff
 trivialReturn = testGroup "trivial return"
  [ testCase "return int" do
      evalsTo [ObjImm (ImmInt 4)]
        [cps|(λ (ktail) (continue ktail 4))|]
  , testCase "return bool" do
      evalsTo [ObjImm (ImmBool True)]
        [cps|(λ (ktail) (continue ktail #t))|]
      evalsTo [ObjImm (ImmBool False)]
        [cps|(λ (ktail) (continue ktail #f))|]
  ]
 tailCall = testGroup "tail call"
  [ testCase "square" do
      evalsTo [ObjImm (ImmInt 16)] [cps|
        (λ (ktail0)
          (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|(λ (ktail0)
            (prim (* 4 5)
               (κ (x) (continue ktail0 x))))|]
  , testCase "add" do
      evalsTo [ObjImm (ImmInt 9)]
        [cps|(λ (ktail0)
        (prim (+ 4 5)
               (κ (x) (continue ktail0 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|(λ (ktail0)
      (if #t (continue ktail0 123) (continue ktail0 456)))|]
  evalsTo [ObjImm (ImmInt 456)]
    [cps|(λ (ktail0)
      (if #f (continue ktail0 123) (continue ktail0 456)))|]
 procedure = testGroup "procedure"
  [ testCase "factorial" do
      evalsTo [ObjImm (ImmInt 720)]
        [cps|(λ (ktail0)
          (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,84 @@
 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 =
  [
  ]
 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
@@ -24,19 +24,19 @@ thinWide name x = testGroup name
  , tcaseW 4 (name <> "-thin") x
  ]
-datumBegin xs = S.styleWith (S.StyleSyntax 0) . S.List $
+datumBegin xs = S.indentWith (S.NSpecial 0) . S.List $
-  S.Symbol "begin" : xs
+  (S.adorn S.SynBuiltin . S.Symbol $ "begin") : xs
 datumLambda formals body =
-  S.styleWith (S.StyleSyntax 1) . S.List $
+  S.indentWith (S.NSpecial 1) . S.List $
-  S.Symbol "lambda" : formals : body
+  (S.adorn S.SynBuiltin . S.Symbol $ "lambda") : formals : body
-test_print = testGroup "sexp pretty printer"
+test_print = testGroup "sexp pretty printer" $
  [ tcase "null" $ S.List []
  , thinWide "simple-list" $
    S.List [ S.Symbol s | s <- ["가","나","다","라"] ]
  , thinWide "begin-nonempty" $
-    S.styleWith (S.StyleSyntax 0) $
+    S.indentWith (S.NSpecial 0) $
    datumBegin [ S.Symbol "책을"
           , S.Symbol "더"
           , S.Symbol "먹으세요~!"
@@ -20,6 +20,7 @@ brokenReaderTests :: List String
 brokenReaderTests =
  [ "delimited-identifier"
  , "string-line-continuation"
  , "peculiar-identifier-dot"
  , "meta-splice-expression-interior-brace"
  , "datum-comment"
  ]
@@ -0,0 +1,111 @@
 {-# 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)
 import Gyehoek.Jalmot
 import Gyehoek.Prelude (i)
 evalsTo :: List Obj -> Program -> Assertion
 evalsTo rs p = runJalmotUnsafe (Sut.eval p) @?= rs
 test_root = testGroup "stack machine"
  [ testCase "immediate halt" do
      evalsTo [] [stkP|
        (define $start
          (return 0))
      |]
  , testCase "lit int" do
      evalsTo [ObjImm (ImmInt 3)] [stkP|
        (define $start
          (push! 3)
          (return 1))
      |]
  , testCase "non-tail identity function" do
      evalsTo [ObjImm (ImmInt 123)] [stkP|
        (define $id
          (return 1))
        (define $c
          (return 1))
        (define $start
          (push! $c)
          (push! $id)
          (push! 123)
          (call 1))
      |]
  , testCase "tail identity function" do
      evalsTo [ObjImm (ImmInt 123)] [stkP|
        (define $id
          (return 1))
        (define $start
          (push! $id)
          (push! 123)
          (tail-call 1))
      |]
  , testCase "return constant" do
      evalsTo [ObjImm (ImmInt 123)] [stkP|
        (define $start
          (push! $silly)
          (tail-call 1))
        (define $silly
          (push! 123)
          (return 1))
      |]
  , testCase "return multiple" do
      evalsTo [ObjImm (ImmInt n) | n <- [1,2,3]] [stkP|
        (define $start
          (push! 3)
          (push! 2)
          (push! 1)
          (return 3))
      |]
  , testCase "return none" do
      evalsTo [] [stkP|
        (define $start
          (return 0))
      |]
  , testCase "square" do
      evalsTo [ObjImm (ImmInt 16)] [stkP|
        (define $start
          (push! $square)
          (push! 4)
          (tail-call 1))
        (define $square
          (pop! %x)
          (prim (* %x %x))
          (return 1))
      |]
  , testGroup "factorial"
      let
        hsfac (n :: Int) = foldr @List (*) 1 [1..n]
        fac (n :: Int) = [stkP|
          (define $start
            (push! $fac)
            (push! #{n})
            (tail-call 1))
          (define $fac
            (load %n 0)
            (prim (zero? %n))
            (pop! %x0)
            (if %x0
                (then (push! 1)
                      (return 1))
                (else (push! $fac-c0)
                      (push! $fac)
                      (prim (- %n 1))
                      (call 1))))
          (define $fac-c0
            (pop! %x2)
            (pop! %n)
            (prim (* %n %x2))
            (return 1))
      |]
        mkcase n = testCase [i|#{n}|] do
          evalsTo [ObjImm . ImmInt $ hsfac n] $ fac n
      -- 20 is the greatest `n` for which n! ≤ maxBount @Int
      in [ mkcase n | n <- [0,1,6,20] ]
  ]
Author	SHA1	Message	Date
msyds	35e1b0cbe2	stupid build / build (push) Failing after 1m24s Details	2026-08-30 10:31:46 -06:00
msyds	64641bb258		2026-08-30 05:39:13 -06:00
msyds	57b1cc830d	wip: call/cc = capture/cc × invoke/cc	2026-08-30 03:33:51 -06:00
		`@@ -1,2 +0,0 @@`
			`(let ((p (cons 123 456)))`
			`(cons (cdr p) (car p)))`
		`@@ -1,2 +0,0 @@`
			`ret > ExitSuccess`
			`out > (0 . (1 . (4 . (9 . (16 . ())))))`
`@@ -1,2 +1,2 @@`
	`[0;31m([0m[0;95;1;3mlambda[0m [0;33m([0m어간 어미[0;33m)[0m`	`[0;31m([0m[0;95;1;3mlambda[0m [0;33m([0m[0m어간[0m [0m어미[0m[0;33m)[0m`
	`[0;33m([0mdisplay 꾸깃[0;33m)[0m[0;31m)[0m`	`[0;33m([0m[0mdisplay[0m [0m꾸깃[0m[0;33m)[0m[0;31m)[0m`
		`@@ -1 +1 @@`
			`[0;31m([0m가 나 다 라[0;31m)[0m`				`[0;31m([0m[0m가[0m [0m나[0m [0m다[0m [0m라[0m[0;31m)[0m`