print begin

.dir-locals.el

@@ -9,9 +9,6 @@
       . (progn (defun apply-cabal-fmt-h ()
                  (haskell-mode-buffer-apply-command "cabal-fmt"))
                (add-hook 'before-save-hook #'apply-cabal-fmt-h nil t)))))
- (scheme-mode
-  . ((eval . (dolist (s '(kappa κ prim))
-               (put s 'scheme-indent-function 1)))))
  (nil
   . ((eval
       . (progn (defun display-ansi ()

.envrc

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

.gitignore

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

cabal.project

@@ -1,10 +1,5 @@
 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,34 +132,3 @@ multiple ~env-ref~ calls could probably be replaced with a primitive that loads
                                  $code)
                      1))))
 #+end_src
-
-** example
-
-#+begin_src scheme
-  (λ (n m ktail)
-    (letrec ((f (λ (x ktail-0) (+ x n ktail-0)))
-             (g (λ (y ktail-1) (+ y g ktail-1))))
-      (prim (cons f g) ktail)))
-#+end_src
-
-#+begin_src scheme
-  (λ (n m ktail)
-    (letrec ((f-code (λ (x ktail-0)
-                       (prim (env-get 2)
-                         (κ (n)
-                           (+ x n ktail-0)))))
-             (g-code (λ (y ktail-1)
-                       (prim (env-get 3)
-                         (κ (m)
-                           (+ y m ktail-1))))))
-      (letrec ((with-closure-code
-                (κ (f g)
-                  (prim (get-env 0)
-                    (κ (ktail)
-                      (prim cons f g ktail))))))
-        (prim (make-shared-closure (with-closure-code)
-                                   ktail)
-          (κ (with-closure)
-            (prim (make-shared-closure (f-code g-code) n m)
-              with-closure))))))
-#+end_src

doc/libraries.org

@@ -1,19 +0,0 @@
-#+title: on libraries
-
-* libraries and the file system
-
-R⁷RS leaves it unspecified how exactly libraries correspond to files:
-
-#+begin_quote
-Programs and libraries are typically stored in files, although in some implementations they can be entered interactively into a running Scheme system. Other paradigms are possible. Implementations which store libraries in files should document the mapping from the name of a library to its location in the file system.
-#+end_quote
-
-thus the implementation of ~define-library~ is open to much interpretation. we could possibly define libraries as first-class objects, or deal with them statically. the former case is appealing to me, as it could massively simplify interactive use.
-
-* semantics of declaration order
-
-mercifully, R⁷RS is similarly ambiguous when it comes to the significance of declaration order. the authors note explicitly example two equally acceptable approaches:
-
-#+begin_quote
-One possible implementation of libraries is as follows: _After all cond-expand library declarations are expanded, a new environment is constructed for the library consisting of all imported bindings._ The expressions from all begin, include and include-ci library declarations are expanded in that environment in the order in which they occur in the library. _Alternatively, cond-expand and import declarations may be processed in left to right order interspersed with the processing of other declarations_, with the environment growing as imported bindings are added to it by each import declaration.
-#+end_quote

doc/make-vm-stackier.org

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

flake.nix

@@ -20,13 +20,12 @@
       overlays = [
         haskellNix.overlay
         (final: prev: {
-          gyehoek-wasm-runtime = final.callPackage ./wasm-runtime {
+          gyehoek-runtime = final.callPackage ./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
@@ -34,16 +33,14 @@
                     pkgs.git # tasty uses git diff
                   ];
                 in ''
-                  export GYEHOEK_WASM_RUNTIME=${
+                  export GYEHOEK_RUNTIME=${lib.getExe final.gyehoek-runtime}
-                    lib.getExe final.gyehoek-wasm-runtime
-                  }
                   export PATH=${lib.makeBinPath bin}:$PATH
                 '';
             })];
             shell = {
               withHoogle = true;
               inputsFrom = [
-                final.gyehoek-wasm-runtime
+                final.gyehoek-runtime
               ];
               tools = {
                 cabal = {};
@@ -55,7 +52,7 @@
                 nodejs
                 wasm-tools
                 wac-cli
-                gauche
+                guile
                 rust-analyzer
                 wasmtime
                 # bashInteractive is necessary to work around an
@@ -94,7 +91,7 @@
         hf.packages.${system} // lib.fix (packages: {
           gyehoek = hf.packages.${system}."gyehoek:exe:gyehoek";
           default = packages.gyehoek;
-          inherit (pkgs) gyehoek-wasm-runtime;
+          inherit (pkgs) gyehoek-runtime;
         }));
 
       devShells = each-system

golden/exec/begin-1/source.scm

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

golden/exec/callcc-nested-2/exec

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

golden/exec/complicated-1/exec

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

golden/exec/complicated-1/source.scm

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

golden/exec/cons-1/exec

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

golden/exec/cons-1/source.scm

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

golden/exec/cons-2/exec

@@ -1,2 +0,0 @@
-ret > ExitSuccess
-out > (456 . 123)

golden/exec/cons-2/source.scm

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

golden/exec/factorial/exec

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

golden/exec/factorial/source.scm

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

golden/exec/lit-int/exec

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

golden/exec/lit-int/source.scm

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

golden/exec/map/exec

@@ -1,2 +0,0 @@
-ret > ExitSuccess
-out > (0 . (1 . (4 . (9 . (16 . ())))))

golden/exec/map/source.scm

@@ -1,7 +0,0 @@
-(letrec ((my-map (λ (f l)
-                   (if (pair? l)
-                       (cons (f (car l))
-                             (my-map f (cdr l)))
-                       (list)))))
-  (my-map (λ (x) (* x x))
-          (list 0 1 2 3 4)))

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

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

golden/print/lambda-nonempty-wide

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

golden/print/lambda-thin

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

golden/print/lambda-wide

@@ -1,2 +0,0 @@
-(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,37 +1,5 @@
-[ MkAnn
+[ SynNone :< SimpleF ( SimpleBoolean True )
-    { position = Just
+, SynNone :< SimpleF ( SimpleBoolean True )
-        ( SourcePos
+, SynNone :< SimpleF ( SimpleBoolean False )
-            { sourceName = "golden/read/bool/source.scm"
+, SynNone :< SimpleF ( SimpleBoolean False )
-            , sourceLine = Pos 1
-            , sourceColumn = Pos 1
-            }
-        )
-    } :< SimpleF ( SimpleBoolean True )
-, MkAnn
-    { position = Just
-        ( SourcePos
-            { sourceName = "golden/read/bool/source.scm"
-            , sourceLine = Pos 1
-            , sourceColumn = Pos 4
-            }
-        )
-    } :< SimpleF ( SimpleBoolean True )
-, MkAnn
-    { position = Just
-        ( SourcePos
-            { sourceName = "golden/read/bool/source.scm"
-            , sourceLine = Pos 1
-            , sourceColumn = Pos 10
-            }
-        )
-    } :< SimpleF ( SimpleBoolean False )
-, MkAnn
-    { position = Just
-        ( SourcePos
-            { sourceName = "golden/read/bool/source.scm"
-            , sourceLine = Pos 1
-            , sourceColumn = Pos 13
-            }
-        )
-    } :< SimpleF ( SimpleBoolean False )
 ]

golden/read/datum-comment/source.scm

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

golden/read/decimal/read

@@ -1,32 +1,8 @@
-[ MkAnn
+[ SynNone :< SimpleF
-    { position = Just
-        ( SourcePos
-            { sourceName = "golden/read/decimal/source.scm"
-            , sourceLine = Pos 1
-            , sourceColumn = Pos 1
-            }
-        )
-    } :< SimpleF
     ( SimpleNumber 45.0 )
-, MkAnn
+, SynNone :< SimpleF
-    { position = Just
-        ( SourcePos
-            { sourceName = "golden/read/decimal/source.scm"
-            , sourceLine = Pos 1
-            , sourceColumn = Pos 4
-            }
-        )
-    } :< SimpleF
     ( SimpleNumber 5667.0 )
-, MkAnn
+, SynNone :< SimpleF
-    { 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,56 +1,16 @@
-[ MkAnn
+[ SynNone :< CompoundF
-    { position = Just
-        ( SourcePos
-            { sourceName = "golden/read/list-dot-flat/source.scm"
-            , sourceLine = Pos 1
-            , sourceColumn = Pos 1
-            }
-        )
-    } :< CompoundF
     ( DotListF
         (
-            ( MkAnn
+            ( SynNone :< SimpleF
-                { position = Just
-                    ( SourcePos
-                        { sourceName = "golden/read/list-dot-flat/source.scm"
-                        , sourceLine = Pos 1
-                        , sourceColumn = Pos 2
-                        }
-                    )
-                } :< SimpleF
                 ( SimpleSymbol "가" )
             ) :|
-            [ MkAnn
+            [ SynNone :< SimpleF
-                { position = Just
-                    ( SourcePos
-                        { sourceName = "golden/read/list-dot-flat/source.scm"
-                        , sourceLine = Pos 1
-                        , sourceColumn = Pos 5
-                        }
-                    )
-                } :< SimpleF
                 ( SimpleSymbol "나" )
-            , MkAnn
+            , SynNone :< SimpleF
-                { position = Just
-                    ( SourcePos
-                        { sourceName = "golden/read/list-dot-flat/source.scm"
-                        , sourceLine = Pos 1
-                        , sourceColumn = Pos 8
-                        }
-                    )
-                } :< SimpleF
                 ( SimpleSymbol "다" )
             ]
         )
-        ( MkAnn
+        ( SynNone :< SimpleF
-            { 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,82 +1,18 @@
-[ MkAnn
+[ SynNone :< CompoundF
-    { position = Just
+    ( ListF Ordinary
-        ( SourcePos
+        [ SynNone :< SimpleF
-            { sourceName = "golden/read/list-flat/source.scm"
-            , sourceLine = Pos 1
-            , sourceColumn = Pos 1
-            }
-        )
-    } :< CompoundF
-    ( ListF StyleData
-        [ MkAnn
-            { position = Just
-                ( SourcePos
-                    { sourceName = "golden/read/list-flat/source.scm"
-                    , sourceLine = Pos 1
-                    , sourceColumn = Pos 2
-                    }
-                )
-            } :< SimpleF
             ( SimpleSymbol "가" )
-        , MkAnn
+        , SynNone :< SimpleF
-            { position = Just
-                ( SourcePos
-                    { sourceName = "golden/read/list-flat/source.scm"
-                    , sourceLine = Pos 1
-                    , sourceColumn = Pos 5
-                    }
-                )
-            } :< SimpleF
             ( SimpleSymbol "나" )
-        , MkAnn
+        , SynNone :< SimpleF
-            { position = Just
-                ( SourcePos
-                    { sourceName = "golden/read/list-flat/source.scm"
-                    , sourceLine = Pos 1
-                    , sourceColumn = Pos 8
-                    }
-                )
-            } :< SimpleF
             ( SimpleSymbol "다" )
-        , MkAnn
+        , SynNone :< SimpleF
-            { position = Just
-                ( SourcePos
-                    { sourceName = "golden/read/list-flat/source.scm"
-                    , sourceLine = Pos 1
-                    , sourceColumn = Pos 11
-                    }
-                )
-            } :< SimpleF
             ( SimpleSymbol "라" )
-        , MkAnn
+        , SynNone :< SimpleF
-            { position = Just
-                ( SourcePos
-                    { sourceName = "golden/read/list-flat/source.scm"
-                    , sourceLine = Pos 1
-                    , sourceColumn = Pos 14
-                    }
-                )
-            } :< SimpleF
             ( SimpleNumber 1.0 )
-        , MkAnn
+        , SynNone :< SimpleF
-            { position = Just
-                ( SourcePos
-                    { sourceName = "golden/read/list-flat/source.scm"
-                    , sourceLine = Pos 1
-                    , sourceColumn = Pos 16
-                    }
-                )
-            } :< SimpleF
             ( SimpleNumber 2.0 )
-        , MkAnn
+        , SynNone :< SimpleF
-            { 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,133 +1,37 @@
-[ MkAnn
+[ SynNone :< CompoundF
-    { position = Just
-        ( SourcePos
-            { sourceName = "golden/read/list/source.scm"
-            , sourceLine = Pos 1
-            , sourceColumn = Pos 1
-            }
-        )
-    } :< CompoundF
     ( DotListF
         (
-            ( MkAnn
+            ( SynNone :< SimpleF
-                { position = Just
-                    ( SourcePos
-                        { sourceName = "golden/read/list/source.scm"
-                        , sourceLine = Pos 1
-                        , sourceColumn = Pos 2
-                        }
-                    )
-                } :< SimpleF
                 ( SimpleSymbol "a" )
             ) :|
-            [ MkAnn
+            [ SynNone :< SimpleF
-                { position = Just
-                    ( SourcePos
-                        { sourceName = "golden/read/list/source.scm"
-                        , sourceLine = Pos 1
-                        , sourceColumn = Pos 4
-                        }
-                    )
-                } :< SimpleF
                 ( SimpleSymbol "b" )
-            , MkAnn
+            , SynNone :< CompoundF
-                { position = Just
+                ( ListF Ordinary
-                    ( SourcePos
+                    [ SynNone :< SimpleF
-                        { sourceName = "golden/read/list/source.scm"
-                        , sourceLine = Pos 1
-                        , sourceColumn = Pos 6
-                        }
-                    )
-                } :< CompoundF
-                ( ListF StyleData
-                    [ MkAnn
-                        { position = Just
-                            ( SourcePos
-                                { sourceName = "golden/read/list/source.scm"
-                                , sourceLine = Pos 1
-                                , sourceColumn = Pos 7
-                                }
-                            )
-                        } :< SimpleF
                         ( SimpleSymbol "c" )
-                    , MkAnn
+                    , SynNone :< SimpleF
-                        { position = Just
-                            ( SourcePos
-                                { sourceName = "golden/read/list/source.scm"
-                                , sourceLine = Pos 1
-                                , sourceColumn = Pos 9
-                                }
-                            )
-                        } :< SimpleF
                         ( SimpleSymbol "d" )
                     ]
                 )
             ]
         )
-        ( MkAnn
+        ( SynNone :< CompoundF
-            { position = Just
+            ( ListF Ordinary
-                ( SourcePos
+                [ SynNone :< SimpleF
-                    { sourceName = "golden/read/list/source.scm"
-                    , sourceLine = Pos 1
-                    , sourceColumn = Pos 14
-                    }
-                )
-            } :< CompoundF
-            ( ListF StyleData
-                [ MkAnn
-                    { position = Just
-                        ( SourcePos
-                            { sourceName = "golden/read/list/source.scm"
-                            , sourceLine = Pos 1
-                            , sourceColumn = Pos 15
-                            }
-                        )
-                    } :< SimpleF
                     ( SimpleSymbol "가" )
-                , MkAnn
+                , SynNone :< CompoundF
-                    { position = Just
-                        ( SourcePos
-                            { sourceName = "golden/read/list/source.scm"
-                            , sourceLine = Pos 1
-                            , sourceColumn = Pos 18
-                            }
-                        )
-                    } :< CompoundF
                     ( DotListF
                         (
-                            ( MkAnn
+                            ( SynNone :< SimpleF
-                                { position = Just
-                                    ( SourcePos
-                                        { sourceName = "golden/read/list/source.scm"
-                                        , sourceLine = Pos 1
-                                        , sourceColumn = Pos 19
-                                        }
-                                    )
-                                } :< SimpleF
                                 ( SimpleSymbol "나" )
                             ) :| []
                         )
-                        ( MkAnn
+                        ( SynNone :< SimpleF
-                            { position = Just
-                                ( SourcePos
-                                    { sourceName = "golden/read/list/source.scm"
-                                    , sourceLine = Pos 1
-                                    , sourceColumn = Pos 24
-                                    }
-                                )
-                            } :< SimpleF
                             ( SimpleSymbol "다" )
                         )
                     )
-                , MkAnn
+                , SynNone :< SimpleF
-                    { position = Just
-                        ( SourcePos
-                            { sourceName = "golden/read/list/source.scm"
-                            , sourceLine = Pos 1
-                            , sourceColumn = Pos 28
-                            }
-                        )
-                    } :< SimpleF
                     ( SimpleSymbol "라" )
                 ]
             )

golden/read/meta-expression/read

@@ -1,10 +0,0 @@
-[ MkAnn
-    { 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

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

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

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

golden/read/meta-splice-expression/read

@@ -1,10 +0,0 @@
-[ MkAnn
-    { 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

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

golden/read/meta-splice-variable/read

@@ -1,10 +0,0 @@
-[ MkAnn
-    { 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

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

golden/read/meta-variable/read

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

golden/read/meta-variable/source.scm

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

golden/read/peculiar-identifier-dot/read

@@ -1,61 +1,7 @@
-[ MkAnn
+[ SynNone :< SimpleF
-    { position = Just
-        ( SourcePos
-            { sourceName = "golden/read/peculiar-identifier-dot/source.scm"
-            , sourceLine = Pos 1
-            , sourceColumn = Pos 1
-            }
-        )
-    } :< SimpleF
-    ( SimpleSymbol "..." )
-, MkAnn
-    { position = Just
-        ( SourcePos
-            { sourceName = "golden/read/peculiar-identifier-dot/source.scm"
-            , sourceLine = Pos 2
-            , sourceColumn = Pos 1
-            }
-        )
-    } :< SimpleF
     ( SimpleSymbol ".." )
-, MkAnn
+, SynNone :< SimpleF
-    { position = Just
-        ( SourcePos
-            { sourceName = "golden/read/peculiar-identifier-dot/source.scm"
-            , sourceLine = Pos 3
-            , sourceColumn = Pos 1
-            }
-        )
-    } :< SimpleF
     ( SimpleSymbol ".abc" )
-, MkAnn
+, SynNone :< SimpleF
-    { position = Just
-        ( SourcePos
-            { sourceName = "golden/read/peculiar-identifier-dot/source.scm"
-            , sourceLine = Pos 4
-            , sourceColumn = Pos 1
-            }
-        )
-    } :< SimpleF
     ( SimpleSymbol "....abcc" )
-, MkAnn
-    { position = Just
-        ( SourcePos
-            { sourceName = "golden/read/peculiar-identifier-dot/source.scm"
-            , sourceLine = Pos 5
-            , sourceColumn = Pos 1
-            }
-        )
-    } :< SimpleF
-    ( SimpleSymbol ".++-" )
-, MkAnn
-    { position = Just
-        ( SourcePos
-            { sourceName = "golden/read/peculiar-identifier-dot/source.scm"
-            , sourceLine = Pos 6
-            , sourceColumn = Pos 1
-            }
-        )
-    } :< SimpleF
-    ( SimpleSymbol ".-" )
 ]

golden/read/peculiar-identifier-dot/source.scm

@@ -1,6 +1 @@
-...
+.. .abc ....abcc
-..
-.abc
-....abcc
-.++-
-.-

golden/read/peculiar-identifier-sign/read

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

golden/read/peculiar-identifier-sign/source.scm

@@ -1,3 +1 @@
 + -
-
-+. +.. -. -...abc -abc..

golden/read/string/read

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

golden/read/typical-identifier-token/read

@@ -1,52 +1,12 @@
-[ MkAnn
+[ SynNone :< SimpleF
-    { position = Just
-        ( SourcePos
-            { sourceName = "golden/read/typical-identifier-token/source.scm"
-            , sourceLine = Pos 1
-            , sourceColumn = Pos 1
-            }
-        )
-    } :< SimpleF
     ( SimpleSymbol "abc" )
-, MkAnn
+, SynNone :< SimpleF
-    { position = Just
-        ( SourcePos
-            { sourceName = "golden/read/typical-identifier-token/source.scm"
-            , sourceLine = Pos 1
-            , sourceColumn = Pos 4
-            }
-        )
-    } :< SimpleF
     ( SimpleString "xyz" )
-, MkAnn
+, SynNone :< SimpleF
-    { position = Just
-        ( SourcePos
-            { sourceName = "golden/read/typical-identifier-token/source.scm"
-            , sourceLine = Pos 2
-            , sourceColumn = Pos 1
-            }
-        )
-    } :< SimpleF
     ( SimpleSymbol "수학" )
-, MkAnn
+, SynNone :< CompoundF
-    { position = Just
+    ( ListF Ordinary
-        ( SourcePos
+        [ SynNone :< SimpleF
-            { sourceName = "golden/read/typical-identifier-token/source.scm"
-            , sourceLine = Pos 2
-            , sourceColumn = Pos 5
-            }
-        )
-    } :< CompoundF
-    ( ListF StyleData
-        [ MkAnn
-            { 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,91 +1,19 @@
-[ MkAnn
+[ SynNone :< SimpleF
-    { position = Just
-        ( SourcePos
-            { sourceName = "golden/read/typical-identifier/source.scm"
-            , sourceLine = Pos 1
-            , sourceColumn = Pos 1
-            }
-        )
-    } :< SimpleF
     ( SimpleSymbol "abc" )
-, MkAnn
+, SynNone :< SimpleF
-    { position = Just
-        ( SourcePos
-            { sourceName = "golden/read/typical-identifier/source.scm"
-            , sourceLine = Pos 1
-            , sourceColumn = Pos 5
-            }
-        )
-    } :< SimpleF
     ( SimpleSymbol "bala-hwa$" )
-, MkAnn
+, SynNone :< SimpleF
-    { position = Just
-        ( SourcePos
-            { sourceName = "golden/read/typical-identifier/source.scm"
-            , sourceLine = Pos 1
-            , sourceColumn = Pos 15
-            }
-        )
-    } :< SimpleF
     ( SimpleSymbol "x!!!" )
-, MkAnn
+, SynNone :< SimpleF
-    { position = Just
-        ( SourcePos
-            { sourceName = "golden/read/typical-identifier/source.scm"
-            , sourceLine = Pos 1
-            , sourceColumn = Pos 20
-            }
-        )
-    } :< SimpleF
     ( SimpleSymbol "z" )
-, MkAnn
+, SynNone :< SimpleF
-    { position = Just
-        ( SourcePos
-            { sourceName = "golden/read/typical-identifier/source.scm"
-            , sourceLine = Pos 1
-            , sourceColumn = Pos 22
-            }
-        )
-    } :< SimpleF
     ( SimpleSymbol "z123" )
-, MkAnn
+, SynNone :< SimpleF
-    { position = Just
-        ( SourcePos
-            { sourceName = "golden/read/typical-identifier/source.scm"
-            , sourceLine = Pos 1
-            , sourceColumn = Pos 27
-            }
-        )
-    } :< SimpleF
     ( SimpleSymbol "나는너무졸리다" )
-, MkAnn
+, SynNone :< SimpleF
-    { position = Just
-        ( SourcePos
-            { sourceName = "golden/read/typical-identifier/source.scm"
-            , sourceLine = Pos 1
-            , sourceColumn = Pos 42
-            }
-        )
-    } :< SimpleF
     ( SimpleSymbol "學" )
-, MkAnn
+, SynNone :< SimpleF
-    { position = Just
-        ( SourcePos
-            { sourceName = "golden/read/typical-identifier/source.scm"
-            , sourceLine = Pos 3
-            , sourceColumn = Pos 1
-            }
-        )
-    } :< SimpleF
     ( SimpleSymbol "車室." )
-, MkAnn
+, SynNone :< SimpleF
-    { position = Just
-        ( SourcePos
-            { sourceName = "golden/read/typical-identifier/source.scm"
-            , sourceLine = Pos 5
-            , sourceColumn = Pos 1
-            }
-        )
-    } :< SimpleF
     ( SimpleSymbol "三個女人一臺戲。" )
 ]

gyehoek.cabal

@@ -13,11 +13,6 @@ 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
@@ -26,7 +21,6 @@ common ghcstuffs
   ghc-options:
     -Wall -fdefer-type-errors -fno-show-valid-hole-fits
     -fdefer-out-of-scope-variables -threaded
-    -Wno-name-shadowing -Wno-partial-type-signatures
 
   default-extensions:
     BlockArguments
@@ -55,33 +49,28 @@ executable gyehoek
 library
   import:           ghcstuffs, ghcstuffs-dev
   ghc-options:      -fplugin=Effectful.Plugin
-  -- build-tool-depends: retrie:retrie
 
   -- cabal-fmt: expand src
   exposed-modules:
     Gyehoek.CPS.Close
     Gyehoek.CPS.Convert
     Gyehoek.CPS.Eval
-    Gyehoek.CPS.Hoist
+    Gyehoek.CPS.Lower
+    Gyehoek.CPS.Stackify
     Gyehoek.CPS.Syntax
     Gyehoek.Driver
     Gyehoek.GenSym
-    Gyehoek.Jalmot
     Gyehoek.Language
-    Gyehoek.Language.Common
-    Gyehoek.Lift1
     Gyehoek.Options
     Gyehoek.Prelude
-    Gyehoek.Scheme.Expand
-    Gyehoek.Scheme.Expand.Old
     Gyehoek.Scheme.Syntax
     Gyehoek.Sexp
     Gyehoek.Sexp.Grammar
-    Gyehoek.Sexp.Grammar.Base
     Gyehoek.Sexp.Print
-    Gyehoek.Sexp.QQ
     Gyehoek.Sexp.Read
     Gyehoek.Sexp.Syntax
+    Gyehoek.Stack.Syntax
+    Gyehoek.Stack.VM
     Gyehoek.Wasm
 
   build-depends:
@@ -102,7 +91,6 @@ library
     , hashable
     , invertible-grammar
     , lens
-    , lucid
     , megaparsec
     , mtl
     , optparse-applicative
@@ -110,21 +98,17 @@ library
     , pretty-simple
     , prettyprinter
     , prettyprinter-ansi-terminal
-    , prettyprinter-lucid
     , process
     , recursion-schemes
     , scientific
-    , semialign
+    , sexp-grammar
     , string-interpolate
-    , tardis
     , template-haskell
     , text
     , text-short
-    , these
     , typed-process
     , unordered-containers
     , vector
-    , witherable
 
   hs-source-dirs:   src
   default-language: GHC2024
@@ -139,12 +123,13 @@ test-suite test
   -- cabal-fmt: expand test -Main
   other-modules:
     Gyehoek.Test.CPS.Eval
+    Gyehoek.Test.CPS.Stackify
     Gyehoek.Test.CPS.Syntax
+    Gyehoek.Test.Golden
     Gyehoek.Test.Scheme.Syntax
+    Gyehoek.Test.Sexp
     Gyehoek.Test.Sexp.Print
-    Gyehoek.Test.Sexp.QQ
+    Gyehoek.Test.Stack.VM
-    Gyehoek.Test.Sexp.Read
-    Gyehoek.TestUtil
     Root
 
   build-depends:
@@ -158,6 +143,7 @@ test-suite test
     , lens
     , pretty-simple
     , process-extras
+    , sexp-grammar
     , tasty
     , tasty-expected-failure
     , tasty-hunit
@@ -165,21 +151,3 @@ 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

macroexpand.scm

@@ -1,11 +0,0 @@
-(define-syntax if-not
-  (syntax-rules ()
-    ((_ c t f) (if (not c) t f))
-    ((_ c t) (if (not c) t))))
-
-(write (macroexpand-1 '(if-not #t 123 456)))
-
-(define (main)
-  (let loop ((datum (read)))
-    (unless (eof-object? datum)
-      ())))

runtime/Cargo.lock

@@ -663,7 +663,7 @@ dependencies = [
 ]
 
 [[package]]
-name = "gyehoek-wasm-runtime"
+name = "gyehoek-runtime"
 version = "0.1.0"
 dependencies = [
  "clap",

runtime/Cargo.toml

@@ -1,5 +1,5 @@
 [package]
-name = "gyehoek-wasm-runtime"
+name = "gyehoek-runtime"
 version = "0.1.0"
 edition = "2024"
 

runtime/default.nix

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

runtime/src/main.rs

@@ -8,7 +8,7 @@ use clio::*;
 use clap::Parser;
 use wasmtime::*;
 
-/// A Wasm runtime for Gyehoek scheme.
+/// A runtime for Gyehoek scheme.
 #[derive(Parser, Debug)]
 #[command(name = "gyehoek", version, about, long_about = None)]
 struct Args {

src/Gyehoek/CPS/Close.hs

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

src/Gyehoek/CPS/Convert.hs

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

src/Gyehoek/CPS/Eval.hs

@@ -1,303 +1,79 @@
 {-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE OverloadedLists #-}
 module Gyehoek.CPS.Eval
   ( evalProgram
   , module Gyehoek.CPS.Syntax
-  , evalExp
-  , eGrammar
   ) where
 
-import Gyehoek.CPS.Syntax hiding (Hob(..), Obj(..), cont)
+import Gyehoek.CPS.Syntax
-import Gyehoek.Sexp qualified as S
+import Control.Lens
-import Control.Lens hiding (assign)
+import Data.Maybe (fromMaybe)
-import Data.Maybe (fromMaybe, isJust)
 import Text.Show.Functions ()
 import qualified Data.HashMap.Strict as H
-import Gyehoek.Prelude hiding (assign)
+import Gyehoek.Prelude
-import Debug.Pretty.Simple
-import Gyehoek.Jalmot
-import Control.Monad.Cont
-import Gyehoek.Sexp qualified as S
-import GHC.Generics (Generically(..))
-import Gyehoek.Sexp ((:-)(..))
-import Data.List (nub, mapAccumR, compareLength)
-import Data.HashSet.Lens (setOf)
-import Data.IntMap.Strict (IntMap)
-import Data.IntMap.Strict qualified as IM
-import Data.Monoid
-import Control.Monad.State
-import Data.Traversable (for)
-import Data.Foldable (traverse_, foldrM)
 
 
-newtype Loc = MkLoc { getLoc :: Int }
+data Env = MkEnv
-  deriving stock (Generic, Data)
+  { vars :: HashMap Name Obj
-  deriving newtype (Show, Eq, Ord, Enum)
+  , labels :: HashMap Name (Env, Abs)
-
-data Store = MkStore
-  { nextLoc :: Loc
-  , heap :: IntMap E
   }
-  deriving stock (Show, Generic)
-
-type instance Index Store = Loc
-type instance IxValue Store = E
-
-instance Ixed Store where ix (MkLoc j) = #heap . ix j
-instance At Store where at (MkLoc j) = #heap . at j
-
-emptyStore :: Store
-emptyStore = MkStore
-  { nextLoc = MkLoc 0
-  , heap = mempty
-  }
-
-newtype Env = MkEnv { getEnv :: HashMap Name Loc }
-  deriving stock (Show, Generic, Data)
-  deriving newtype (Semigroup, Monoid)
-
-emptyEnv :: Env
-emptyEnv = mempty
-
-type instance Index Env = Name
-type instance IxValue Env = Loc
-
-instance Ixed Env where ix j = #getEnv . ix j
-instance At Env where at j = #getEnv . at j
-
-update :: Loc -> E -> Store -> Store
-update (MkLoc loc) v = #heap %~ IM.alter f loc
-  where
-    f (Just _) = Just v
-    f Nothing = error "segfault lol"
-
-updates :: Foldable f => f (Loc, E) -> Store -> Store
-updates = alaf Endo foldMap (uncurry update)
-
-fetch :: Loc -> M r E
-fetch (MkLoc loc) = gets (^?! #heap . ix loc)
-
-new :: M r Loc
-new = state \st -> (st.nextLoc, st & #nextLoc %~ succ)
-
-new' :: E -> M r Loc
-new' e = state \st ->
-  ( st.nextLoc
-  , st & #nextLoc %~ succ & at st.nextLoc ?~ e
-  )
-
-defines :: Traversable t => t (Name, E) -> M Answer Env
-defines = alaf Ap foldMap \(name,e) -> do
-  l <- new' e
-  pure $ bind name l
-
-var :: HasCallStack => Env -> Name -> M Answer Loc
-var g x = case g ^. at x of
-  Just l -> pure l
-  Nothing -> wrong [i|unbound variable #{x}|]
-
-type CmdCont = Store -> Answer
-type ExpCont = List E -> CmdCont
-
-type M r = ContT r (State Store)
-
-data Answer
-  = AnswerValues (List E)
-  | AnswerError AJalmot
   deriving (Show, Generic)
 
-data Mutability
+eval :: Env -> Exp -> List Obj
-  = Mut
-  | NoMut
-  deriving (Show, Generic, Data, Eq)
 
-wrong :: Text -> M Answer a
+eval g (Halt xs) = evalVal g <$> xs
-wrong s = ContT \_ -> pure . AnswerError . EvalError $ s
 
-orWrong
+eval g (ExpContinue k xs) =
-  :: Getting (First a) s a
+  case g ^. #labels . at k of
-  -> Text -> s -> M Answer a
+    Just (h, AbsKappa' bs m) -> eval h' m
-orWrong p msg s = case getFirst . getConst $ p (Const . First . Just) s of
+      where h' = h & #vars <>~ envOfBinds bs (evalVal g <$> xs)
-  Nothing -> wrong msg
+    _ -> error [i|not a kappa: #{k}|]
-  Just x -> pure x
 
-bind :: Name -> Loc -> Env
+eval g (ExpApply ((^?! #ValVar) -> f) xs ktail) =
-bind k = MkEnv . H.singleton k
+  case g ^?! #labels . at f of
+    Just (h,AbsLambda' bs kb m) -> eval h' m
+      where h' = h & #vars <>~ envOfBinds bs (evalVal g <$> xs)
+                   & #labels . at kb .~ (g ^. #labels . at ktail)
+    Nothing -> error [i|undefined label: #{f}|]
 
-extends :: Foldable f => f (Name, Loc) -> Env -> Env
+eval g (ExpLetRec [(b, ab)] e) = eval g' e
-extends xs g = g <> foldMap (uncurry bind) xs
+  where g' = g & #labels . at b ?~ (g,ab)
 
-assign :: Loc -> E -> M Answer ()
+eval g (ExpPrim p (MkKappa bs e)) = case evalVal g <$> p of
-assign l e = do
+  PrimAdd x y -> arithBinop (+) x y
-  use (at l) >>= \case
+  PrimMul x y -> arithBinop (*) x y
-    Just _ -> at l ?= e
+  PrimSub x y -> arithBinop (-) x y
-    Nothing -> wrong [i|#{e}에서 #{l}이라는 주소는 없다|]
+  PrimDiv x y -> arithBinop div x y
-
+  _ -> error [i|unhandled prim: #{p}|]
-
-
--- | The denotation of an expressed value.
-data E
-  = ESymbol Text
-  | ECharacter Char
-  | EInt Int
-  | EBool Bool
-  | EUndefined
-  | EUnspecified
-  | ENull
-  | EPair Mutability Loc Loc
-  | EVec Mutability (List Loc)
-  | EString Mutability (List Loc)
-  | EProcedure Procedure
-  deriving stock (Show, Generic)
-
-type Procedure = List E -> DynPoints -> M Answer (List E)
-
-eGrammar :: Store -> S.DatumGrammar E
-eGrammar st = S.partialOsi (const . Left $ mempty) go
   where
-    gofetch x = go $ st ^?! ix x
+    ret rs = eval
-    go = \case
+        (g & #vars <>~ envOfBinds bs rs)
-      ESymbol s -> S.Symbol s
+        e
-      ECharacter c -> S.Character c
+    arithBinop f (ObjImm (ImmInt x)) (ObjImm (ImmInt y)) =
-      EInt n -> S.Number (fromIntegral n)
+      ret [ObjImm . ImmInt $ f x y]
-      EBool b -> S.Boolean b
+    arithBinop _ x y = error [i|bad arith: #{x}, #{y}|]
-      EUndefined -> S.Unreadable "#<undefined>"
-      EUnspecified -> S.Unreadable "#<unspecified>"
-      EProcedure _ -> S.Unreadable "#<procedure>"
-      ENull -> S.List []
-      EPair _mut car cdr -> S.DotList [gofetch car] (gofetch cdr)
-      EVec _mut xs -> S.Vector . fmap gofetch $ xs
-      EString _mut xs -> S.String _
 
-data DynPoints = MkDynPoints
+eval _ e = error [i|unimplemented case: #{e}|]
-  deriving (Generic, Data)
 
-
+envOfBinds bs xs = foldMap (uncurry H.singleton) (zip bs xs)
 
-truthy :: E -> Bool
+evalVal :: Env -> Val -> Obj
-truthy (EBool False) = False
+evalVal g = \case
-truthy _ = True
+  ValVar x -> fromMaybe (error [i|unbound: #{x}|]) $ g ^?! #vars . at x
+  ValImm x -> ObjImm x
 
-
+emptyEnv :: Env
+emptyEnv = MkEnv
+  { vars = mempty
+  -- a kinda silly hack to make sure `halt` is handled correctly when
+  -- it appears as the tail continuation of an application. the
+  -- special case of `eval` responsible for `halt` only covers terms
+  -- of the form `(continue $halt xs …)`; other terms such as
+  -- `($some-fn xs $halt)` just see an undefined label `$halt`.
+  , labels = H.singleton "halt"
+    ( emptyEnv
+    , AbsKappa' ["h0"] $ Halt [ValVar "h0"]
+    )
+  }
 
-evalVal :: Env -> Val -> M Answer E
+evalProgram :: Program -> List Obj
-
+evalProgram (MkProgram e) = eval emptyEnv e
-evalVal g (ValVar x) = var g x >>= fetch
-
-evalVal g (ValImm imm) = case imm of
-  ImmLabel (MkLabel l) -> var g l >>= fetch
-  ImmInt n -> pure $ EInt n
-  ImmBool b -> pure $ EBool b
-  ImmUndefined -> pure EUndefined
-
-evalKexp :: Env -> Kexp -> M Answer E
-evalKexp g (KexpVar x) = var g x >>= fetch
-evalKexp g (KexpKappa kap) = evalAbs g (AbsKappa kap)
-
-evalAbs :: Env -> Abs -> M Answer E
-evalAbs g (MkAbs formals ktail e) = pure . EProcedure $ \xs dps ->
-  let
-    formals' = formals ++ foldMap (:[]) ktail
-    lformals = length formals'
-    lxs = length xs
-  in if lformals /= lxs
-  then wrong [i|함수는 #{lformals}개의 인자를 필요로 하는데 #{lxs}개 받았다.|]
-  else do
-    ls <- xs & traverse new'
-    let g' = g & extends (zip formals' ls)
-    eval g' dps e
-
-eval :: Env -> DynPoints -> Exp -> M Answer (List E)
-
-eval g dps (ExpJump f xs ktail) = do
-  f' <- evalVal g f
-  xs' <- traverse (evalVal g) xs
-  ktail' <- traverse (evalKexp g) (ktail ^.. _Just)
-  case f' of
-    EProcedure p -> p (xs' ++ ktail') dps
-    _ -> wrong "bad procedure"
-
-eval g dps (ExpLetRec bs e) = do
-  ls <- for bs . const $ new' EUndefined
-  let g' = g & extends (zip (bs ^.. each . _1) ls)
-  bs' <- forOf (each . _2) bs (evalAbs g')
-  traverse_ (uncurry assign) $ zip ls (bs' ^.. each . _2)
-  eval g' dps e
-
-eval g dps (ExpBuiltin (BuiltinCallCC withcc) k) = do
-  withcc' <- evalVal g withcc >>= orWrong #_EProcedure
-    [i|call/cc: 함수가 아닌 것을 받았다|]
-  k' <- evalKexp g k
-  kproc <- orWrong #_EProcedure [i|call/cc: 몰라...|] k'
-  let cc = EProcedure \xs dps -> case unsnoc xs of
-        Just (xs',_) -> kproc xs' dps
-        Nothing -> wrong [i|call/cc: 잘못하는데!|]
-  withcc' [cc,k'] dps
-
-eval g dps (ExpBuiltin p k) = do
-  p' <- evalBuiltin g dps =<< traverse (evalVal g) p
-  evalKexp g k >>= \case
-    EProcedure fp -> fp p' dps
-    _ -> wrong [i|prim(#{p})의 계속을 나쁘다|]
-
-eval g dps (ExpIf c t f) = do
-  c' <- evalVal g c
-  let b = if truthy c' then t else f
-  var g b >>= fetch >>= \case
-    EProcedure fp -> fp [] dps
-    _ -> wrong [i|if의 계속을 나쁘다|]
-
-eval g dps e = error [i|unimplemented #{e}|]
-
-evalBuiltin :: Env -> DynPoints -> Builtin E -> M Answer (List E)
-evalBuiltin g dps = \case
-  BuiltinAdd x y -> arith2 (+) x y
-  BuiltinMul x y -> arith2 (*) x y
-  BuiltinSub x y -> arith2 (-) x y
-  BuiltinDiv x y -> arith2 div x y
-  BuiltinZeroP x -> pure1 . EBool . isJust $ x ^? #EInt . only 0
-  BuiltinCons x y -> pcons x y >>= pure1
-  BuiltinCar p -> cr p _2
-  BuiltinCdr p -> cr p _3
-  BuiltinPairP p -> pure1 . EBool . maybe False (const True) $
-    p ^? #_EPair
-  BuiltinValues xs -> pure xs
-  BuiltinList xs -> foldrM pcons ENull xs >>= pure1
-  p -> wrong [i|prim(#{p})은 벌써 나지 않다|]
-  where
-    pure1 x = pure [x]
-    pcons x y = do
-      (x',y') <- traverseOf both new' (x,y)
-      pure $ EPair Mut x' y'
-    arith2 f (EInt x) (EInt y) = pure [EInt $ f x y]
-    arith2 f x y = wrong [i|나쁜 인자: #{x}, #{y}|]
-    cr p l = orWrong (#_EPair . l) [i|car/cdr는 pair을 받지 않다|] p
-      >>= fmap (:[]) . fetch
-
-
-
-evalExp :: Jalmot :> es => Exp -> Eff es _
-evalExp e = _
-
-evalProgram :: Jalmot :> es => Program -> Eff es (List S.Datum)
-evalProgram (MkProgram lam) = case run (pure . AnswerValues) of
-  (AnswerError jm, _) -> throwError jm
-  (AnswerValues vs, st) -> traverse (S.toDatum $ eGrammar st) vs
-  where
-    run f = (`runState` emptyStore) . (`runContT` f) $ do
-      g <- setup
-      eval g MkDynPoints (ExpLetRec
-        [("_start",AbsLambda lam)]
-        (ExpApply (ValVar "_start") [] (KexpVar "halt")))
-
-
-
-setup :: M Answer Env
-setup = defines @List
-  [ ("halt", EProcedure prim_halt)
-  ]
-
-prim_halt :: Procedure
-prim_halt xs _dps = ContT \_ -> pure $ AnswerValues xs

src/Gyehoek/CPS/Hoist.hs

@@ -1,24 +0,0 @@
-module Gyehoek.CPS.Hoist
-  ( hoistProgram
-  ) where
-
-import Gyehoek.CPS.Syntax
-import Gyehoek.Prelude
-import qualified Data.HashMap.Strict as H
-import Effectful.Writer.Static.Local
-import Data.Foldable
-
-
-type Hoist = Writer (HashMap Label Abs)
-
-hoist :: Hoist :> es => Exp -> Eff es Exp
-hoist = transformM \case
-  ExpLetRec bs m -> do
-    traverse_ (\(k,v) -> tell $ H.singleton (MkLabel k) v) bs
-    pure m
-  e -> pure e
-
-hoistProgram :: Program -> Eff es HoistedProgram
-hoistProgram p = do
-  (body,bindings) <- runWriter $ traverseOf #body hoist p.body
-  pure $ MkHoistedProgram {body,bindings}

src/Gyehoek/CPS/Lower.hs

@@ -0,0 +1,342 @@
+{-# 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

@@ -0,0 +1,145 @@
+{-# LANGUAGE OverloadedLists #-}
+module Gyehoek.CPS.Stackify
+  ( stackifyExp
+  , stackifyProgram
+  , module Gyehoek.CPS.Syntax
+  ) where
+
+import Gyehoek.CPS.Syntax
+import Gyehoek.Stack.Syntax qualified as Stk
+import Data.Sequence (Seq)
+import Data.Sequence qualified as Seq
+import Gyehoek.GenSym
+import Effectful.Writer.Static.Shared
+import Data.Foldable
+import qualified Data.HashMap.Strict as H
+import Data.List (elemIndex)
+import Gyehoek.Prelude
+
+
+type Stackify = Writer Stk.Program
+
+runStackify :: Eff (Stackify : es) a -> Eff es (a, Stk.Program)
+runStackify = runWriter
+
+live :: Free a => Env -> a -> List Name
+live g e = free' e & filter \x ->
+  x `H.member` g.bound
+  && not (x `elem` g.contStack)
+
+stackify
+  :: (GenSym :> es, Stackify :> es)
+  => Env -> Exp -> Eff es (Seq Stk.Instr)
+
+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 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 _ 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}|]
+
+var :: Env -> Name -> Stk.Val
+var g v = case g ^. #bound . at v of
+  Just x -> x
+  Nothing -> Stk.ValLabel v
+
+bindReg :: Name -> (Name, Stk.Val)
+bindReg x = (x, Stk.ValReg x)
+
+
+
+data Env = MkEnv
+  { bound :: HashMap Name Stk.Val
+  -- | for each locally-bound continuation @k@, @liveness@ has an
+  -- entry @(k,ls)@ where @ls@ is the sequence of registers @k@
+  -- expects to find saved on the stack.
+  , liveness :: HashMap Name (List Name)
+  , contStack :: List Name
+  }
+  deriving (Show, Generic)
+
+emptyEnv :: Env
+emptyEnv = MkEnv mempty mempty ["halt"]
+
+
+
+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 :: 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))
+|]

src/Gyehoek/CPS/Syntax.hs

@@ -5,29 +5,24 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE DeriveAnyClass #-}
-{- HLINT ignore "Avoid lambda using `infix`" -}
-{- HLINT ignore "Redundant $" -}
 module Gyehoek.CPS.Syntax
   ( Val(..)
   , Kappa(..)
   , Lambda(..)
   , Exp(..)
-  , Kexp(..)
   , ExpF(..)
   , Name(..)
-  , Builtin(..)
+  , Prim(..)
   , Program(..)
-  , HoistedProgram(..)
   , Lit(..)
   , Imm(..)
   , Obj(..)
   , Hob(..)
-  , Label(..)
+  , pattern Void
-  , Reg(..)
   , pattern Halt
   , pattern Halt1
   , _MkKappa
-  , _ExpBuiltin
+  , _ExpPrim
   , _ExpLetRec
   , _ExpApply
   , _AbsLambda'
@@ -42,31 +37,27 @@ module Gyehoek.CPS.Syntax
   , Abs(..)
   , Free(..)
   , pattern ValLabel
-  , pattern ObjLabel
+  , labelName -- don't like that this is part of the api
-  , absBody
-  , pattern MkAbs
-  , _MkAbs
-  , unhoist
-  , pattern ExpJump
-  , _ExpJump
   )
   where
 
-import Gyehoek.Scheme.Syntax (Name (..), Builtin(..), builtinDatumIso, Lit(..))
+import Language.SexpGrammar qualified as S
-import Gyehoek.Sexp qualified as S
+import Gyehoek.Sexp qualified
+import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primSexpIso, Lit(..), pattern Void)
+import Language.SexpGrammar.Generic
 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 (G, (:-)(..), Datum)
-import qualified Data.InvertibleGrammar.Base as IG
-import Gyehoek.GenSym (Gen)
-import Data.String (IsString)
-import Control.Applicative
-import qualified Data.HashMap.Strict as H
 
 -- Data types
 
@@ -75,24 +66,13 @@ data Val
   | ValVar Name
   deriving (Show, Generic, Data, Eq)
 
-pattern ValLabel :: Label -> Val
+pattern ValLabel :: Name -> Val
 pattern ValLabel x = ValImm (ImmLabel x)
 
-newtype Label = MkLabel { inner :: Name }
-  deriving stock (Generic, Data)
-  deriving newtype (Show, Eq, Gen, IsString, Hashable)
-  deriving anyclass (NFData, Wrapped)
-
-newtype Reg = MkReg { inner :: Name }
-  deriving stock (Generic, Data)
-  deriving newtype (Show, Eq, Gen, IsString, Hashable)
-  deriving anyclass (NFData, Wrapped)
-
 data Imm
   = ImmInt Int
   | ImmBool Bool
-  | ImmLabel Label
+  | ImmLabel Name
-  | ImmUndefined
   deriving stock (Show, Generic, Data, Eq)
   deriving anyclass (NFData)
 
@@ -102,15 +82,9 @@ data Obj
   deriving stock (Show, Generic, Data, Eq)
   deriving anyclass (NFData)
 
-pattern ObjLabel :: Label -> Obj
-pattern ObjLabel l = ObjImm (ImmLabel l)
-
 -- | a heap object.
 data Hob
-  = HobClosure { label :: Label, env :: List Obj }
+  = HobClosure { label :: Name, 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)
 
@@ -125,92 +99,46 @@ data Abs
   | AbsLambda Lambda
   deriving (Show, Generic, Data, Eq)
 
-pattern AbsKappa' :: List Name -> Exp -> Abs
+pattern AbsKappa' :: [Name] -> Exp -> Abs
 pattern AbsKappa' xs e = AbsKappa (MkKappa xs e)
 
-pattern AbsLambda' :: List Name -> Name -> Exp -> Abs
+pattern AbsLambda' :: [Name] -> Name -> Exp -> Abs
 pattern AbsLambda' xs e ktail = AbsLambda (MkLambda xs e ktail)
 
-{-# COMPLETE AbsKappa', AbsLambda' #-}
-
-_MkAbs :: Iso' Abs (List Name, Maybe Name, Exp)
-_MkAbs = iso
-  (\case
-    AbsKappa' xs e -> (xs,Nothing,e)
-    AbsLambda' xs ktail e -> (xs,Just ktail,e))
-  (\(xs,ktail,e) -> case ktail of
-    Just k -> AbsLambda' xs k e
-    Nothing -> AbsKappa' xs e)
-
-pattern MkAbs :: List Name -> Maybe Name -> Exp -> Abs
-pattern MkAbs xs ktail body <- (view _MkAbs -> (xs,ktail,body))
-  where MkAbs xs ktail body = review _MkAbs (xs,ktail,body)
-
-{-# COMPLETE MkAbs #-}
-
-_ExpJump :: Prism' Exp (Val, List Val, Maybe Kexp)
-_ExpJump = prism'
-  (\(f,xs,ktail) -> case ktail of
-    Just k -> ExpApply f xs k
-    Nothing -> ExpContinue f xs)
-  \case
-    ExpApply f xs ktail -> Just (f,xs,Just ktail)
-    ExpContinue f xs -> Just (f,xs,Nothing)
-    _ -> Nothing
-
-pattern ExpJump :: Val -> List Val -> Maybe Kexp -> Exp
-pattern ExpJump f xs ktail <- (preview _ExpJump -> Just (f,xs,ktail))
-  where ExpJump f xs ktail = review _ExpJump (f,xs,ktail)
-
 data Exp
-  = ExpBuiltin (Builtin Val) Kexp
+  = ExpPrim (Prim Val) Kappa
   | ExpLetRec { binders :: List (Name, Abs), body :: Exp }
-  | ExpContinue Val (List Val)
+  | ExpContinue Name (List Val)
-  | ExpIf Val Name Name
+  | ExpIf Val Exp Exp
   | ExpApply
     { op :: Val
     , args :: List Val
-    , cont :: Kexp
+    , cont :: Name
     }
   deriving (Show, Generic, Data, Eq)
 
-data Kexp
-  = KexpVar Name
-  | KexpKappa Kappa
-  deriving (Show, Generic, Data, Eq)
-
 pattern Halt :: List Val -> Exp
-pattern Halt xs = ExpContinue (ValLabel "halt") xs
+pattern Halt xs = ExpContinue "halt" xs
 
 pattern Halt1 :: Val -> Exp
-pattern Halt1 x = ExpContinue (ValLabel "halt") [x]
+pattern Halt1 x = ExpContinue "halt" [x]
 
 data Def = DefConstant Name Exp
   deriving (Show, Generic, Data)
 
-newtype Program = MkProgram
+data Program = MkProgram
-  { body :: Lambda
+  { body :: Exp
   }
   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
@@ -230,193 +158,159 @@ _AbsLambda' = prism'
   (\case AbsLambda' bs ktail e -> Just (bs,ktail,e)
          _ -> Nothing)
 
-instance Plated Exp where plate = uniplate
+instance Plated Exp where
-
+  plate = uniplate
-absBody :: Lens' Abs Exp
+  -- plate k = \case
-absBody = lens
+  --   ExpPrim p kap -> ExpPrim p <$> body k kap
-  (\case
+  --   ExpLetRec bs e -> ExpLetRec <$> (each . _2 . body) k bs <*> k e
-    AbsLambda lam -> lam.body
+  --   ExpContinue c xs -> pure $ ExpContinue c xs
-    AbsKappa kap -> kap.body)
+  --   ExpIf c t f -> ExpIf c <$> k t <*> k f
-  (\cases
+  --   ExpApply f xs ktail -> pure $ ExpApply f xs ktail
-    (AbsLambda lam) b -> AbsLambda $ lam & #body .~ b
-    (AbsKappa kap) b -> AbsKappa $ kap & #body .~ b)
-
-unhoist :: HoistedProgram -> Program
-unhoist p =
-  MkProgram $ p.body & body %~ ExpLetRec
-    (p ^.. #bindings . itraversed . withIndex
-      . to (\(MkLabel l, ab) -> (l,ab)))
 
 
--- DatumIso instances
+-- SexpIso instances
 
-instance S.DatumIso Val where
+instance S.SexpIso Val where
-  datumIso = S.match
+  sexpIso = match
-    $ S.With (\imm -> imm . S.datumIso)
+    $ With (\imm -> imm . S.sexpIso)
-    $ S.With (\var -> var . S.datumIso)
+    $ With (\var -> var . S.sexpIso)
-    $ S.End
+    $ End
 
-instance S.DatumIso Obj where
+instance S.SexpIso Obj where
-  datumIso = S.match
+  sexpIso = match
-    $ S.With (\imm -> imm . S.datumIso)
+    $ With (\imm -> imm . S.sexpIso)
-    $ S.With (\hob -> hob . S.datumIso)
+    $ With (\hob -> hob . S.sexpIso)
-    $ S.End
+    $ End
 
-instance S.DatumIso Imm where
+instance S.SexpIso Imm where
-  datumIso = S.match
+  sexpIso = match
-    $ S.With (. S.int)
+    $ With (. S.int)
-    $ S.With (. S.datumIso)
+    $ With (. GS.schemeBool)
-    $ S.With (. S.datumIso)
+    $ With (. labelName)
-    $ S.With (. S.unreadable (const "#<undefined>"))
+    $ End
-    $ S.End
 
-instance S.DatumIso Label where
+labelName :: S.SexpGrammar Name
-  datumIso = S.with \g -> S.coproduct
+labelName = S.coproduct
-    [ S.datumIso @Name >>> S.prismIso
+  [ S.sexpIso @Name >>> Gyehoek.Sexp.prismIso
-          (S.expected "label")
+        (S.expected "label")
-          (prefixed @Name "$")
+        (prefixed @Name "$")
-    , S.list $ S.el (S.sym "$") >>> S.el (S.datumIso @Name)
+  , S.list $ S.el (S.sym "$") >>> S.el (S.sexpIso @Name)
-    ]
+  ]
-    >>> g
 
-instance S.DatumIso Reg where
+instance S.SexpIso Hob where
-  datumIso = S.with \g ->
+  sexpIso = match
-    S.datumIso @Name >>> S.prismIso
+    $ With (. closure)
-      (S.expected "register")
+    $ End
-      (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 :: G (Datum :- t) (List Obj :- Label :- t)
+      closure :: S.Grammar S.Position (Sexp :- t) (List Obj :- Name :- t)
       closure = IG.Flip $ IG.PartialIso
-        (\(env:-code:-t) -> S.Unreadable [i|\#<procedure $#{code}>|] :- t)
+        (\(env:-code:-t) -> SL.Modified SL.Hash [GS.sx|(#{code} ##{env})|] :- 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.DatumIso Lambda where
+instance S.SexpIso Lambda where
-  datumIso = S.with (lam >>>)
+  sexpIso = match
+    $ With (. lambda)
+    $ End
     where
-      lam :: forall t. G (Datum :- t) (Exp :- Name :- List Name :- t)
+      lambda = S.list $
-      lam = S.lambdaLike
+        S.el Gyehoek.Sexp.lambdaKeyword
-        S.lambdaKeyword
+        >>> S.el binders
-        binders
+        >>> S.el S.sexpIso
-        (S.el $ S.datumIso @Exp)
+      binders :: forall t.
-      binders :: forall t. G (Datum :- t) (Name :- List Name :- t)
+        IG.Grammar S.Position (Sexp :- t) (Name :- List Name :- t)
-      binders =
+      binders = S.list $
-        S.list (S.rest $ S.datumIso @Name)
+        S.rest (S.sexpIso @Name)
-        >>> S.flipped S.snoced
+        >>> S.onTail (S.flipped $ IG.PartialIso
-        >>> S.swap
+                     (\(ktail:-args:-t) -> (args ++ [ktail]) :- t)
+                     (\(args:-t) -> case args ^? _Snoc of
+                         Just (args',ktail) -> Right $ ktail :- args' :- t
+                         Nothing -> Left $ S.expected "cont param")
+                     )
 
-instance S.DatumIso Kappa where
+instance S.SexpIso Kappa where
-  datumIso = S.with \g ->
+  sexpIso = match
-    S.lambdaLike S.kappaKeyword
+    $ With (. kappa)
-      (S.datumIso @(List Name))
+    $ End
-      (S.el $ S.datumIso @Exp)
-    >>> g
-
-instance S.DatumIso Abs where
-  datumIso = S.match
-    $ S.With (\lambda -> lambda . S.datumIso)
-    $ S.With (\kappa -> kappa . S.datumIso)
-    $ S.End
-
-instance S.DatumIso Exp where
-  datumIso = S.match
-    $ S.With (. builtin)
-    $ S.With (. letrec)
-    $ S.With (. continue)
-    $ S.With (. if_)
-    $ S.With (. app)
-    $ S.End
     where
-      continue = S.listWithStyle (S.StyleSyntax 1) $
+      kappa = S.list $
+        S.el Gyehoek.Sexp.kappaKeyword
+        >>> S.el (S.list $ S.rest S.sexpIso)
+        >>> S.el S.sexpIso
+
+instance S.SexpIso Abs where
+  sexpIso = match
+    $ With (\lambda -> lambda . S.sexpIso)
+    $ With (\kappa -> kappa . S.sexpIso)
+    $ End
+
+instance S.SexpIso Exp where
+  sexpIso = match
+    $ With (. prim)
+    $ With (. letrec)
+    $ With (. continue)
+    $ With (. if_)
+    $ With (. app)
+    $ End
+    where
+      continue = S.list $
         S.el (S.sym "continue")
-        >>> S.el S.datumIso
+        >>> S.el S.sexpIso
-        >>> S.rest S.datumIso
+        >>> S.rest S.sexpIso
-      letrec = S.letLike "letrec" S.datumIso S.datumIso S.datumIso
+      letrec = Gyehoek.Sexp.let_ "letrec" S.sexpIso S.sexpIso S.sexpIso
-      if_ = S.ifLike "if"
+      if_ = S.list $ S.el (S.sym "if")
-        S.datumIso S.datumIso S.datumIso
+        >>> S.el S.sexpIso >>> S.el S.sexpIso >>> S.el S.sexpIso
       app :: forall t.
-        G (Datum :- t) (Kexp :- List Val :- Val :- t)
+        IG.Grammar S.Position (Sexp :- t) (Name :- ([Val] :- (Val :- t)))
-      app = S.list $
+      app = S.list $ S.el (S.sexpIso @Val)
-        S.flipped (S.PartialIso
+        -- >>> S.flipped Gyehoek.Sexp.nonEmptyGrammar
-          (\(S.MkListContext ctx :- t) ->
+        >>> S.rest (S.sexpIso @Val)
-            case ctx of
+        -- >>> _
-              f:kexp:xs -> S.MkListContext (f : snoc xs kexp) :- t
+        >>> S.onTail (S.flipped $ IG.PartialIso
-              _ -> error "unreachable")
+                      (\(karg :- args :- op :- t) ->
-          (\(S.MkListContext ctx :- t) ->
+                         (args ++ [ValVar karg]) :- op :- t)
-            case unsnoc ctx of
+                      (\(xs :- op :- t) -> case xs ^? _Snoc of
-              Just (f:xs,kexp) -> Right $ S.MkListContext (f:kexp:xs) :- t
+                          Just (args,preview #ValVar -> Just karg) ->
-              _ -> Left $ S.expected "continuation arg"))
+                            Right $ karg:- args :- op :- t
-        >>> S.el (S.datumIso @Val)
+                          _ -> Left $ S.expected "continuation arg"
-        >>> S.el (S.datumIso @Kexp)
+                      ))
-        >>> S.rest (S.datumIso @Val)
+        where
-        >>> S.onTail S.swap
+          _ = S.flipped $ Gyehoek.Sexp.nonEmptyGrammar @S.Position @Val
-      builtin = S.listWithStyle (S.StyleSyntax 1) $
+      prim = S.list $
-        S.el (S.sym "builtin")
+        S.el (S.sym "prim")
-        >>> S.el (builtinDatumIso id (S.datumIso @Val))
+        >>> S.el (primSexpIso id (S.sexpIso @Val))
-        >>> S.el S.datumIso
+        >>> S.el S.sexpIso
 
-instance S.DatumIso Kexp where
+instance S.SexpIso Program where
-  datumIso = S.match
+  sexpIso = with \prog -> S.sexpIso @Exp >>> prog
-    $ S.With (S.datumIso @Name >>>)
-    $ S.With (S.datumIso @Kappa >>>)
-    $ S.End
-
-instance S.DatumIso Program where
-  datumIso = S.with \prog -> S.datumIso @Lambda >>> prog
-
--- the printed representation is pretty dishonest in its current
--- state. consider the following hoisted program:
--- 
---  (letrec ((k (κ () (continue start-ktail 123))))
---    (λ (start-ktail)
---      (continue k)))
--- 
--- here, `start-ktail` is bound in `k`, but the printed representation
--- fails to reflect that.
-instance S.DatumIso HoistedProgram where
-  datumIso = S.with \prog ->
-    S.letLike "letrec"
-      (S.datumIso @Label) (S.datumIso @Abs) (S.datumIso @Lambda)
-    >>> S.onTail (S.iso H.fromList H.toList)
-    >>> prog
 
 
 -- quasiquoters
 
 class Data a => CPS a where
-  toCPS :: HasCallStack => Datum -> a
+  toCPS :: Sexp -> a
 
-instance CPS Exp where toCPS = S.fromDatumUnsafe S.datumIso
+instance CPS Exp where toCPS = Gyehoek.Sexp.fromSexp
-instance CPS Val where toCPS = S.fromDatumUnsafe S.datumIso
+instance CPS Val where toCPS = Gyehoek.Sexp.fromSexp
-instance CPS Kappa where toCPS = S.fromDatumUnsafe S.datumIso
+instance CPS Kappa where toCPS = Gyehoek.Sexp.fromSexp
-instance CPS Lambda where toCPS = S.fromDatumUnsafe S.datumIso
+instance CPS Lambda where toCPS = Gyehoek.Sexp.fromSexp
-instance CPS Abs where toCPS = S.fromDatumUnsafe S.datumIso
+instance CPS Abs where toCPS = Gyehoek.Sexp.fromSexp
-instance CPS Program where toCPS = S.fromDatumUnsafe S.datumIso
+instance CPS Program where toCPS = Gyehoek.Sexp.fromSexp
-instance CPS HoistedProgram where toCPS = S.fromDatumUnsafe S.datumIso
 
-cps :: S.QuasiQuoter
+cps :: QuasiQuoter
-cps = S.makeSx' [| toCPS |]
+cps = Gyehoek.Sexp.makeSx' [| toCPS |]
 
 
 
+deleteFrom :: (Foldable f, Hashable a) => f a -> HashSet a -> HashSet a
+deleteFrom = flip $ foldr HS.delete
+
 insertFrom :: (Foldable f, Hashable a) => f a -> HashSet a -> HashSet a
 insertFrom = flip $ foldr HS.insert
 
+toHashSetOf :: Hashable a => Getting (Endo (HashSet a)) s a -> s -> HashSet a
+toHashSetOf l = foldrOf l HS.insert mempty
+
 class Free a where
   free :: a -> HashSet Name
   free = freeWithBound mempty
@@ -424,8 +318,7 @@ class Free a where
   freeWithBound :: HashSet Name -> a -> HashSet Name
   freeWithBound bound = HS.fromList . freeWithBound' bound
 
-  -- | Free variables given in the same left-to-right order they
+  -- | Free variables given in the order of their appearance.
-  -- appear.
   free' :: a -> List Name
   free' = freeWithBound' mempty
 
@@ -435,32 +328,22 @@ instance Free Abs where
   freeWithBound' bound (AbsKappa kap) = freeWithBound' bound kap
   freeWithBound' bound (AbsLambda lam) = freeWithBound' bound lam
 
-mif :: Alternative f => (a -> Bool) -> a -> f a
-mif p a
-  | p a = pure a
-  | otherwise = empty
-
-instance Free Kexp where
-  freeWithBound' bound = \case
-    KexpVar x -> mif (`notElem` bound) x
-    KexpKappa kap -> freeWithBound' bound kap
-
 instance Free Exp where
   freeWithBound' bound = \case
-    ExpBuiltin p k ->
+    ExpPrim p k ->
-      (p ^.. folded . #ValVar . filtered (`notElem` bound))
+      p & toListOf (folded . #ValVar . filtered (`notElem` bound))
-      ++ freeWithBound' bound k
+        & (<> freeWithBound' bound k)
     ExpLetRec bs m ->
       foldMapOf (each . _2) (freeWithBound' bound') bs
       <> freeWithBound' bound' m
       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))
-      <> mif (`notElem` bound) t <> mif (`notElem` bound) f
+      <> freeWithBound' bound t <> freeWithBound' bound f
     ExpApply f xs k ->
       (f:xs) ^.. (each . #ValVar . filtered (`notElem` bound))
-      <> freeWithBound' bound k
+      <> (k ^.. filtered (`notElem` bound))
 
 instance Free Kappa where
   freeWithBound' bound (MkKappa xs m) =
@@ -469,3 +352,21 @@ 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, convert_e2e, parse_e2e, readScm, eval_cps1_e2e, eval_cps2_e2e)
+  (main, lower_e2e, convert_e2e, parse_e2e, readScm, eval_e2e)
   where
 
 import Gyehoek.Options
@@ -17,6 +17,7 @@ import qualified Data.Text.Encoding as T
 import System.IO (Handle)
 import System.IO qualified as IO
 import Gyehoek.CPS.Convert
+import Gyehoek.CPS.Lower
 import Gyehoek.CPS.Eval qualified as CPS
 import Control.Monad
 import Text.Pretty.Simple (pShowNoColor)
@@ -24,20 +25,20 @@ import System.Process.Typed
 import System.Environment.Blank (getEnvDefault)
 import qualified Data.Text.IO as TIO
 import qualified Data.ByteString.Lazy as BS
+import Gyehoek.CPS.Stackify (stackifyProgram)
+import Gyehoek.Stack.VM (eval, writeObj, Obj)
 import qualified Data.Text as T
+import Gyehoek.Stack.Syntax qualified as Stk
 import Gyehoek.CPS.Close (closeProgram)
 import Control.Lens.Extras (is)
 import Control.Arrow ((>>>))
 import Gyehoek.Prelude
-import Gyehoek.Jalmot
-import qualified Gyehoek.Sexp as S
-import Gyehoek.CPS.Hoist (hoistProgram)
 
 
 main :: IO ()
 main = do
   opts <- execParser $ info (helper <*> parser) fullDesc
-  runJalmotIO . runFileSystem . runGenSym . driver $ opts
+  runEff . runFileSystem . runGenSym . driver $ opts
 
 
 
@@ -64,12 +65,11 @@ fileName :: FilePath -> FilePath
 fileName "-" = "<interactive>"
 fileName e = e
 
-readScm
+readScm :: FileSystem :> es => FilePath -> Eff es Scm.Program
-  :: forall es. (Jalmot :> es, FileSystem :> es)
-  => FilePath -> Eff es Scm.Program
 readScm f =
   withFile f FS.ReadMode $ \h ->
-    S.decodeDataWith @es S.dataIso =<< hGetContents h
+    Sexp.parseSexps @Scm.CommandOrDef (fileName f) <$> hGetContents h
+     >>= either error (pure . Scm.MkProgram)
 
 inspectWasm :: IOE :> es => Text -> Eff es ()
 inspectWasm wat = do
@@ -107,7 +107,7 @@ dumpOrRun dump run acquire do_dump do_run =
     when run (do_run x)
 
 driver
-  :: (GenSym :> es, FileSystem :> es, Jalmot :> es, IOE :> es)
+  :: (GenSym :> es, FileSystem :> es, IOE :> es)
   => Options -> Eff es ()
 driver opts = do
   scm <- readScm opts.sourceFile
@@ -115,40 +115,41 @@ driver opts = do
     hPutStrLn FS.stdout . view strict . pShowNoColor $ scm
   cps <- convertProgram scm
   when opts.dumpCPS do
-     S.writeDatum cps
+    hPutStrLn FS.stdout $ Sexp.encodePretty cps ^?! _Right
   closedCps <- closeProgram cps
   when opts.dumpClosed do
-    S.writeDatum closedCps
+    hPutStrLn FS.stdout $ Sexp.encodePretty closedCps ^?! _Right
-  hoistedCps <- hoistProgram closedCps
-  when opts.dumpHoisted do
-    S.writeDatum hoistedCps
   let rt_is p = is (_Just . p) opts.runtime
-  when (rt_is #HigherOrderCPS) do
+  dumpOrRun opts.dumpStackified (rt_is #Stackify)
-    CPS.evalProgram cps
+    (stackifyProgram closedCps)
-      >>= S.writeData
+    (hPutStrLn FS.stdout . Stk.encodeProgram)
+    (eval >>> fmap writeObj      
+         >>> T.unwords          
+         >>> hPutStrLn FS.stdout)
   when (rt_is #CPS) do
-    CPS.evalProgram closedCps
+    closedCps
-      >>= S.writeData
+      & CPS.evalProgram
+      & fmap writeObj      
+      & T.unwords          
+      & hPutStrLn FS.stdout
+  dumpOrRun opts.inspectWasm (rt_is #Wasm)
+    (lowerProgram cps)
+    inspectWasm
+    (\wat -> withFile opts.output FS.WriteMode \h -> hPutStrLn h wat)
 
 parse_e2e :: FilePath -> IO Scm.Program
-parse_e2e = runJalmotIO . runFileSystem . readScm
+parse_e2e = runEff . runFileSystem . readScm
 
 convert_e2e :: FilePath -> IO CPS.Program
-convert_e2e = runJalmotIO . runFileSystem . runGenSym
+convert_e2e = runEff . runFileSystem . runGenSym
   . (closeProgram <=< convertProgram <=< readScm)
 
-eval_cps1_e2e :: FilePath -> IO Text
+lower_e2e :: FilePath -> IO Text
-eval_cps1_e2e fp = runJalmotIO . runFileSystem . runGenSym $
+lower_e2e =
-  readScm fp
+  runEff . runFileSystem . runGenSym
-   >>= convertProgram
+  . (lowerProgram <=< closeProgram <=< convertProgram <=< readScm)
-   >>= closeProgram
-   >>= CPS.evalProgram
-   >>= pure . S.encodeOrShowData' S.dataIso
 
-eval_cps2_e2e :: FilePath -> IO Text
+eval_e2e :: FilePath -> IO (List Obj)
-eval_cps2_e2e fp = runJalmotIO . runFileSystem . runGenSym $
+eval_e2e fp = runEff . runFileSystem . runGenSym $ do
-  readScm fp
+  stk <- stackifyProgram <=< closeProgram <=< convertProgram <=< readScm $ fp
-   >>= convertProgram
+  pure . eval $ stk
-   -- >>= closeProgram
-   >>= CPS.evalProgram
-   >>= pure . S.encodeOrShowData' S.dataIso

src/Gyehoek/Jalmot.hs

@@ -1,75 +0,0 @@
-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,4 +1,25 @@
+{-# 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/Language/Common.hs

@@ -1,62 +0,0 @@
-{-# LANGUAGE DeriveAnyClass #-}
-module Gyehoek.Language.Common
-  (
-  -- * Syntax
-    Lib(..)
-  , LibName(..)
-  , Exports
-  , Imports
-  , ExternName(..)
-  , Name(..)
-  ) where
-
-import Gyehoek.Prelude
-import Data.String (IsString)
-import Gyehoek.GenSym (Gen)
-import qualified Gyehoek.Sexp as S
-
-
--- | R⁷RS 라이프러리의 표현.
-data Lib name body = MkLib
-  { name :: LibName
-  , exports :: Exports name
-  , imports :: Imports name
-  }
-  deriving (Show)
-
-newtype LibName = MkLibName { getLibName :: NonEmpty Text }
-  deriving stock (Show, Generic, Data, Eq)
-  deriving anyclass (NFData, Hashable)
-
--- | A map whose keys are names of library definitions and whose
--- values are the names they are exported as. An @⟨identifier⟩@ @x@
--- corresponds to an entry @(⟨identifier⟩, ⟨identifier⟩)@, while a
--- @(rename ⟨identifier₁⟩ ⟨identifier₂⟩)@ form corresponds to an entry
--- @(⟨identifier₁⟩, ⟨identifier₂⟩)@.
-type Exports name = HashMap name ExternName
-
--- | A map whose keys are symbols to be brought into the library's
--- environment and whose values are pairs of the library in which the
--- symbol is defined and the name the symbol is exported as.
-type Imports name = HashMap name (LibName, ExternName)
-
--- | Representation of an identifier at the library boundary. While
--- 'Name's are used within a compilation unit and may be decorated
--- with additional structure and metadata, they are exported as
--- 'ExternName's, which are essentially just plain strings.
-newtype ExternName = MkExternName { getExternName :: Text }
-  deriving newtype (Show)
-
-newtype Name = MkName { inner :: Text }
-  deriving newtype (Show, Eq, Ord, IsString, Gen, Hashable)
-  deriving stock (Generic, Data)
-  deriving anyclass (Wrapped, NFData)
-
-instance Prefixed Name where
-  prefixed (MkName s) = _Wrapped' . prefixed @Text s . from _Wrapped'
-
-
---- DatumIsos
-
-instance S.DatumIso Name where
-  datumIso = S.symbol >>> S.iso coerce coerce

src/Gyehoek/Lift1.hs

@@ -1,30 +0,0 @@
-{-# 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,13 +13,14 @@ import Data.Foldable
 import Gyehoek.Prelude hiding (argument)
 
 
-data Runtime = Wasm | CPS | HigherOrderCPS
+data Runtime = Stackify | Wasm | CPS
   deriving (Show, Generic, Eq)
 
 data Language
   = LanguageScheme
   | LanguageCPS
   | LanguageClosed
+  | LanguageStackified
   | LanguageWasm
   deriving (Show, Generic, Eq)
 
@@ -27,30 +28,29 @@ data Options = MkOptions
   { dumpClosed :: Bool
   , dumpCPS :: Bool
   , dumpParsed :: Bool
-  , dumpHoisted :: Bool
+  , dumpStackified :: Bool
-  , noColour :: Bool
   , runtime :: Maybe Runtime
   , inspectWasm :: Bool
   , output :: FilePath
   , sourceFile :: FilePath
   , sourceLanguage :: Language
-  , targetLanguage :: Language
   }
   deriving (Show, Generic)
 
-languageValues = ["scheme","cps","closed","wasm"]
+languageValues = ["scheme","cps","closed","stackified","wasm"]
 languageReader = maybeReader \case
   "scheme" -> Just LanguageScheme
   "cps" -> Just LanguageCPS
   "closed" -> Just LanguageClosed
+  "stackified" -> Just LanguageStackified
   "wasm" -> Just LanguageWasm
   _ -> Nothing
 
 runtimeValues = ["stackify","wasm","cps","none"]
 runtimeReader = maybeReader \case
+  "stackify" -> Just (Just Stackify)
   "wasm" -> Just (Just Wasm)
-  "cps1" -> Just (Just CPS)
+  "cps" -> Just (Just CPS)
-  ("cps";"higher-order-cps") -> Just (Just HigherOrderCPS)
   "none" -> Just Nothing
   _ -> Nothing
 
@@ -58,19 +58,15 @@ parser :: Parser Options
 parser = do
   dumpClosed <- switch (long "dump-closed")
   dumpCPS <- switch (long "dump-cps")
+  dumpStackified <- switch (long "dump-stackified")
   dumpParsed <- switch (long "dump-parsed")
-  dumpHoisted <- switch (long "dump-hoisted")
-  noColour <- switch . fold $
-    [ long "no-colour"
-    , long "no-color"
-    ]
   inspectWasm <- switch $ long "inspect-wasm" <> short 'p'
   runtime <- option runtimeReader . fold $
     [ long "runtime"
     , short 'R'
-    , value (Just HigherOrderCPS)
+    , value (Just Stackify)
     , completeWith runtimeValues
-    , showDefaultWith $ const "higher-order-cps"
+    , showDefaultWith $ const "stackify"
     , metavar "RUNTIME"
     ]
   sourceLanguage <- option languageReader . fold $
@@ -81,14 +77,6 @@ parser = do
     , showDefaultWith $ const "scheme"
     , metavar "LANGUAGE"
     ]
-  targetLanguage <- option languageReader . fold $
-    [ long "target"
-    , short 'T'
-    , value LanguageCPS
-    , completeWith languageValues
-    , showDefaultWith $ const "cps"
-    , metavar "LANGUAGE"
-    ]
   output <- strOption . fold $
     [ long "output"
     , short 'o'

src/Gyehoek/Prelude.hs

@@ -17,12 +17,9 @@ module Gyehoek.Prelude
   , NonEmpty((:|))
   , Natural
   , (>>>)
-  , (>=>)
-  , (<=<)
-  , wrappedIso
   ) where
 
-import Control.Lens hiding (List, (:<))
+import Control.Lens
 import Data.List (List)
 import Data.Text (Text)
 import Effectful
@@ -40,6 +37,4 @@ 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/Expand.hs

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

src/Gyehoek/Scheme/Expand/Old.hs

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

src/Gyehoek/Scheme/Syntax.hs

@@ -10,34 +10,37 @@
 {-# LANGUAGE OrPatterns #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE ViewPatterns #-}
-{- HLINT ignore "Avoid lambda using `infix`" -}
-{- HLINT ignore "Redundant $" -}
 module Gyehoek.Scheme.Syntax
   ( Name(..)
-  , Builtin(..)
+  , Prim(..)
   , Lit(..)
   , Def(..)
   , Exp(..)
   , ExpF(..)
+  , Sexp(..)
   , Program(..)
   , CommandOrDef(..)
-  , Trans(..)
+  , primSexpIso
-  , Rule(..)
+  , pattern Void
-  , Pat(..)
-  , Tem(..)
-  , El(..)
-  , builtinDatumIso
   , 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
 import Gyehoek.Sexp qualified as GS
@@ -50,12 +53,12 @@ import Data.Functor.Foldable hiding (fold)
 import qualified Data.HashSet as HS
 import Data.Foldable (fold, toList)
 import Language.Haskell.TH.Quote (QuasiQuoter)
+import Effectful.FileSystem (runFileSystem)
+import qualified Effectful.FileSystem.IO as FS
+import qualified Data.Text.Encoding as T
+import qualified Effectful.FileSystem.IO.ByteString as FB
 import qualified Data.Set.Ordered as O
-import Gyehoek.Sexp.Grammar qualified as S
-import Gyehoek.Sexp.Grammar (DatumIso, G, DataIso, (:-)((:-)))
 import Gyehoek.Prelude
-import Control.Lens.Extras (is)
-import qualified Data.Scientific as Sci
 
 
 newtype Name = MkName { inner :: Text }
@@ -69,121 +72,65 @@ instance Prefixed Name where
 getName :: Name -> Text
 getName (MkName x) = x
 
-data Builtin e
+data Prim e
-  = BuiltinAdd e e
+  = PrimAdd e e
-  | BuiltinSub e e
+  | PrimSub e e
-  | BuiltinMul e e
+  | PrimMul e e
-  | BuiltinDiv e e
+  | PrimDiv e e
-  | BuiltinCons e e
+  | PrimCons e e
-  | BuiltinCar e
+  | PrimCar e
-  | BuiltinCdr e
+  | PrimCdr e
-  | BuiltinImmediateP e
+  | PrimImmediateP e
-  | BuiltinConsP e
+  | PrimConsP e
-  | BuiltinIntegerP e
+  | PrimIntegerP e
-  | BuiltinWrite e
+  | PrimWrite e
-  | BuiltinZeroP e
+  | PrimZeroP e
-  | BuiltinNewline
+  | PrimNewline
-  | BuiltinMakeClosure { code :: e, env :: List e }
+  | PrimMakeClosure { code :: e, env :: List e }
-  | BuiltinMakeSharedClosure { codes :: List e, env :: List e }
+  | PrimEnvRef e Int
-  | BuiltinGetEnv
+  | PrimEnvCode e
-  | BuiltinEnv
+  | PrimCallCC e
-  | BuiltinEnvRef Int
-  | BuiltinCallCC e
-  | BuiltinCaptureCC
-  | BuiltinInvokeCC e (List e)
-  | BuiltinValues (List e)
-  | BuiltinCallWithValues e e
-  | BuiltinPairP e
-  | BuiltinList (List e)
   deriving stock (Show, Generic, Functor, Foldable, Traversable, Data, Eq)
   deriving anyclass (NFData)
 
-instance Each (Builtin e) (Builtin e') e e'
+instance Each (Prim e) (Prim e') e e'
 
 data Lit
   = LitInt Int
+  | 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)
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
 
-data Formals a
-  = FormalsFixed (List a)
-  | FormalsVar (List a) a
-  deriving stock (Show, Generic, Data, Functor, Foldable, Traversable)
-  deriving anyclass (NFData)
-
 data Exp
   = ExpLet (List (Name, Exp)) Exp
-  | ExpLetSyntax (List (Name, Trans)) Exp
   | ExpLetRec (List (Name, Exp)) Exp
-  | ExpBuiltin (Builtin Exp)
+  | ExpPrim (Prim Exp)
-  | ExpBegin (NonEmpty Exp)
+  | ExpBegin (List Exp)
-  | ExpIf Exp Exp (Maybe Exp)
+  | ExpIf Exp Exp Exp
   | ExpLit Lit
   | ExpLambda (List Name) Exp
   | ExpVar Name
-  | ExpSyntaxRules Trans
   | ExpApply Exp (List Exp)
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
 
-data Trans = MkTrans
+data Sexp
-  { ellipsis :: Name
+  = SexpCons Sexp Sexp
-  , keywords :: List Name
+  | SexpSymbol Text
-  , rules :: List Rule
+  | SexpLit Lit
-  }
+  deriving stock (Show, Generic, Data, Eq)
-  deriving stock (Show, Generic, Data)
-  deriving anyclass (NFData)
-
-data Rule = MkRule
-  { rhs :: Pat
-  , lhs :: Tem
-  }
-  deriving (Show, Generic, Data)
-  deriving anyclass (NFData)
-
-data Pat
-  = PatWildcard
-  | PatVar Name
-  | PatList
-    { init :: List Pat
-    , ellipsis :: Maybe (List Pat)
-    , tail :: Maybe Pat
-    }
-  -- | PatVec
-  --   { init :: List Pat
-  --   , ellipsis :: Maybe (List Pat)
-  --   }
-  deriving (Show, Generic, Data)
-  deriving anyclass (NFData)
-
-data Tem
-  -- | @(⟨element⟩ …)@
-  -- @(⟨element⟩ ⟨element⟩ … . ⟨element⟩)@
-  = TemList
-    { init :: List El
-    , tail :: Maybe Tem
-    }
-  -- | @(⟨ellipsis⟩ ⟨template⟩)@
-  | TemTrail Tem
-  | TemLit Lit
-  | TemVar Name
-  deriving (Show, Generic, Data)
-  deriving anyclass (NFData)
-
-data El
-  -- | @⟨template⟩ ⟨ellipsis⟩@
-  = Ellipsis Tem
-  -- | @⟨template⟩@
-  | El Tem
-  deriving (Show, Generic, Data)
   deriving anyclass (NFData)
 
 data CommandOrDef
@@ -193,37 +140,8 @@ data CommandOrDef
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
 
-newtype LibName = MkLibName { inner :: NonEmpty Name }
-  deriving stock (Show, Generic, Data)
-  deriving anyclass (NFData)
-
-data ImportSet
-  = ImportLib LibName
-  | ImportOnly ImportSet (NonEmpty Name)
-  | ImportExcept ImportSet (NonEmpty Name)
-  | ImportPrefix ImportSet Name
-  | ImportRename ImportSet (NonEmpty (Name, Name))
-  deriving stock (Show, Generic, Data)
-  deriving anyclass (NFData)
-
-newtype ImportDecl = MkImportDecl (NonEmpty ImportSet)
-  deriving stock (Show, Generic, Data)
-  deriving anyclass (NFData)
-
-data LibDecl
-  deriving stock (Show, Generic, Data)
-  deriving anyclass (NFData)
-
-data Lib = MkLib
-  { name :: LibName
-  , decls :: List LibDecl
-  }
-  deriving stock (Show, Generic, Data)
-  deriving anyclass (NFData)
-
 data Program = MkProgram
-  { imports :: List ImportDecl
+  { commandsAndDefs :: List CommandOrDef
-  , commandsAndDefs :: List CommandOrDef
   }
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
@@ -241,274 +159,102 @@ makeBaseFunctor ''Exp
 
 
 
-instance DatumIso Name where
+instance SexpIso Name where
-  datumIso = S.symbol >>> S.iso coerce coerce
+  sexpIso = symbol >>> Sexp.partialOsi f g
-
-builtinDatumIso
-  :: (Text -> Text)
-  -> S.DatumGrammar a -> S.DatumGrammar (Builtin a)
-builtinDatumIso 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.With (. ht1 "pair?")
-    $ S.With (. ht0' "list")
-    $ S.End
     where
-      idn = S.el . S.sym . namefn
+      f = Right . MkName
-      ht0 s = S.list $ idn s
+      g (MkName s) = s
-      ht1 s = S.headTagged1 (namefn s) a
-      ht2 s = S.headTagged2 (namefn s) a a
-      ht1' s = S.headTagged1' (namefn s) a a
-      ht0' s = S.headTagged0' (namefn s) a
 
-instance DatumIso a => DatumIso (Builtin a) where
+primSexpIso :: (Text -> Text) -> Sexp.SexpGrammar a -> Sexp.SexpGrammar (Prim a)
-  datumIso = builtinDatumIso id S.datumIso
+primSexpIso namefn a = match
-
+    $ With (. ht2 "+")
-instance DatumIso Lit where
+    $ With (. ht2 "-")
-  datumIso = S.match
+    $ With (. ht2 "*")
-    $ S.With (. S.int)
+    $ With (. ht2 "/")
-    $ S.With (. S.boolean)
+    $ With (. ht2 "cons")
-    $ S.With (. S.string)
+    $ With (. ht1 "car")
-    $ S.End
+    $ With (. ht1 "cdr")
-
+    $ With (. ht1 "immediate?")
-instance DatumIso Def where
+    $ With (. ht1 "cons?")
-  datumIso = S.match
+    $ With (. ht1 "integer?")
-    $ S.With (. defconst)
+    $ With (. ht1 "write")
-    $ S.With (. defun)
+    $ With (. ht1 "zero?")
-    $ S.End
+    $ 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
     where
-      defconst = S.list $ S.el (S.sym "define")
+      idn s = el (sym (namefn s))
-        >>> S.el S.datumIso >>> S.el S.datumIso
+      nullop s = list $ idn s
-      defun = S.list $ S.el (S.sym "define")
+      ht1 s = GS.headTagged1 (namefn s) a
-        >>> S.el args >>> S.rest S.datumIso
+      ht2 s = GS.headTagged2 (namefn s) a a
-      args = S.list $ S.el S.datumIso >>> S.rest S.datumIso
+      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
   
-instance DatumIso Trans where
+instance SexpIso Exp where
-  datumIso = S.with \g ->
+  sexpIso = match
-    S.listWithStyle
+    $ With (. GS.let_ "let" sexpIso sexpIso sexpIso)
-      (S.StyleSyntax 1)
+    $ With (. GS.let_ "letrec" sexpIso sexpIso sexpIso)
-      ( S.el (S.sym "syntax-rules")
+    $ With (. sexpIso)
-      >>> S.Iso (\(ctx:-t) -> ctx:-"...":-t) (\(ctx:-_:-t) -> ctx:-t)
+    $ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso))
-      >>> S.el (S.list $ S.rest (S.datumIso @Name))
+    $ With (. if_)
-      >>> S.rest (S.datumIso @Rule)
+    $ With (. sexpIso)
-      )
+    $ With (. lam)
-    >>> g
+    $ With (. sexpIso)
-
+    $ With (\app -> app . list (el sexpIso >>> rest sexpIso))
-instance DatumIso Exp where
+    $ End
-  datumIso = S.match
-    $ S.With (. S.letLike "let" S.datumIso S.datumIso S.datumIso)
-    $ S.With (letsyntax >>>)
-    $ S.With (. S.letLike "letrec" S.datumIso S.datumIso S.datumIso)
-    $ S.With (. S.datumIso)
-    $ S.With (. begin)
-    $ S.With (. if_)
-    $ S.With (. S.datumIso)
-    $ S.With (. lam)
-    $ S.With (. S.datumIso)
-    $ S.With (. S.datumIso)
-    $ S.With (\app -> app . S.list (S.el S.datumIso >>> S.rest S.datumIso))
-    $ S.End
     where
-      letsyntax = S.listWithStyle (S.StyleSyntax 1) $
+      if_ = list $ el (sym "if") >>> el sexpIso >>> el sexpIso >>> el sexpIso
-        S.el (S.sym "let-syntax")
+      lam = list
-        >>> S.el (S.list $ S.rest $ S.datumIso)
+        ( el GS.lambdaKeyword
-        >>> S.el S.datumIso
+          >>> el (sexpIso @(List Name))
-      lam = S.lambdaLike S.lambdaKeyword S.datumIso (S.el S.datumIso)
+          >>> el sexpIso )
-      if_ = S.ifLike "if" S.datumIso S.datumIso $ S.datumIso @Exp >>> S.iso
-        Just
-        \case
-          Just x -> x
-          Nothing -> error "안 괜찮다ㅠㅠ"
-      begin :: forall t. G (S.Datum :- t) (NonEmpty Exp :- t)
-      begin = S.beginLike "begin" $
-        S.el (S.datumIso @Exp) >>> S.rest (S.datumIso @Exp)
-        >>> S.onTail (S.Iso
-          (\(xs:-x:-t) -> (x:|xs):-t)
-          (\((x:|xs):-t) -> xs:-x:-t))
 
-instance S.DatumIso Rule where
+instance SexpIso CommandOrDef where
-  datumIso = S.with \g ->
+  sexpIso = match
-    S.list (S.el S.datumIso >>> S.el S.datumIso) >>> g
+    $ With (\_Command -> _Command . sexpIso)
-
+    $ With (\_Definition -> _Definition . sexpIso)
-instance S.DatumIso Pat where
+    $ With (\_Begin -> _Begin . bgn)
-  datumIso = S.match
+    $ End
-    $ S.With (S.sym "_" >>>)
-    $ S.With (S.datumIso >>>)
-    $ S.With (lst >>>)
-    $ S.End
     where
-      lst :: S.G (S.Datum :- t) (Maybe Pat :- Maybe (List Pat) :- List Pat :- t)
+      bgn = list $ el (sym "begin") >>> rest sexpIso
-      lst = S.coproduct
-        [ S.list $
-            ellipsis
-            >>> S.onTail (S.push Nothing (is _Nothing) (const mempty))
-        , S.dottedList
-            ellipsis
-            ( S.datumIso @Pat
-              >>> S.partialIso Just (maybe (Left mempty) Right) )
-        ]
-      ellipsis =
-        S.restData split
-            >>> S.onTail
-              ( S.onHead (S.traversed . S.traversed . S.sealed $
-                S.datumIso @Pat)
-              >>> S.onTail (S.onHead . S.traversed . S.sealed $
-                S.datumIso @Pat)
-              )
-      split
-        :: forall t. S.G (List S.Datum :- t)
-            (Maybe (List S.Datum) :- List S.Datum :- t)
-      split = S.Iso
-        (\(ps0:-t) ->
-          let (ps,ell) = splitEllipsis ps0
-          in ell :- ps :- t)
-        (\(ell:-ps:-t) -> (ps ++ foldMap ([S.Symbol "..."]++) ell) :- t)
-
-splitEllipsis :: List S.Datum -> (List S.Datum, Maybe (List S.Datum))
-splitEllipsis [] = ([], Nothing)
-splitEllipsis (S.Symbol "..." : xs) = ([], Just xs)
-splitEllipsis (x:xs) = splitEllipsis xs & _1 %~ (x:)
-
-instance S.DataIso El where
-  dataIso = S.match
-    $ S.With (ellipsis >>>)
-    $ S.With (noellipsis >>>)
-    $ S.End
-    where
-      ellipsis = S.recontextualise $
-        S.el (S.datumIso @Tem) >>> S.el (S.sym "...")
-      noellipsis = S.recontextualise $ S.el (S.datumIso @Tem)
-
-instance S.DatumIso Tem where
-  datumIso = S.match
-    $ S.With (lst >>>)
-    $ S.With (trail >>>)
-    $ S.With (S.datumIso @Lit >>>)
-    $ S.With (S.datumIso @Name >>>)
-    $ S.End
-    where
-      trail = S.list $ S.el (S.sym "...") >>> S.el (S.datumIso @Tem)
-
-      lst :: S.G (S.Datum :- t) (Maybe Tem :- List El :- t)
-      lst = S.coproduct
-        [ S.list els
-          >>> (S.push Nothing (is _Nothing) (const mempty))
-        , S.dottedList els $
-            S.datumIso @Tem
-            >>> S.partialIso Just (maybe (Left mempty) Right)
-        ]
-      els :: S.G (S.ListContext :- t) (S.ListContext :- List El :- t)
-      els =
-        S.iso
-          (\(S.MkListContext ds) -> affixEllipses ds)
-          (S.MkListContext . foldMap \(d,b) ->
-            d : if b then [S.Symbol "..."] else [])
-        >>> S.onHead (S.traversed . S.sealed $
-          S.flipped S.pair
-          >>> S.onTail (S.datumIso @Tem)
-          >>> S.pair
-          >>> S.iso
-            (\(t,b) -> if b then Ellipsis t else El t)
-            (\case
-              Ellipsis t -> (t,True)
-              El t -> (t,False)))
-        >>> S.push (S.MkListContext [])
-          (\(S.MkListContext xs) -> null xs)
-          (const mempty)
-      affixEllipses :: List S.Datum -> List (S.Datum, Bool)
-      affixEllipses (x : S.Symbol "..." : xs) = (x,True) : affixEllipses xs
-      affixEllipses (x : xs) = (x,False) : affixEllipses xs
-      affixEllipses [] = []
-
-
-instance DatumIso CommandOrDef where
-  datumIso = S.match
-    $ S.With (\_Command -> _Command . S.datumIso)
-    $ S.With (\_Definition -> _Definition . S.datumIso)
-    $ S.With (\_Begin -> _Begin . S.beginLike "begin" (S.rest S.datumIso))
-    $ S.End
-
-instance DatumIso LibName where
-  datumIso = S.with \g ->
-    S.list (S.restData $ S.nonEmptyData comp)
-    >>> g
-    where
-      comp = S.partialOsi
-        (\case
-          S.Symbol s -> Right $ MkName s
-          S.Number (Sci.floatingOrInteger @Double @Int -> Right n)
-            | n > 0 -> Right $ MkName [i|#{n}|]
-          _ -> Left $ S.expected "library name part"
-          )
-        \(MkName s) -> S.Symbol s
-
-instance DatumIso ImportSet where
-  datumIso = S.match
-    $ S.With (S.datumIso @LibName >>>)
-    $ S.With (imp "only" >>>)
-    $ S.With (imp "except" >>>)
-    $ S.With (imp' "prefix" >>>)
-    $ S.With (imp "rename" >>>)
-    $ S.End
-    where
-      imp s = S.list $ S.el (S.sym s)
-        >>> S.el S.datumIso >>> S.restData S.dataIso
-      imp' s = S.list $
-        S.el (S.sym s)
-        >>> S.el S.datumIso
-        >>> S.el S.datumIso
-
-instance DatumIso ImportDecl where
-  datumIso = S.with \decl ->
-    S.list (S.el (S.sym "import") >>> S.restData S.dataIso)
-    >>> decl
-
-instance DataIso Program where
-  dataIso = S.with \g ->
-    splitG
-    >>> S.onHead (S.sealed S.dataIso)
-    >>> S.onTail (S.onHead . S.sealed $ S.dataIso)
-    >>> g
-    where
-      isImport = \case
-        S.List (S.Symbol "import" : _) -> True
-        _ -> False
-      splitG :: G (List S.Datum :- t) (List S.Datum :- List S.Datum :- t)
-      splitG = S.Iso
-        (\(xs:-t) ->
-          let (ys,zs) = span isImport xs
-          in zs :- ys :- t
-        )
-        \(zs:-ys:-t) -> (ys ++ zs) :- t
 
 
 -- utilities
 
 scm :: QuasiQuoter
-scm = GS.makeSx [|| S.fromDatumUnsafe @Exp S.datumIso ||]
+scm = GS.makeSx [|| GS.fromSexp @Exp ||]
 
 freeWithBound' :: Foldable f => f Name -> Exp -> List Name
 freeWithBound' bound = filter (`elem` bound) . free'
@@ -563,3 +309,27 @@ 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,11 +1,453 @@
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
+{-# LANGUAGE OrPatterns #-}
 module Gyehoek.Sexp
-  ( module Gyehoek.Sexp.QQ
+  ( let_
-  , module Gyehoek.Sexp.Syntax
+  , sexp
-  , module Gyehoek.Sexp.Grammar
+  , 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
   )
   where
 
-import Gyehoek.Sexp.QQ
+import Data.Text (Text)
-import Gyehoek.Sexp.Syntax
+import Language.SexpGrammar as Sexp hiding (toSexp, List, encode, decode, encodeWith, decodeWith, iso, encodePrettyWith, encodePretty, fromSexp)
-import Gyehoek.Sexp.Grammar
+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
 
+
+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,203 +1,4 @@
 module Gyehoek.Sexp.Grammar
-  ( module Gyehoek.Sexp.Grammar.Base
+  (
-  , module Data.InvertibleGrammar.Combinators
+  ) where
-  , (>>>)
-  , 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)
-import Data.Foldable (toList)
-
-
-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 Natural where
-  datumIso = int
-    >>> partialOsi
-      (\x -> if x < 0
-        then Left $ expected "non-negative integer" <> unexpected [i|#{x}|]
-        else Right $ fromIntegral x)
-      fromIntegral
-
-instance DatumIso Datum where datumIso = Control.Category.id
-
-instance DatumIso a => DataIso (List a) where
-  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 => DataIso (NonEmpty a) where
-  dataIso = nonEmptyData datumIso
-
-instance (DatumIso a, DatumIso b) => DatumIso (a, b) where
-  datumIso = with \tup2 -> list (el datumIso >>> el datumIso) >>> tup2

src/Gyehoek/Sexp/Grammar/Base.hs

@@ -1,467 +0,0 @@
-{- HLINT ignore "Avoid lambda" -}
--- | 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
-  , ListContext(..)
-  , (:-)((:-))
-  -- * lists
-  , list
-  , listWithStyle
-  , el
-  , rest
-  , restData
-  , nonEmptyData
-  , headTagged0'
-  , headTagged0
-  , headTagged1'
-  , headTagged1
-  , headTagged2
-  , headTagged2'
-  -- * atoms
-  , simple
-  , string
-  , symbol
-  , sym
-  , boolean
-  , number
-  , integer
-  , int
-  , unreadable
-  -- * TODO: sort lol
-  , prismIso
-  , isoIso
-  , snoced
-  , letLike
-  , ifLike
-  , lambdaLike
-  , lambdaKeyword
-  , kappaKeyword
-  , beginLike
-  , dottedList
-  , reifyContext, recontextualise, decontextualise, redecorate
-  ) where
-
-import Data.InvertibleGrammar
-import Data.InvertibleGrammar.Base
-import Data.InvertibleGrammar.Combinators
-import Gyehoek.Prelude hiding (flipped, traversed, 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 qualified Data.List.NonEmpty as NE
-import Data.Foldable (toList)
-
-
--- $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)
-
-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 = listWithStyle StyleData
-
--- |
--- >>> 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)
-
-listWithStyle
-  :: Style
-  -> G (ListContext :- t) (ListContext :- t')
-  -> G (Datum :- t) t'
-listWithStyle 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)
-
-reifyContext :: G (ListContext :- t) (List Datum :- t)
-reifyContext = iso coerce coerce
-
-decontextualise
-  :: G (List Datum :- t) (List Datum :- t')
-  -> G (ListContext :- t) t'
-decontextualise g = reifyContext >>> g >>> end
-  where
-    end = Flip $ PartialIso
-      (\t -> [] :- t)
-      (\(lst :- t) ->
-         case lst of
-           [] -> Right t
-           d:_ -> Left $ unexpectedDatum d)
-
-recontextualise
-  :: G (ListContext :- t) (ListContext :- t')
-  -> G (List Datum :- t) t'
-recontextualise g = flipped reifyContext >>> g >>> end
-  where
-    end = Flip $ PartialIso
-      (\t -> MkListContext [] :- t)
-      (\(MkListContext lst :- t) ->
-         case lst of
-           [] -> Right t
-           d:_ -> Left $ unexpectedDatum d)
-
--- | matches the remainder of a list as repetition of a given
--- grammar.
---
--- >>> 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) t'
-  -> G (ListContext :- t) (ListContext :- t')
-restData g =
-  iso coerce coerce
-  >>> g
-  >>> push (MkListContext []) (const True) mempty
-
-nonEmptyData :: DatumGrammar a -> DataGrammar (NonEmpty a)
-nonEmptyData g = partialOsi
-    (\case
-      [] -> Left $ expected "non-empty sequence"
-      x:xs -> Right $ x:|xs)
-    toList
-  >>> (onHead . traversed . sealed $ g)
-
-snoced
-  :: Snoc s s a a
-  => Grammar p (s :- a :- t) (s :- t)
-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
-
-redecorate :: Style -> G (Datum :- t) t' -> G (Datum :- t) t'
-redecorate sty g = iso (styleWith sty) (styleWith sty) >>> g
-
-headTagged0 :: Text -> G (Datum :- t) t
-headTagged0 s = listWithStyle StyleCode $ el (sym s)
-
-headTagged0' :: Text -> DatumGrammar a -> G (Datum :- t) (List a :- t)
-headTagged0' s gt = listWithStyle StyleCode $ el (sym s) >>> rest gt
-
-headTagged1 :: Text -> DatumGrammar a -> G (Datum :- t) (a :- t)
-headTagged1 s g1 = listWithStyle StyleCode $ el (sym s) >>> el g1
-
-headTagged1'
-  :: Text
-  -> DatumGrammar a -> DatumGrammar b
-  -> G (Datum :- t) (List b :- a :- t)
-headTagged1' s g1 gt = list $ el (sym s) >>> el g1 >>> rest gt
-
-headTagged2
-  :: Text
-  -> DatumGrammar a -> DatumGrammar b
-  -> G (Datum :- t) (b :- a :- t)
-headTagged2 s g1 g2 = listWithStyle StyleCode $ el (sym s) >>> el g1 >>> el g2
-
-headTagged2'
-  :: Text
-  -> DatumGrammar a -> DatumGrammar b -> DatumGrammar c
-  -> G (Datum :- t) (List c :- b :- a :- t)
-headTagged2' s g1 g2 gt =
-  listWithStyle StyleCode $ el (sym s) >>> el g1 >>> el g2 >>> rest gt
-
-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 =
-  listWithStyle (StyleSyntax 1) $
-    el (sym kw) >>> el c >>> el t >>> el f
-
-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 = listWithStyle (StyleSyntax 1) $
-  el (sym 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 = listWithStyle (StyleSyntax 1) $
-  el 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 =
-  listWithStyle (StyleSyntax 0) $
-    el (sym 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)