fix runtime parsing lol

.dir-locals.el

@@ -9,6 +9,9 @@
       . (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 ()

.envrc

@@ -1 +1,3 @@
 use flake
+watch_file gyehoek.cabal cabal.project
+PATH_add $(dirname $(cabal list-bin gyehoek))

.gitignore

@@ -8,4 +8,5 @@ dist-newstyle
 *.tix
 .direnv
 result
-play/
+play/
+trace.html

cabal.project

@@ -1,5 +1,10 @@
 packages: *.cabal
 tests: True
+-- required for doctest-parallel
+write-ghc-environment-files: always
+
+-- https://github.com/martijnbastiaan/doctest-parallel/pull/66
+allow-older: Cabal:process 
 
 source-repository-package
     type: git

doc/closure-conversion.org

@@ -132,3 +132,34 @@ 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

doc/make-vm-stackier.org

@@ -0,0 +1,100 @@
+* rationale?
+
+previously, the VM's stack was used for storing local variables across blocks; a Scheme procedure was split into several low-level routines (one for the procedure itself and one for each continuation), and the stack was used as a communication channel for these separate routines. in contrast, registers were local to each routine. this aligns with Wasm's model of functions pretty well, with Wasm /locals/ acting as the VM's /registers/, and a global mutable stack serving as fallback.
+
+this worked quite well until it became time to implement ~call/cc~.
+
+we are considering making the following alterations to the VM:
+- explicitly segment the stack into frames.
+- passing procedures and return addresses on the stack.
+- new instructions:
+  + ~(tail-call /n/)~
+  + ~(call /n/)~
+  + ~(load /r/ /n/)~
+  + ~(return /n/)~
+
+* scratchpad
+
+#+begin_src scheme
+  (letrec ((fac (λ (n)
+                (if (zero? n)
+                    1
+                    (* n (fac (- n 1)))))))
+  (fac 3))
+#+end_src
+
+#+begin_src scheme
+  (λ (ktail0)
+  (letrec ((fac
+            (λ (n ktail1)
+              (zero?
+               n
+               (κ (x0)
+                  (if x0
+                      (continue ktail1 1)
+                      (- n 1
+                         (κ (x1)
+                            (fac x1
+                                 (κ (x2)
+                                    (* n x2 ktail1)))))))))))
+    (fac 3)))
+#+end_src
+
+#+begin_example
+n ktail1
+| |
+| | x0
+| | |
+| | ^
+| |
+| | x1
+| | |
+| | ^
+| | 
+| | x2
+| | |
+^ ^ ^
+#+end_example
+
+#+begin_src scheme
+  (define $fac-c0
+    (pop! %x0 0) ; [ x0 $fac-c0 n $fac ktail1 ]
+    (if %x0 ; [ $fac-c0 n $fac ktail1 ]
+        ;; every variable but `ktail1' is dead so we pop them all.
+        ;; this probably means that `if' should take two continuations
+        ;; rather than two blocks.
+        (then (push! 1) ; [ $fac-c0 n $fac ktail1 ]
+              (return 1)) ; [ 1 $fac-c0 n $fac ktail1 ]
+        (else (load %n 1) ; [ $fac-c0 n $fac ktail1 ]
+              (prim %x1 (- %n 1)) ; [ $fac-c0 n $fac ktail1 ]
+              (push! $fac-c1) ; [ $fac-c0 n $fac ktail1 ]
+              (push! $fac) ; [ $fac-c1 $fac-c0 n $fac ktail1 ]
+              (push! %x1) ; [ $fac $fac-c1 $fac-c0 n $fac ktail1 ]
+              (call 1) ; [ x1 $fac $fac-c1 $fac-c0 n $fac ktail1 ]
+              )))
+
+  (define $fac-c1
+    (pop! %x2) ; [ x2 $fac-c1 $fac-c0 n $fac ktail1 ]
+    (load %n 3) ; [ $fac-c1 $fac-c0 n $fac ktail1 ]
+    (prim %x3 (* %n %x2))
+    (push! %x3) ; [ $fac-c1 $fac-c0 n $fac ktail1 ]
+    (return 1) ; [ x3 $fac-c1 $fac-c0 n $fac ktail1 ]
+    )
+
+  (define $fac
+    (load %ktail1 2) ; [ n $fac ktail1 ]
+    (load %n 0) ; [ n $fac ktail1 ]
+    (push! $fac-c0) ; [ n $fac ktail1 ]
+    (push! $zero?) ; [ $fac-c0 n $fac ktail1 ]
+    (push! %n) ; [ $zero? $fac-c0 n $fac ktail1 ]
+    (call 1) ; [ n $zero? $fac-c0 n $fac ktail1 ]
+    )
+
+  (define $start
+    (push! $fac) ; [ $start ktail0 ]
+    (push! 3) ; [ $fac $start ktail0 ]
+    (tail-call 1) ; [ 3 $fac $start ktail0 ]
+    ;; ↑ `tail-call' knows how to dispose of the caller's stack frame.
+    )
+#+end_src
+

flake.nix

@@ -20,12 +20,13 @@
       overlays = [
         haskellNix.overlay
         (final: prev: {
-          gyehoek-runtime = final.callPackage ./runtime {
+          gyehoek-wasm-runtime = final.callPackage ./wasm-runtime {
             crane-lib = inputs.crane.mkLib final;
           };
           gyehoek = final.haskell-nix.project' {
             src = ./.;
             compiler-nix-name = "ghc912";
+            configureArgs = "-f-doctest";
             modules = [({ pkgs, lib, ...}: {
               packages.gyehoek.components.tests.test.preCheck =
                 let
@@ -33,14 +34,16 @@
                     pkgs.git # tasty uses git diff
                   ];
                 in ''
-                  export GYEHOEK_RUNTIME=${lib.getExe final.gyehoek-runtime}
+                  export GYEHOEK_WASM_RUNTIME=${
+                    lib.getExe final.gyehoek-wasm-runtime
+                  }
                   export PATH=${lib.makeBinPath bin}:$PATH
                 '';
             })];
             shell = {
               withHoogle = true;
               inputsFrom = [
-                final.gyehoek-runtime
+                final.gyehoek-wasm-runtime
               ];
               tools = {
                 cabal = {};
@@ -91,7 +94,7 @@
         hf.packages.${system} // lib.fix (packages: {
           gyehoek = hf.packages.${system}."gyehoek:exe:gyehoek";
           default = packages.gyehoek;
-          inherit (pkgs) gyehoek-runtime;
+          inherit (pkgs) gyehoek-wasm-runtime;
         }));
 
       devShells = each-system

golden/exec/begin-1/source.scm

@@ -0,0 +1 @@
+(begin 123 456) ; => 456

golden/exec/callcc-early-exit-1/exec

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

golden/exec/callcc-early-exit-1/source.scm

@@ -0,0 +1,12 @@
+(letrec ((iter (λ (n f)
+                 (if (zero? n)
+                     #f
+                     (begin (f n)
+                            (iter (- n 1) f))))))
+  (call/cc
+   (λ (k)
+     (iter 10 (λ (n)
+                ;; i don't feel like implementing (= n 5) right now lmfao
+                (if (zero? (- n 5))
+                    (k #t)
+                    #f))))))

golden/exec/callcc-early-exit-2/exec

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

golden/exec/callcc-early-exit-2/source.scm

@@ -0,0 +1,4 @@
+(call/cc
+ (λ (k)
+   (begin (k #t)
+          #f)))

golden/exec/callcc-early-exit-3/exec

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

golden/exec/callcc-early-exit-3/source.scm

@@ -0,0 +1,5 @@
+;; confer ../callcc-early-exit-4
+(letrec ((app (λ (f x)
+                (begin (f x)
+                       #f))))
+  (call/cc (λ (k) (app k #t))))

golden/exec/callcc-early-exit-4/exec

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

golden/exec/callcc-early-exit-4/source.scm

@@ -0,0 +1,5 @@
+;; confer ../callcc-early-exit-3
+(letrec ((app (λ (f x)
+                (begin (f x)
+                       #f))))
+  (call/cc (λ (k) (app (λ (x) (k x)) #t))))

golden/exec/callcc-early-exit-5/exec

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

golden/exec/callcc-early-exit-5/source.scm

@@ -0,0 +1,4 @@
+(call/cc
+ (λ (k)
+   (begin ((λ () (k #t)))
+          #f)))

golden/exec/callcc-early-exit-6/exec

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

golden/exec/callcc-early-exit-6/source.scm

@@ -0,0 +1,4 @@
+(* 2 (call/cc
+      (λ (k)
+        (begin (k 6)
+               3))))

golden/exec/callcc-nested-2/exec

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

golden/exec/complicated-1/exec

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

golden/exec/complicated-1/source.scm

@@ -0,0 +1,10 @@
+(letrec ((factorial (λ (n)
+                      (if (zero? n)
+                          1
+                          (* n (factorial (- n 1)))))))
+  (letrec ((sum-of-factorials
+            (λ (n)
+              (if (zero? n)
+                  0
+                  (+ (factorial n) (sum-of-factorials (- n 1)))))))
+    (+ 2 (sum-of-factorials 5))))

golden/exec/cons-1/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > (6 . 7)

golden/exec/cons-1/source.scm

@@ -0,0 +1 @@
+(cons 6 7)

golden/exec/cons-2/source.scm

@@ -0,0 +1,2 @@
+(let ((p (cons 123 456)))
+  (cons (cdr p) (car p)))

golden/exec/factorial/exec

@@ -1,2 +1,2 @@
 ret > ExitSuccess
-out > 720
+out > 2432902008176640000

golden/exec/factorial/source.scm

@@ -2,4 +2,4 @@
                 (if (zero? n)
                     1
                     (* n (fac (- n 1)))))))
-  (fac 6))
+  (fac 20))

golden/exec/lit-int/exec

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

golden/exec/lit-int/source.scm

@@ -0,0 +1 @@
+123

golden/print/begin-nonempty-thin

@@ -1,4 +1,4 @@
-(begin
+(begin
   책을
   더
-  먹으세요~!)
+  먹으세요~!)

golden/print/begin-nonempty-wide

@@ -1,4 +1,4 @@
-(begin
+(begin
   책을
   더
-  먹으세요~!)
+  먹으세요~!)

golden/print/lambda-nonempty-thin

@@ -1,5 +0,0 @@
-(lambda
-    (어간
-     어미)
-  (display
-   꾸깃))

golden/print/lambda-nonempty-wide

@@ -1,2 +0,0 @@
-(lambda (어간 어미)
-  (display 꾸깃))

golden/print/lambda-thin

@@ -0,0 +1,5 @@
+(lambda
+    (어간
+     어미)
+  (display
+   꾸깃))

golden/print/lambda-wide

@@ -0,0 +1,2 @@
+(lambda (어간 어미)
+  (display 꾸깃))

golden/print/null

@@ -1 +1 @@
-()
+()

golden/print/rainbow

@@ -1 +1 @@
-((((()))))
+((((()))))

golden/print/simple-list-thin

@@ -1,4 +1,4 @@
-(가
+(가
  나
  다
- 라)
+ 라)

golden/print/simple-list-wide

@@ -1 +1 @@
-(가 나 다 라)
+(가 나 다 라)

golden/read/bool/read

@@ -1,5 +1,41 @@
-[ SynNone :< SimpleF ( SimpleBoolean True )
-, SynNone :< SimpleF ( SimpleBoolean True )
-, SynNone :< SimpleF ( SimpleBoolean False )
-, SynNone :< SimpleF ( SimpleBoolean False )
+[ MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/bool/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< SimpleF ( SimpleBoolean True )
+, MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/bool/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 4
+            }
+        )
+    } :< SimpleF ( SimpleBoolean True )
+, MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/bool/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 10
+            }
+        )
+    } :< SimpleF ( SimpleBoolean False )
+, MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/bool/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 13
+            }
+        )
+    } :< SimpleF ( SimpleBoolean False )
 ]

golden/read/datum-comment/source.scm

@@ -0,0 +1,4 @@
+#;(a datum comment can
+span multiple lines)
+
+(but it ends here)

golden/read/decimal/read

@@ -1,8 +1,35 @@
-[ SynNone :< SimpleF
+[ MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/decimal/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< SimpleF
     ( SimpleNumber 45.0 )
-, SynNone :< SimpleF
+, MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/decimal/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 4
+            }
+        )
+    } :< SimpleF
     ( SimpleNumber 5667.0 )
-, SynNone :< SimpleF
+, MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/decimal/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 10
+            }
+        )
+    } :< SimpleF
     ( SimpleNumber
         ( -123.0 )
     )

golden/read/list-dot-flat/read

@@ -1,16 +1,61 @@
-[ SynNone :< CompoundF
+[ MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/list-dot-flat/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< CompoundF
     ( DotListF
         (
-            ( SynNone :< SimpleF
+            ( MkAnn
+                { syntax = SynNone
+                , position = Just
+                    ( SourcePos
+                        { sourceName = "golden/read/list-dot-flat/source.scm"
+                        , sourceLine = Pos 1
+                        , sourceColumn = Pos 2
+                        }
+                    )
+                } :< SimpleF
                 ( SimpleSymbol "가" )
             ) :|
-            [ SynNone :< SimpleF
+            [ MkAnn
+                { syntax = SynNone
+                , position = Just
+                    ( SourcePos
+                        { sourceName = "golden/read/list-dot-flat/source.scm"
+                        , sourceLine = Pos 1
+                        , sourceColumn = Pos 5
+                        }
+                    )
+                } :< SimpleF
                 ( SimpleSymbol "나" )
-            , SynNone :< SimpleF
+            , MkAnn
+                { syntax = SynNone
+                , position = Just
+                    ( SourcePos
+                        { sourceName = "golden/read/list-dot-flat/source.scm"
+                        , sourceLine = Pos 1
+                        , sourceColumn = Pos 8
+                        }
+                    )
+                } :< SimpleF
                 ( SimpleSymbol "다" )
             ]
         )
-        ( SynNone :< SimpleF
+        ( MkAnn
+            { syntax = SynNone
+            , position = Just
+                ( SourcePos
+                    { sourceName = "golden/read/list-dot-flat/source.scm"
+                    , sourceLine = Pos 1
+                    , sourceColumn = Pos 13
+                    }
+                )
+            } :< SimpleF
             ( SimpleSymbol "라" )
         )
     )

golden/read/list-flat/read

@@ -1,18 +1,90 @@
-[ SynNone :< CompoundF
+[ MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/list-flat/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< CompoundF
     ( ListF Ordinary
-        [ SynNone :< SimpleF
+        [ MkAnn
+            { syntax = SynNone
+            , position = Just
+                ( SourcePos
+                    { sourceName = "golden/read/list-flat/source.scm"
+                    , sourceLine = Pos 1
+                    , sourceColumn = Pos 2
+                    }
+                )
+            } :< SimpleF
             ( SimpleSymbol "가" )
-        , SynNone :< SimpleF
+        , MkAnn
+            { syntax = SynNone
+            , position = Just
+                ( SourcePos
+                    { sourceName = "golden/read/list-flat/source.scm"
+                    , sourceLine = Pos 1
+                    , sourceColumn = Pos 5
+                    }
+                )
+            } :< SimpleF
             ( SimpleSymbol "나" )
-        , SynNone :< SimpleF
+        , MkAnn
+            { syntax = SynNone
+            , position = Just
+                ( SourcePos
+                    { sourceName = "golden/read/list-flat/source.scm"
+                    , sourceLine = Pos 1
+                    , sourceColumn = Pos 8
+                    }
+                )
+            } :< SimpleF
             ( SimpleSymbol "다" )
-        , SynNone :< SimpleF
+        , MkAnn
+            { syntax = SynNone
+            , position = Just
+                ( SourcePos
+                    { sourceName = "golden/read/list-flat/source.scm"
+                    , sourceLine = Pos 1
+                    , sourceColumn = Pos 11
+                    }
+                )
+            } :< SimpleF
             ( SimpleSymbol "라" )
-        , SynNone :< SimpleF
+        , MkAnn
+            { syntax = SynNone
+            , position = Just
+                ( SourcePos
+                    { sourceName = "golden/read/list-flat/source.scm"
+                    , sourceLine = Pos 1
+                    , sourceColumn = Pos 14
+                    }
+                )
+            } :< SimpleF
             ( SimpleNumber 1.0 )
-        , SynNone :< SimpleF
+        , MkAnn
+            { syntax = SynNone
+            , position = Just
+                ( SourcePos
+                    { sourceName = "golden/read/list-flat/source.scm"
+                    , sourceLine = Pos 1
+                    , sourceColumn = Pos 16
+                    }
+                )
+            } :< SimpleF
             ( SimpleNumber 2.0 )
-        , SynNone :< SimpleF
+        , MkAnn
+            { syntax = SynNone
+            , position = Just
+                ( SourcePos
+                    { sourceName = "golden/read/list-flat/source.scm"
+                    , sourceLine = Pos 1
+                    , sourceColumn = Pos 18
+                    }
+                )
+            } :< SimpleF
             ( SimpleNumber 3.0 )
         ]
     )

golden/read/list/read

@@ -1,37 +1,145 @@
-[ SynNone :< CompoundF
+[ MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/list/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< CompoundF
     ( DotListF
         (
-            ( SynNone :< SimpleF
+            ( MkAnn
+                { syntax = SynNone
+                , position = Just
+                    ( SourcePos
+                        { sourceName = "golden/read/list/source.scm"
+                        , sourceLine = Pos 1
+                        , sourceColumn = Pos 2
+                        }
+                    )
+                } :< SimpleF
                 ( SimpleSymbol "a" )
             ) :|
-            [ SynNone :< SimpleF
+            [ MkAnn
+                { syntax = SynNone
+                , position = Just
+                    ( SourcePos
+                        { sourceName = "golden/read/list/source.scm"
+                        , sourceLine = Pos 1
+                        , sourceColumn = Pos 4
+                        }
+                    )
+                } :< SimpleF
                 ( SimpleSymbol "b" )
-            , SynNone :< CompoundF
+            , MkAnn
+                { syntax = SynNone
+                , position = Just
+                    ( SourcePos
+                        { sourceName = "golden/read/list/source.scm"
+                        , sourceLine = Pos 1
+                        , sourceColumn = Pos 6
+                        }
+                    )
+                } :< CompoundF
                 ( ListF Ordinary
-                    [ SynNone :< SimpleF
+                    [ MkAnn
+                        { syntax = SynNone
+                        , position = Just
+                            ( SourcePos
+                                { sourceName = "golden/read/list/source.scm"
+                                , sourceLine = Pos 1
+                                , sourceColumn = Pos 7
+                                }
+                            )
+                        } :< SimpleF
                         ( SimpleSymbol "c" )
-                    , SynNone :< SimpleF
+                    , MkAnn
+                        { syntax = SynNone
+                        , position = Just
+                            ( SourcePos
+                                { sourceName = "golden/read/list/source.scm"
+                                , sourceLine = Pos 1
+                                , sourceColumn = Pos 9
+                                }
+                            )
+                        } :< SimpleF
                         ( SimpleSymbol "d" )
                     ]
                 )
             ]
         )
-        ( SynNone :< CompoundF
+        ( MkAnn
+            { syntax = SynNone
+            , position = Just
+                ( SourcePos
+                    { sourceName = "golden/read/list/source.scm"
+                    , sourceLine = Pos 1
+                    , sourceColumn = Pos 14
+                    }
+                )
+            } :< CompoundF
             ( ListF Ordinary
-                [ SynNone :< SimpleF
+                [ MkAnn
+                    { syntax = SynNone
+                    , position = Just
+                        ( SourcePos
+                            { sourceName = "golden/read/list/source.scm"
+                            , sourceLine = Pos 1
+                            , sourceColumn = Pos 15
+                            }
+                        )
+                    } :< SimpleF
                     ( SimpleSymbol "가" )
-                , SynNone :< CompoundF
+                , MkAnn
+                    { syntax = SynNone
+                    , position = Just
+                        ( SourcePos
+                            { sourceName = "golden/read/list/source.scm"
+                            , sourceLine = Pos 1
+                            , sourceColumn = Pos 18
+                            }
+                        )
+                    } :< CompoundF
                     ( DotListF
                         (
-                            ( SynNone :< SimpleF
+                            ( MkAnn
+                                { syntax = SynNone
+                                , position = Just
+                                    ( SourcePos
+                                        { sourceName = "golden/read/list/source.scm"
+                                        , sourceLine = Pos 1
+                                        , sourceColumn = Pos 19
+                                        }
+                                    )
+                                } :< SimpleF
                                 ( SimpleSymbol "나" )
                             ) :| []
                         )
-                        ( SynNone :< SimpleF
+                        ( MkAnn
+                            { syntax = SynNone
+                            , position = Just
+                                ( SourcePos
+                                    { sourceName = "golden/read/list/source.scm"
+                                    , sourceLine = Pos 1
+                                    , sourceColumn = Pos 24
+                                    }
+                                )
+                            } :< SimpleF
                             ( SimpleSymbol "다" )
                         )
                     )
-                , SynNone :< SimpleF
+                , MkAnn
+                    { syntax = SynNone
+                    , position = Just
+                        ( SourcePos
+                            { sourceName = "golden/read/list/source.scm"
+                            , sourceLine = Pos 1
+                            , sourceColumn = Pos 28
+                            }
+                        )
+                    } :< SimpleF
                     ( SimpleSymbol "라" )
                 ]
             )

golden/read/meta-expression/read

@@ -0,0 +1,11 @@
+[ MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/meta-expression/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< MetaF "aHaskellVariable + abc * 2"
+]

golden/read/meta-expression/source.scm

@@ -0,0 +1 @@
+#{aHaskellVariable + abc * 2}

golden/read/meta-splice-expression-interior-brace/source.scm

@@ -0,0 +1,2 @@
+##{case 123 of { 123 -> blah
+               ; xyz -> flah }}

golden/read/meta-splice-expression/read

@@ -0,0 +1,11 @@
+[ MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/meta-splice-expression/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< MetaSpliceF "takeWhile (\x -> even x) aHaskellList"
+]

golden/read/meta-splice-expression/source.scm

@@ -0,0 +1 @@
+##{takeWhile (\x -> even x) aHaskellList}

golden/read/meta-splice-variable/read

@@ -0,0 +1,11 @@
+[ MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/meta-splice-variable/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< MetaSpliceF "aHaskellList"
+]

golden/read/meta-splice-variable/source.scm

@@ -0,0 +1 @@
+##{aHaskellList}

golden/read/meta-variable/read

@@ -0,0 +1,11 @@
+[ MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/meta-variable/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< MetaF "aHaskellVariable"
+]

golden/read/meta-variable/source.scm

@@ -0,0 +1 @@
+#{aHaskellVariable}

golden/read/peculiar-identifier-sign/read

@@ -1,5 +1,23 @@
-[ SynNone :< SimpleF
+[ MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/peculiar-identifier-sign/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< SimpleF
     ( SimpleSymbol "+" )
-, SynNone :< SimpleF
+, MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/peculiar-identifier-sign/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 3
+            }
+        )
+    } :< SimpleF
     ( SimpleSymbol "-" )
 ]

golden/read/string/read

@@ -1,3 +1,12 @@
-[ SynNone :< SimpleF
+[ MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/string/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< SimpleF
     ( SimpleString "가나다라" )
 ]

golden/read/typical-identifier-token/read

@@ -1,12 +1,57 @@
-[ SynNone :< SimpleF
+[ MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/typical-identifier-token/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< SimpleF
     ( SimpleSymbol "abc" )
-, SynNone :< SimpleF
+, MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/typical-identifier-token/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 4
+            }
+        )
+    } :< SimpleF
     ( SimpleString "xyz" )
-, SynNone :< SimpleF
+, MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/typical-identifier-token/source.scm"
+            , sourceLine = Pos 2
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< SimpleF
     ( SimpleSymbol "수학" )
-, SynNone :< CompoundF
+, MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/typical-identifier-token/source.scm"
+            , sourceLine = Pos 2
+            , sourceColumn = Pos 5
+            }
+        )
+    } :< CompoundF
     ( ListF Ordinary
-        [ SynNone :< SimpleF
+        [ MkAnn
+            { syntax = SynNone
+            , position = Just
+                ( SourcePos
+                    { sourceName = "golden/read/typical-identifier-token/source.scm"
+                    , sourceLine = Pos 2
+                    , sourceColumn = Pos 6
+                    }
+                )
+            } :< SimpleF
             ( SimpleSymbol "數學" )
         ]
     )

golden/read/typical-identifier/read

@@ -1,19 +1,100 @@
-[ SynNone :< SimpleF
+[ MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/typical-identifier/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< SimpleF
     ( SimpleSymbol "abc" )
-, SynNone :< SimpleF
+, MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/typical-identifier/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 5
+            }
+        )
+    } :< SimpleF
     ( SimpleSymbol "bala-hwa$" )
-, SynNone :< SimpleF
+, MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/typical-identifier/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 15
+            }
+        )
+    } :< SimpleF
     ( SimpleSymbol "x!!!" )
-, SynNone :< SimpleF
+, MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/typical-identifier/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 20
+            }
+        )
+    } :< SimpleF
     ( SimpleSymbol "z" )
-, SynNone :< SimpleF
+, MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/typical-identifier/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 22
+            }
+        )
+    } :< SimpleF
     ( SimpleSymbol "z123" )
-, SynNone :< SimpleF
+, MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/typical-identifier/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 27
+            }
+        )
+    } :< SimpleF
     ( SimpleSymbol "나는너무졸리다" )
-, SynNone :< SimpleF
+, MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/typical-identifier/source.scm"
+            , sourceLine = Pos 1
+            , sourceColumn = Pos 42
+            }
+        )
+    } :< SimpleF
     ( SimpleSymbol "學" )
-, SynNone :< SimpleF
+, MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/typical-identifier/source.scm"
+            , sourceLine = Pos 3
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< SimpleF
     ( SimpleSymbol "車室." )
-, SynNone :< SimpleF
+, MkAnn
+    { syntax = SynNone
+    , position = Just
+        ( SourcePos
+            { sourceName = "golden/read/typical-identifier/source.scm"
+            , sourceLine = Pos 5
+            , sourceColumn = Pos 1
+            }
+        )
+    } :< SimpleF
     ( SimpleSymbol "三個女人一臺戲。" )
 ]

gyehoek.cabal

@@ -13,6 +13,11 @@ build-type:    Simple
 -- extra-doc-files:    CHANGELOG.md
 -- extra-source-files:
 
+flag doctest
+  description: enable the doctest suite
+  default:     True
+  manual:      True
+
 common ghcstuffs-dev
   ghc-options:
     -Wno-unused-matches -Wno-missing-signatures -Wno-typed-holes
@@ -53,22 +58,28 @@ library
   -- cabal-fmt: expand src
   exposed-modules:
     Gyehoek.CPS.Close
+    Gyehoek.CPS.Contify
     Gyehoek.CPS.Convert
     Gyehoek.CPS.Eval
-    Gyehoek.CPS.Lower
+    Gyehoek.CPS.Hoist
     Gyehoek.CPS.Stackify
     Gyehoek.CPS.Syntax
     Gyehoek.Driver
     Gyehoek.GenSym
+    Gyehoek.Jalmot
     Gyehoek.Language
+    Gyehoek.Lift1
     Gyehoek.Options
     Gyehoek.Prelude
     Gyehoek.Scheme.Syntax
     Gyehoek.Sexp
     Gyehoek.Sexp.Grammar
+    Gyehoek.Sexp.Grammar.Base
     Gyehoek.Sexp.Print
+    Gyehoek.Sexp.QQ
     Gyehoek.Sexp.Read
     Gyehoek.Sexp.Syntax
+    Gyehoek.Stack.Lower
     Gyehoek.Stack.Syntax
     Gyehoek.Stack.VM
     Gyehoek.Wasm
@@ -91,6 +102,7 @@ library
     , hashable
     , invertible-grammar
     , lens
+    , lucid
     , megaparsec
     , mtl
     , optparse-applicative
@@ -98,10 +110,10 @@ library
     , pretty-simple
     , prettyprinter
     , prettyprinter-ansi-terminal
+    , prettyprinter-lucid
     , process
     , recursion-schemes
     , scientific
-    , sexp-grammar
     , string-interpolate
     , template-haskell
     , text
@@ -109,6 +121,7 @@ library
     , typed-process
     , unordered-containers
     , vector
+    , tardis
 
   hs-source-dirs:   src
   default-language: GHC2024
@@ -127,9 +140,11 @@ test-suite test
     Gyehoek.Test.CPS.Syntax
     Gyehoek.Test.Golden
     Gyehoek.Test.Scheme.Syntax
-    Gyehoek.Test.Sexp
     Gyehoek.Test.Sexp.Print
+    Gyehoek.Test.Sexp.QQ
+    Gyehoek.Test.Sexp.Read
     Gyehoek.Test.Stack.VM
+    Gyehoek.TestUtil
     Root
 
   build-depends:
@@ -143,7 +158,6 @@ test-suite test
     , lens
     , pretty-simple
     , process-extras
-    , sexp-grammar
     , tasty
     , tasty-expected-failure
     , tasty-hunit
@@ -151,3 +165,21 @@ test-suite test
     , text
 
   default-language:   GHC2024
+
+-- https://github.com/martijnbastiaan/doctest-parallel/pull/66
+test-suite doctest
+  import:             ghcstuffs, ghcstuffs-dev
+  type:               exitcode-stdio-1.0
+  hs-source-dirs:     test
+  build-depends:
+    , base
+    , gyehoek
+
+  default-extensions: CPP
+  main-is:            doctest.hs
+
+  if flag(doctest)
+    build-depends: doctest-parallel >=0.1
+
+  else
+    cpp-options: -DGYEHOEK_NO_DOCTEST

src/Gyehoek/CPS/Close.hs

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

src/Gyehoek/CPS/Contify.hs

@@ -0,0 +1,67 @@
+{-# LANGUAGE ApplicativeDo #-}
+module Gyehoek.CPS.Contify
+  ( contifyProgram
+  ) where
+
+import Control.Monad.Tardis
+import Gyehoek.CPS.Syntax
+import Gyehoek.Prelude
+import qualified Data.HashSet as HS
+import Control.Lens.Unsound (adjoin)
+import Debug.Pretty.Simple
+import qualified Data.HashMap.Strict as H
+import Control.Monad.Writer.Lazy
+import Control.Monad.Trans.Tardis (liftTardisT)
+
+
+-- | ain't no way...
+-- type T = WriterT (HashSet Name) (Tardis (HashSet Name) (HashSet Name))
+type T = TardisT (HashSet Name) (HashSet Name) (Writer (HashSet Name))
+
+evalT :: T a -> a
+-- evalT = (`evalTardis` (mempty,mempty)) . fmap fst . runWriterT
+evalT = fst . runWriter . (`evalTardisT` (mempty,mempty))
+
+runT :: T a -> (a, HashSet Name)
+-- runT = (`evalTardis` (mempty,mempty)) . runWriterT
+runT = runWriter . (`evalTardisT` (mempty,mempty))
+
+-- | inline function if it hasn't been used in the past, and won't
+-- be used in the future.
+tryInline :: Name -> Kappa -> T Kexp
+tryInline kname kap = do
+  modifyBackwards (HS.insert kname)
+  p <- getsPast (HS.member kname)
+  modifyForwards (HS.insert kname)
+  q <- getsFuture (HS.member kname)
+  let c = p || q
+  liftTardisT . tell $ if c then HS.singleton kname else mempty
+  pure $ if c
+    then KexpVar kname
+    else KexpKappa kap
+
+getKap :: HashMap Name Abs -> Name -> Maybe Kappa
+getKap g kname = g ^? ix kname . #AbsKappa
+
+contify :: HashMap Name Abs -> Exp -> T Exp
+contify g = transformM \case
+  ExpApply f xs (KexpVar kname) | Just kap <- getKap g kname
+   -> ExpApply f xs <$> tryInline kname kap
+  ExpPrim p (KexpVar kname) | Just kap <- getKap g kname
+   -> ExpPrim p <$> tryInline kname kap
+  e -> pure e
+
+contifyProgram :: HoistedProgram -> Eff es HoistedProgram
+contifyProgram p = do
+  let g = p.bindings
+  let (p',contifiedVars) =
+        runT $
+          traverseOf
+            (adjoin
+              (#bindings . each . body)
+              (#body . body))
+            (contify g)
+            p
+  pTraceShowM contifiedVars
+  -- pure $ p' & #bindings %~ H.filterWithKey \k _ -> HS.member k contifiedVars
+  pure p'

src/Gyehoek/CPS/Convert.hs

@@ -12,6 +12,7 @@ import Data.List.NonEmpty (NonEmpty((:|)))
 import Control.Monad.Cont qualified as Cont
 import qualified Data.List.NonEmpty as NE
 import Gyehoek.Prelude
+import Debug.Pretty.Simple
 
 
 -- 뻘짓이어라
@@ -23,66 +24,78 @@ telescope f = Cont.runCont . traverse (Cont.cont . f)
 
 
 
+one :: a -> List a
+one a = [a]
+
+oneOrUndefined :: List Val -> Val
+oneOrUndefined = \case
+  [x] -> x
+  _ -> ValImm ImmUndefined
+
+convert1 :: (GenSym :> es) => Scm.Exp -> (Val -> Eff es Exp) -> Eff es Exp
+convert1 e k = convert e (k . oneOrUndefined)
+
 -- | Transform an expression with a meta-continuation.
 convert
   :: forall es. (GenSym :> es)
-  => Scm.Exp -> (Val -> Eff es Exp) -> Eff es Exp
+  => Scm.Exp -> (List Val -> Eff es Exp) -> Eff es Exp
 
-convert (Scm.ExpVar x) k = k $ ValVar x
-convert (Scm.ExpLit l) k = k . ValImm $ case l of
+convert (Scm.ExpVar x) k = k [ValVar x]
+convert (Scm.ExpLit l) k = k . one . ValImm $ case l of
   LitInt n -> ImmInt n
   LitBool b -> ImmBool b
   _ -> _
 
--- special case: call/cc is desugared during cps-conversion...
-convert (Scm.ExpPrim (PrimCallCC withcc)) k = do
-  convert withcc \withcc' -> do
-    cc <- gensym' @Name "cc"
-    r <- gensym' "r"
-    m <- k $ ValVar r
-    ccish <- gensym' @Name "cc-ish"
-    x <- gensym' @Name "x"
-    pure [cps|
-      (letrec ((#{cc} (κ (#{r}) #{m})))
-        (letrec ((#{ccish} (λ (#{x} _) (continue #{cc} #{x}))))
-          (#{withcc'} #{ccish} #{cc})))
-    |]
-
--- ...while all other prims are left as-is for later stages to
--- handle..
 convert (Scm.ExpPrim p) k =
-  telescope (convert @es) p \p' -> do
-    r <- gensym' "r"
-    ExpPrim p' . MkKappa [r] <$> k (ValVar r)
+  telescope (convert1 @es) p \p' -> do
+    r_l <- gensym' "r"
+    -- k_l <- gensym' @Name "prim-k"
+    m <- k [ValVar r_l]
+    pure [cps|
+      (prim #{p'} (κ (#{r_l}) #{m}))
+    |]
+    -- pure [cps|
+    --   (letrec ((#{k_l} (κ (#{r_l}) #{m})))
+    --     (prim #{p'} #{k_l}))
+    -- |]
 
 convert (Scm.ExpLambda xs e) k = do
   f <- gensym' "lambda-body"
   lam <- convertLambda xs e
-  ke <- k $ ValVar f
+  ke <- k [ValVar f]
   pure [cps|
     (letrec ((#{f} #{lam}))
       #{ke})
   |]
 
 convert (Scm.ExpApply f xs) k =
-  telescope (convert @es) (f:|xs) \(f':|xs') -> do
-    r <- gensym' "r"
+  telescope (convert1 @es) (f:|xs) \(f':|xs') -> do
+    r <- gensym' @Name "r"
     x <- gensym' "x"
-    m <- k (ValVar x)
-    pure $ ExpLetRec [(r, AbsKappa' [x] m)] $ ExpApply f' xs' r
+    m <- k [ValVar x]
+    pure $ ExpLetRec [(r, AbsKappa' [x] m)] $
+      ExpApply f' xs' (KexpVar r)
 
-convert (Scm.ExpBegin xs) k = _
+convert (Scm.ExpBegin xs) k = telescope (convert @es) xs (k . NE.last)
 
 convert (Scm.ExpIf c t f) k =
-  convert c \c' ->
-    ExpIf c' <$> convert t k <*> convert f k
+  convert1 c \c' -> do
+    t_l <- gensym' @Name "truthy-cont"
+    f_l <- gensym' @Name "falsey-cont"
+    t' <- convert t k
+    f' <- convert f k
+    pure [cps|
+      (letrec ((#{t_l} (κ () #{t'}))
+               (#{f_l} (κ () #{f'})))
+        (if #{c'} #{t_l} #{f_l}))
+    |]
 
 -- let-bindings are desugared into continuation calls whose parameters
 -- are the left-hand sides and whose arguments are the right-hand
 -- sides.
 convert (Scm.ExpLet bs e) k =
   let rhss = bs ^.. each . _2
-  in telescope (convert @es) rhss \rhss' -> do
+  in telescope (convert1 @es) rhss \rhss' -> do
     e' <- convert e k
     kbody <- gensym' @Name "let-body"
     let bs' = bs ^.. each . _1
@@ -105,12 +118,15 @@ convertLambda
   => List Name -> Scm.Exp -> Eff es Lambda
 convertLambda bs m = do
   ktail <- gensym' "lambda-tail"
-  m' <- convert m $ pure . ExpContinue ktail . (:[])
+  m' <- convert1 m $ pure . ExpContinue (ValVar ktail) . (:[])
   pure [cps|(λ (##{bs} #{ktail}) #{m'})|]
 
 convertProgram :: forall es. (GenSym :> es) => Scm.Program -> Eff es Program
-convertProgram p =
-  MkProgram <$> telescope (convert @es) (p ^.. each . _Left) (pure . Halt)
+convertProgram p = do
+  ktail <- gensym' "start-ktail"
+  m <- telescope (convert1 @es) (p ^.. each . _Left)
+        (pure . ExpContinue (ValVar ktail))
+  pure . MkProgram $ MkLambda [] ktail m
 
 convertExp :: forall es. (GenSym :> es) => Scm.Exp -> Eff es Exp
-convertExp e = convert e (pure . Halt1)
+convertExp e = convert e (pure . Halt)

src/Gyehoek/CPS/Eval.hs

@@ -1,79 +1,259 @@
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE OverloadedLists #-}
 module Gyehoek.CPS.Eval
   ( evalProgram
   , module Gyehoek.CPS.Syntax
+  , evalExp
+  , eGrammar
   ) where
 
-import Gyehoek.CPS.Syntax
-import Control.Lens
+import Gyehoek.CPS.Syntax hiding (Hob(..), Obj(..), cont)
+import Gyehoek.Sexp qualified as S
+import Control.Lens hiding (assign)
 import Data.Maybe (fromMaybe)
 import Text.Show.Functions ()
 import qualified Data.HashMap.Strict as H
-import Gyehoek.Prelude
+import Gyehoek.Prelude hiding (assign)
+import Debug.Pretty.Simple
+import Gyehoek.Jalmot
+import Control.Monad.Cont
+import Gyehoek.Sexp qualified as S
+import GHC.Generics (Generically(..))
+import Gyehoek.Sexp ((:-)(..))
+import Data.List (nub, mapAccumR, compareLength)
+import Data.HashSet.Lens (setOf)
+import Data.IntMap.Strict (IntMap)
+import Data.IntMap.Strict qualified as IM
+import Data.Monoid
+import Control.Monad.State
+import Data.Traversable (for)
+import Data.Foldable (traverse_)
 
 
-data Env = MkEnv
-  { vars :: HashMap Name Obj
-  , labels :: HashMap Name (Env, Abs)
+newtype Loc = MkLoc { getLoc :: Int }
+  deriving stock (Generic, Data)
+  deriving newtype (Show, Eq, Ord, Enum)
+
+data Store = MkStore
+  { nextLoc :: Loc
+  , heap :: IntMap E
   }
-  deriving (Show, Generic)
+  deriving stock (Show, Generic)
 
-eval :: Env -> Exp -> List Obj
+type instance Index Store = Loc
+type instance IxValue Store = E
 
-eval g (Halt xs) = evalVal g <$> xs
+instance Ixed Store where ix (MkLoc j) = #heap . ix j
+instance At Store where at (MkLoc j) = #heap . at j
 
-eval g (ExpContinue k xs) =
-  case g ^. #labels . at k of
-    Just (h, AbsKappa' bs m) -> eval h' m
-      where h' = h & #vars <>~ envOfBinds bs (evalVal g <$> xs)
-    _ -> error [i|not a kappa: #{k}|]
+emptyStore :: Store
+emptyStore = MkStore
+  { nextLoc = MkLoc 0
+  , heap = mempty
+  }
 
-eval g (ExpApply ((^?! #ValVar) -> f) xs ktail) =
-  case g ^?! #labels . at f of
-    Just (h,AbsLambda' bs kb m) -> eval h' m
-      where h' = h & #vars <>~ envOfBinds bs (evalVal g <$> xs)
-                   & #labels . at kb .~ (g ^. #labels . at ktail)
-    Nothing -> error [i|undefined label: #{f}|]
-
-eval g (ExpLetRec [(b, ab)] e) = eval g' e
-  where g' = g & #labels . at b ?~ (g,ab)
-
-eval g (ExpPrim p (MkKappa bs e)) = case evalVal g <$> p of
-  PrimAdd x y -> arithBinop (+) x y
-  PrimMul x y -> arithBinop (*) x y
-  PrimSub x y -> arithBinop (-) x y
-  PrimDiv x y -> arithBinop div x y
-  _ -> error [i|unhandled prim: #{p}|]
-  where
-    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}|]
-
-eval _ e = error [i|unimplemented case: #{e}|]
-
-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
+newtype Env = MkEnv { getEnv :: HashMap Name Loc }
+  deriving stock (Show, Generic, Data)
+  deriving newtype (Semigroup, Monoid)
 
 emptyEnv :: Env
-emptyEnv = MkEnv
-  { vars = mempty
-  -- a kinda silly hack to make sure `halt` is handled correctly when
-  -- it appears as the tail continuation of an application. the
-  -- special case of `eval` responsible for `halt` only covers terms
-  -- of the form `(continue $halt xs …)`; other terms such as
-  -- `($some-fn xs $halt)` just see an undefined label `$halt`.
-  , labels = H.singleton "halt"
-    ( emptyEnv
-    , AbsKappa' ["h0"] $ Halt [ValVar "h0"]
-    )
-  }
+emptyEnv = mempty
 
-evalProgram :: Program -> List Obj
-evalProgram (MkProgram e) = eval emptyEnv e
+type instance Index Env = Name
+type instance IxValue Env = Loc
+
+instance Ixed Env where ix j = #getEnv . ix j
+instance At Env where at j = #getEnv . at j
+
+update :: Loc -> E -> Store -> Store
+update (MkLoc loc) v = #heap %~ IM.alter f loc
+  where
+    f (Just _) = Just v
+    f Nothing = error "segfault lol"
+
+updates :: Foldable f => f (Loc, E) -> Store -> Store
+updates = alaf Endo foldMap (uncurry update)
+
+fetch :: Loc -> M r E
+fetch (MkLoc loc) = gets (^?! #heap . ix loc)
+
+new :: M r Loc
+new = state \st -> (st.nextLoc, st & #nextLoc %~ succ)
+
+new' :: E -> M r Loc
+new' e = state \st ->
+  ( st.nextLoc
+  , st & #nextLoc %~ succ & at st.nextLoc ?~ e
+  )
+
+defines :: Traversable t => t (Name, E) -> M Answer Env
+defines = alaf Ap foldMap \(name,e) -> do
+  l <- new' e
+  pure $ bind name l
+
+var :: HasCallStack => Env -> Name -> M Answer Loc
+var g x = case g ^. at x of
+  Just l -> pure l
+  Nothing -> wrong [i|unbound variable #{x}|]
+
+type CmdCont = Store -> Answer
+type ExpCont = List E -> CmdCont
+
+type M r = ContT r (State Store)
+
+data Answer
+  = AnswerValues (List E)
+  | AnswerError AJalmot
+  deriving (Show, Generic)
+
+data Mutability
+  = Mut
+  | NoMut
+  deriving (Show, Generic, Data, Eq)
+
+wrong :: Text -> M Answer a
+wrong s = ContT \_ -> pure . AnswerError . EvalError $ s
+
+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 Loc Loc Mutability
+  | EVec (List Loc) Mutability
+  | EString (List Loc) Mutability
+  | 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
+    go = \case
+      ESymbol s -> S.Symbol s
+      ECharacter c -> S.Character c
+      EInt n -> S.Number (fromIntegral n)
+      EBool b -> S.Boolean b
+      EUndefined -> S.Unreadable "#<undefined>"
+      EUnspecified -> S.Unreadable "#<unspecified>"
+      ENull -> S.List []
+      EPair car cdr _mut -> S.DotList [gofetch car] (gofetch cdr)
+      EVec xs _mut -> S.Vector . fmap gofetch $ xs
+      EString xs _mut -> S.String _
+
+data DynPoints = MkDynPoints
+  deriving (Generic, Data)
+
+
+
+evalVal :: Env -> Val -> M Answer E
+
+evalVal g (ValVar x) = var g x >>= fetch
+
+evalVal g (ValImm imm) = pure case imm of
+  ImmLabel l -> error [i|#{l}|]
+  ImmInt n -> EInt n
+  ImmBool b -> EBool b
+  ImmUndefined -> 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 (ExpPrim p k) = do
+  p' <- evalPrim g =<< traverse (evalVal g) p
+  evalKexp g k >>= \case
+    EProcedure fp -> fp p' dps
+    _ -> wrong [i|prim(#{p})의 계속을 나쁘다|]
+
+eval g dps e = error [i|unimplemented #{e}|]
+
+evalPrim :: Env -> Prim E -> M Answer (List E)
+evalPrim g = \case
+  PrimAdd x y -> arith2 (+) x y
+  PrimMul x y -> arith2 (*) x y
+  PrimSub x y -> arith2 (-) x y
+  PrimDiv x y -> arith2 div x y
+  PrimValues xs -> pure xs
+  p -> wrong [i|prim(#{p})은 벌써 나지 않다|]
+  where
+    arith2 f (EInt x) (EInt y) = pure [EInt $ f x y]
+    arith2 f x y = wrong [i|나쁜 인자: #{x}, #{y}|]
+
+
+
+evalExp :: Jalmot :> es => Exp -> Eff es _
+evalExp e = _
+
+evalProgram :: Jalmot :> es => Program -> Eff es (List S.Datum)
+evalProgram (MkProgram lam) = case run (pure . AnswerValues) of
+  (AnswerError jm, _) -> throwError jm
+  (AnswerValues vs, st) -> traverse (S.toDatum $ eGrammar st) vs
+  where
+    run f = (`runState` emptyStore) . (`runContT` f) $ do
+      g <- setup
+      eval g MkDynPoints (ExpLetRec
+        [("_start",AbsLambda lam)]
+        (ExpApply (ValVar "_start") [] (KexpVar "halt")))
+
+
+
+setup :: M Answer Env
+setup = defines @List
+  [ ("halt", EProcedure prim_halt)
+  ]
+
+prim_halt :: Procedure
+prim_halt xs _dps = ContT \_ -> pure $ AnswerValues xs

src/Gyehoek/CPS/Hoist.hs

@@ -0,0 +1,24 @@
+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}

src/Gyehoek/CPS/Lower.hs

@@ -1,342 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE OverloadedRecordDot #-}
-{-# LANGUAGE OverloadedLabels #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE MultilineStrings #-}
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE ApplicativeDo #-}
-{-# LANGUAGE RecursiveDo #-}
-{- HLINT ignore "Use camelCase" -}
-module Gyehoek.CPS.Lower
-  (lower, lowerProgram) where
-
-import Gyehoek.CPS.Syntax
-import Data.Vector.Strict (Vector)
-import Control.Lens hiding (op)
-import Numeric.Natural
-import qualified Data.Vector.Strict as V
-import Gyehoek.Wasm qualified as Wasm
-import Gyehoek.Wasm hiding (Expr)
-import Language.Sexp.Located qualified as SL
-import Control.Monad.Fix
-import qualified Gyehoek.Sexp
-import Data.Text qualified as T
-import Data.Foldable (fold)
-import Gyehoek.Sexp (encodeOrShow)
-import Gyehoek.Prelude
-
-
-data Env = MkEnv
-  { vars :: Vector Name
-  , kvars :: Vector Name
-  }
-  deriving (Show, Generic)
-
-type instance Index Env = Natural
-type instance IxValue Env = Name
-
-instance Ixed Env where
-  ix i = #vars . ix (fromIntegral i)
-
-
-
-tonat :: Integral a => a -> Natural
-tonat = fromIntegral
-
--- | @makeSmallFixnum@ emits an expression injecting the i32 on top
--- of the stack into the SCM unitype.
-makeSmallFixnum :: Wasm.Expr
-makeSmallFixnum = [expr|
-    (@gyehoek "construct small fixnum")
-    (i32.const 1)
-    i32.shl
-    ref.i31
-  |]
-
-getArgRegister :: Natural -> SL.Sexp
-getArgRegister n = SL.Symbol [i|$arg#{n}|]
-
--- | Given an expression @e@ leaving a @ref eq@ atop the stack,
--- @pushArg rt n e@ sets the nth slot of the arg-passing array to the
--- result of @e@.
-pushArg :: Natural -> Wasm.Expr -> Wasm.Expr
-pushArg n e = [expr|
-    (@gyehoek begin pushArg)
-    ##{e}
-    (global.set #{reg})
-    (@gyehoek end pushArg)
-  |]
-  where reg = getArgRegister n
-
--- | Pop the nth arg from the arg-passing array onto the stack.
-popArg :: Natural -> Wasm.Expr
-popArg n = [expr|
-  (@gyehoek begin popArg)
-  (global.get #{reg})
-  ref.as_non_null
-  (@gyehoek end popArg)
-|]
-  where reg = getArgRegister n
-
-
-
-lowerVal :: (HasCallStack, GenMod :> es) => Env -> Val -> Eff es Wasm.Expr
-
-lowerVal g (ValImm imm) =
-  pure $ case imm of
-    ImmInt n -> [expr|
-      (i32.const #{n})
-      ##{makeSmallFixnum}
-    |]
-    ImmBool b -> [expr|
-      (i32.const #{b'})
-      ref.i31
-    |]
-      where b' :: Int = if b then 0b11 else 0b01
-    _ -> _
-
-lowerVal g (ValVar x) = do
-  pure [expr|(global.get #{l})|]
-  where
-    l = getArgRegister . fromIntegral . succ $ V.elemIndex x g.vars ^?! _Just
-
-lower' :: (GenMod :> es) => Env -> Exp -> Eff es Wasm.Expr
-
-lower' g (Halt [v]) = do
-  arg <- pushArg 0 <$> lowerVal g v
-  pure [expr|
-    ##{arg}
-    (return_call $halt (i32.const 1))
-  |]
-
-lower' g e@(ExpPrim p k) =
-  ([expr|(@gyehoek :origin #{origin})|]<>)
-  <$> case p of
-    PrimAdd x y -> lowerBinOp "i32.add" g x y k
-    PrimMul x y -> lowerBinOp "i32.mul" g x y k
-  where origin = encodeOrShow @_ @Text e
-
-lower' g (ExpIf c t f) = do
-  c' <- lowerVal g c
-  t' <- lower' g t
-  f' <- lower' g f
-  pure [expr|
-    ##{c'}
-    (call $gh-truthy?)
-    (if (then ##{t'})
-        (else ##{f'}))
-  |]
-
-lower' g (ExpLetRec [(r,AbsKappa kap)] e) = do
-  idx <- lowerKappa g kap
-  let g' = g & #kvars <>~ [r]
-  e' <- lower' g' e
-  let origin = encodeOrShow @_ @Text e
-  pure [expr|
-    (@gyehoek :origin #{origin})
-    (@gyehoek "push cont" :idx #{idx})
-    (array.set $cont-stack-type
-               (global.get $cont-stack)
-               (global.get $cont-stack-top)
-               (ref.func #{idx}))
-    (global.set $cont-stack-top
-                (i32.add (global.get $cont-stack-top)
-                         (i32.const 1)))
-    ##{e'}
-  |]
-
-lower' g (ExpLetRec [(r,AbsLambda lam)] e) = do
-  idx <- lowerLambda g lam
-  let g' = g & #vars <>~ [r]
-  let n = succ $ length g.vars
-  e' <- lower' g' e
-  let reg = getArgRegister . fromIntegral $ n
-  pure [expr|
-    (i32.const 0)
-    (ref.func #{idx})
-    (struct.new $closure)
-    (global.set #{reg})
-    ##{e'}
-  |]
-
-lower' g e@(ExpApply f xs ktail) = do
-  let nargs = length xs
-  f' <- lowerVal g f
-  let l = succ $ V.elemIndex ktail g.kvars ^?! _Just
-  args <- fold <$>
-    itraverse (\i -> fmap (pushArg $ tonat i) . lowerVal g) xs
-  let origin = encodeOrShow @_ @Text e
-  pure [expr|
-    (@gyehoek :origin #{origin})
-    (@gyehoek "load args")
-    ##{args}
-    (i32.const 1)
-    ##{f'}
-    (ref.cast (ref $closure))
-    (struct.get $closure $code)
-    (return_call_ref $cont-type)
-    (@gyehoek todo
-     (f' ##{f'})
-     (ktail #{l}))
-  |]
-
-lower' g e@(ExpContinue k xs) = do
-  let nargs = length xs
-  args <- fold <$>
-    itraverse (\i -> fmap (pushArg $ tonat i) . lowerVal g) xs
-  let origin = encodeOrShow @_ @Text e
-  pure [expr|
-    (@gyehoek :origin #{origin})
-    (@gyehoek "push args")
-    ##{args}
-    (@gyehoek "nargs")
-    (i32.const #{nargs})
-    (@gyehoek "pop cont stack")
-    (global.get $cont-stack-top)
-    (i32.const #{l})
-    i32.sub
-    (global.set $cont-stack-top)
-    (global.get $cont-stack)
-    (global.get $cont-stack-top)
-    (array.get $cont-stack-type)
-    ref.as_non_null
-    (return_call_ref $cont-type)
-  |]
-  where
-    l = succ $ V.elemIndex k g.kvars ^?! _Just
-
-lower' g e = error $ case Gyehoek.Sexp.encode e of
-  Left _ -> show e
-  Right x -> T.unpack x
-
-lowerKappa :: GenMod :> es => Env -> Kappa -> Eff es Idx
-lowerKappa g e@(MkKappa xs m) = do
-  let g' = g & #vars <>~ V.fromList xs
-  m' <- lower' g' m
-  let origin = encodeOrShow @_ @Text e
-  idx <- Wasm.defineFunction [wat|
-    (func (param i32)
-      (@gyehoek :origin #{origin})
-      (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-      ##{m'})
-  |]
-  Wasm.emit [wats|(elem declare funcref (ref.func #{idx}))|]
-  pure idx
-
-lowerLambda :: GenMod :> es => Env -> Lambda -> Eff es Idx
-lowerLambda g e@(MkLambda xs ktail m) = do
-  let g' = g & #vars .~ V.fromList xs
-             & #kvars <>~ [ktail]
-  m' <- lower' g' m
-  let origin = encodeOrShow @_ @Text e
-  idx <- Wasm.defineFunction [wat|
-    (func (param i32)
-      (@gyehoek :origin #{origin})
-      (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-      ##{m'})
-  |]
-  Wasm.emit [wats|(elem declare funcref (ref.func #{idx}))|]
-  pure idx
-
-lowerBinOp
-  :: (GenMod :> es)
-  => Text -> Env -> Val -> Val -> Kappa -> Eff es Wasm.Expr
-lowerBinOp op g x y (MkKappa [r] e) = do
-  let op' = SL.Symbol op
-  let g' = g & #vars <>~ [r]
-  let n = succ $ length (g ^. #vars)
-  let reg = getArgRegister . fromIntegral $ n
-  x' <- lowerVal g x
-  y' <- lowerVal g y
-  e' <- lower' g' e
-  pure [expr|
-    ##{x'}
-    (i31.get_s (ref.cast (ref i31)))
-    (i32.const 1)
-    i32.shr_u
-    ##{y'}
-    (i31.get_s (ref.cast (ref i31)))
-    (i32.const 1)
-    i32.shr_u
-    #{op'}
-    ##{makeSmallFixnum}
-    (global.set #{reg})
-    ##{e'}
-  |]
-
-
-
-emitRuntime :: GenMod :> es => Eff es ()
-emitRuntime = mfix \runtime -> do
-  Wasm.defineFunctions [wats|
-    (import "gyehoek" "write" (func $gh-write (param (ref eq))))
-    (import "gyehoek" "truthy?" (func $gh-truthy? (param (ref eq))
-                                  (result i32)))
-  |]
-  -- cont stack
-  Wasm.defineTypes [wats|
-    (type $heap-object (sub (struct (field $hash (mut i32)))))
-    (type $cont-type (func (param i32)))
-    (type $cont-stack-type (array (mut (ref null $cont-type))))
-    (type $closure (sub $heap-object
-                        (struct (field $hash (mut i32))
-                                (field $code (ref $cont-type)))))
-  |]
-  Wasm.defineGlobals [wats|
-    (global $cont-stack-top (mut i32) (i32.const 0))
-    (global $cont-stack (ref $cont-stack-type)
-            (array.new_default $cont-stack-type (i32.const 128)))
-  |]
-  -- arg registers
-  Wasm.defineGlobals [wats|
-    (global $arg0 (mut (ref null eq)) (ref.null eq))
-    (global $arg1 (mut (ref null eq)) (ref.null eq))
-    (global $arg2 (mut (ref null eq)) (ref.null eq))
-    (global $arg3 (mut (ref null eq)) (ref.null eq))
-    (global $arg4 (mut (ref null eq)) (ref.null eq))
-    (global $arg5 (mut (ref null eq)) (ref.null eq))
-    (global $arg6 (mut (ref null eq)) (ref.null eq))
-    (global $arg7 (mut (ref null eq)) (ref.null eq))
-    (global $arg8 (mut (ref null eq)) (ref.null eq))
-    (global $arg9 (mut (ref null eq)) (ref.null eq))
-    (global $arg10 (mut (ref null eq)) (ref.null eq))
-    (global $arg11 (mut (ref null eq)) (ref.null eq))
-    (global $arg12 (mut (ref null eq)) (ref.null eq))
-    (global $arg13 (mut (ref null eq)) (ref.null eq))
-    (global $arg14 (mut (ref null eq)) (ref.null eq))
-    (global $arg15 (mut (ref null eq)) (ref.null eq))
-  |]
-  -- other  things 😼
-  Wasm.defineGlobal [wat|
-    (global $result (mut (ref null eq))
-            (ref.null eq))
-  |]
-  -- procedures
-  let arg = popArg 0
-  Wasm.defineFunction [wat|
-    (func $halt (param i32)
-      ##{arg}
-      (global.set $result))
-  |]
-  pure ()
-
-lower :: Exp -> Eff es Text
-lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do
-  runtime <- emitRuntime
-  let g = MkEnv mempty mempty
-  e' <- lower' g e
-  let origin = encodeOrShow @_ @Text e
-  Wasm.defineFunction [wat|
-    (func $scm-entry (param i32)
-      (@gyehoek :origin #{origin})
-      (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-      ##{e'})
-  |]
-  Wasm.defineFunction [wat|
-    (func (export "main")
-      (call $scm-entry (i32.const 0))
-      (call $gh-write (ref.as_non_null (global.get $result))))
-  |]
-  
-lowerProgram :: Program -> Eff es Text
-lowerProgram (MkProgram e) = lower e

src/Gyehoek/CPS/Stackify.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE OverloadedLists #-}
 module Gyehoek.CPS.Stackify
-  ( stackifyExp
-  , stackifyProgram
+  ( stackifyProgram
   , module Gyehoek.CPS.Syntax
   ) where
 
@@ -13,133 +12,155 @@ import Gyehoek.GenSym
 import Effectful.Writer.Static.Shared
 import Data.Foldable
 import qualified Data.HashMap.Strict as H
-import Data.List (elemIndex)
+import Data.List (elemIndex, nub, intersect)
+import Data.Text qualified as T
 import Gyehoek.Prelude
+import Debug.Pretty.Simple
+import qualified Gyehoek.Sexp as S
+import Data.Monoid
 
 
-type Stackify = Writer Stk.Program
+data BlockBuilder
+  = Code (List Stk.Instr) BlockBuilder
+  | Tail Stk.Tail
+  deriving (Show, Generic)
 
-runStackify :: Eff (Stackify : es) a -> Eff es (a, Stk.Program)
-runStackify = runWriter
+buildBlock :: BlockBuilder -> Stk.Block
+buildBlock = go [] where
+  go acc (Code xs bb) = go (acc ++ xs) bb
+  go acc (Tail t) = Stk.MkBlock acc t
 
-live :: Free a => Env -> a -> List Name
-live g e = free' e & filter \x ->
-  x `H.member` g.bound
-  && not (x `elem` g.contStack)
+-- affine
+_ValName :: Traversal' Val Name
+_ValName = failing #_ValVar (#_ValImm . #_ImmLabel . #_MkLabel)
 
 stackify
-  :: (GenSym :> es, Stackify :> es)
-  => Env -> Exp -> Eff es (Seq Stk.Instr)
+  :: forall es. (GenSym :> es)
+  => Env -> Exp -> Eff es BlockBuilder
 
-stackify g (ExpLetRec [(f, kap@(AbsKappa' xs m))] e) = do
-  let vs = (f, Stk.ValLabel f) : (bindReg <$> xs)
-  let ls = live g kap
-  m' <- stackify (g & #bound .~ H.fromList (vs ++ (bindReg <$> ls))) m
-  tell [Stk.MkBlock f xs $
-        [Stk.Pop x | x <- ls] <> toList m']
-  let g' = g & #bound . at f ?~ Stk.ValLabel f
-             & #liveness . at f ?~ ls
-  stackify g' e
+stackify _ (ExpContinue (ValVar k) xs) =
+  Code [ ] _
 
-stackify g (ExpLetRec [(f, AbsLambda' xs k m)] e) = do
-  let vs = (k:xs) <&> \x -> (x, Stk.ValReg x)
-  m' <- stackify (g & #bound .~ H.fromList vs
-                    & #contStack %~ (k:)) m
-  tell [Stk.MkBlock f xs . toList $ m']
-  stackify g e
-
-stackify g (ExpIf c t f) = do
-  t' <- stackify g t
-  f' <- stackify g f
-  pure [ Stk.If (stackifyVal g c) (toList t') (toList f') ]
-
-stackify g (ExpApply f xs ktail) = do
-  pure $
-    [ Stk.PushCont k ]
-    <> fromList [ Stk.Push (Stk.ValReg l) | l <- ls ]
-    <> [ Stk.Call (stackifyVal g f) (stackifyVal g <$> xs) ]
-  where
-    k = var g ktail
-    ls = fold $ (k ^? #ValImm . #ImmLabel)
-      >>= \klbl -> g ^. #liveness . at klbl
-
-stackify g (ExpContinue k xs) =
-  -- return continuations require popping the stack. how do we know
-  -- when a continuation is a return continuation? is this a correct
-  -- test?
-  case elemIndex k g.contStack of
-    Nothing -> pure [ Stk.Call (Stk.ValLabel k) xs' ]
-    Just j -> do
-      ktail <- gensym' $ k ^. _Wrapped'
-      pure $
-       Seq.replicate j (Stk.PopCont "_")
-       <> [ Stk.PopCont ktail
-          , Stk.Call (Stk.ValReg ktail) (stackifyVal g <$> xs)
-          ]
-
-  where xs' = stackifyVal g <$> xs
-
-stackify g (ExpPrim p (MkKappa [x] e)) = do
-  e' <- stackify (g & #bound . at x ?~ Stk.ValReg x) e
-  pure $ [ Stk.Prim x (stackifyVal g <$> p) ] <> e'
+stackify _ (ExpPrim p k) = _
 
 stackify _ e = error [i|unimplemented exp: #{e}|]
 
-stackifyVal :: Env -> Val -> Stk.Val
-stackifyVal g = \case
-  ValImm imm -> Stk.ValImm imm
-  ValVar v -> var g v
-  v -> error [i|unimplemented val: #{v}|]
+stackifyAbs :: (GenSym :> es) => Env -> Label -> Abs -> Eff es Stk.Routine
 
-var :: Env -> Name -> Stk.Val
-var g v = case g ^. #bound . at v of
-  Just x -> x
-  Nothing -> Stk.ValLabel v
+stackifyAbs g lbl (MkAbs xs mtail e) =
+  Stk.MkRoutine lbl . buildBlock . preamble <$> stackify g e
+  where
+    preamble = Code (popArgs $ (mtail ^.. _Just) ++ xs)
 
-bindReg :: Name -> (Name, Stk.Val)
-bindReg x = (x, Stk.ValReg x)
+popArgs :: List Name -> List Stk.Instr
+popArgs = fmap (Stk.Pop . MkReg) . reverse
+
+pushArgs :: List Name -> List Stk.Instr
+pushArgs = _
 
 
 
 data Env = MkEnv
-  { bound :: HashMap Name Stk.Val
-  -- | for each locally-bound continuation @k@, @liveness@ has an
-  -- entry @(k,ls)@ where @ls@ is the sequence of registers @k@
-  -- expects to find saved on the stack.
-  , liveness :: HashMap Name (List Name)
-  , contStack :: List Name
+  {
   }
   deriving (Show, Generic)
 
 emptyEnv :: Env
-emptyEnv = MkEnv mempty mempty ["halt"]
+emptyEnv = MkEnv
+  {
+  }
 
 
 
-stackifyExp :: GenSym :> es => Name -> Exp -> Eff es Stk.Program
-stackifyExp lbl e = do
-  (code,p) <- runStackify $ stackify emptyEnv e
-  pure $ p <> Stk.MkProgram [ Stk.MkBlock lbl [] (toList code) ]
+stackifyProgram
+  :: forall es. GenSym :> es
+  => HoistedProgram -> Eff es Stk.Program
+stackifyProgram p = p
+  & ifoldMapOf
+    ((#bindings . itraversed)
+     <> (#body . to (H.singleton "start" . AbsLambda) . itraversed))
+    (\l -> Ap . stackifyBinding l)
+  & getAp
+  where
+    g = emptyEnv
+    stackifyBinding lbl ab =
+      Stk.MkProgram . H.singleton lbl <$> stackifyAbs @es g lbl ab
 
-stackifyProgram :: GenSym :> es => Program -> Eff es Stk.Program
-stackifyProgram (MkProgram e) = stackifyExp "main" e
-
-
-
-fac :: Program
-fac = [cps|
-  (letrec ((fac (λ (n ktail)
-                  (prim (zero? n)
-                        (κ (x0)
-                           (if x0
-                               (continue ktail 1)
-                               (prim (- n 1)
-                                 (κ (x1)
-                                    (letrec ((fac-k0
-                                              (κ (x2)
-                                                 (prim (* n x2)
-                                                   (κ (x3)
-                                                     (continue ktail x3))))))
-                                      (fac x1 fac-k0))))))))))
-    (fac 6 halt))
+p :: HoistedProgram
+p = [cps|
+(letrec (($r12-code32
+          (κ (x13)
+            (prim
+             (get-env)
+             (κ (r12 start-ktail0)
+               (continue start-ktail0 x13)))))
+         ($prim-k7-code22
+          (κ (r6)
+            (prim
+             (get-env)
+             (κ (prim-k7 lambda-tail1 n fac)
+               (prim
+                (make-shared-closure ($r8-code19) (lambda-tail1 n))
+                (κ (r8)
+                  (fac r6 r8)))))))
+         ($prim-k11-code16
+          (κ (r10)
+            (prim
+             (get-env)
+             (κ (prim-k11 lambda-tail1)
+               (continue lambda-tail1 r10)))))
+         ($falsey-cont5-code26
+          (κ ()
+            (prim
+             (get-env)
+             (κ (truthy-cont4 falsey-cont5 lambda-tail1 n fac)
+               (prim
+                (make-shared-closure ($prim-k7-code22) (lambda-tail1 n fac))
+                (κ (prim-k7)
+                  (prim (- n 1) prim-k7)))))))
+         ($r8-code19
+          (κ (x9)
+            (prim
+             (get-env)
+             (κ (r8 lambda-tail1 n)
+               (prim
+                (make-shared-closure ($prim-k11-code16) (lambda-tail1))
+                (κ (prim-k11)
+                  (prim (* n x9) prim-k11)))))))
+         ($truthy-cont4-code25
+          (κ ()
+            (prim
+             (get-env)
+             (κ (truthy-cont4 falsey-cont5 lambda-tail1 n fac)
+               (continue lambda-tail1 1)))))
+         ($fac-code35
+          (λ (n lambda-tail1)
+            (prim
+             (get-env)
+             (κ (fac)
+               (prim
+                (make-shared-closure ($prim-k3-code29) (lambda-tail1 n fac))
+                (κ (prim-k3)
+                  (prim (zero? n) prim-k3)))))))
+         ($prim-k3-code29
+          (κ (r2)
+            (prim
+             (get-env)
+             (κ (prim-k3 lambda-tail1 n fac)
+               (prim
+                (make-shared-closure
+                 ($truthy-cont4-code25 $falsey-cont5-code26)
+                 (lambda-tail1 n fac))
+                (κ (truthy-cont4 falsey-cont5)
+                  (if r2
+                    truthy-cont4
+                    falsey-cont5))))))))
+  (λ (start-ktail0)
+    (prim
+     (make-shared-closure ($fac-code35) ())
+     (κ (fac)
+       (prim
+        (make-shared-closure ($r12-code32) (start-ktail0))
+        (κ (r12)
+          (fac 20 r12)))))))
 |]

src/Gyehoek/CPS/Syntax.hs

@@ -10,15 +10,18 @@ module Gyehoek.CPS.Syntax
   , Kappa(..)
   , Lambda(..)
   , Exp(..)
+  , Kexp(..)
   , ExpF(..)
   , Name(..)
   , Prim(..)
   , Program(..)
+  , HoistedProgram(..)
   , Lit(..)
   , Imm(..)
   , Obj(..)
   , Hob(..)
-  , pattern Void
+  , Label(..)
+  , Reg(..)
   , pattern Halt
   , pattern Halt1
   , _MkKappa
@@ -37,27 +40,34 @@ module Gyehoek.CPS.Syntax
   , Abs(..)
   , Free(..)
   , pattern ValLabel
-  , labelName -- don't like that this is part of the api
+  , pattern ObjLabel
+  , absBody
+  , pattern MkAbs
+  , _MkAbs
+  , unhoist
+  , pattern ExpJump
+  , _ExpJump
   )
   where
 
-import Language.SexpGrammar qualified as S
-import Gyehoek.Sexp qualified
-import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primSexpIso, Lit(..), pattern Void)
-import Language.SexpGrammar.Generic
+import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primDatumIso, Lit(..))
+import Gyehoek.Sexp qualified as S
 import Control.Category
 import Prelude hiding ((.), id)
-import Language.Haskell.TH.Quote (QuasiQuoter)
-import Language.Sexp.Located (Sexp)
-import qualified Data.InvertibleGrammar.Base as IG
-import Data.InvertibleGrammar.Base (type (:-)((:-)))
 import qualified Data.HashSet as HS
 import Data.Monoid (Endo)
 import Data.Functor.Foldable.TH
-import qualified Gyehoek.Sexp as GS
-import qualified Language.Sexp.Located as SL
 import Data.Data.Lens (uniplate)
 import Gyehoek.Prelude hiding (op)
+import Gyehoek.Sexp (Datum)
+import Gyehoek.Sexp (G, (:-)(..))
+import qualified Data.InvertibleGrammar.Base as IG
+import Gyehoek.GenSym (Gen)
+import Data.String (IsString)
+import Control.Applicative
+import qualified Data.HashMap.Strict as H
+import GHC.Records (HasField (..))
+import Data.Bifunctor
 
 -- Data types
 
@@ -66,13 +76,24 @@ data Val
   | ValVar Name
   deriving (Show, Generic, Data, Eq)
 
-pattern ValLabel :: Name -> Val
+pattern ValLabel :: Label -> Val
 pattern ValLabel x = ValImm (ImmLabel x)
 
+newtype Label = MkLabel { inner :: Name }
+  deriving stock (Generic, Data)
+  deriving newtype (Show, Eq, Gen, IsString, Hashable)
+  deriving anyclass (NFData, Wrapped)
+
+newtype Reg = MkReg { inner :: Name }
+  deriving stock (Generic, Data)
+  deriving newtype (Show, Eq, Gen, IsString, Hashable)
+  deriving anyclass (NFData, Wrapped)
+
 data Imm
   = ImmInt Int
   | ImmBool Bool
-  | ImmLabel Name
+  | ImmLabel Label
+  | ImmUndefined
   deriving stock (Show, Generic, Data, Eq)
   deriving anyclass (NFData)
 
@@ -82,9 +103,14 @@ data Obj
   deriving stock (Show, Generic, Data, Eq)
   deriving anyclass (NFData)
 
+pattern ObjLabel l = ObjImm (ImmLabel l)
+
 -- | a heap object.
 data Hob
-  = HobClosure { label :: Name, env :: List Obj }
+  = HobClosure { label :: Label, env :: List Obj }
+  -- should a continuation have a label, or an Obj?
+  | HobContinuation { cont :: Obj, stack :: NonEmpty (List Obj) }
+  | HobPair Obj Obj
   deriving stock (Show, Generic, Data, Eq)
   deriving anyclass (NFData)
 
@@ -99,46 +125,92 @@ data Abs
   | AbsLambda Lambda
   deriving (Show, Generic, Data, Eq)
 
-pattern AbsKappa' :: [Name] -> Exp -> Abs
+pattern AbsKappa' :: List Name -> Exp -> Abs
 pattern AbsKappa' xs e = AbsKappa (MkKappa xs e)
 
-pattern AbsLambda' :: [Name] -> Name -> Exp -> Abs
+pattern AbsLambda' :: List 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
-  = ExpPrim (Prim Val) Kappa
+  = ExpPrim (Prim Val) Kexp
   | ExpLetRec { binders :: List (Name, Abs), body :: Exp }
-  | ExpContinue Name (List Val)
-  | ExpIf Val Exp Exp
+  | ExpContinue Val (List Val)
+  | ExpIf Val Name Name
   | ExpApply
     { op :: Val
     , args :: List Val
-    , cont :: Name
+    , cont :: Kexp
     }
   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 "halt" xs
+pattern Halt xs = ExpContinue (ValLabel "halt") xs
 
 pattern Halt1 :: Val -> Exp
-pattern Halt1 x = ExpContinue "halt" [x]
+pattern Halt1 x = ExpContinue (ValLabel "halt") [x]
 
 data Def = DefConstant Name Exp
   deriving (Show, Generic, Data)
 
 data Program = MkProgram
-  { body :: Exp
+  { 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
--- makeLenses ''Kappa
 makePrisms ''Exp
--- makeLenses ''Exp
--- makeFieldsNoPrefix ''Exp
--- makeFieldsNoPrefix ''Kappa
--- makeLensesWith abbreviatedFields ''Exp
--- makeLensesFor [("binders", "_binders"), ("body", "_body")] ''Exp
 makeFieldsId ''Exp
 makeFieldsId ''Kappa
 makeFieldsId ''Lambda
@@ -158,147 +230,187 @@ _AbsLambda' = prism'
   (\case AbsLambda' bs ktail e -> Just (bs,ktail,e)
          _ -> Nothing)
 
-instance Plated Exp where
-  plate = uniplate
-  -- plate k = \case
-  --   ExpPrim p kap -> ExpPrim p <$> body k kap
-  --   ExpLetRec bs e -> ExpLetRec <$> (each . _2 . body) k bs <*> k e
-  --   ExpContinue c xs -> pure $ ExpContinue c xs
-  --   ExpIf c t f -> ExpIf c <$> k t <*> k f
-  --   ExpApply f xs ktail -> pure $ ExpApply f xs ktail
+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)))
 
 
--- SexpIso instances
+-- DatumIso instances
 
-instance S.SexpIso Val where
-  sexpIso = match
-    $ With (\imm -> imm . S.sexpIso)
-    $ With (\var -> var . S.sexpIso)
-    $ End
+instance S.DatumIso Val where
+  datumIso = S.match
+    $ S.With (\imm -> imm . S.datumIso)
+    $ S.With (\var -> var . S.datumIso)
+    $ S.End
 
-instance S.SexpIso Obj where
-  sexpIso = match
-    $ With (\imm -> imm . S.sexpIso)
-    $ With (\hob -> hob . S.sexpIso)
-    $ End
+instance S.DatumIso Obj where
+  datumIso = S.match
+    $ S.With (\imm -> imm . S.datumIso)
+    $ S.With (\hob -> hob . S.datumIso)
+    $ S.End
 
-instance S.SexpIso Imm where
-  sexpIso = match
-    $ With (. S.int)
-    $ With (. GS.schemeBool)
-    $ With (. labelName)
-    $ End
+instance S.DatumIso Imm where
+  datumIso = S.match
+    $ S.With (. S.int)
+    $ S.With (. S.datumIso)
+    $ S.With (. S.datumIso)
+    $ S.With (. S.unreadable (const "#<undefined>"))
+    $ S.End
 
-labelName :: S.SexpGrammar Name
-labelName = S.coproduct
-  [ S.sexpIso @Name >>> Gyehoek.Sexp.prismIso
-        (S.expected "label")
-        (prefixed @Name "$")
-  , S.list $ S.el (S.sym "$") >>> S.el (S.sexpIso @Name)
-  ]
+instance S.DatumIso Label where
+  datumIso = S.with \g -> S.coproduct
+    [ S.decorate S.SynConstant >>> S.datumIso @Name >>> S.prismIso
+          (S.expected "label")
+          (prefixed @Name "$")
+    , S.list $ S.el (S.sym "$") >>> S.el (S.datumIso @Name)
+    ]
+    >>> g
 
-instance S.SexpIso Hob where
-  sexpIso = match
-    $ With (. closure)
-    $ End
+instance S.DatumIso Reg where
+  datumIso = S.with \g ->
+    S.decorate S.SynVariable >>> S.datumIso @Name >>> S.prismIso
+      (S.expected "register")
+      (prefixed @Name "%")
+    >>> g
+
+instance S.DatumIso Hob where
+  datumIso = S.match
+    $ S.With (. closure)
+    $ S.With (. cont)
+    $ S.With (. conspair)
+    $ S.End
     where
+      conspair = S.dottedList (S.el S.datumIso) S.datumIso
       -- closures can be printed, but not parsed.
-      closure :: S.Grammar S.Position (Sexp :- t) (List Obj :- Name :- t)
+      closure :: G (Datum :- t) (List Obj :- Label :- t)
       closure = IG.Flip $ IG.PartialIso
-        (\(env:-code:-t) -> SL.Modified SL.Hash [GS.sx|(#{code} ##{env})|] :- t)
+        (\(env:-code:-t) -> S.Unreadable [i|\#<procedure $#{code}>|] :- t)
+        (const . Left $ mempty)
+      cont :: G (Datum :- t) (NonEmpty (List Obj) :- _ :- t)
+      cont = IG.Flip $ IG.PartialIso
+        (\(_ :- l :- t) -> 
+          let x = S.encodeOrShow' @Text S.datumIso l
+          in S.Unreadable [i|\#<continuation #{x}>|] :- t)
         (const . Left $ mempty)
 
-instance S.SexpIso Lambda where
-  sexpIso = match
-    $ With (. lambda)
-    $ End
+instance S.DatumIso Lambda where
+  datumIso = S.with (lam >>>)
     where
-      lambda = S.list $
-        S.el Gyehoek.Sexp.lambdaKeyword
-        >>> S.el binders
-        >>> S.el S.sexpIso
-      binders :: forall t.
-        IG.Grammar S.Position (Sexp :- t) (Name :- List Name :- t)
-      binders = S.list $
-        S.rest (S.sexpIso @Name)
-        >>> S.onTail (S.flipped $ IG.PartialIso
-                     (\(ktail:-args:-t) -> (args ++ [ktail]) :- t)
-                     (\(args:-t) -> case args ^? _Snoc of
-                         Just (args',ktail) -> Right $ ktail :- args' :- t
-                         Nothing -> Left $ S.expected "cont param")
-                     )
+      lam :: forall t. G (Datum :- t) (Exp :- Name :- List Name :- t)
+      lam = S.lambdaLike
+        S.lambdaKeyword
+        binders
+        (S.el $ S.datumIso @Exp)
+      binders :: forall t. G (Datum :- t) (Name :- List Name :- t)
+      binders =
+        S.list (S.rest $ S.datumIso @Name)
+        >>> S.flipped S.snoced
+        >>> S.swap
 
-instance S.SexpIso Kappa where
-  sexpIso = match
-    $ With (. kappa)
-    $ End
-    where
-      kappa = S.list $
-        S.el Gyehoek.Sexp.kappaKeyword
-        >>> S.el (S.list $ S.rest S.sexpIso)
-        >>> S.el S.sexpIso
+instance S.DatumIso Kappa where
+  datumIso = S.with \g ->
+    S.lambdaLike S.kappaKeyword
+      (S.datumIso @(List Name))
+      (S.el $ S.datumIso @Exp)
+    >>> g
 
-instance S.SexpIso Abs where
-  sexpIso = match
-    $ With (\lambda -> lambda . S.sexpIso)
-    $ With (\kappa -> kappa . S.sexpIso)
-    $ End
+instance S.DatumIso Abs where
+  datumIso = S.match
+    $ S.With (\lambda -> lambda . S.datumIso)
+    $ S.With (\kappa -> kappa . S.datumIso)
+    $ S.End
 
-instance S.SexpIso Exp where
-  sexpIso = match
-    $ With (. prim)
-    $ With (. letrec)
-    $ With (. continue)
-    $ With (. if_)
-    $ With (. app)
-    $ End
+instance S.DatumIso Exp where
+  datumIso = S.match
+    $ S.With (. prim)
+    $ S.With (. letrec)
+    $ S.With (. continue)
+    $ S.With (. if_)
+    $ S.With (. app)
+    $ S.End
     where
       continue = S.list $
-        S.el (S.sym "continue")
-        >>> S.el S.sexpIso
-        >>> S.rest S.sexpIso
-      letrec = Gyehoek.Sexp.let_ "letrec" S.sexpIso S.sexpIso S.sexpIso
-      if_ = S.list $ S.el (S.sym "if")
-        >>> S.el S.sexpIso >>> S.el S.sexpIso >>> S.el S.sexpIso
+        S.el (S.decorate S.SynBuiltin >>> S.sym "continue")
+        >>> 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.
-        IG.Grammar S.Position (Sexp :- t) (Name :- ([Val] :- (Val :- t)))
-      app = S.list $ S.el (S.sexpIso @Val)
-        -- >>> S.flipped Gyehoek.Sexp.nonEmptyGrammar
-        >>> S.rest (S.sexpIso @Val)
-        -- >>> _
-        >>> S.onTail (S.flipped $ IG.PartialIso
-                      (\(karg :- args :- op :- t) ->
-                         (args ++ [ValVar karg]) :- op :- t)
-                      (\(xs :- op :- t) -> case xs ^? _Snoc of
-                          Just (args,preview #ValVar -> Just karg) ->
-                            Right $ karg:- args :- op :- t
-                          _ -> Left $ S.expected "continuation arg"
-                      ))
-        where
-          _ = S.flipped $ Gyehoek.Sexp.nonEmptyGrammar @S.Position @Val
+        G (Datum :- t) (Kexp :- List Val :- Val :- t)
+      app = S.list $
+        S.flipped (S.PartialIso
+          (\(S.MkListContext ctx :- t) ->
+            case ctx of
+              f:kexp:xs -> S.MkListContext (f : snoc xs kexp) :- t
+              _ -> error "unreachable")
+          (\(S.MkListContext ctx :- t) ->
+            case unsnoc ctx of
+              Just (f:xs,kexp) -> Right $ S.MkListContext (f:kexp:xs) :- t
+              _ -> Left $ S.expected "continuation arg"))
+        >>> S.el (S.datumIso @Val)
+        >>> S.el (S.datumIso @Kexp)
+        >>> S.rest (S.datumIso @Val)
+        >>> S.onTail S.swap
       prim = S.list $
-        S.el (S.sym "prim")
-        >>> S.el (primSexpIso id (S.sexpIso @Val))
-        >>> S.el S.sexpIso
+        S.el (S.decorate S.SynBuiltin >>> S.sym "prim")
+        >>> S.el (primDatumIso id (S.datumIso @Val))
+        >>> S.el S.datumIso
 
-instance S.SexpIso Program where
-  sexpIso = with \prog -> S.sexpIso @Exp >>> prog
+instance S.DatumIso Kexp where
+  datumIso = S.match
+    $ S.With (S.datumIso @Name >>>)
+    $ S.With (S.datumIso @Kappa >>>)
+    $ S.End
+
+instance S.DatumIso Program where
+  datumIso = S.with \prog -> S.datumIso @Lambda >>> prog
+
+-- the printed representation is pretty dishonest in its current
+-- state. consider the following hoisted program:
+-- 
+--  (letrec ((k (κ () (continue start-ktail 123))))
+--    (λ (start-ktail)
+--      (continue k)))
+-- 
+-- here, `start-ktail` is bound in `k`, but the printed representation
+-- fails to reflect that.
+instance S.DatumIso HoistedProgram where
+  datumIso = S.with \prog ->
+    S.letLike "letrec"
+      (S.datumIso @Label) (S.datumIso @Abs) (S.datumIso @Lambda)
+    >>> S.onTail (S.iso H.fromList H.toList)
+    >>> prog
 
 
 -- quasiquoters
 
 class Data a => CPS a where
-  toCPS :: Sexp -> a
+  toCPS :: HasCallStack => Datum -> a
 
-instance CPS Exp where toCPS = Gyehoek.Sexp.fromSexp
-instance CPS Val where toCPS = Gyehoek.Sexp.fromSexp
-instance CPS Kappa where toCPS = Gyehoek.Sexp.fromSexp
-instance CPS Lambda where toCPS = Gyehoek.Sexp.fromSexp
-instance CPS Abs where toCPS = Gyehoek.Sexp.fromSexp
-instance CPS Program where toCPS = Gyehoek.Sexp.fromSexp
+instance CPS Exp where toCPS = S.fromDatumUnsafe S.datumIso
+instance CPS Val where toCPS = S.fromDatumUnsafe S.datumIso
+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 :: QuasiQuoter
-cps = Gyehoek.Sexp.makeSx' [| toCPS |]
+cps :: S.QuasiQuoter
+cps = S.makeSx' [| toCPS |]
 
 
 
@@ -318,7 +430,8 @@ class Free a where
   freeWithBound :: HashSet Name -> a -> HashSet Name
   freeWithBound bound = HS.fromList . freeWithBound' bound
 
-  -- | Free variables given in the order of their appearance.
+  -- | Free variables given in the same left-to-right order they
+  -- appear.
   free' :: a -> List Name
   free' = freeWithBound' mempty
 
@@ -328,22 +441,32 @@ 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
     ExpPrim p k ->
-      p & toListOf (folded . #ValVar . filtered (`notElem` bound))
-        & (<> freeWithBound' bound k)
+      (p ^.. folded . #ValVar . filtered (`notElem` bound))
+      ++ freeWithBound' bound k
     ExpLetRec bs m ->
       foldMapOf (each . _2) (freeWithBound' bound') bs
       <> freeWithBound' bound' m
       where bound' = bound & insertFrom (bs ^.. each . _1)
-    ExpContinue k xs -> filter (`notElem` bound) (k : xs ^.. each . #ValVar)
+    ExpContinue k xs -> filter (`notElem` bound) ((k:xs) ^.. each . #ValVar)
     ExpIf c t f ->
       (c ^.. #ValVar . filtered (`notElem` bound))
-      <> freeWithBound' bound t <> freeWithBound' bound f
+      <> mif (`notElem` bound) t <> mif (`notElem` bound) f
     ExpApply f xs k ->
       (f:xs) ^.. (each . #ValVar . filtered (`notElem` bound))
-      <> (k ^.. filtered (`notElem` bound))
+      <> freeWithBound' bound k
 
 instance Free Kappa where
   freeWithBound' bound (MkKappa xs m) =
@@ -352,21 +475,3 @@ instance Free Kappa where
 instance Free Lambda where
   freeWithBound' bound (MkLambda xs k m) =
     freeWithBound' (bound & insertFrom (k:xs)) m
-
-
-
-class Vars a where
-  -- | Traverse the immediate variables of an expression.
-  vars :: Traversal' a Name
-
-instance Vars Val where
-  vars k (ValVar x) = ValVar <$> k x
-  vars _ x = pure x
-
-instance Vars a => Vars (Prim a) where
-  vars k p = traverseOf (each . vars) k p
-
-instance Vars Exp where
-  vars k (ExpPrim p kap) = ExpPrim <$> vars k p <*> pure kap
-  vars k (ExpContinue kname xs) = ExpContinue <$> k kname <*> pure xs
-  vars _ e = pure e

src/Gyehoek/Driver.hs

@@ -1,5 +1,5 @@
 module Gyehoek.Driver
-  (main, lower_e2e, convert_e2e, parse_e2e, readScm, eval_e2e)
+  (main, lower_e2e, convert_e2e, parse_e2e, readScm, eval_e2e, eval_cps_e2e, eval_cps2_e2e)
   where
 
 import Gyehoek.Options
@@ -17,7 +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.CPS.Lower
+import Gyehoek.Stack.Lower
 import Gyehoek.CPS.Eval qualified as CPS
 import Control.Monad
 import Text.Pretty.Simple (pShowNoColor)
@@ -26,19 +26,23 @@ import System.Environment.Blank (getEnvDefault)
 import qualified Data.Text.IO as TIO
 import qualified Data.ByteString.Lazy as BS
 import Gyehoek.CPS.Stackify (stackifyProgram)
-import Gyehoek.Stack.VM (eval, writeObj, Obj)
+import 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)
+import Gyehoek.CPS.Contify (contifyProgram)
 
 
 main :: IO ()
 main = do
   opts <- execParser $ info (helper <*> parser) fullDesc
-  runEff . runFileSystem . runGenSym . driver $ opts
+  runJalmotIO . runFileSystem . runGenSym . driver $ opts
 
 
 
@@ -65,11 +69,12 @@ fileName :: FilePath -> FilePath
 fileName "-" = "<interactive>"
 fileName e = e
 
-readScm :: FileSystem :> es => FilePath -> Eff es Scm.Program
+readScm
+  :: forall es. (Jalmot :> es, FileSystem :> es)
+  => FilePath -> Eff es Scm.Program
 readScm f =
   withFile f FS.ReadMode $ \h ->
-    Sexp.parseSexps @Scm.CommandOrDef (fileName f) <$> hGetContents h
-     >>= either error (pure . Scm.MkProgram)
+    S.decodeDataWith @es S.dataIso =<< hGetContents h
 
 inspectWasm :: IOE :> es => Text -> Eff es ()
 inspectWasm wat = do
@@ -107,7 +112,7 @@ dumpOrRun dump run acquire do_dump do_run =
     when run (do_run x)
 
 driver
-  :: (GenSym :> es, FileSystem :> es, IOE :> es)
+  :: (GenSym :> es, FileSystem :> es, Jalmot :> es, IOE :> es)
   => Options -> Eff es ()
 driver opts = do
   scm <- readScm opts.sourceFile
@@ -115,41 +120,65 @@ driver opts = do
     hPutStrLn FS.stdout . view strict . pShowNoColor $ scm
   cps <- convertProgram scm
   when opts.dumpCPS do
-    hPutStrLn FS.stdout $ Sexp.encodePretty cps ^?! _Right
+     S.writeDatum cps
   closedCps <- closeProgram cps
   when opts.dumpClosed do
-    hPutStrLn FS.stdout $ Sexp.encodePretty closedCps ^?! _Right
+    S.writeDatum closedCps
+  hoistedCps <- hoistProgram closedCps
+  when opts.dumpHoisted do
+    S.writeDatum hoistedCps
+  -- contifiedCps <- contifyProgram hoistedCps
+  -- when opts.dumpContified do
+  --   hPutStrLn FS.stdout =<< S.encodeWith S.datumIso contifiedCps
   let rt_is p = is (_Just . p) opts.runtime
   dumpOrRun opts.dumpStackified (rt_is #Stackify)
-    (stackifyProgram closedCps)
-    (hPutStrLn FS.stdout . Stk.encodeProgram)
-    (eval >>> fmap writeObj      
-         >>> T.unwords          
+    (stackifyProgram hoistedCps)
+    (hPutStrLn FS.stdout <=< S.encodeDataWith S.dataIso)
+    (eval >=> fmap writeObj
+         >>> T.unwords
          >>> hPutStrLn FS.stdout)
+  when (rt_is #HigherOrderCPS) do
+    CPS.evalProgram cps
+      >>= S.writeData
   when (rt_is #CPS) do
-    closedCps
-      & CPS.evalProgram
-      & fmap writeObj      
-      & T.unwords          
-      & hPutStrLn FS.stdout
-  dumpOrRun opts.inspectWasm (rt_is #Wasm)
-    (lowerProgram cps)
-    inspectWasm
-    (\wat -> withFile opts.output FS.WriteMode \h -> hPutStrLn h wat)
+    CPS.evalProgram closedCps
+      >>= S.writeData
+  -- dumpOrRun opts.inspectWasm (rt_is #Wasm)
+  --   (lowerProgram cps)
+  --   inspectWasm
+  --   (\wat -> withFile opts.output FS.WriteMode \h -> hPutStrLn h wat)
+  when opts.traceStackified do
+    stackifyProgram hoistedCps >>= traceEval
 
 parse_e2e :: FilePath -> IO Scm.Program
-parse_e2e = runEff . runFileSystem . readScm
+parse_e2e = runJalmotIO . runFileSystem . readScm
 
 convert_e2e :: FilePath -> IO CPS.Program
-convert_e2e = runEff . runFileSystem . runGenSym
+convert_e2e = runJalmotIO . runFileSystem . runGenSym
   . (closeProgram <=< convertProgram <=< readScm)
 
 lower_e2e :: FilePath -> IO Text
 lower_e2e =
-  runEff . runFileSystem . runGenSym
+  runJalmotIO . runFileSystem . runGenSym
   . (lowerProgram <=< closeProgram <=< convertProgram <=< readScm)
 
 eval_e2e :: FilePath -> IO (List Obj)
-eval_e2e fp = runEff . runFileSystem . runGenSym $ do
+eval_e2e fp = runJalmotIO . runFileSystem . runGenSym $ do
   stk <- stackifyProgram <=< closeProgram <=< convertProgram <=< readScm $ fp
-  pure . eval $ stk
+  eval stk
+
+eval_cps_e2e :: FilePath -> IO Text
+eval_cps_e2e fp = runJalmotIO . runFileSystem . runGenSym $
+  readScm fp
+   >>= convertProgram
+   >>= closeProgram
+   >>= CPS.evalProgram
+   >>= pure . S.encodeOrShowData' S.dataIso
+
+eval_cps2_e2e :: FilePath -> IO Text
+eval_cps2_e2e fp = runJalmotIO . runFileSystem . runGenSym $
+  readScm fp
+   >>= convertProgram
+   -- >>= closeProgram
+   >>= CPS.evalProgram
+   >>= pure . S.encodeOrShowData' S.dataIso

src/Gyehoek/Jalmot.hs

@@ -0,0 +1,75 @@
+module Gyehoek.Jalmot
+  ( Jalmot
+  , Exception(..)
+  , AJalmot(..)
+  , AJalmotCS(..)
+  , module Effectful.Error.Static
+  , runJalmot
+  , runJalmotIO
+  , runJalmotIOE
+  , runJalmotUnsafe
+  , runJalmotCS
+  )
+  where
+
+import Gyehoek.Prelude
+import Text.Megaparsec.Error (ParseErrorBundle, errorBundlePretty)
+import Data.Void (Void)
+import Effectful.Exception
+import Effectful.Error.Static
+import qualified Data.InvertibleGrammar as Grammar
+import Gyehoek.Sexp.Syntax (Ann)
+import Prettyprinter (defaultLayoutOptions, layoutPretty, pretty)
+import Prettyprinter.Render.String (renderString)
+import Control.Exception.Base (throw)
+
+
+deriving instance Show p => Show (Grammar.ErrorMessage p) 
+deriving instance Data p => Data (Grammar.ErrorMessage p) 
+
+data AJalmot
+  = ReaderError (ParseErrorBundle Text Void)
+  | GrammarError (Grammar.ErrorMessage Ann)
+  | VMError Text
+  | EvalError Text
+  deriving (Show, Generic, Data)
+
+data AJalmotCS = MkAJalmotCS !CallStack !AJalmot
+  deriving (Show)
+
+type Jalmot = Error AJalmot
+
+runJalmot :: Eff (Jalmot : es) a -> Eff es (Either (CallStack, AJalmot) a)
+runJalmot = runError
+
+runJalmotCS :: Eff (Jalmot : es) a -> Eff es (Either AJalmotCS a)
+runJalmotCS = (mapped . _Left %~ uncurry MkAJalmotCS) . runError
+
+runJalmotIOE :: IOE :> es => Eff (Jalmot : es) a -> Eff es a
+runJalmotIOE eff =
+  runJalmot eff >>= \case
+    Right a -> pure a
+    Left (cs,jm) -> throwIO $ MkAJalmotCS cs jm
+
+runJalmotIO :: Eff '[Jalmot, IOE] a -> IO a
+runJalmotIO = runEff . runJalmotIOE
+
+runJalmotUnsafe :: Eff '[Jalmot] a -> a
+runJalmotUnsafe m = case runPureEff . runJalmot $ m of
+  Left (cs,e) -> throw $ MkAJalmotCS cs e
+  Right x -> x
+
+instance Exception AJalmot where
+  displayException = \case
+    ReaderError eb -> errorBundlePretty eb
+    GrammarError err ->
+        pretty err
+        & layoutPretty defaultLayoutOptions
+        & renderString
+    VMError err -> [i|#{err}|]
+    EvalError err -> [i|#{err}|]
+
+instance Exception AJalmotCS where
+  backtraceDesired = const False
+  displayException (MkAJalmotCS cs jm) =
+    "\n" <> displayException jm <> "\n\n" <> prettyCallStack cs <> "\n"

src/Gyehoek/Language.hs

@@ -1,25 +1,4 @@
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE AllowAmbiguousTypes #-}
 module Gyehoek.Language
-  ( Language(..)
+  (
   ) where
 
-import Data.Kind (Type)
-import Gyehoek.Prelude
-import Language.SexpGrammar (Position, Grammar, (:-), Sexp)
-
-
-class Language l where
-  type Program l :: Type
-  languageName :: Text
-  programGrammar :: forall t. Grammar Position (List Sexp :- t) (Program l :- t)
-
-readProgramFile
-  :: forall l es. Language l
-  => FilePath -> Eff es (Program l)
-readProgramFile fp = _
-
-readProgramStringPos
-  :: forall l. Language l
-  => Position -> Text -> Either Text (Program l)
-readProgramStringPos pos s = _

src/Gyehoek/Lift1.hs

@@ -0,0 +1,30 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Gyehoek.Lift1
+  ( Lift1(..)
+  , lift1
+  ) where
+
+import Gyehoek.Prelude hiding ((:<))
+import Language.Haskell.TH (Quote, Exp, listE)
+import Language.Haskell.TH.Syntax (Lift (..))
+import Control.Comonad.Cofree (Cofree(..))
+
+
+-- 뻘짓뻘짓뻘짓뻘짓뻘짓
+class Lift1 f where
+  liftLift :: Quote m => (a -> m Exp) -> f a -> m Exp
+
+lift1 :: (Lift1 f, Lift a, Quote m) => f a -> m Exp
+lift1 = liftLift lift
+
+
+--- instances
+
+instance Lift1 f => Lift1 (Cofree f) where
+  liftLift l (a :< e) = [|(:<) $(l a) $(liftLift (liftLift l) e)|]
+
+instance Lift1 List where
+  liftLift l xs = listE $ l <$> xs
+
+instance Lift1 NonEmpty where
+  liftLift l (x :| xs) = [|(:|) $(l x) $(liftLift l xs)|]

src/Gyehoek/Options.hs

@@ -13,7 +13,7 @@ import Data.Foldable
 import Gyehoek.Prelude hiding (argument)
 
 
-data Runtime = Stackify | Wasm | CPS
+data Runtime = Stackify | Wasm | CPS | HigherOrderCPS
   deriving (Show, Generic, Eq)
 
 data Language
@@ -29,6 +29,10 @@ data Options = MkOptions
   , dumpCPS :: Bool
   , dumpParsed :: Bool
   , dumpStackified :: Bool
+  , dumpHoisted :: Bool
+  , dumpContified :: Bool
+  , traceStackified :: Bool
+  , noColour :: Bool
   , runtime :: Maybe Runtime
   , inspectWasm :: Bool
   , output :: FilePath
@@ -50,7 +54,8 @@ runtimeValues = ["stackify","wasm","cps","none"]
 runtimeReader = maybeReader \case
   "stackify" -> Just (Just Stackify)
   "wasm" -> Just (Just Wasm)
-  "cps" -> Just (Just CPS)
+  "cps1" -> Just (Just CPS)
+  ("cps";"higher-order-cps") -> Just (Just HigherOrderCPS)
   "none" -> Just Nothing
   _ -> Nothing
 
@@ -60,13 +65,20 @@ parser = do
   dumpCPS <- switch (long "dump-cps")
   dumpStackified <- switch (long "dump-stackified")
   dumpParsed <- switch (long "dump-parsed")
+  dumpHoisted <- switch (long "dump-hoisted")
+  dumpContified <- switch (long "dump-contified")
+  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 Stackify)
+    , value (Just HigherOrderCPS)
     , completeWith runtimeValues
-    , showDefaultWith $ const "stackify"
+    , showDefaultWith $ const "higher-order-cps"
     , metavar "RUNTIME"
     ]
   sourceLanguage <- option languageReader . fold $

src/Gyehoek/Prelude.hs

@@ -17,9 +17,12 @@ module Gyehoek.Prelude
   , NonEmpty((:|))
   , Natural
   , (>>>)
+  , (>=>)
+  , (<=<)
+  , wrappedIso
   ) where
 
-import Control.Lens
+import Control.Lens hiding (List, (:<))
 import Data.List (List)
 import Data.Text (Text)
 import Effectful
@@ -37,4 +40,6 @@ import Data.Hashable (Hashable)
 import Data.List.NonEmpty (NonEmpty((:|)))
 import Numeric.Natural (Natural)
 import Control.Category ((>>>))
+import Control.Monad
+import Data.Generics.Wrapped (Wrapped(..))
 

src/Gyehoek/Scheme/Syntax.hs

@@ -17,29 +17,20 @@ module Gyehoek.Scheme.Syntax
   , Def(..)
   , Exp(..)
   , ExpF(..)
-  , Sexp(..)
   , Program(..)
   , CommandOrDef(..)
-  , primSexpIso
-  , pattern Void
+  , primDatumIso
   , free
   , subst
   , getName
   , scm
-  , readExp
-  , readProgram
   , free'
   , freeWithBound'
   , freeO
-  , encodeProgram
   )
   where
 
 import Data.List (intersperse)
-import Language.SexpGrammar
-  ( SexpIso(..), list, el, rest, sym, symbol )
-import Language.SexpGrammar qualified as Sexp
-import Language.SexpGrammar.Generic
 import Effectful
 import Prelude hiding ((.), id)
 import Control.Category
@@ -58,6 +49,9 @@ 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
 
 
@@ -87,9 +81,15 @@ data Prim e
   | PrimZeroP e
   | PrimNewline
   | PrimMakeClosure { code :: e, env :: List e }
-  | PrimEnvRef e Int
-  | PrimEnvCode e
+  | PrimMakeSharedClosure { codes :: List e, env :: List e }
+  | PrimGetEnv
+  | PrimEnv
+  | PrimEnvRef Int
   | PrimCallCC e
+  | PrimCaptureCC
+  | PrimInvokeCC e (List e)
+  | PrimValues (List e)
+  | PrimCallWithValues e e
   deriving stock (Show, Generic, Functor, Foldable, Traversable, Data, Eq)
   deriving anyclass (NFData)
 
@@ -97,16 +97,11 @@ instance Each (Prim e) (Prim e') e e'
 
 data Lit
   = LitInt Int
-  | LitNil
   | LitBool Bool
   | LitString Text
-  | LitQuote Sexp
   deriving stock (Show, Generic, Data, Eq)
   deriving anyclass (NFData)
 
-pattern Void :: Lit
-pattern Void = LitNil
-
 data Def
   = DefConstant Name Exp
   | DefProcedure Name (List Name) (List Exp)
@@ -117,7 +112,7 @@ data Exp
   = ExpLet (List (Name, Exp)) Exp
   | ExpLetRec (List (Name, Exp)) Exp
   | ExpPrim (Prim Exp)
-  | ExpBegin (List Exp)
+  | ExpBegin (NonEmpty Exp)
   | ExpIf Exp Exp Exp
   | ExpLit Lit
   | ExpLambda (List Name) Exp
@@ -126,13 +121,6 @@ data Exp
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
 
-data Sexp
-  = SexpCons Sexp Sexp
-  | SexpSymbol Text
-  | SexpLit Lit
-  deriving stock (Show, Generic, Data, Eq)
-  deriving anyclass (NFData)
-
 data CommandOrDef
   = Command Exp
   | Definition Def
@@ -140,7 +128,7 @@ data CommandOrDef
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
 
-data Program = MkProgram
+newtype Program = MkProgram
   { commandsAndDefs :: List CommandOrDef
   }
   deriving stock (Show, Generic, Data)
@@ -159,102 +147,107 @@ makeBaseFunctor ''Exp
 
 
 
-instance SexpIso Name where
-  sexpIso = symbol >>> Sexp.partialOsi f g
+instance DatumIso Name where
+  datumIso = S.decorate S.SynVariable
+    >>> S.symbol
+    >>> S.iso coerce coerce
+
+primDatumIso
+  :: (Text -> Text)
+  -> S.DatumGrammar a -> S.DatumGrammar (Prim a)
+primDatumIso namefn a = S.match
+    $ S.With (. ht2 "+")
+    $ S.With (. ht2 "-")
+    $ S.With (. ht2 "*")
+    $ S.With (. ht2 "/")
+    $ S.With (. ht2 "cons")
+    $ S.With (. ht1 "car")
+    $ S.With (. ht1 "cdr")
+    $ S.With (. ht1 "immediate?")
+    $ S.With (. ht1 "cons?")
+    $ S.With (. ht1 "integer?")
+    $ S.With (. ht1 "write")
+    $ 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")
+    $ S.With (. ht0 "capture/cc")
+    $ S.With (. ht1' "invoke/cc")
+    $ S.With (. ht0' "values")
+    $ S.With (. ht2 "call-with-values")
+    $ S.End
     where
-      f = Right . MkName
-      g (MkName s) = s
+      idn = S.el . S.sym . namefn
+      ht0 s = S.list $ idn s
+      ht1 s = S.headTagged1 (namefn s) a
+      ht2 s = S.headTagged2 (namefn s) a a
+      ht1' s = S.headTagged1' (namefn s) a a
+      ht0' s = S.headTagged0' (namefn s) a
 
-primSexpIso :: (Text -> Text) -> Sexp.SexpGrammar a -> Sexp.SexpGrammar (Prim a)
-primSexpIso namefn a = match
-    $ With (. ht2 "+")
-    $ With (. ht2 "-")
-    $ With (. ht2 "*")
-    $ With (. ht2 "/")
-    $ With (. ht2 "cons")
-    $ With (. ht1 "car")
-    $ With (. ht1 "cdr")
-    $ With (. ht1 "immediate?")
-    $ With (. ht1 "cons?")
-    $ With (. ht1 "integer?")
-    $ With (. ht1 "write")
-    $ With (. ht1 "zero?")
-    $ With (. nullop "newline")
-    $ With (. ht1' "make-closure")
-    $ With (. GS.headTagged2 (namefn "env-ref") a Sexp.int)
-    $ With (. ht1 "env-code")
-    $ With (. ht1 "call/cc")
-    $ End
+instance DatumIso a => DatumIso (Prim a) where
+  datumIso = primDatumIso id S.datumIso
+
+instance DatumIso Lit where
+  datumIso = S.match
+    $ S.With (. S.int)
+    $ S.With (. S.boolean)
+    $ S.With (. S.string)
+    $ S.End
+
+instance DatumIso Def where
+  datumIso = S.match
+    $ S.With (. defconst)
+    $ S.With (. defun)
+    $ S.End
     where
-      idn s = el (sym (namefn s))
-      nullop s = list $ idn s
-      ht1 s = GS.headTagged1 (namefn s) a
-      ht2 s = GS.headTagged2 (namefn s) a a
-      ht1' s = GS.headTagged1' (namefn s) a a
-
-instance SexpIso a => SexpIso (Prim a) where
-  -- sexpIso = primSexpIso ("prim:"<>) sexpIso
-  sexpIso = primSexpIso id sexpIso
-
-instance SexpIso Lit where
-  sexpIso = match
-    $ With (. sexpIso)
-    $ With (. sym "nil")
-    $ With (. GS.schemeBool)
-    $ With (. sexpIso)
-    $ With (. GS.prefixSugar "quote" Sexp.Quote sexpIso)
-    $ End
-
-instance SexpIso Sexp where
-  sexpIso = match
-    $ With (\conss -> conss . GS.todo)
-    $ With (\s -> s . symbol)
-    $ With (\lit -> lit . sexpIso)
-    $ End
-
-instance SexpIso Def where
-  sexpIso = match
-    $ With (. defconst)
-    $ With (. defun)
-    $ End
-    where
-      defconst = list $ el (sym "define") >>> el sexpIso >>> el sexpIso
-      defun = list $ el (sym "define") >>> el args >>> rest sexpIso
-      args = list $ el sexpIso >>> rest sexpIso
+      defconst = S.list $ S.el (S.sym "define")
+        >>> S.el S.datumIso >>> S.el S.datumIso
+      defun = S.list $ S.el (S.sym "define")
+        >>> S.el args >>> S.rest S.datumIso
+      args = S.list $ S.el S.datumIso >>> S.rest S.datumIso
   
-instance SexpIso Exp where
-  sexpIso = match
-    $ With (. GS.let_ "let" sexpIso sexpIso sexpIso)
-    $ With (. GS.let_ "letrec" sexpIso sexpIso sexpIso)
-    $ With (. sexpIso)
-    $ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso))
-    $ With (. if_)
-    $ With (. sexpIso)
-    $ With (. lam)
-    $ With (. sexpIso)
-    $ With (\app -> app . list (el sexpIso >>> rest sexpIso))
-    $ End
+instance DatumIso Exp where
+  datumIso = S.match
+    $ S.With (. S.letLike "let" S.datumIso S.datumIso S.datumIso)
+    $ S.With (. S.letLike "letrec" S.datumIso S.datumIso S.datumIso)
+    $ S.With (. S.datumIso)
+    $ S.With (. begin)
+    $ S.With (. S.ifLike "if" S.datumIso S.datumIso S.datumIso)
+    $ S.With (. S.datumIso)
+    $ S.With (. lam)
+    $ S.With (. S.datumIso)
+    $ S.With (\app -> app . S.list (S.el S.datumIso >>> S.rest S.datumIso))
+    $ S.End
     where
-      if_ = list $ el (sym "if") >>> el sexpIso >>> el sexpIso >>> el sexpIso
-      lam = list
-        ( el GS.lambdaKeyword
-          >>> el (sexpIso @(List Name))
-          >>> el sexpIso )
+      lam = S.lambdaLike S.lambdaKeyword S.datumIso (S.el S.datumIso)
+      begin :: forall t. G (S.Datum :- t) (NonEmpty Exp :- t)
+      begin = S.beginLike "begin" $
+        S.el (S.datumIso @Exp) >>> S.rest (S.datumIso @Exp)
+        >>> S.onTail (S.Iso
+          (\(xs:-x:-t) -> (x:|xs):-t)
+          (\((x:|xs):-t) -> xs:-x:-t))
 
-instance SexpIso CommandOrDef where
-  sexpIso = match
-    $ With (\_Command -> _Command . sexpIso)
-    $ With (\_Definition -> _Definition . sexpIso)
-    $ With (\_Begin -> _Begin . bgn)
-    $ End
-    where
-      bgn = list $ el (sym "begin") >>> rest sexpIso
+instance DatumIso CommandOrDef where
+  datumIso = S.match
+    $ S.With (\_Command -> _Command . S.datumIso)
+    $ S.With (\_Definition -> _Definition . S.datumIso)
+    $ S.With (\_Begin -> _Begin . S.beginLike "begin" (S.rest S.datumIso))
+    $ S.End
+
+instance DataIso Program where
+  dataIso = S.dataIso @(List CommandOrDef) >>> S.iso coerce coerce
 
 
 -- utilities
 
 scm :: QuasiQuoter
-scm = GS.makeSx [|| GS.fromSexp @Exp ||]
+scm = GS.makeSx [|| S.fromDatumUnsafe @Exp S.datumIso ||]
 
 freeWithBound' :: Foldable f => f Name -> Exp -> List Name
 freeWithBound' bound = filter (`elem` bound) . free'
@@ -309,27 +302,3 @@ subst f = \e -> cata go e mempty where
   go (ExpLetF _ _) _ = error "todo lol"
   go (ExpLambdaF bs e) bound = e $ insertFrom bs bound
   go e bound = embed $ fmap ($ bound) e
-
-
-
-fileName :: FilePath -> FilePath
-fileName "-" = "<interactive>"
-fileName e = e
-
-hGetContents :: FS.FileSystem :> es => FS.Handle -> Eff es Text
-hGetContents h = T.decodeUtf8 <$> FB.hGetContents h
-
-readProgram :: IOE :> es => FilePath -> Eff es Program
-readProgram fp = runFileSystem $
-  FS.withFile fp FS.ReadMode $ \h ->
-    GS.parseSexps @CommandOrDef (fileName fp) <$> hGetContents h
-     >>= either error (pure . MkProgram)
-
-readExp :: IOE :> es => FilePath -> Eff es Exp
-readExp fp = readProgram fp <&> (^?! #commandsAndDefs . _head . #Command)
-
-encodeProgram :: Program -> Text
-encodeProgram p = p.commandsAndDefs
-  & fmap ((^?! _Right) . GS.encodePretty)
-  & intersperse "\n\n"
-  & mconcat

src/Gyehoek/Sexp.hs

@@ -1,453 +1,11 @@
-{-# LANGUAGE PartialTypeSignatures #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE OverloadedLabels #-}
-{-# LANGUAGE DerivingVia #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TemplateHaskellQuotes #-}
-{-# LANGUAGE OrPatterns #-}
 module Gyehoek.Sexp
-  ( let_
-  , sexp
-  , nonempty
-  , nonEmptyGrammar
-  , encode
-  , decode
-  , parseSexps
-  , prefixSugar
-  , todo
-  , isoIso
-  , encodeWith
-  , decodeWith
-  , kappa
-  , lambda
-  , kappaKeyword
-  , lambdaKeyword
-  , encodePrettyWith
-  , encodePretty
-  , SpliceSexp(..)
-  , Position(..)
-  , parseSexpsWithPos
-  , parseSexpWithPos
-  , parseSexp
-  , sx
-  , sxs
-  , makeSx
-  , makeSxs
-  , makeSx'
-  , toSexp
-  , fromSexp
-  , fromSexp'
-  , stripLocation
-  , format
-  , equivalent
-  , encodeOrShow
-  , readSxs
-  , prismIso
-  , schemeBool
-  , headTagged1'
-  , headTagged1
-  , headTagged2
+  ( module Gyehoek.Sexp.QQ
+  , module Gyehoek.Sexp.Syntax
+  , module Gyehoek.Sexp.Grammar
   )
   where
 
-import Data.Text (Text)
-import Language.SexpGrammar as Sexp hiding (toSexp, List, encode, decode, encodeWith, decodeWith, iso, encodePrettyWith, encodePretty, fromSexp)
-import Language.SexpGrammar qualified as Sexp
-import Language.Sexp qualified as S
-import Data.InvertibleGrammar.Base qualified as IGB
-import Data.InvertibleGrammar qualified as IG
-import Data.InvertibleGrammar.Base ((:-)((:-)))
-import Data.List.NonEmpty (NonEmpty ((:|)))
-import Data.List (List, groupBy)
-import Data.Text.Encoding
-import GHC.Generics (Generic)
-import Control.Lens hiding (para)
-import Control.Monad (join)
-import qualified Language.Sexp.Located as SL
-import Data.Void (absurd)
-import Language.Haskell.TH.Quote
-import Language.Haskell.TH (Quote, location, Loc (..), ExpQ, varE, mkName, listE, Exp, appE, Q, Code, unTypeCode)
-import qualified Data.Text as T
-import qualified Control.Category
-import Data.Data (Data (..), Typeable, cast)
-import Language.Haskell.TH.Syntax (lift, Lift, liftData)
-import Data.Functor.Foldable (cata)
-import Data.Vector (Vector)
-import Numeric.Natural (Natural)
-import qualified Data.Vector.Strict
-import Data.Function (on)
-import Data.String (IsString (fromString))
-import Effectful
-import qualified Effectful.FileSystem.IO as FS
-import qualified Effectful.FileSystem.IO.ByteString as FB
-import qualified Data.Text.Encoding as T
+import Gyehoek.Sexp.QQ
+import Gyehoek.Sexp.Syntax
+import Gyehoek.Sexp.Grammar
 
-
-sexp :: SexpIso a => Iso' a Text
-sexp = iso
-  (either error id . encode)
-  (either error id . decode)
-
-format :: Sexp -> Text
-format = decodeUtf8 . view strict . SL.format
-
-encode :: SexpIso a => a -> Either String Text
-encode = encodeWith sexpIso
-
-decode :: SexpIso a => Text -> Either String a
-decode = decodeWith sexpIso
-
-encodeWith :: SexpGrammar a -> a -> Either String Text
-encodeWith g = (_Right %~ decodeUtf8 . view strict) . Sexp.encodeWith g
-
-encodePretty :: SexpIso a => a -> Either String Text
-encodePretty = encodePrettyWith sexpIso
-
-decodeWith :: SexpGrammar a -> Text -> Either String a
-decodeWith g = Sexp.decodeWith g "FILE" . view lazy . encodeUtf8
-
-encodePrettyWith :: SexpGrammar a -> a -> Either String Text
-encodePrettyWith g =
-  (_Right %~ decodeUtf8 . view strict) . Sexp.encodePrettyWith g
-
-parseSexps :: SexpIso a => FilePath -> Text -> Either String (List a)
-parseSexps f = marshal . SL.parseSexps f . view lazy . encodeUtf8
-  where marshal = join . traverseOf (_Right . each) (Sexp.fromSexp sexpIso)
-
-parseSexpsWith :: SexpGrammar a -> FilePath -> Text -> Either String (List a)
-parseSexpsWith g f = marshal . SL.parseSexps f . view lazy . encodeUtf8
-  where marshal = join . traverseOf (_Right . each) (Sexp.fromSexp g)
-
-parseSexp :: SexpIso a => FilePath -> Text -> Either String a
-parseSexp f = marshal . SL.parseSexp f . view lazy . encodeUtf8
-  where marshal = join . traverseOf _Right (Sexp.fromSexp sexpIso)
-
-readSexpWithPos :: Position -> Text -> Either String Sexp
-readSexpWithPos pos = SL.parseSexpWithPos pos . view lazy . encodeUtf8
-
-readSexpsWithPos :: Position -> Text -> Either String (List Sexp)
-readSexpsWithPos pos = SL.parseSexpsWithPos pos . view lazy . encodeUtf8
-
-parseSexpsWithPos :: SexpGrammar a -> Position -> Text -> Either String (List a)
-parseSexpsWithPos g pos =
-  marshal . SL.parseSexpsWithPos pos . view lazy . encodeUtf8
-  where marshal = join . traverseOf (_Right . each) (Sexp.fromSexp g)
-
-parseSexpWithPos :: SexpGrammar a -> Position -> Text -> Either String a
-parseSexpWithPos g pos =
-  marshal . SL.parseSexpWithPos pos . view lazy . encodeUtf8
-  where marshal = join . traverseOf _Right (Sexp.fromSexp g)
-
-fileName :: FilePath -> FilePath
-fileName "-" = "<interactive>"
-fileName e = e
-
-hGetContents :: FS.FileSystem :> es => FS.Handle -> Eff es Text
-hGetContents h = T.decodeUtf8 <$> FB.hGetContents h
-
-readSxs
-  :: IOE :> es
-  => SexpGrammar a
-  -> FilePath -> Eff es (List a)
-readSxs g fp = FS.runFileSystem $
-  FS.withFile fp FS.ReadMode $ \h ->
-    parseSexpsWith g (fileName fp) <$> hGetContents h
-     >>= either error pure
-
-
-
-nonEmptyGrammar :: Grammar p (NonEmpty x :- t) (List x :- x :- t)
-nonEmptyGrammar = IGB.Iso
-  (\((x:|xs) :- t) -> reverse xs :- x :- t)
-  (\(xs :- x :- t) -> (x :| reverse xs) :- t)
-
-nonempty :: SexpGrammar a -> SexpGrammar (NonEmpty a)
-nonempty a =
-  list (el a >>> rest a) >>>
-    IG.flipped nonEmptyGrammar
-
-let_
-  :: Text
-  -> (forall t. Grammar Position (Sexp :- t) (a :- t))
-  -> (forall t. Grammar Position (Sexp :- t) (b :- t))
-  -> Grammar Position (Sexp :- (List (a, b) :- t1)) t2
-  -> Grammar Position (Sexp :- t1) t2
-let_ kw name rhs e = list (el (sym kw) >>> el bindings >>> el e)
-  where
-    -- bindings :: Grammar Position (Sexp :- _) (List (_, _) :- _)
-    bindings = list $ rest binding
-    binding :: Grammar Position (Sexp :- t) ((_, _) :- t)
-    binding = list (el name >>> el rhs) >>> pair
-
-data DotList a = MkDotList (NonEmpty a) a
-  deriving (Show, Generic)
-
--- | Define a sexp representation as either (⟨name⟩ ⟨e⟩) or '⟨e⟩.
-prefixSugar
-  :: Text -> Prefix
-  -> Grammar Position (Sexp :- t') a
-  -> Grammar Position (Sexp :- t') a
-prefixSugar name prefix e = coproduct
-  -- 'something
-  [ Sexp.prefixed prefix e
-  -- (quote something)
-  , list $ el (sym name) >>> el e
-  ]
-
-todo :: Grammar p (Sexp :- t) t'
-todo = IGB.Flip (IGB.PartialIso absurd f) >>> IGB.PartialIso absurd g
-  where
-    f _ = Left $ unexpected "todo"
-    g _ = Left $ unexpected "todo"
-
-kappa
-  :: (forall t. Grammar Position (Sexp :- t) (a :- t))
-  -> Grammar Position (Sexp :- List a :- t1) t2
-  -> Grammar Position (Sexp :- t1) t2
-kappa name e = list $
-  el kappaKeyword
-  >>> el (list $ rest name)
-  >>> el e
-
-lambda
-  :: (forall t. Grammar Position (Sexp :- t) (a :- t))
-  -> Grammar Position (Sexp :- List a :- t1) t2
-  -> Grammar Position (Sexp :- t1) t2
-lambda name e = list $
-  el lambdaKeyword
-  >>> el (list $ rest name)
-  >>> el e
-
-isoIso :: Iso' s a -> Grammar p (s :- t) (a :- t)
-isoIso l = Sexp.iso (view l) (review l)
-
-prismIso :: Mismatch -> Prism' s a -> Grammar p (s :- t) (a :- t)
-prismIso mm p = Sexp.partialOsi
-  (maybe (Left mm) Right . preview p)
-  (review p)
-
-kappaKeyword :: Grammar Position (Sexp :- t) t
-kappaKeyword = coproduct [ sym "κ", sym "kappa" ]
-
-lambdaKeyword :: Grammar Position (Sexp :- t) t
-lambdaKeyword = coproduct [ sym "λ", sym "lambda" ]
-
-schemeBool :: SexpGrammar Bool
-schemeBool = Sexp.hashed $ Sexp.partialOsi f g
-  where
-    f (SL.Symbol ("t";"true")) = Right True
-    f (SL.Symbol ("f";"false")) = Right False
-    f _ = Left $ Sexp.expected "bool"
-    g True = SL.Symbol "true"
-    g False = SL.Symbol "false"
-
-headTagged1 :: Text -> SexpGrammar a -> Grammar Position (Sexp :- t) (a :- t)
-headTagged1 s g1 = list $ el (sym s) >>> el g1
-
-headTagged1'
-  :: Text
-  -> SexpGrammar a -> SexpGrammar b
-  -> Grammar Position (Sexp :- t) (List b :- a :- t)
-headTagged1' s g1 gt = list $ el (sym s) >>> el g1 >>> rest gt
-
-headTagged2
-  :: Text
-  -> SexpGrammar a -> SexpGrammar b
-  -> Grammar Position (Sexp :- t) (b :- a :- t)
-headTagged2 s g1 g2 = list $ el (sym s) >>> el g1 >>> el g2
-
-
-
-instance SexpIso Sexp where
-  sexpIso = Control.Category.id
-
--- evil ass orphan instances
-deriving instance (Data a, Data e) => Data (SL.LocatedBy a e)
-deriving instance Data SL.Atom
-deriving instance Data SL.Prefix
-deriving instance Data SL.Position
-deriving instance (Data e) => Data (SL.SexpF e)
-
-
--- Quasiquoter
-
-getPos = do
-  Loc {loc_filename,loc_start} <- location
-  pure $ SL.Position loc_filename (fst loc_start) (snd loc_start)
-
-fromSexp :: SexpIso a => Sexp -> a
-fromSexp = either error id . Sexp.fromSexp sexpIso
-
-fromSexp' :: SexpGrammar a -> Sexp -> a
-fromSexp' g = either error id . Sexp.fromSexp g
-
-toSexp :: SexpIso a => a -> Sexp
-toSexp = either error id . Sexp.toSexp sexpIso
-
-toSexps :: (Foldable f, SexpIso a) => f a -> List Sexp
-toSexps = foldMap \x -> [toSexp x]
-
-pattern Unquote :: Text -> Sexp
-pattern Unquote x =
-  SL.Modified Hash (SL.BraceList [SL.Symbol x])
-
-pattern UnquoteSplicing :: Text -> Sexp
-pattern UnquoteSplicing x =
-  SL.Modified Hash (SL.Modified Hash (SL.BraceList [SL.Symbol x]))
-
-_UnquoteSplicing :: Prism' Sexp.Sexp Text
-_UnquoteSplicing = prism'
-  UnquoteSplicing
-  (\case { UnquoteSplicing x -> Just x ; _ -> Nothing })
-
-instance Each Sexp Sexp Sexp Sexp where
-  each k (SL.ParenList xs)              = SL.ParenList <$> traverse k xs
-  each k (SL.BracketList xs)            = SL.BracketList <$> traverse k xs
-  each k (SL.BraceList xs)              = SL.BraceList <$> traverse k xs
-  -- each k (SL.Modified m e)   = SL.Modified m <$> each k e
-  each _ e@(SL.Atom _; SL.Modified _ _) = pure e
-
-stripLocation :: Sexp -> Sexp
-stripLocation = cata \case
-  SL.Compose (a SL.:< e) ->
-    SL.Fix . SL.Compose $ SL.dummyPos SL.:< e
-
--- | @('==')@ for 'Sexp's modulo source location — return true if the
--- two sexps are equal in all but 'Position' fields.
-equivalent :: Sexp -> Sexp -> Bool
-equivalent = (==) `on` stripLocation
-
-instance SexpIso Natural where
-  sexpIso = Sexp.integer >>> Sexp.partialOsi f g
-    where
-      f n | n < 0 = Left $ Sexp.unexpected "negative"
-                        <> Sexp.expected "natural"
-          | otherwise = Right $ fromIntegral n
-      g n = fromIntegral n
-
-class SpliceSexp a where
-  spliceSexp :: a -> List Sexp
-
-instance SexpIso a => SpliceSexp (Data.Vector.Strict.Vector a) where
-  spliceSexp = toSexps
-
-instance SexpIso a => SpliceSexp (Vector a) where
-  spliceSexp = toSexps
-
-instance SexpIso a => SpliceSexp (List a) where
-  spliceSexp = toSexps
-
-instance SpliceSexp Sexp where
-  spliceSexp = toListOf each
-
-unquoteSplicingRecursive :: List Sexp.Sexp -> ExpQ
-unquoteSplicingRecursive xs = [| mconcat $(spans) |]
-  where
-    spans = xs
-      & groupBy \cases
-          (UnquoteSplicing _) _ -> False
-          _ (UnquoteSplicing _) -> False
-          _ _                   -> True
-      & fmap \case
-        [UnquoteSplicing x] ->
-          [| spliceSexp $(varE (mkName (T.unpack x))) |]
-        es -> listE $ unquoteRecursive <$> es
-      & listE
-
-unquoteRecursive :: Sexp.Sexp -> ExpQ
-unquoteRecursive = \case
-  Unquote x -> [| toSexp $(varE (mkName (T.unpack x))) |]
-  SL.ParenList xs -> [|SL.ParenList $(unquoteSplicingRecursive xs)|]
-  e -> liftData e
-
-_ParenList :: Prism' Sexp (List Sexp)
-_ParenList = prism' SL.ParenList \case
-  SL.ParenList xs -> Just xs
-  _ -> Nothing
-
-metaSexps :: List Sexp.Sexp -> Maybe ExpQ
-metaSexps = Just . unquoteSplicingRecursive
-
-metaSexp :: Sexp.Sexp -> Maybe ExpQ
-metaSexp = Just . unquoteRecursive
-
--- 뻘짓뻘짓뻘짓뻘짓뻘짓
-class Lift1 f where
-  liftLift :: Quote m => (a -> m Exp) -> f a -> m Exp
-
-lift1 :: (Lift1 f, Lift a, Quote m) => f a -> m Exp
-lift1 = liftLift lift
-
-instance Lift1 f => Lift (SL.Fix f) where
-  lift (SL.Fix inner) = appE [|SL.Fix|] (lift1 inner)
-
-instance (Lift1 f, Lift1 g) => Lift1 (SL.Compose f g) where
-  liftLift l (SL.Compose fga) = [|SL.Compose $(liftLift (liftLift l) fga)|]
-
-instance Lift a => Lift1 (SL.LocatedBy a) where
-  liftLift l (a SL.:< e) = [|(SL.:<) $(lift a) $(l e)|]
-
-instance Lift1 List where
-  liftLift l xs = listE $ l <$> xs
-
-instance Lift1 SL.SexpF where
-  liftLift l = \case
-    SL.AtomF a -> [|SL.AtomF $(lift a)|]
-    SL.ParenListF es -> [|SL.ParenListF $(liftLift l es)|]
-    SL.BracketListF es -> [|SL.BracketListF $(liftLift l es)|]
-    SL.BraceListF es -> [|SL.BraceListF $(liftLift l es)|]
-    SL.ModifiedF p e -> [|SL.ModifiedF $(lift p) $(l e)|]
-
--- deriving instance Lift a => Lift (SL.SexpF a)
-deriving instance Lift SL.Atom
-deriving instance Lift SL.Position
-deriving instance Lift SL.Prefix
-
-encodeOrShow :: (SexpIso a, Show a, IsString s) => a -> s
-encodeOrShow a = fromString case encode a of
-  Left _ -> show a
-  Right e -> T.unpack e
-
-extQ :: (Typeable a, Typeable b) => (a -> r) -> (b -> r) -> a -> r
-extQ f g a = maybe (f a) g (cast a)
-
-makeSxs :: Data r => Code Q (List Sexp -> r) -> QuasiQuoter
-makeSxs f = QuasiQuoter
-  { quoteExp = \str -> do
-      pos <- getPos
-      case readSexpsWithPos pos (T.pack str) of
-        Left e -> fail e
-        Right xs -> [| $(unTypeCode f) $e |]
-          where
-            e = dataToExpQ
-              (const Nothing `extQ` metaSexp `extQ` metaSexps)
-              xs
-  , quotePat = undefined
-  , quoteType = undefined
-  , quoteDec = undefined
-  }
-
--- | An untyped variant of 'makeSx', useful when the user function is
--- polymorphic in its return value.
-makeSx' :: ExpQ -> QuasiQuoter
-makeSx' f = QuasiQuoter
-  { quoteExp = \str -> do
-      pos <- getPos
-      case readSexpWithPos pos (T.pack str) of
-        Left e -> fail e
-        Right x -> [| $f $e |]
-          where
-            e = dataToExpQ
-              (const Nothing `extQ` metaSexp `extQ` metaSexps)
-              x
-  , quotePat = undefined
-  , quoteType = undefined
-  , quoteDec = undefined
-  }
-
-makeSx :: Data r => Code Q (Sexp -> r) -> QuasiQuoter
-makeSx = makeSx' . unTypeCode
-
-sxs = makeSxs [||id||]
-sx = makeSx [||id||]

src/Gyehoek/Sexp/Grammar.hs

@@ -1,4 +1,191 @@
 module Gyehoek.Sexp.Grammar
-  (
-  ) where
+  ( module Gyehoek.Sexp.Grammar.Base
+  , module Data.InvertibleGrammar.Combinators
+  , (>>>)
+  , toDatum
+  , fromDatum
+  , toData
+  , fromData
+  , encodeWith
+  , encodeWith'
+  , encodeDataWith
+  , decodeWith
+  , encodeTest
+  , encodeTestColour
+  , encodeDataTest
+  , encodeDataTestColour
+  , encodeOrShow'
+  , encodeOrShowData'
+  , decodeDataWith
+  , encodeDataWith'
+  , decodeTest
+  , decodeDataTest
+  , DataIso(..)
+  , DatumIso(..)
+  -- * generics
+  , with
+  , match
+  , Coproduct(..)
+  , fromDatumUnsafe
+  , Control.Category.id
+  , fromDataUnsafe
+  , writeDatum
+  , writeData
+  )
+  where
 
+import Gyehoek.Sexp.Grammar.Base
+import Gyehoek.Prelude hiding (snoc, Iso, flipped, cons, traversed, iso)
+import Data.InvertibleGrammar (backward, sealed, forward, runGrammar)
+import Gyehoek.Sexp.Print (printDatum, printDatum', printData, printData')
+import Gyehoek.Jalmot
+import Data.InvertibleGrammar.Combinators
+import qualified Gyehoek.Sexp.Read as Read
+import qualified Data.Text.IO as TIO
+import Text.Pretty.Simple (pPrintNoColor)
+import Data.InvertibleGrammar.Generic
+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)
+
+
+toDatum :: Jalmot :> es => DatumGrammar a -> a -> Eff es Datum
+toDatum g =
+  backward (sealed g)
+  >>> runGrammar noAnn
+  >>> either (throwError . GrammarError) pure
+
+toData :: Jalmot :> es => DataGrammar a -> a -> Eff es (List Datum)
+toData g =
+  backward (sealed g)
+  >>> runGrammar noAnn
+  >>> either (throwError . GrammarError) pure
+
+fromDatum :: (HasCallStack, Jalmot :> es) => DatumGrammar a -> Datum -> Eff es a
+fromDatum g =
+  forward (sealed g)
+  >>> runGrammar noAnn
+  >>> either (throwError . GrammarError) pure
+
+fromDatumUnsafe :: HasCallStack => DatumGrammar a -> Datum -> a
+fromDatumUnsafe g = runJalmotUnsafe . fromDatum g
+
+fromDataUnsafe :: HasCallStack => DataGrammar a -> List Datum -> a
+fromDataUnsafe g = runJalmotUnsafe . fromData g
+
+fromData
+  :: (HasCallStack, Jalmot :> es)
+  => DataGrammar a -> List Datum -> Eff es a
+fromData g =
+  forward (sealed g)
+  >>> runGrammar noAnn
+  >>> either (throwError . GrammarError) pure
+
+encodeWith :: Jalmot :> es => DatumGrammar a -> a -> Eff es Text
+encodeWith g = toDatum g >>> fmap printDatum
+
+encodeDataWith :: Jalmot :> es => DataGrammar a -> a -> Eff es Text
+encodeDataWith g = toData g >>> fmap printData
+
+encodeDataWith' :: Jalmot :> es => DataGrammar a -> a -> Eff es Text
+encodeDataWith' g = toData g >>> fmap printData'
+
+encodeWith' :: Jalmot :> es => DatumGrammar a -> a -> Eff es Text
+encodeWith' g = toDatum g >>> fmap printDatum'
+
+decodeWith :: forall es a. Jalmot :> es => DatumGrammar a -> Text -> Eff es a
+decodeWith g = Read.readString1 @es >=> fromDatum g
+
+decodeDataWith
+  :: forall es a. Jalmot :> es => DataGrammar a -> Text -> Eff es a
+decodeDataWith g = Read.readString @es >=> fromData g
+
+-- | run a grammar, quick and dirty.
+decodeTest :: Show a => DatumGrammar a -> Text -> IO ()
+decodeTest g = pPrintNoColor <=< (runJalmotIO . decodeWith g)
+
+-- | run a grammar, quick and dirty.
+encodeTest :: DatumGrammar a -> a -> IO ()
+encodeTest g = TIO.putStrLn <=< (runJalmotIO . encodeWith' g)
+
+-- | run a grammar, quick and dirty.
+encodeTestColour :: DatumGrammar a -> a -> IO ()
+encodeTestColour g = TIO.putStrLn <=< (runJalmotIO . encodeWith g)
+
+encodeDataTest :: DataGrammar a -> a -> IO ()
+encodeDataTest g = TIO.putStrLn <=< (runJalmotIO . encodeDataWith' g)
+
+encodeDataTestColour :: DataGrammar a -> a -> IO ()
+encodeDataTestColour g = TIO.putStrLn <=< (runJalmotIO . encodeDataWith g)
+
+-- | run a grammar, quick and dirty.
+decodeDataTest :: Show a => DataGrammar a -> Text -> IO ()
+decodeDataTest g = pPrintNoColor <=< (runJalmotIO . decodeDataWith g)
+
+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
+
+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
+
+class DataIso a where
+  dataIso :: DataGrammar a
+
+
+
+instance DatumIso a => DatumIso (List a) where
+  datumIso = list $ rest datumIso
+
+instance DatumIso Bool where datumIso = boolean
+
+instance DatumIso Int where datumIso = int
+
+instance DatumIso Datum where datumIso = Control.Category.id
+
+instance DatumIso a => DataIso (List a) where
+  dataIso = onHead . traversed . sealed $ datumIso @a
+
+instance DatumIso a => DataIso (V.Vector a) where
+  dataIso = iso fromList V.toList
+    >>> (onHead . traversed . sealed $ datumIso @a)
+
+instance (DatumIso a, DatumIso b) => DatumIso (a, b) where
+  datumIso = with \tup2 -> list (el datumIso >>> el datumIso) >>> tup2

src/Gyehoek/Sexp/Grammar/Base.hs

@@ -0,0 +1,439 @@
+-- | cribbed from sexp-grammar:Language.SexpGrammar.Base
+module Gyehoek.Sexp.Grammar.Base
+  ( module Gyehoek.Sexp.Syntax
+  , module Data.InvertibleGrammar.Combinators
+  , expected, unexpected
+  -- * types
+  , G
+  , Grammar(..)
+  , DatumGrammar
+  , DataGrammar
+  , Grammar
+  , ListContext(..)
+  , (:-)((:-))
+  -- * lists
+  , list
+  , listWithIndentation
+  , el
+  , rest
+  , restData
+  , headTagged0'
+  , headTagged0
+  , headTagged1'
+  , headTagged1
+  , headTagged2
+  -- * atoms
+  , simple
+  , string
+  , symbol
+  , sym
+  , boolean
+  , number
+  , integer
+  , int
+  , unreadable
+  -- * TODO: sort lol
+  , prismIso
+  , isoIso, decorate
+  , snoced
+  , letLike
+  , ifLike
+  , lambdaLike
+  , lambdaKeyword
+  , kappaKeyword
+  , beginLike, headTagged2', dottedList
+  ) where
+
+import Data.InvertibleGrammar
+import Data.InvertibleGrammar.Base
+import Data.InvertibleGrammar.Base as Re
+  ( Grammar(..))
+import Data.InvertibleGrammar.Combinators
+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
+
+
+-- $setup
+-- >>> :set -XOverloadedStrings
+-- >>> import Gyehoek.Sexp.Grammar
+-- >>> import Data.Text (Text)
+-- >>> import GHC.Generics (Generic)
+-- >>> import Data.List (List)
+
+type G = Grammar Ann
+
+type DatumGrammar a = forall t. G (Datum :- t) (a :- t)
+type DataGrammar a = forall t. G (List Datum :- t) (a :- t)
+
+-- | extract\/inject an annotation from\/into a 'Datum'.
+position :: G (Datum :- t) (Ann :- Datum :- t)
+position = Iso
+  (\(s :- t) -> view ann s :- s :- t)
+  (\(a :- s :- t) -> (s & ann .~ a) :- t)
+
+locate :: G (Datum :- t) (Datum :- t)
+locate =
+  position
+  >>> onHead Locate
+  >>> Iso
+    (\(_ :- 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
+unexpectedSimple = unexpected . printDatum' . Simple
+
+unexpectedDatum :: Datum -> Mismatch
+unexpectedDatum = unexpected . printDatum'
+
+list
+  :: G (ListContext :- t) (ListContext :- t')
+  -> G (Datum :- t) t'
+list = listWithIndentation Ordinary
+
+-- |
+-- >>> let grammar = with \g -> dottedList (el int) int >>> g
+-- >>> decodeTest @(Int,Int) grammar "(1 . 2)"
+-- ( 1
+-- , 2
+-- )
+-- >>> let grammar = with \g -> dottedList (el int >>> el int) int >>> g
+-- >>> decodeTest @(Int,Int,Int) grammar "(1 2 . 3)"
+-- ( 1
+-- , 2
+-- , 3
+-- )
+dottedList
+  :: forall t t' t''. G (ListContext :- t) (ListContext :- t')
+  -> G (Datum :- t') t''
+  -> G (Datum :- t) t''
+dottedList g final = begin >>> Dive (onTail (g >>> end) >>> final)
+  where
+    begin = locate >>> Flip (PartialIso
+      (\(x:-MkListContext xs:-t) -> case NE.nonEmpty xs of
+          Just xs' -> DotList xs' x :- t
+          Nothing -> error "fuck")
+      (\case
+          DotList xs x :- t -> Right $ x :- MkListContext (NE.toList xs) :- t
+          _ -> Left $ expected "dotted list"))
+    end :: Grammar Ann (ListContext :- t') t'
+    end = Flip $ PartialIso
+      (\t -> MkListContext [] :- t)
+      (\(MkListContext lst :- t) ->
+         case lst of
+           [] -> Right t
+           d:_ -> Left $ unexpectedDatum d)
+
+listWithIndentation
+  :: Indentation
+  -> G (ListContext :- t) (ListContext :- t')
+  -> G (Datum :- t) t'
+listWithIndentation ind g = begin >>> Dive (g >>> end)
+  where
+    begin = locate >>> partialOsi
+      (\case
+          List xs -> Right . MkListContext $ xs
+          _ -> Left $ expected "list")
+      (List' ind . coerce)
+    end = Flip $ PartialIso
+      (\t -> MkListContext [] :- t)
+      (\(MkListContext lst :- t) ->
+         case lst of
+           [] -> Right t
+           d:_ -> Left $ unexpectedDatum d)
+
+-- |
+-- >>> decodeTest (list $ el simple) "(in-here!)"
+-- SimpleSymbol "in-here!"
+el
+  :: G (Datum :- t) t'
+  -> G (ListContext :- t) (ListContext :- t')
+el g = coerced (Flip cons >>> onTail g >>> Step)
+
+-- | matches the remainder of a list as repetition of a given
+-- grammar.
+--
+-- >>> decodeTest (list $ rest simple) "(ga na da ra)"
+-- [ SimpleSymbol "ga"
+-- , SimpleSymbol "na"
+-- , SimpleSymbol "da"
+-- , SimpleSymbol "ra"
+-- ]
+rest
+  :: (forall t'. G (Datum :- t') (a :- t'))
+  -> G (ListContext :- t) (ListContext :- List a :- t)
+rest g =
+  iso coerce coerce >>>
+  onHead (Traverse (sealed g >>> Step)) >>>
+  Iso (\a -> MkListContext [] :- a) (\(_ :- a) -> a)
+
+-- | matches the remainder of a list with a 'DataGrammar'. this
+-- differs from 'rest' in that the tail can be matched as a single
+-- chunk, as opposed to matching each element individually with a
+-- homogeneous \"rest element\" grammar.
+--
+-- >>> :{
+--  data Example = MkExample (List Int) Text
+--    deriving (Generic, Show)
+--  dataGrammar :: DataGrammar Example
+--  dataGrammar = with \g ->
+--    flipped snoced >>>
+--    onHead (traversed $ sealed int) >>>
+--    onTail (onHead $ sealed symbol) >>>
+--    swap >>>
+--    g
+-- :}
+--
+-- a 'DataGrammar' is usually used to code sequences of S-expressions,
+-- e.g. the top-level of a Scheme program:
+-- >>> decodeDataTest dataGrammar "1 2 3 end"
+-- MkExample
+--     [ 1
+--     , 2
+--     , 3
+--     ] "end"
+-- >>> encodeDataTest dataGrammar $ MkExample [1,2,3] "end"
+-- 1
+-- <BLANKLINE>
+-- 2
+-- <BLANKLINE>
+-- 3
+-- <BLANKLINE>
+-- end
+--
+-- with 'dataRest', we can apply that same "top-level" grammar within a list:
+-- >>> :{
+--  dataRestGrammar :: DatumGrammar Example
+--  dataRestGrammar = list . restData $ dataGrammar
+-- :}
+--
+-- >>> decodeTest dataRestGrammar "(1 2 3 end)"
+-- MkExample
+--     [ 1
+--     , 2
+--     , 3
+--     ] "end"
+-- >>> encodeTest dataRestGrammar $ MkExample [1,2,3] "end"
+-- (1 2 3 end)
+restData
+  :: G (List Datum :- t) (a :- t)
+  -> G (ListContext :- t) (ListContext :- a :- t)
+restData g =
+  iso coerce coerce
+  >>> g
+  >>> push (MkListContext []) (const True) mempty
+
+snoced
+  :: Snoc s s a a
+  => Grammar p (s :- a :- t) (s :- t)
+snoced = PartialIso
+  (\(s:-a:-t) -> Gyehoek.Prelude.snoc s a :- t)
+  (\(s:-t) -> case s ^? _Snoc of
+      Nothing -> Left $ expected "list element"
+      Just (s',a) -> Right $ s' :- a :- t)
+
+
+-- atoms
+
+-- | matches simple forms — atomic S-expressions.
+--
+-- >>> decodeTest simple "call/cc"
+-- SimpleSymbol "call/cc"
+simple :: G (Datum :- t) (Simple :- t)
+simple = locate >>> partialOsi
+  (\case Simple s -> Right s
+         _ -> Left . expected $ "atom")
+  Simple
+
+prismGrammar
+  -- | expected
+  :: Text
+  -- | unexpected
+  -> (s -> Mismatch)
+  -> Prism' s a
+  -> Grammar p (s :- t) (a :- t)
+prismGrammar exp unexp p =
+  partialOsi
+    ((_Left %~ \x -> expected exp <> unexp x) . matching p)
+    (review p)
+
+-- |
+-- >>> decodeTest symbol "symbolic-of-what???"
+-- "symbolic-of-what???"
+symbol :: G (Datum :- t) (Text :- t)
+symbol = simple >>> prismGrammar "symbol" unexpectedSimple #SimpleSymbol
+
+-- |
+-- >>> let grammar = list $ el (sym "a-specific-symbol") >>> el string
+-- >>> decodeTest grammar "(a-specific-symbol \"this works\")"
+-- "this works"
+-- >>> decodeTest grammar "(some-other-symbol \"this does not\")"
+-- *** Exception:
+-- <none>:1:2: mismatch:
+--     Expected: symbol a-specific-symbol
+--     But got:  some-other-symbol
+-- ...
+sym :: Text -> G (Datum :- t) t
+sym s = simple >>> Flip (PartialIso
+  (SimpleSymbol s :-)
+  (\(a :- t) ->
+      case a of
+        SimpleSymbol s' | s == s' -> Right t
+        other -> Left $ expected ("symbol " <> s) <>
+                        unexpectedSimple other))
+
+-- |
+-- >>> decodeTest string "\"these r annoying to escape\""
+-- "these r annoying to escape"
+-- >>> encodeTest string "john Haskell"
+-- "john Haskell"
+string :: G (Datum :- t) (Text :- t)
+string = simple >>> prismGrammar "string" unexpectedSimple #SimpleString
+
+-- |
+-- >>> decodeTest boolean "#t"
+-- True
+-- >>> decodeTest boolean "#false"
+-- False
+-- >>> encodeTest boolean True
+-- #t
+boolean :: G (Datum :- t) (Bool :- t)
+boolean = simple >>> prismGrammar "boolean" unexpectedSimple #SimpleBoolean
+
+-- |
+-- >>> decodeTest number "123"
+-- 123.0
+-- >>> encodeTest number (fromInteger 456)
+-- 456
+number :: G (Datum :- t) (Scientific :- t)
+number = simple >>> prismGrammar "number" unexpectedSimple #SimpleNumber
+
+-- |
+-- >>> decodeTest integer "123"
+-- 123
+-- >>> encodeTest number 456
+-- 456
+integer :: G (Datum :- t) (Integer :- t)
+integer = number >>> partialOsi
+  ((_Left %~ (unexpected . T.pack . show @Double)) . Sci.floatingOrInteger)
+  fromIntegral
+
+int :: G (Datum :- t) (Int :- t)
+int = integer >>> iso fromIntegral fromIntegral
+
+
+-- high-level combinators
+
+headTagged0 :: Text -> G (Datum :- t) t
+headTagged0 s = list $ el (symProcedure s)
+
+headTagged0' :: Text -> DatumGrammar a -> G (Datum :- t) (List a :- t)
+headTagged0' s gt = list $ el (symProcedure s) >>> rest gt
+
+headTagged1 :: Text -> DatumGrammar a -> G (Datum :- t) (a :- t)
+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 (symProcedure s) >>> el g1 >>> rest gt
+
+headTagged2
+  :: Text
+  -> DatumGrammar a -> DatumGrammar b
+  -> G (Datum :- t) (b :- a :- t)
+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 =
+  list $ el (symProcedure s) >>> el g1 >>> el g2 >>> rest gt
+
+ifLike
+  -- | keyword
+  :: Text
+  -- | condition
+  -> DatumGrammar a
+  -- | consequent (then-branch)
+  -> DatumGrammar b
+  -- | alternative (else-branch)
+  -> DatumGrammar c
+  -> G (Datum :- t) (c :- b :- a :- t)
+ifLike kw c t f =
+  listWithIndentation (NSpecial 1) $
+    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 :- t1) t2
+letLike kw name rhs e = listWithIndentation (NSpecial 1) $
+  el (symBuiltin kw) >>> el bindings >>> el e
+  where
+    bindings = list $ rest binding
+    binding :: G (Datum :- t) ((_, _) :- t)
+    binding = list (el name >>> el rhs) >>> pair
+
+lambdaLike
+  :: (forall t. G (Datum :- t) t)
+  -> G (Datum :- t1) (a :- t2)
+  -> G (ListContext :- a :- t2) (ListContext :- t3)
+  -> G (Datum :- t1) t3
+lambdaLike kw formals body = listWithIndentation (NSpecial 1) $
+  el (decorate SynBuiltin >>> kw)
+  >>> el formals
+  >>> body
+
+lambdaKeyword :: G (Datum :- t) t
+lambdaKeyword = coproduct [ sym "λ", sym "lambda" ]
+
+kappaKeyword :: G (Datum :- t) t
+kappaKeyword = coproduct [ sym "κ", sym "kappa" ]
+
+beginLike
+  :: Text
+  -> G (ListContext :- t) (ListContext :- t')
+  -> G (Datum :- t) t'
+beginLike kw g =
+  listWithIndentation (NSpecial 0) $
+    el (symBuiltin kw) >>> g
+
+-- | define a printed syntax for an object which cannot be read.
+unreadable
+  :: (t -> Text)
+  -> G (Datum :- t) t
+unreadable f = Flip $ PartialIso
+  (\t -> Unreadable (f t) :- t)
+  (const $ Left mempty)
+
+isoIso :: Iso' s a -> Grammar p (s :- t) (a :- t)
+isoIso l = iso (view l) (review l)
+
+prismIso :: Mismatch -> Prism' s a -> Grammar p (s :- t) (a :- t)
+prismIso mm p = partialOsi
+  (maybe (Left mm) Right . preview p)
+  (review p)

src/Gyehoek/Sexp/Print.hs

@@ -1,29 +1,80 @@
 module Gyehoek.Sexp.Print
   ( printDatum
   , printDatumW
+  , printDatum'
+  , printData
+  , printData'
+  , htmlDatum
+  , htmlData
   ) where
 
 import Gyehoek.Sexp.Syntax
-import Data.Text.Prettyprint.Doc
+import Prettyprinter
 import Data.Functor.Foldable
 import qualified Control.Comonad.Trans.Cofree as F
 import Prettyprinter.Util
 import Gyehoek.Prelude hiding (Simple, (:<))
-import Gyehoek.Sexp.Read (rd)
-import Data.Foldable (traverse_)
+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)
+import Prettyprinter.Render.Terminal (Color(..), color, italicized, AnsiStyle, bold, colorDull)
+import Prettyprinter.Render.Text (renderStrict)
+import qualified Data.Scientific as Sci
+import Data.List (intersperse)
+import Lucid
+import Prettyprinter.Render.Util.SimpleDocTree (treeForm)
+import Prettyprinter.Lucid (renderHtml)
 
 
+printDatum' :: Datum -> Text
+printDatum' =
+  prettyDatum 0
+  >>> layoutSmart opts
+  >>> renderStrict
+  where
+    opts = LayoutOptions
+      { layoutPageWidth = AvailablePerLine 80 1.0
+      }
+
+htmlDatum :: Datum -> Html ()
+htmlDatum =
+  prettyDatum 0
+  >>> layoutPretty opts
+  >>> treeForm
+  >>> fmap highlightHtml
+  >>> renderHtml
+  where
+    opts = LayoutOptions
+      { layoutPageWidth = AvailablePerLine 80 1.0
+      }
+
+htmlData :: Foldable f => f Datum -> Html ()
+htmlData =
+  foldr f mempty
+  >>> layoutPretty opts
+  >>> treeForm
+  >>> fmap highlightHtml
+  >>> renderHtml
+  where
+    f x y = prettyDatum 0 x <> hardline <> hardline <> y
+    opts = LayoutOptions
+      { layoutPageWidth = AvailablePerLine 80 1.0
+      }
+
 printDatum :: Datum -> Text
 printDatum = printDatumW 80
 
+printData :: List Datum -> Text
+printData = mconcat . intersperse "\n\n" . fmap printDatum
+
+printData' :: List Datum -> Text
+printData' = mconcat . intersperse "\n\n" . fmap printDatum'
+
 printDatumW :: Int -> Datum -> Text
 printDatumW w =
   prettyDatum 0
   >>> layoutSmart opts
-  >>> reAnnotateS highlight
+  >>> reAnnotateS highlightAnsi
   >>> ANSI.renderStrict
   where
     opts = LayoutOptions
@@ -31,24 +82,31 @@ printDatumW w =
       }
 
 prettyDatum :: Int -> Datum -> Doc Syn
-prettyDatum depth = \case
-  syn :< SimpleF s -> annotate syn $ prettySimple depth s
-  syn :< CompoundF compound -> case compound of
-    ListF indent 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 $
-                [ prettyDatum (depth+1) keyword
-                , if null specialArgs then mempty else softline
-                , hsep $ prettyDatum (depth+1) <$> specialArgs
-                ]
-              , vsep $ prettyDatum (depth+1) <$> body
+prettyDatum depth datum = case datum of
+  Simple simp -> annotate (datum ^. syntax) $ prettySimple depth simp
+  DotList xs x ->
+    pparen depth . group . align $
+      vsep [ vsep (prettyDatum (depth+1) <$> toList xs)
+           , "."
+           , prettyDatum (depth+1) x
+           ]
+      
+  List' indent xs ->
+    case indent of
+      NSpecial n | keyword:args <- xs ->
+        let (specialArgs,body) = splitAt n args
+        in pparen depth . nest 2 . vsep $
+            [ group . nest 2 . hcat $
+              [ prettyDatum (depth+1) keyword
+              , if null specialArgs then mempty else softline
+              , hsep $ prettyDatum (depth+1) <$> specialArgs
               ]
-        Ordinary; NSpecial _ -> pparen depth $
-          group . align . vsep $
-            prettyDatum (depth+1) <$> xs
+            , vsep $ prettyDatum (depth+1) <$> body
+            ]
+      Ordinary; NSpecial _ -> pparen depth $
+        group . align . vsep $
+          prettyDatum (depth+1) <$> xs
+  _ -> error [i|unimplemented: #{datum}|]
 
 pparen depth = enclose (delim depth "(") (delim depth ")")
 delim depth = annotate (SynParen depth)
@@ -60,22 +118,37 @@ delimited depth open close =
 prettySimple :: Int -> Simple -> Doc Syn
 prettySimple depth = \case
   SimpleBoolean b -> annotate SynConstant $ if b then "#t" else "#f"
-  SimpleNumber n -> annotate SynConstant $ viaShow n
+  SimpleNumber n ->
+    Sci.floatingOrInteger n
+    & either viaShow viaShow
+    & annotate SynConstant
   SimpleString s -> annotate SynString $ viaShow s
   SimpleSymbol s -> pretty s
-
-rdpr n s = rd s >>= traverse_ \x -> do
-                                  putDocW n . prettyDatum 0 $ x
-                                  putStr "\n"
+  SimpleUnreadable s -> pretty s
 
 putDoc :: Doc Syn -> IO ()
 putDoc = ANSI.renderIO stdout
-  . reAnnotateS highlight . layoutSmart defaultLayoutOptions . (<>"\n")
+  . reAnnotateS highlightAnsi . layoutSmart defaultLayoutOptions . (<>"\n")
 
-highlight :: Syn -> AnsiStyle
-highlight = \case
+highlightAnsi :: Syn -> AnsiStyle
+highlightAnsi = \case
   (SynBuiltin; SynMacro) -> color Magenta <> italicized <> bold
-  SynParen n -> color $ rainbow ^?! ix n
+  SynProcedure -> color Blue
+  SynConstant -> color Yellow
+  SynParen n -> colorDull $ rainbow ^?! ix n
   _ -> mempty
   where
     rainbow = cycle [Red,Yellow,Green,Blue,Magenta,Cyan]
+
+highlightHtml :: Syn -> Html () -> Html ()
+highlightHtml syn = span_ [class_ synClass]
+  where
+    synClass = case syn of
+      SynBuiltin -> "syn-builtin"
+      SynMacro -> "syn-macro"
+      SynConstant -> "syn-constant"
+      SynString -> "syn-string"
+      SynProcedure -> "syn-procedure"
+      SynVariable -> "syn-variable"
+      SynNone -> "syn-none"
+      SynParen n -> [i|syn-paren-#{mod n 5}|]

src/Gyehoek/Sexp/QQ.hs

@@ -0,0 +1,129 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Gyehoek.Sexp.QQ
+  ( makeSxs
+  , makeSx
+  , makeSx'
+  , sx
+  , sxs
+  , QuasiQuoter
+  ) where
+
+import Data.Data (Typeable, cast)
+import Gyehoek.Prelude
+import Gyehoek.Sexp.Syntax
+import Language.Haskell.TH
+import qualified Data.Text as T
+import Data.List (groupBy)
+import Language.Haskell.TH.Syntax (liftData, Lift (lift))
+import Gyehoek.Jalmot
+import Gyehoek.Sexp.Grammar
+import Control.Exception (throw)
+import Language.Haskell.TH.Quote (QuasiQuoter(..))
+import Language.Haskell.TH.Syntax (dataToExpQ)
+import qualified Gyehoek.Sexp.Read as Read
+import Text.Megaparsec.Pos (mkPos)
+import Gyehoek.Lift1
+import Data.Foldable (toList)
+
+
+extQ :: (Typeable a, Typeable b) => (a -> r) -> (b -> r) -> a -> r
+extQ f g a = maybe (f a) g (cast a)
+
+spliceMeta :: (HasCallStack, DataIso a) => a -> List Datum
+spliceMeta x =
+  case runPureEff . runJalmot . toData dataIso $ x of
+    Left (cs,e) -> throw $ MkAJalmotCS cs e
+    Right xs -> xs
+
+meta :: (HasCallStack, DatumIso a) => a -> Datum
+meta x =
+  case runPureEff . runJalmot . toDatum datumIso $ x of
+    Left (cs,e) -> throw $ MkAJalmotCS cs e
+    Right xs -> xs
+
+unquoteSplicingRecursive :: List Datum -> ExpQ
+unquoteSplicingRecursive xs = [| mconcat $(spans) |]
+  where
+    spans = xs
+      & groupBy \cases
+          (MetaSplice _) _ -> False
+          _ (MetaSplice _) -> False
+          _ _              -> True
+      & fmap \case
+        [MetaSplice x] ->
+          [| spliceMeta $(varE (mkName (T.unpack x))) |]
+        es -> listE $ unquoteRecursive <$> es
+      & listE
+
+unquoteRecursive :: Datum -> ExpQ
+unquoteRecursive = \case
+  Meta x -> [| meta $(varE (mkName (T.unpack x))) |]
+  a :< CompoundF x -> [| $(liftData a) :< CompoundF $c|]
+    where
+      c = case x of
+        ListF ind xs ->
+          [| ListF $(lift ind) $(unquoteSplicingRecursive xs) |]
+        VectorF xs ->
+          [| VectorF $(unquoteSplicingRecursive xs) |]
+        DotListF xs t ->
+          [| DotListF $(liftLift unquoteRecursive xs) $(unquoteRecursive t) |]
+        AbbrevF p t ->
+          [| AbbrevF $(lift p) $(unquoteRecursive t) |]
+  e -> liftData e
+
+
+
+getPos :: Q SourcePos
+getPos = do
+  Loc {loc_filename,loc_start} <- location
+  pure $ SourcePos
+    { sourceName = loc_filename
+    , sourceLine = mkPos $ fst loc_start
+    , sourceColumn = mkPos $ snd loc_start
+    }
+
+readq
+  :: (SourcePos -> Text -> Eff '[Jalmot, IOE] a)
+  -> String -> Q a
+readq f s = do
+  pos <- getPos
+  liftIO . runJalmotIO . f pos . T.pack $ s
+
+makeSxs :: Data r => Code Q (List Datum -> r) -> QuasiQuoter
+makeSxs f = QuasiQuoter
+  { quoteExp = \str -> do
+      xs <- readq Read.readStringWithPos str
+      let e = dataToExpQ
+             (const Nothing
+              `extQ` (Just . unquoteRecursive)
+              `extQ` (Just . unquoteSplicingRecursive))
+             xs
+      [| $(unTypeCode f) $e |]
+  , quotePat = undefined
+  , quoteType = undefined
+  , quoteDec = undefined
+  }
+
+-- | An untyped variant of 'makeSx', useful when the user function is
+-- polymorphic in its return value.
+makeSx' :: ExpQ -> QuasiQuoter
+makeSx' f = QuasiQuoter
+  { quoteExp = \str -> do
+      x <- readq Read.readStringWithPos1 str
+      let e = dataToExpQ
+             (const Nothing
+              `extQ` (Just . unquoteRecursive)
+              `extQ` (Just . unquoteSplicingRecursive))
+             x
+      [| $f $e |]
+  , quotePat = undefined
+  , quoteType = undefined
+  , quoteDec = undefined
+  }
+
+makeSx :: Data r => Code Q (Datum -> r) -> QuasiQuoter
+makeSx = makeSx' . unTypeCode
+
+sx, sxs :: QuasiQuoter
+sxs = makeSxs [|| Prelude.id @(List Datum) ||]
+sx = makeSx [|| Prelude.id @Datum ||]

src/Gyehoek/Sexp/Read.hs

@@ -1,7 +1,10 @@
 module Gyehoek.Sexp.Read
   ( readFile
   , readString
-  , rd
+  , readString1
+  , SourcePos(..)
+  , readStringWithPos
+  , readStringWithPos1
   ) where
 
 import Text.Megaparsec
@@ -11,46 +14,79 @@ import Data.Void (Void)
 import Gyehoek.Sexp.Syntax
 import Gyehoek.Prelude hiding (Simple, (:<))
 import qualified Data.Text.IO as T
-import System.IO (stderr, hPutStrLn)
 import Prelude hiding (readFile)
-import Data.Functor (($>), void)
+import Data.Functor (($>))
 import qualified Data.Text as T
 import Data.Char (GeneralCategory(..), generalCategory)
-import Control.Exception hiding (try)
 import Data.Scientific (Scientific)
+import Gyehoek.Jalmot
 
 
--- i'm lazy
-newtype ReaderError = MkReaderError String
-  deriving (Show)
-
-instance Exception ReaderError where
-  displayException (MkReaderError x) = x
-
-  -- temp
-rd = runEff . readString
-
-readFile :: IOE :> es => FilePath -> Eff es (List Datum)
+readFile :: (Jalmot :> es, IOE :> es) => FilePath -> Eff es (List Datum)
 readFile f = do
   s <- liftIO . T.readFile $ f
   case runParser file f s of
     Right x -> pure x
-    Left e -> do
-      liftIO . throw . MkReaderError . errorBundlePretty $ e
+    Left eb -> throwError . ReaderError $ eb
 
-readString :: IOE :> es => Text -> Eff es (List Datum)
+readString :: Jalmot :> es => Text -> Eff es (List Datum)
 readString s = 
   case runParser file "<none>" s of
     Right x -> pure x
-    Left e -> do
-      liftIO . throw . MkReaderError . errorBundlePretty $ e
+    Left eb -> throwError . ReaderError $ eb
+
+readString1 :: Jalmot :> es => Text -> Eff es Datum
+readString1 s = 
+  case runParser file1 "<none>" s of
+    Right x -> pure x
+    Left eb -> throwError . ReaderError $ eb
+
+initialStateFromSourcePos :: SourcePos -> s -> State s e
+initialStateFromSourcePos pos s = State
+  { stateInput = s
+  , stateOffset = 0
+  , stateParseErrors = []
+  , statePosState = PosState
+    { pstateInput = s
+    , pstateOffset = 0
+    , pstateSourcePos = pos
+    , pstateTabWidth = defaultTabWidth
+    , pstateLinePrefix = ""
+    }
+  }
+
+readStringWithPos1
+  :: Jalmot :> es
+  => SourcePos
+  -> Text
+  -> Eff es Datum
+readStringWithPos1 pos s =
+  case snd $ runParser' file1 st of
+    Right x -> pure x
+    Left eb -> throwError . ReaderError $ eb
+  where
+    st = initialStateFromSourcePos pos s
+
+readStringWithPos
+  :: Jalmot :> es
+  => SourcePos
+  -> Text
+  -> Eff es (List Datum)
+readStringWithPos pos s =
+  case snd $ runParser' file st of
+    Right x -> pure x
+    Left eb -> throwError . ReaderError $ eb
+  where
+    st = initialStateFromSourcePos pos s
 
 type P = Parsec Void Text
 
 
 --- lexer helpers
 
--- TODO: check R⁷RS
+-- TODO: check R⁷RS's definition of ⟨atmosphere⟩.
+-- TODO: datum comments.
+-- | whitespace consumer.
 sc :: P ()
 sc = L.space space1
   (L.skipLineComment ";")
@@ -59,6 +95,7 @@ sc = L.space space1
 lexeme :: P a -> P a
 lexeme = L.lexeme sc
 
+-- | verbatim text.
 verb :: Text -> P Text
 verb = L.symbol sc
 
@@ -90,6 +127,7 @@ identifier = label "identifier" . lexeme . choice $
       , ModifierSymbol, OtherSymbol, PrivateUse ]
       || c == '\x200c' || c == '\x200d')
       && c /= ';' && c /= '|' && c /= '"' && c /= '.'
+      && c /= ',' && c /= '#'
 
 boolean :: P Bool
 boolean = label "boolean" . lexeme $ choice
@@ -135,18 +173,33 @@ string = label "string" . lexeme $
       , "\\\\" $> '\\'
       ]
 
+metaSplice :: P Text
+metaSplice = label "splicing meta" . lexeme . between "##{" "}" $
+  takeWhile1P Nothing (/= '}')
+
+meta :: P Text
+meta = label "meta" . lexeme . between "#{" "}" $
+  takeWhile1P Nothing (/= '}')
+
 
 
 file :: P (List Datum)
-file = many datum <* eof
+file = sc *> many datum <* eof
+
+file1 :: P Datum
+file1 = sc *> datum <* eof
 
 datum :: P Datum
-datum = choice
-  [ (SynNone :<) . CompoundF <$> compoundDatum
-  , (SynNone :<) . SimpleF <$> simpleDatum
-  -- , labeled
-  -- , labelRef
-  ]
+datum = do
+  pos <- getSourcePos
+  (position ?~ pos) <$> choice
+    [ Compound <$> compoundDatum
+    , Simple <$> simpleDatum
+    -- , labeled
+    -- , labelRef
+    , MetaSplice <$> metaSplice
+    , Meta <$> meta
+    ]
 
 simpleDatum :: P Simple
 simpleDatum = choice

src/Gyehoek/Sexp/Syntax.hs

@@ -19,6 +19,8 @@ module Gyehoek.Sexp.Syntax
   , pattern Compound
   , pattern Labeled
   , pattern LabelRef
+  , pattern Meta
+  , pattern MetaSplice
   , pattern Abbrev
   , pattern Vector
   , pattern DotList
@@ -27,24 +29,38 @@ module Gyehoek.Sexp.Syntax
   , indentation
   , adorn
   , indentWith
+  , pattern Unreadable
   , pattern Bytevector
   , pattern Symbol
   , pattern String
   , pattern Character
   , pattern Number
   , pattern Boolean
+  , Ann(..)
+  , noAnn
+  , ann
+  , pattern List'
+  , position
+  , stripAnn
   ) where
 
-import Language.Haskell.TH.Syntax (Lift)
+import Language.Haskell.TH.Syntax (Lift (lift), liftData)
 import Data.Scientific (Scientific)
 import Data.ByteString (ByteString)
 import Gyehoek.Prelude hiding ((:<), Simple)
-import Text.Megaparsec.Pos (SourcePos(..))
-import Control.Comonad.Cofree (Cofree((:<)), _extract)
+import Text.Megaparsec.Pos (SourcePos(..), sourcePosPretty)
+import Control.Comonad.Cofree (Cofree((:<)), _extract, _unwrap)
 import Data.Fix (Fix (..))
 import Data.Functor.Foldable
 import Text.Show.Deriving (deriveShow1)
+import Data.Eq.Deriving (deriveEq1)
 import qualified Control.Comonad.Trans.Cofree as F
+import Prettyprinter (Pretty (pretty), viaShow)
+import Gyehoek.Lift1 (Lift1 (liftLift))
+import Data.Data (Typeable, cast)
+import Language.Haskell.TH
+import qualified Data.Text as T
+import Control.Comonad.Trans.Cofree (tailF)
 
 
 data DatumF a
@@ -52,6 +68,8 @@ data DatumF a
   | CompoundF (CompoundF a)
   | LabeledF Label a
   | LabelRefF Label
+  | MetaF Text
+  | MetaSpliceF Text
   deriving stock (Show, Eq, Data, Generic, Lift, Functor, Foldable, Traversable)
   deriving anyclass (NFData)
 
@@ -62,6 +80,7 @@ data Simple
   | SimpleString Text
   | SimpleSymbol Text
   | SimpleBytevector ByteString
+  | SimpleUnreadable Text
   deriving stock (Show, Eq, Data, Generic, Lift)
   deriving anyclass (NFData)
 
@@ -92,7 +111,7 @@ newtype Label = MkLabel Natural
 
 
 
-type Datum = Cofree DatumF Syn
+type Datum = Cofree DatumF Ann
 type Compound = CompoundF Datum
 
 data Indentation
@@ -108,16 +127,42 @@ data Syn
   | SynParen Int
   | SynString
   | SynConstant
+  | SynVariable
   | SynNone
-  deriving (Show, Read)
+  deriving (Show, Read, Data, Generic, Eq, Lift)
 
-
+data Ann = MkAnn
+  { syntax :: Syn
+  , position :: Maybe SourcePos
+  }
+  deriving (Show, Data, Eq, Generic)
+
+noAnn :: Ann
+noAnn = MkAnn
+  { syntax = SynNone
+  , position = Nothing
+  }
+
+-- requisite of the Pretty instance for invertible-grammar's error type.
+instance Pretty Ann where
+  pretty = pretty . maybe "<unknown>" sourcePosPretty . view #position
 
 deriveShow1 ''CompoundF
+deriveEq1 ''CompoundF
 deriveShow1 ''DatumF
+deriveEq1 ''DatumF
+
+
+--- modification and extraction of annotations
+
+ann :: Lens' Datum Ann
+ann = _extract
 
 syntax :: Lens' Datum Syn
-syntax = _extract
+syntax = ann . #syntax
+
+position :: Lens' Datum (Maybe SourcePos)
+position = ann . #position
 
 indentation :: Traversal' Datum Indentation
 indentation k (syn :< CompoundF (ListF ind xs)) = do
@@ -126,42 +171,60 @@ indentation k (syn :< CompoundF (ListF ind xs)) = do
 indentation k a = pure a
 
 adorn :: Syn -> Datum -> Datum
-adorn syn (_ :< d) = syn :< d
+adorn = set syntax
 
 indentWith :: Indentation -> Datum -> Datum
 indentWith = set indentation
 
+stripAnn :: Datum -> Fix DatumF
+stripAnn = hoist tailF
+
+
+--- pattern synonyms
+
 pattern Simple :: Simple -> Datum
 pattern Simple a <- _ :< SimpleF a
-  where Simple a = SynNone :< SimpleF a
+  where Simple a = noAnn :< SimpleF a
 
 pattern Compound :: CompoundF Datum -> Datum
 pattern Compound a <- _ :< CompoundF a
-  where Compound a = SynNone :< CompoundF a
+  where Compound a = noAnn :< CompoundF a
 
 pattern Labeled :: Label -> Datum -> Datum
 pattern Labeled l a <- _ :< LabeledF l a
-  where Labeled l a = SynNone :< LabeledF l a
+  where Labeled l a = noAnn :< LabeledF l a
 
 pattern LabelRef :: Label -> Datum
 pattern LabelRef l <- _ :< LabelRefF l
-  where LabelRef l = SynNone :< LabelRefF l
+  where LabelRef l = noAnn :< LabelRefF l
+
+pattern MetaSplice :: Text -> Datum
+pattern MetaSplice x <- _ :< MetaSpliceF x
+  where MetaSplice x = noAnn :< MetaSpliceF x
+
+pattern Meta :: Text -> Datum
+pattern Meta x <- _ :< MetaF x
+  where Meta x = noAnn :< MetaF x
 
 pattern List :: List Datum -> Datum
 pattern List a <- _ :< CompoundF (ListF _ a)
-  where List a = SynNone :< CompoundF (ListF Ordinary a)
+  where List a = noAnn :< CompoundF (ListF Ordinary a)
+
+pattern List' :: Indentation -> List Datum -> Datum
+pattern List' ind a <- _ :< CompoundF (ListF ind a)
+  where List' ind a = noAnn :< CompoundF (ListF ind a)
 
 pattern DotList :: NonEmpty Datum -> Datum -> Datum
 pattern DotList xs x <- _ :< CompoundF (DotListF xs x)
-  where DotList xs x = SynNone :< CompoundF (DotListF xs x)
+  where DotList xs x = noAnn :< CompoundF (DotListF xs x)
 
 pattern Vector :: [Datum] -> Datum
 pattern Vector xs <- _ :< CompoundF (VectorF xs)
-  where Vector xs = SynNone :< CompoundF (VectorF xs)
+  where Vector xs = noAnn :< CompoundF (VectorF xs)
 
 pattern Abbrev :: Prefix -> Datum -> Datum
 pattern Abbrev p a <- _ :< CompoundF (AbbrevF p a)
-  where Abbrev p a = SynNone :< CompoundF (AbbrevF p a)
+  where Abbrev p a = noAnn :< CompoundF (AbbrevF p a)
 
 pattern Boolean a = Simple (SimpleBoolean a)
 pattern Number a = Simple (SimpleNumber a)
@@ -169,3 +232,23 @@ pattern Character a = Simple (SimpleCharacter a)
 pattern String a = Simple (SimpleString a)
 pattern Symbol a = Simple (SimpleSymbol a)
 pattern Bytevector a = Simple (SimpleBytevector a)
+pattern Unreadable a = Simple (SimpleUnreadable a)
+
+
+--- Lift1 instances
+
+instance Lift1 DatumF where
+  liftLift l = \case
+    SimpleF s -> [|SimpleF $(lift s)|]
+    CompoundF c -> [|CompoundF $(liftLift l c)|]
+    LabeledF lbl x -> [|LabeledF $(lift lbl) $(l x)|]
+    LabelRefF lbl -> [|LabelRefF $(lift lbl)|]
+    MetaF x -> [|MetaF $(lift x)|]
+    MetaSpliceF x -> [|MetaSpliceF $(lift x)|]
+
+instance Lift1 CompoundF where
+  liftLift l = \case
+    ListF ind xs -> [|ListF $(lift ind) $(liftLift l xs)|]
+    DotListF xs t -> [|DotListF $(liftLift l xs) $(l t)|]
+    VectorF xs -> [|VectorF $(liftLift l xs)|]
+    AbbrevF p x -> [|AbbrevF $(lift p) $(l x)|]

src/Gyehoek/Stack/Lower.hs

@@ -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

src/Gyehoek/Stack/Syntax.hs

@@ -4,72 +4,89 @@
 {-# LANGUAGE DeriveAnyClass #-}
 module Gyehoek.Stack.Syntax
   ( Program(..)
-  , Block(..)
+  , Routine(..)
   , Instr(..)
+  , Block(..)
+  , Tail(..)
   , Val(..)
   , Lit(..)
   , Obj(..)
   , Imm(..)
   , Hob(..)
   , Prim(..)
-  , Name
+  , Name(..)
+  , Reg(..)
+  , Label(..)
   , pattern ValLabel
-  , encodeProgram
+  , pattern ObjLabel
+  , stkP
   ) where
 
 import Control.Lens
-import Language.SexpGrammar (SexpIso, (>>>))
-import Language.SexpGrammar qualified as S
-import Language.SexpGrammar.Generic
-import qualified Gyehoek.Sexp
+import qualified Gyehoek.Sexp as S
 import Gyehoek.Scheme.Syntax (Name(..), Lit(..), Prim(..))
 import GHC.Exts (IsList(..))
 import Data.List (intersperse)
-import Gyehoek.CPS.Syntax (Imm(..), Obj(..), Hob(..), labelName)
+import Gyehoek.CPS.Syntax (Imm(..), Obj(..), Hob(..), pattern ObjLabel, Reg, Label)
 import Gyehoek.Prelude
+import Gyehoek.Sexp ((:-)((:-)))
 
 
 newtype Program = MkProgram
-  { blocks :: List Block
+  { routines :: HashMap Label Routine
   }
   deriving stock (Show, Generic, Data)
   deriving newtype (Semigroup, Monoid)
   deriving anyclass (NFData)
 
 instance IsList Program where
-  type Item Program = Block
-  fromList = MkProgram
-  toList = view #blocks
+  type Item Program = Routine
+  fromList rs = MkProgram
+    { routines = fromList [ (r.label, r) | r <- rs ]
+    }
+  toList = toListOf $ #routines . each
 
-data Block = MkBlock
-  { label :: Name
-  , params :: List Name
-  , code :: List Instr
+data Routine = MkRoutine
+  { label :: Label
+  , start :: Block
   }
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
 
-instance Each Block Block Instr Instr where
-  each = #code . each
+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 Name
+  = Pop Reg
   | Push Val
-  | PopCont Name
-  | PushCont Val
-  | Prim Name (Prim Val)
-  | Call Val (List Val)
-  | If Val (List Instr) (List Instr)
+  | Load Reg Int
+  | Prim Reg (Prim Val)
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
 
 data Val
-  = ValReg Name
+  = ValReg Reg
   | ValImm Imm
   deriving stock (Show, Generic, Data, Eq)
   deriving anyclass (NFData)
 
-pattern ValLabel :: Name -> Val
+pattern ValLabel :: Label -> Val
 pattern ValLabel x = ValImm (ImmLabel x)
 
 
@@ -77,43 +94,57 @@ pattern ValLabel x = ValImm (ImmLabel x)
 
 pure []
 
-instance SexpIso Instr where
-  sexpIso = match
-    $ With (Gyehoek.Sexp.headTagged1 "pop!" regName >>>)
-    $ With (Gyehoek.Sexp.headTagged1 "push!" S.sexpIso >>>)
-    $ With (Gyehoek.Sexp.headTagged1 "pop-cont!" regName >>>)
-    $ With (Gyehoek.Sexp.headTagged1 "push-cont!" S.sexpIso >>>)
-    $ With (Gyehoek.Sexp.headTagged2 "prim" regName S.sexpIso >>>)
-    $ With (Gyehoek.Sexp.headTagged1' "call" S.sexpIso S.sexpIso >>>)
-    $ With (if_ >>>)
-    $ End
+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.headTagged2 "prim" S.datumIso S.datumIso >>>)
+    $ S.End
     where
-      if_ = S.list $ S.el (S.sym "if")
-        >>> S.el (S.sexpIso @Val)
-        >>> S.el (S.list $ S.el (S.sym "then") >>> S.rest (S.sexpIso @Instr))
-        >>> S.el (S.list $ S.el (S.sym "else") >>> S.rest (S.sexpIso @Instr))
 
-instance SexpIso Val where
-  sexpIso = match
-    $ With (regName >>>)
-    $ With (S.sexpIso >>>)
-    $ End
+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 SexpIso Block where
-  sexpIso = with (block >>>)
+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
-      block = S.list $
-        S.el (S.sym "define")
-        >>> S.el (S.list $ S.el labelName >>> S.rest regName)
-        >>> S.rest (S.sexpIso @Instr)
+      -- 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)
 
-encodeProgram :: Program -> Text
-encodeProgram p = p.blocks
-  & fmap ((^?! _Right) . Gyehoek.Sexp.encodePretty)
-  & intersperse "\n\n"
-  & mconcat
+instance S.DatumIso Val where
+  datumIso = S.match
+    $ S.With (S.datumIso >>>)
+    $ S.With (S.datumIso >>>)
+    $ S.End
 
-regName :: S.SexpGrammar Name
-regName = S.sexpIso @Name >>> Gyehoek.Sexp.prismIso
-  (S.expected "register")
-  (prefixed @Name "%")
+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) ||]

src/Gyehoek/Stack/VM.hs

@@ -1,4 +1,6 @@
-{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE ViewPatterns, MultilineStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeriveAnyClass #-}
 module Gyehoek.Stack.VM
   ( VM(..)
   , Env(..)
@@ -6,120 +8,318 @@ module Gyehoek.Stack.VM
   , 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)
+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 :: List Obj
-  , kstack :: List Name
+  { stack :: Stack
   , code :: List Instr
-  , registers :: HashMap Name Obj
+  , 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
-  { blocks :: HashMap Name Block
+  { labels :: HashMap Label Routine
   }
   deriving (Show, Generic)
 
-step :: Env -> VM -> VM
-step e vm = case vm ^. #code of
-  c:cs -> stepI e (vm & #code .~ cs) c
-  _ -> error "halt never called"
+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
 
-stepI :: Env -> VM -> Instr -> VM
+vmerror :: (HasCallStack, Jalmot :> es) => Text -> Eff es a
+vmerror = throwError . VMError
 
-stepI e vm (Push v) = vm & #stack %~ (evalVal e vm v :)
+stepI :: Jalmot :> es => Env -> VM -> Instr -> Eff es VM
 
-stepI e vm (PushCont k) = vm & #kstack %~ (evalToLabel e vm k :)
+stepI e vm ins = vmerror [i|unimplemented instruction: #{ins}|]
 
-stepI e vm (Prim r p) = case evalVal e vm <$> p of
+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) -> ret . ObjImm . ImmBool $ n == 0
-    _ -> error [i|bad arg to zero?: #{x}|]
+    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) -> ret . ObjHob $ HobClosure l env
-      _ -> error [i|expected label, got #{f}|]
-  PrimEnvCode env ->
-    case env of
-      ObjHob (HobClosure l _) -> ret . ObjImm . ImmLabel $ l
-      _ -> error [i|expected closure, got #{env}|]
-  PrimEnvRef env n ->
-    case env of
-      ObjHob (HobClosure _ xs) -> ret $ xs ^?! ix n
-      _ -> error [i|expected closure, got #{env}|]
-  x -> error [i|unimplemented prim: #{p}|]
+      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 v = vm & #registers . at r ?~ v
+    ret vs = pure $ vm & activeFrame . #locals <>:~ vs
+    ret1 v = ret [v]
     arith_binop op (ObjImm (ImmInt x)) (ObjImm (ImmInt y)) =
-      ret $ ObjImm (ImmInt (op x y))
-    arith_binop _ x y = error [i|bad arith: #{x}, #{y}|]
+      ret1 $ ObjImm (ImmInt (op x y))
+    arith_binop _ x y = vmerror [i|bad arith: #{x}, #{y}|]
 
-stepI e vm (Pop r) = case vm ^. #stack of
-  [] -> error "empty stack"
-  (x:xs) -> vm & #registers . at r ?~ x
-               & #stack .~ xs
+
 
-stepI e vm ins@(PopCont r) = case vm ^. #kstack of
-  [] -> error [i|empty cont stack: #{ins}|]
-  (x:xs) -> vm & #registers . at r ?~ ObjImm (ImmLabel x)
-               & #kstack .~ xs
+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)
 
-stepI e vm (Call v xs) =
-  case evalToLabel e vm v of
-    "halt" -> vm & #result ?~ fmap (evalVal e vm) xs
-    l -> vm & #code .~ b.code
-            & #registers .~ fmap (evalVal e vm) (H.fromList $ b.params `zip` xs)
-      where
-        b = case e ^. #blocks . at l of
-          Just x -> x
-          Nothing -> error [i|undefined label: #{l}|]
+jumpToBlock :: Block -> VM -> VM
+jumpToBlock b vm = vm
+  & #code .~ b.code
+  & #tail .~ b.tail
 
-stepI e vm (If c t f) =
-  case evalVal e vm c of
-    ObjImm (ImmBool False) -> vm & #code .~ f
-    _ -> vm & #code .~ t
+jumpToRoutine :: Routine -> VM -> VM
+jumpToRoutine rt vm = vm
+  & jumpToBlock rt.start
+  & #debug . #activeRoutine .~ rt.label
 
-stepI e vm ins = error [i|unimplemented instruction: #{ins}|]
+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 =
-  case evalVal e vm v of
-    ObjImm (ImmLabel x) -> x
-    x -> error [i|not a label: #{x}|]
+  evalVal e vm v >>= \case
+    ObjImm (ImmLabel x) -> pure x
+    x -> vmerror [i|not a label: #{x}|]
 
-evalVal :: Env -> VM -> Val -> Obj
+evalVal :: Jalmot :> es => Env -> VM -> Val -> Eff es Obj
 evalVal e vm = \case
-  ValImm imm -> ObjImm imm
+  ValImm imm -> pure $ ObjImm imm
   ValReg r -> case vm ^. #registers . at r of
-    Just x -> x
-    Nothing -> error [i|undefined register: #{r}|]
+    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 = []
-  , kstack = ["halt"]
-  , code = [Call (ValImm $ ImmLabel "main") []]
+  { 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 (MkProgram bs) = MkEnv
-  { blocks = bs & foldMap \b -> H.singleton b.label b
+initialEnv p = MkEnv
+  { labels = p.routines
   }
 
 loop :: (a -> Either b a) -> a -> b
@@ -127,23 +327,181 @@ loop f a = case f a of
   Right a' -> loop f a'
   Left b -> b
 
-eval :: Program -> List Obj
-eval p = initialVM & loop \vm -> case vm ^. #result of
-  Nothing -> Right $ step (initialEnv p) vm
-  Just rs -> Left rs
+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
 
-trace :: Program -> List VM
-trace p = initialVM & unfoldr \vm ->
-    case vm.result of
-      Just _ -> Nothing
-      Nothing -> Just (vm, step e vm)
-  where e = initialEnv p
+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 (ObjImm im) = case im of
-  ImmInt n -> [i|#{n}|]
-  ImmBool True -> "#t"
-  ImmBool False -> "#f"
-  ImmLabel l -> "#<procedure>"
-writeObj (ObjHob h) = case h of
-  HobClosure code env -> "#<procedure>"
+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))
+|]

src/Gyehoek/Wasm.hs

@@ -6,187 +6,41 @@ module Gyehoek.Wasm
   (
     -- * syntax
     Module
-  , Idx
+  , Program
+  , Function
   , Expr
     -- ** quasiquoters
-  , expr
-  , Gyehoek.Sexp.sx
-  , Gyehoek.Sexp.sxs
-  -- * GenMod effect
-  , GenMod
-  , runGenMod
-  , execGenMod
-  , defineFunction
-  , defineType
-  , defineGlobal
-  , emit
-  , renderModule
+  , watM
   , wat
-  , wats
-  , defineFunctions
-  , defineTypes
-  , defineGlobals
   )
   where
 
-import Language.SexpGrammar
-  ( SexpIso(..), (>>>) )
-import Language.SexpGrammar qualified as Sexp
-import Language.SexpGrammar.Generic
 import Data.List (List)
 import GHC.Generics (Generic)
-import Data.Text (Text)
-import Effectful
-import Numeric.Natural (Natural)
-import Effectful.Dispatch.Dynamic
-import Effectful.State.Dynamic
-import Control.Lens
-import Data.Vector.Strict (Vector)
-import qualified Data.Vector.Strict as V
-import Language.Sexp.Located
-import qualified Gyehoek.Sexp
-import GHC.IsList (IsList(..))
 import Language.Haskell.TH.Quote (QuasiQuoter)
+import Gyehoek.Sexp qualified as S
+import Gyehoek.Sexp (Datum, (>>>))
 import Data.Data (Data)
-import Gyehoek.Sexp (sx)
-import Data.Foldable (traverse_)
 
 
-newtype Module = MkModule { inner :: Vector Sexp }
-  deriving (Show, Generic)
+type Program = Module
+type Function = Datum
+type Expr = List Datum
+
+newtype Module = MkModule { inner :: List Datum }
+  deriving (Show, Generic, Data)
   deriving newtype (Semigroup, Monoid)
 
-newtype Expr = MkExpr { inner :: Vector Instr }
-  deriving (Show, Generic, Data, Eq)
-  deriving newtype (Semigroup, Monoid)
-
-instance IsList Expr where
-  type Item Expr = Instr
-  fromList = MkExpr . V.fromList
-  toList = V.toList . view #inner
-
-newtype Instr = MkInstr { inner :: Sexp }
-  deriving (Show, Generic, Data, Eq)
-
-newtype Idx = MkIdx { inner :: Natural }
-  deriving (Generic, Data)
-  deriving newtype (Show)
-
-
--- GenMod
-
--- | 'GenModState' is a 'Module' paired with the numbers of functions,
--- types, globals, etc. defined in the module.
-data GenModState = MkGenModState
-  { mod :: Module
-  , funcs :: Natural
-  , types :: Natural
-  , globals :: Natural
-  }
-  deriving (Show, Generic)
-
-instance Semigroup GenModState where
-  m1 <> m2 = MkGenModState
-    { mod = m1.mod <> m2.mod
-    , funcs = m1.funcs + m2.funcs
-    , types = m1.types + m2.types
-    , globals = m1.globals + m2.globals
-    }
-
-instance Monoid GenModState where
-  mempty = MkGenModState
-    { mod = mempty
-    , funcs = 0
-    , types = 0
-    , globals = 0
-    }
-
-data GenMod :: Effect where
-  DefineFunction :: Sexp -> GenMod m Idx
-  DefineType :: Sexp -> GenMod m Idx
-  DefineGlobal :: Sexp -> GenMod m Idx
-  Emit :: Sexp -> GenMod m ()
-
-type instance DispatchOf GenMod = Dynamic
-
-defineFunction :: GenMod :> es => Sexp -> Eff es Idx
-defineFunction = send . DefineFunction
-
-defineFunctions :: GenMod :> es => List Sexp -> Eff es (List Idx)
-defineFunctions = traverse (send . DefineFunction)
-
-defineType :: GenMod :> es => Sexp -> Eff es Idx
-defineType = send . DefineType
-
-defineTypes :: GenMod :> es => List Sexp -> Eff es (List Idx)
-defineTypes = traverse (send . DefineType)
-
-defineGlobal :: GenMod :> es => Sexp -> Eff es Idx
-defineGlobal = send . DefineGlobal
-
-defineGlobals :: GenMod :> es => List Sexp -> Eff es (List Idx)
-defineGlobals = traverse (send . DefineGlobal)
-
-emit :: GenMod :> es => List Sexp -> Eff es ()
-emit = traverse_ (send . Emit)
-
-appendAndIncrement
-  :: State GenModState :> es
-  => LensLike' ((,) Natural) GenModState Natural
-  -> Sexp
-  -> Eff es Idx
-appendAndIncrement l s =
-  state \st -> st
-    & #mod . #inner <>~ V.singleton s
-    & l <<%~ succ
-    & _1 %~ MkIdx
-
-runGenMod :: Eff (GenMod : es) a -> Eff es (a, Module)
-runGenMod =
-  let run = (mapped . _2 %~ view #mod) . runStateLocal (mempty @GenModState)
-  in reinterpret run \cases
-    _ (DefineFunction s) -> appendAndIncrement #funcs s
-    _ (DefineType s) -> appendAndIncrement #types s
-    _ (DefineGlobal s) -> appendAndIncrement #globals s
-    _ (Emit s) -> #mod . #inner <>= V.singleton s
-
-execGenMod :: Eff (GenMod : es) a -> Eff es Module
-execGenMod = fmap snd . runGenMod
-
-renderModule :: Module -> Text
-renderModule (MkModule ss) = Gyehoek.Sexp.format [sx|
-  (module ##{ss})
-|]
-
-
--- SexpIso instances
-
-instance SexpIso Idx where
-  sexpIso = with \idx ->
-    Sexp.integer >>> Sexp.partialOsi f g
-    >>> idx
-    where
-      f n | n < 0 = Left $ Sexp.unexpected "negative"
-                        <> Sexp.expected "natural"
-          | otherwise = Right $ fromIntegral n
-      g = fromIntegral
-
-instance SexpIso Instr where
-  sexpIso = with id
-
-instance Gyehoek.Sexp.SpliceSexp Expr where
-  spliceSexp = toListOf $ #inner . each . #inner
+instance S.DatumIso Module where
+  datumIso = S.with \g ->
+    S.list (S.el (S.sym "module") >>> S.rest S.datumIso)
+    >>> g
 
 
 -- quasiquoters
 
-expr :: QuasiQuoter
-expr = Gyehoek.Sexp.makeSxs
-  [||MkExpr . V.fromList . (each . #inner %~ Gyehoek.Sexp.stripLocation)
-   . fmap (Gyehoek.Sexp.fromSexp @Instr) ||]
-
 wat :: QuasiQuoter
-wat = Gyehoek.Sexp.makeSx [|| id ||]
+wat = S.makeSxs [|| S.fromDataUnsafe (S.dataIso @(List Datum)) ||]
 
-wats :: QuasiQuoter
-wats = Gyehoek.Sexp.makeSxs [|| id ||]
+watM :: QuasiQuoter
+watM = S.makeSx [|| S.fromDatumUnsafe (S.datumIso @Module) ||]

t.scm

@@ -0,0 +1,5 @@
+((λ ()
+   (* 2 (call/cc
+         (λ (k)
+           (begin (k 6)
+                  3))))))

test/Gyehoek/Test/CPS/Eval.hs

@@ -2,54 +2,78 @@ module Gyehoek.Test.CPS.Eval where
 
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.HUnit
-import Language.SexpGrammar ()
 import Gyehoek.CPS.Syntax (cps, Obj(..), Hob(..), Imm(..))
 import Gyehoek.CPS.Eval qualified as Sut
 import Data.List (List)
+import Test.Tasty.ExpectedFailure (ignoreTestBecause, expectFail)
+import System.Directory (listDirectory)
+import Test.Tasty.Silver
+import System.FilePath
+import Control.Exception
+import qualified Gyehoek.Driver as Driver
+import Control.DeepSeq (($!!))
+import System.Exit (ExitCode(..))
+import qualified Data.Text as T
+import Data.Function (applyWhen)
+import Gyehoek.Prelude
 
 
-test_cpsInterpreter = testGroup "cps interpreter" $
-  [ primitives
-  , testCase "halt with constant" do
-      evalsTo [ObjImm (ImmInt 123)] [cps|
-        (continue halt 123)
-      |]
-  , testCase "identity cont" do
-      evalsTo [ObjImm (ImmInt 154)] [cps|
-        (letrec ((id (κ (x)
-                       (continue halt x))))
-          (continue id 154))
-      |]
-  , testCase "identity function" do
-      evalsTo [ObjImm (ImmInt 456)] [cps|
-        (letrec ((id (λ (x ktail)
-                       (continue ktail x))))
-          (id 456 halt))
-      |]
-  , testCase "square" do
-      evalsTo [ObjImm (ImmInt 81)] [cps|
-        (letrec ((square (λ (x ktail)
-                           (prim (* x x)
-                             (κ (r) (continue ktail r))))))
-          (square 9 halt))
-      |]
-  ]
+brokenEvalTests :: List String
+brokenEvalTests =
+  []
+  -- [ "adder"
+  -- , "apply2"
+  -- , "apply-twice"
+  -- , "arith"
+  -- , "begin-1"
+  -- , "callcc-constant"
+  -- , "callcc-discard"
+  -- , "callcc-early-exit-1"
+  -- , "callcc-early-exit-2"
+  -- , "callcc-early-exit-3"
+  -- , "callcc-early-exit-4"
+  -- , "callcc-early-exit-5"
+  -- , "callcc-early-exit-6"
+  -- , "callcc-nested-1"
+  -- , "callcc-nested-2"
+  -- , "complicated-1"
+  -- , "cons-1"
+  -- , "factorial"
+  -- , "false"
+  -- , "fn-of-fn"
+  -- , "if-false"
+  -- , "if-number"
+  -- , "if-true"
+  -- , "lambda"
+  -- , "letrec-fn"
+  -- , "let-fn"
+  -- , "lit-int"
+  -- , "square"
+  -- , "true"
+  -- ]
 
-evalsTo :: HasCallStack => List Obj -> Sut.Program -> Assertion
-evalsTo rs p = Sut.evalProgram p @?= rs
-
-primitives = testGroup "primitives"
-  [ testGroup "arith"
-    [ testCase "basic 1" do
-        evalsTo [ObjImm (ImmInt 20)] [cps|
-          (prim (* 4 5)
-            (κ (x) (continue halt x)))
-          |]
-    , testCase "basic 2" do
-        evalsTo [ObjImm (ImmInt 35)] [cps|
-          (prim (* 2 16)
-            (κ (x) (prim (+ x 3)
-                      (κ (r) (continue halt r)))))
-          |]
+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_cps_e2e <$> cs
     ]
-  ]
+
+maybeBroken name broken = applyWhen (name `elem` broken) expectFail
+
+cpsCase :: (FilePath -> IO Text) -> FilePath -> TestTree
+cpsCase f test =
+  maybeBroken testName brokenEvalTests $
+    goldenVsAction testName resultFile action printProcResult
+  where
+    testName = takeFileName test
+    resultFile = test </> "exec"
+    sourceFile = test </> "source.scm"
+    action = catch @SomeException
+      (do r <- f sourceFile
+          pure $!! ( ExitSuccess
+                   , r
+                   , "" ))
+      \e -> pure (ExitFailure 1, "", T.pack $ displayException e)

test/Gyehoek/Test/CPS/Stackify.hs

@@ -4,83 +4,93 @@ import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.HUnit
 import qualified Gyehoek.CPS.Stackify as Sut
 import Gyehoek.Stack.VM as Stk
-import Data.List (List)
 import Gyehoek.CPS.Syntax (cps)
+import Gyehoek.CPS.Syntax qualified as CPS
 import Gyehoek.GenSym (runGenSym)
 import Effectful
+import Gyehoek.Prelude
+import Gyehoek.Jalmot
+import Test.Tasty.ExpectedFailure (expectFail, ignoreTestBecause)
 
 
-test_stackify =
-  [ trivialReturn
-  , tailCall
-  , prim
-  , condition
-  , procedure
-  ]
+-- test_stackify =
+--   [ trivialReturn
+--   , tailCall
+--   , prim
+--   , condition
+--   , procedure
+--   ]
 
-evalsTo :: List Obj -> Sut.Exp -> Assertion
-evalsTo rs e =
-  Stk.eval e' @?= rs
-  where e' = runPureEff . runGenSym $ Sut.stackifyExp "main" e
+-- 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|(continue halt 4)|]
-  , testCase "return bool" do
-      evalsTo [ObjImm (ImmBool True)]
-        [cps|(continue halt #t)|]
-      evalsTo [ObjImm (ImmBool False)]
-        [cps|(continue halt #f)|]
-  ]
+-- 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|(letrec ((square (λ (x ktail)
-                                (prim (* x x)
-                                  (κ (x0) (continue ktail x0))))))
-               (square 4 halt))|]
-  ]
+-- 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|(prim (* 4 5)
-               (κ (x) (continue halt x)))|]
-  , testCase "add" do
-      evalsTo [ObjImm (ImmInt 9)]
-        [cps|(prim (+ 4 5)
-               (κ (x) (continue halt x)))|]
-  -- , testGroup "call/cc"
-  --   [ testCase "trivial" do
-  --       evalsTo [ObjImm (ImmInt 123)]
-  --         [cps|(letrec ((f (λ (cc ktail) (continue cc 123))))
-  --                (prim (call/cc f)))|]
-  --   ]
-  ]
+-- 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|(if #t (continue halt 123) (continue halt 456))|]
-  evalsTo [ObjImm (ImmInt 456)]
-    [cps|(if #f (continue halt 123) (continue halt 456))|]
+-- 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|(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))|]
-  ]
+-- 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)))|]
+--   ]

test/Gyehoek/Test/CPS/Syntax.hs

@@ -3,7 +3,6 @@ module Gyehoek.Test.CPS.Syntax where
 
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.HUnit
-import Language.SexpGrammar ()
 import Gyehoek.CPS.Syntax (cps)
 import Gyehoek.CPS.Syntax qualified as Sut
 
@@ -29,22 +28,27 @@ free = testGroup "free"
 qq :: TestTree
 qq = testGroup "parser"
   [ testCase "lambda" do
-      assertEqual "" (Sut.MkLambda ["x","y"] "ktail"
-               (Sut.ExpContinue "ktail" [Sut.ValVar "x"]))
+      assertEqual ""
+        (Sut.MkLambda ["x","y"] "ktail"
+         (Sut.ExpContinue (Sut.ValVar "ktail") [Sut.ValVar "x"]))
         [cps|(λ (x y ktail) (continue ktail x))|]
-      assertEqual "" (Sut.MkLambda [] "ktail"
-               (Sut.ExpContinue "ktail" [Sut.ValVar "x"]))
+      assertEqual ""
+        (Sut.MkLambda [] "ktail"
+         (Sut.ExpContinue (Sut.ValVar "ktail") [Sut.ValVar "x"]))
         [cps|(λ (ktail) (continue ktail x))|]
   , testCase "kappa" do
-      assertEqual "" (Sut.MkKappa ["x","y"]
-               (Sut.ExpContinue "k123" [Sut.ValVar "x", Sut.ValVar "y"]))
+      assertEqual ""
+        (Sut.MkKappa ["x","y"]
+         (Sut.ExpContinue
+          (Sut.ValVar "k123")
+          [Sut.ValVar "x", Sut.ValVar "y"]))
         [cps|(κ (x y) (continue k123 x y))|]
   , testCase "application" do
       assertEqual "" (Sut.ExpApply (Sut.ValVar "f")
                      [Sut.ValVar "x",Sut.ValVar "y"]
-                     "k")
+                     (Sut.KexpVar "k"))
         [cps|(f x y k)|]
       assertEqual "" (Sut.ExpApply (Sut.ValVar "f")
-                     [] "k")
+                     [] (Sut.KexpVar "k"))
         [cps|(f k)|]
   ]

test/Gyehoek/Test/Golden.hs

@@ -29,16 +29,7 @@ brokenWasmTests =
 
 brokenStackifyTests :: List String
 brokenStackifyTests =
-  []
-  -- [ "adder"
-  -- , "let-fn"
-  -- , "callcc-nested1" -- requires closure-conversion
-  -- ]
-
-brokenReaderTests =
-  [ "delimited-identifier"
-  , "string-line-continuation"
-  , "peculiar-identifier-dot"
+  [
   ]
 
 test_root :: IO TestTree
@@ -49,15 +40,16 @@ test_root = do
   testGroup "execution" <$> sequenceA
     [ ignoreTestBecause "wasm codegen is on the backburner"
       <$> wasmTests tests
-    , stackifyTests tests
+    , ignoreTestBecause "i'm killing myself"
+      <$> stackifyTests tests
     ]
 
 maybeBroken name broken = applyWhen (name `elem` broken) expectFail
 
 wasmTests :: List FilePath -> IO TestTree
 wasmTests files = do
-  cmd <- getEnvDefault "GYEHOEK_RUNTIME"
-    "runtime/target/debug/gyehoek-runtime"
+  cmd <- getEnvDefault "GYEHOEK_WASM_RUNTIME"
+    "runtime/target/debug/gyehoek-wasm-runtime"
   pure $ testGroup "wasm" $ files <&> \test ->
     let testname = takeFileName test
         scmfile = test </> "source.scm"
@@ -91,22 +83,3 @@ stackifyTests files = do
        resultfile
        action
        printProcResult
-
-test_reader :: IO TestTree
-test_reader = do
-  all_cases <- listDirectory "golden/read"
-  let tests = all_cases
-            & fmap ("golden/read"</>)
-  pure . testGroup "reader" $ tests <&> \test ->
-    let testname = takeFileName test
-        scmfile = test </> "source.scm"
-        resultfile = test </> "read"
-        action = runEff $ Read.readFile scmfile
-    in maybeBroken testname brokenReaderTests $ goldenVsAction
-        testname
-        resultfile
-        action
-        (view strict . pShowNoColor)
-
--- readTests files = pure . testGroup "reader" $ files <&> \test ->
---   let

test/Gyehoek/Test/Scheme/Syntax.hs

@@ -2,7 +2,6 @@ module Gyehoek.Test.Scheme.Syntax where
 
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.HUnit
-import Language.SexpGrammar ()
 import Gyehoek.Scheme.Syntax (scm)
 import Gyehoek.Scheme.Syntax qualified as Sut
 

test/Gyehoek/Test/Sexp/Print.hs

@@ -24,23 +24,26 @@ thinWide name x = testGroup name
   , tcaseW 4 (name <> "-thin") x
   ]
 
+datumBegin xs = S.indentWith (S.NSpecial 0) . S.List $
+  (S.adorn S.SynBuiltin . S.Symbol $ "begin") : xs
+
+datumLambda formals body =
+  S.indentWith (S.NSpecial 1) . S.List $
+  (S.adorn S.SynBuiltin . S.Symbol $ "lambda") : formals : body
+
 test_print = testGroup "sexp pretty printer" $
   [ tcase "null" $ S.List []
   , thinWide "simple-list" $
     S.List [ S.Symbol s | s <- ["가","나","다","라"] ]
   , thinWide "begin-nonempty" $
     S.indentWith (S.NSpecial 0) $
-    S.List [ S.adorn S.SynBuiltin $ S.Symbol "begin"
-           , S.Symbol "책을"
+    datumBegin [ S.Symbol "책을"
            , S.Symbol "더"
            , S.Symbol "먹으세요~!"
            ]
-  , thinWide "lambda-nonempty" $
-    S.indentWith (S.NSpecial 1) $
-    S.List [ S.adorn S.SynBuiltin $ S.Symbol "lambda"
-           , S.List [S.Symbol "어간", S.Symbol "어미"]
-           , S.List [S.Symbol "display", S.Symbol "꾸깃"]
-           ]
+  , thinWide "lambda" $
+    datumLambda (S.List [S.Symbol "어간", S.Symbol "어미"])
+           [ S.List [S.Symbol "display", S.Symbol "꾸깃"] ]
   , tcase "rainbow" $
     S.List [S.List [S.List [S.List [S.List []]]]]
   ]

test/Gyehoek/Test/Sexp/QQ.hs

@@ -1,35 +1,32 @@
-module Gyehoek.Test.Sexp where
+module Gyehoek.Test.Sexp.QQ where
 
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.HUnit
-import Language.Sexp.Located qualified as SL
-import Language.SexpGrammar ()
-import Gyehoek.Sexp (sx, equivalent)
+import Gyehoek.Sexp.QQ (sx)
 import Data.Function (on)
+import Gyehoek.Sexp.Syntax
+import Data.Coerce (coerce)
 
 
-test_root = testGroup "sexp" $
-  [ sxTree
-  ]
-
-newtype EquivSexp = MkEquiv SL.Sexp
+newtype EquivDatum = MkEquiv Datum
   deriving newtype (Show)
 
-instance Eq EquivSexp where
-  MkEquiv x == MkEquiv y = equivalent x y
+instance Eq EquivDatum where
+  (==) = (==) `on` (stripAnn . coerce)
 
 assertEquiv
   :: HasCallStack
-  => String -> SL.Sexp -> SL.Sexp -> Assertion
+  => String -> Datum -> Datum -> Assertion
 assertEquiv prefix = assertEqual prefix `on` MkEquiv
 
+equivto :: HasCallStack => Datum -> Datum -> Assertion
 equivto = assertEquiv ""
 
-sxTree :: TestTree
-sxTree = testGroup "sx"
+test_qq :: TestTree
+test_qq = testGroup "sexp quasiquoter"
   [ testCase "quotation" do
-      equivto (SL.Symbol "abc") [sx|abc|]
-      equivto (SL.ParenList [SL.Symbol "a", SL.Symbol "b"]) [sx|(a b)|]
+      equivto (Symbol "abc") [sx|abc|]
+      equivto (List [Symbol "a", Symbol "b"]) [sx|(a b)|]
   , testCase "antiquotation" do
       equivto [sx|123|]
         let meta = 123 :: Int
@@ -37,13 +34,14 @@ sxTree = testGroup "sx"
       equivto [sx|(blah (blah blah) blah)|]
         let meta = [sx|blah|]
         in [sx|(#{meta} (#{meta} #{meta}) #{meta})|]
-  , testCase "splicing" do
+  , testCase "splicing simple" do
       equivto [sx|(a b c d e f g)|]
-        let metas = SL.Symbol <$> ["c","d","e"]
+        let metas = Symbol <$> ["c","d","e"]
         in [sx|(a b ##{metas} f g)|]
+  , testCase "splicing multiple" do
       equivto [sx|(a (b c d) e f g)|]
         let
-          e1 = SL.Symbol "c"
-          e2 = SL.Symbol <$> ["e","f"]
+          e1 = Symbol "c"
+          e2 = Symbol <$> ["e","f"]
         in [sx|(a (b #{e1} d) ##{e2} g)|]
   ]

test/Gyehoek/Test/Sexp/Read.hs

@@ -0,0 +1,60 @@
+module Gyehoek.Test.Sexp.Read where
+
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.Silver
+import System.FilePath
+import Data.List (List)
+import System.Directory
+import Gyehoek.Prelude
+import qualified Gyehoek.Sexp.Read as Read
+import Gyehoek.TestUtil
+import Gyehoek.Jalmot (runJalmotIO)
+import Text.Pretty.Simple (pShowNoColor)
+import Gyehoek.Sexp.Syntax
+import Test.Tasty.HUnit
+import Control.Exception (tryWithContext, ExceptionWithContext (..), rethrowIO)
+import Gyehoek.Jalmot
+
+
+brokenReaderTests :: List String
+brokenReaderTests =
+  [ "delimited-identifier"
+  , "string-line-continuation"
+  , "peculiar-identifier-dot"
+  , "meta-splice-expression-interior-brace"
+  , "datum-comment"
+  ]
+
+test_golden :: IO TestTree
+test_golden = do
+  all_cases <- listDirectory "golden/read"
+  let tests = all_cases
+            & fmap ("golden/read"</>)
+  pure . testGroup "reader" $ tests <&> \test ->
+    let testname = takeFileName test
+        scmfile = test </> "source.scm"
+        resultfile = test </> "read"
+        action = runJalmotIO $ Read.readFile scmfile
+    in markIfBroken testname brokenReaderTests $ goldenVsAction
+        testname
+        resultfile
+        action
+        (view strict . pShowNoColor)
+
+readString1 = runJalmotIO . Read.readString1
+
+test_invalidIdentifiers :: TestTree
+test_invalidIdentifiers = testGroup "invalid identifiers"
+  [ testCase "dot" $ notIdentifier (readString1 ".")
+  , testCase "comma" $ notIdentifier (readString1 ",")
+  , testCase "pound" $ notIdentifier (readString1 "#")
+  , testCase "pound anything" $ notIdentifier (readString1 "#abc")
+  ]
+  where
+    notIdentifier m = tryWithContext m >>= \case
+      -- the reader is allowed to fail; we're just don't want it to
+      -- return a symbol.
+      Left (ExceptionWithContext _ (MkAJalmotCS _ (ReaderError _))) -> pure ()
+      Left e -> rethrowIO e
+      Right (Symbol s) -> assertFailure [i|got symbol #{s}|]
+      Right _ -> pure ()