parse lists

.dir-locals.el

@@ -8,12 +8,4 @@
   . ((eval
       . (progn (defun apply-cabal-fmt-h ()
                  (haskell-mode-buffer-apply-command "cabal-fmt"))
-               (add-hook 'before-save-hook #'apply-cabal-fmt-h nil t)))))
+               (add-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 ()
-                 (interactive)
-                 (ansi-color-apply-on-region (point-min) (point-max))))))))

.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/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 = {};
@@ -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/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/print/begin-nonempty-thin

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

golden/print/begin-nonempty-wide

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

golden/print/lambda-thin

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

golden/print/lambda-wide

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

golden/print/null

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

golden/print/rainbow

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

golden/print/simple-list-thin

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

golden/print/simple-list-wide

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

golden/read/bool/read

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

golden/read/datum-comment/source.scm

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

golden/read/decimal/read

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

golden/read/list-dot-flat/read

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

golden/read/list-flat/read

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

golden/read/list/read

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

golden/read/meta-expression/read

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

golden/read/meta-expression/source.scm

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

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

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

golden/read/meta-splice-variable/read

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

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

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

golden/read/meta-variable/read

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

golden/read/meta-variable/source.scm

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

golden/read/peculiar-identifier-dot/read

@@ -1,7 +0,0 @@
-[ SynNone :< SimpleF
-    ( SimpleSymbol ".." )
-, SynNone :< SimpleF
-    ( SimpleSymbol ".abc" )
-, SynNone :< SimpleF
-    ( SimpleSymbol "....abcc" )
-]

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

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

golden/read/peculiar-identifier-sign/read

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

golden/read/string/read

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

golden/read/typical-identifier-token/read

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

golden/read/typical-identifier-token/source.scm

@@ -1,2 +0,0 @@
-abc"xyz"
-수학(數學)

golden/read/typical-identifier/read

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

golden/read/typical-identifier/source.scm

@@ -1,5 +0,0 @@
-abc bala-hwa$ x!!! z z123 나는너무졸리다 學
-
-車室.
-
-三個女人一臺戲。

golden/reader/bool/read

@@ -0,0 +1,9 @@
+[ Fix
+    ( SimpleF ( Boolean True ) )
+, Fix
+    ( SimpleF ( Boolean True ) )
+, Fix
+    ( SimpleF ( Boolean False ) )
+, Fix
+    ( SimpleF ( Boolean False ) )
+]

golden/reader/decimal/read

@@ -0,0 +1,15 @@
+[ Fix
+    ( SimpleF
+        ( Number 45.0 )
+    )
+, Fix
+    ( SimpleF
+        ( Number 5667.0 )
+    )
+, Fix
+    ( SimpleF
+        ( Number
+            ( -123.0 )
+        )
+    )
+]

golden/reader/list-dot-flat/read

@@ -0,0 +1,25 @@
+[ Fix
+    ( CompoundF
+        ( DotListF
+            ( Fix
+                ( SimpleF
+                    ( Symbol "가" )
+                ) :|
+                [ Fix
+                    ( SimpleF
+                        ( Symbol "나" )
+                    )
+                , Fix
+                    ( SimpleF
+                        ( Symbol "다" )
+                    )
+                ]
+            )
+            ( Fix
+                ( SimpleF
+                    ( Symbol "라" )
+                )
+            )
+        )
+    )
+]

golden/reader/list-flat/read

@@ -0,0 +1,35 @@
+[ Fix
+    ( CompoundF
+        ( ListF
+            [ Fix
+                ( SimpleF
+                    ( Symbol "가" )
+                )
+            , Fix
+                ( SimpleF
+                    ( Symbol "나" )
+                )
+            , Fix
+                ( SimpleF
+                    ( Symbol "다" )
+                )
+            , Fix
+                ( SimpleF
+                    ( Symbol "라" )
+                )
+            , Fix
+                ( SimpleF
+                    ( Number 1.0 )
+                )
+            , Fix
+                ( SimpleF
+                    ( Number 2.0 )
+                )
+            , Fix
+                ( SimpleF
+                    ( Number 3.0 )
+                )
+            ]
+        )
+    )
+]

golden/reader/list/read

@@ -0,0 +1,60 @@
+[ Fix
+    ( CompoundF
+        ( DotListF
+            ( Fix
+                ( SimpleF
+                    ( Symbol "a" )
+                ) :|
+                [ Fix
+                    ( SimpleF
+                        ( Symbol "b" )
+                    )
+                , Fix
+                    ( CompoundF
+                        ( ListF
+                            [ Fix
+                                ( SimpleF
+                                    ( Symbol "c" )
+                                )
+                            , Fix
+                                ( SimpleF
+                                    ( Symbol "d" )
+                                )
+                            ]
+                        )
+                    )
+                ]
+            )
+            ( Fix
+                ( CompoundF
+                    ( ListF
+                        [ Fix
+                            ( SimpleF
+                                ( Symbol "가" )
+                            )
+                        , Fix
+                            ( CompoundF
+                                ( DotListF
+                                    ( Fix
+                                        ( SimpleF
+                                            ( Symbol "나" )
+                                        ) :| []
+                                    )
+                                    ( Fix
+                                        ( SimpleF
+                                            ( Symbol "다" )
+                                        )
+                                    )
+                                )
+                            )
+                        , Fix
+                            ( SimpleF
+                                ( Symbol "라" )
+                            )
+                        ]
+                    )
+                )
+            )
+        )
+    )
+]

golden/reader/peculiar-identifier/read

@@ -0,0 +1,9 @@
+[ Fix
+    ( SimpleF
+        ( Symbol "+" )
+    )
+, Fix
+    ( SimpleF
+        ( Symbol "-" )
+    )
+]

golden/reader/string/read

@@ -0,0 +1,5 @@
+[ Fix
+    ( SimpleF
+        ( String "가나다라" )
+    )
+]

golden/reader/typical-identifier/read

@@ -0,0 +1,37 @@
+[ Fix
+    ( SimpleF
+        ( Symbol "abc" )
+    )
+, Fix
+    ( SimpleF
+        ( Symbol "balahwa$" )
+    )
+, Fix
+    ( SimpleF
+        ( Symbol "x!!!" )
+    )
+, Fix
+    ( SimpleF
+        ( Symbol "z" )
+    )
+, Fix
+    ( SimpleF
+        ( Symbol "z123" )
+    )
+, Fix
+    ( SimpleF
+        ( Symbol "나는너무졸리다" )
+    )
+, Fix
+    ( SimpleF
+        ( Symbol "學" )
+    )
+, Fix
+    ( SimpleF
+        ( Symbol "車室." )
+    )
+, Fix
+    ( SimpleF
+        ( Symbol "三個女人一臺戲。" )
+    )
+]

golden/reader/typical-identifier/source.scm

@@ -0,0 +1,5 @@
+abc balahwa$ x!!! z z123 나는너무졸리다 學
+
+車室.
+
+三個女人一臺戲。

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
@@ -58,34 +53,28 @@ library
   -- cabal-fmt: expand src
   exposed-modules:
     Gyehoek.CPS.Close
-    Gyehoek.CPS.Contify
     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.Lift1
     Gyehoek.Options
     Gyehoek.Prelude
     Gyehoek.Scheme.Syntax
     Gyehoek.Sexp
     Gyehoek.Sexp.Grammar
-    Gyehoek.Sexp.Grammar.Base
     Gyehoek.Sexp.Print
-    Gyehoek.Sexp.QQ
     Gyehoek.Sexp.Read
     Gyehoek.Sexp.Syntax
-    Gyehoek.Stack.Lower
     Gyehoek.Stack.Syntax
     Gyehoek.Stack.VM
     Gyehoek.Wasm
 
   build-depends:
-    , base                         ^>=4.21.2.0
+    , base                  ^>=4.21.2.0
     , binary
     , bytestring
     , comonad
@@ -102,18 +91,16 @@ library
     , hashable
     , invertible-grammar
     , lens
-    , lucid
     , megaparsec
     , mtl
     , optparse-applicative
     , ordered-containers
     , pretty-simple
     , prettyprinter
-    , prettyprinter-ansi-terminal
-    , prettyprinter-lucid
     , process
     , recursion-schemes
     , scientific
+    , sexp-grammar
     , string-interpolate
     , template-haskell
     , text
@@ -121,7 +108,6 @@ library
     , typed-process
     , unordered-containers
     , vector
-    , tardis
 
   hs-source-dirs:   src
   default-language: GHC2024
@@ -140,11 +126,8 @@ test-suite test
     Gyehoek.Test.CPS.Syntax
     Gyehoek.Test.Golden
     Gyehoek.Test.Scheme.Syntax
-    Gyehoek.Test.Sexp.Print
+    Gyehoek.Test.Sexp
-    Gyehoek.Test.Sexp.QQ
-    Gyehoek.Test.Sexp.Read
     Gyehoek.Test.Stack.VM
-    Gyehoek.TestUtil
     Root
 
   build-depends:
@@ -158,6 +141,7 @@ test-suite test
     , lens
     , pretty-simple
     , process-extras
+    , sexp-grammar
     , tasty
     , tasty-expected-failure
     , tasty-hunit
@@ -165,21 +149,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

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`,
-  (prim (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})
-        (prim (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/Contify.hs

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

src/Gyehoek/CPS/Convert.hs

@@ -12,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,78 +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.ExpPrim 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
-    -- k_l <- gensym' @Name "prim-k"
+    cc <- gensym' @Name "cc"
-    m <- k [ValVar r_l]
+    r <- gensym' "r"
+    m <- k $ ValVar r
+    ccish <- gensym' @Name "cc-ish"
+    x <- gensym' @Name "x"
     pure [cps|
-      (prim #{p'} (κ (#{r_l}) #{m}))
+      (letrec ((#{cc} (κ (#{r}) #{m})))
+        (letrec ((#{ccish} (λ (#{x} _) (continue #{cc} #{x}))))
+          (#{withcc'} #{ccish} #{cc})))
     |]
-    -- pure [cps|
+
-    --   (letrec ((#{k_l} (κ (#{r_l}) #{m})))
+-- ...while all other prims are left as-is for later stages to
-    --     (prim #{p'} #{k_l}))
+-- 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 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
@@ -118,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,259 +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 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_)
 
 
-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
 
-bind :: Name -> Loc -> Env
+eval g (ExpContinue k xs) =
-bind k = MkEnv . H.singleton k
+  case g ^. #labels . at k of
+    Just (h, AbsKappa' bs m) -> eval h' m
+      where h' = h & #vars <>~ envOfBinds bs (evalVal g <$> xs)
+    _ -> error [i|not a kappa: #{k}|]
 
-extends :: Foldable f => f (Name, Loc) -> Env -> Env
+eval g (ExpApply ((^?! #ValVar) -> f) xs ktail) =
-extends xs g = g <> foldMap (uncurry bind) xs
+  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}|]
 
-assign :: Loc -> E -> M Answer ()
+eval g (ExpLetRec [(b, ab)] e) = eval g' e
-assign l e = do
+  where g' = g & #labels . at b ?~ (g,ab)
-  use (at l) >>= \case
-    Just _ -> at l ?= e
-    Nothing -> wrong [i|#{e}에서 #{l}이라는 주소는 없다|]
 
-
+eval g (ExpPrim p (MkKappa bs e)) = case evalVal g <$> p of
-
+  PrimAdd x y -> arithBinop (+) x y
--- | The denotation of an expressed value.
+  PrimMul x y -> arithBinop (*) x y
-data E
+  PrimSub x y -> arithBinop (-) x y
-  = ESymbol Text
+  PrimDiv x y -> arithBinop div x y
-  | ECharacter Char
+  _ -> error [i|unhandled prim: #{p}|]
-  | EInt Int
-  | EBool Bool
-  | EUndefined
-  | EUnspecified
-  | ENull
-  | EPair Loc Loc Mutability
-  | EVec (List Loc) Mutability
-  | EString (List Loc) Mutability
-  | EProcedure Procedure
-  deriving stock (Show, Generic)
-
-type Procedure = List E -> DynPoints -> M Answer (List E)
-
-eGrammar :: Store -> S.DatumGrammar E
-eGrammar st = S.partialOsi (const . Left $ mempty) go
   where
-    gofetch x = go $ st ^?! ix x
+    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>"
-      ENull -> S.List []
-      EPair car cdr _mut -> S.DotList [gofetch car] (gofetch cdr)
-      EVec xs _mut -> S.Vector . fmap gofetch $ xs
-      EString xs _mut -> S.String _
 
-data DynPoints = MkDynPoints
+eval _ e = error [i|unimplemented case: #{e}|]
-  deriving (Generic, Data)
 
-
+envOfBinds bs xs = foldMap (uncurry H.singleton) (zip bs xs)
 
-evalVal :: Env -> Val -> M Answer E
+evalVal :: Env -> Val -> Obj
+evalVal g = \case
+  ValVar x -> fromMaybe (error [i|unbound: #{x}|]) $ g ^?! #vars . at x
+  ValImm x -> ObjImm x
 
-evalVal g (ValVar x) = var g x >>= fetch
+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 g (ValImm imm) = pure case imm of
+evalProgram :: Program -> List Obj
-  ImmLabel l -> error [i|#{l}|]
+evalProgram (MkProgram e) = eval emptyEnv e
-  ImmInt n -> EInt n
-  ImmBool b -> EBool b
-  ImmUndefined -> EUndefined
-
-evalKexp :: Env -> Kexp -> M Answer E
-evalKexp g (KexpVar x) = var g x >>= fetch
-evalKexp g (KexpKappa kap) = evalAbs g (AbsKappa kap)
-
-evalAbs :: Env -> Abs -> M Answer E
-evalAbs g (MkAbs formals ktail e) = pure . EProcedure $ \xs dps ->
-  let
-    formals' = formals ++ foldMap (:[]) ktail
-    lformals = length formals'
-    lxs = length xs
-  in if lformals /= lxs
-  then wrong [i|함수는 #{lformals}개의 인자를 필요로 하는데 #{lxs}개 받았다.|]
-  else do
-    ls <- xs & traverse new'
-    let g' = g & extends (zip formals' ls)
-    eval g' dps e
-
-eval :: Env -> DynPoints -> Exp -> M Answer (List E)
-
-eval g dps (ExpJump f xs ktail) = do
-  f' <- evalVal g f
-  xs' <- traverse (evalVal g) xs
-  ktail' <- traverse (evalKexp g) (ktail ^.. _Just)
-  case f' of
-    EProcedure p -> p (xs' ++ ktail') dps
-    _ -> wrong "bad procedure"
-
-eval g dps (ExpLetRec bs e) = do
-  ls <- for bs . const $ new' EUndefined
-  let g' = g & extends (zip (bs ^.. each . _1) ls)
-  bs' <- forOf (each . _2) bs (evalAbs g')
-  traverse_ (uncurry assign) $ zip ls (bs' ^.. each . _2)
-  eval g' dps e
-
-eval g dps (ExpPrim p k) = do
-  p' <- evalPrim g =<< traverse (evalVal g) p
-  evalKexp g k >>= \case
-    EProcedure fp -> fp p' dps
-    _ -> wrong [i|prim(#{p})의 계속을 나쁘다|]
-
-eval g dps e = error [i|unimplemented #{e}|]
-
-evalPrim :: Env -> Prim E -> M Answer (List E)
-evalPrim g = \case
-  PrimAdd x y -> arith2 (+) x y
-  PrimMul x y -> arith2 (*) x y
-  PrimSub x y -> arith2 (-) x y
-  PrimDiv x y -> arith2 div x y
-  PrimValues xs -> pure xs
-  p -> wrong [i|prim(#{p})은 벌써 나지 않다|]
-  where
-    arith2 f (EInt x) (EInt y) = pure [EInt $ f x y]
-    arith2 f x y = wrong [i|나쁜 인자: #{x}, #{y}|]
-
-
-
-evalExp :: Jalmot :> es => Exp -> Eff es _
-evalExp e = _
-
-evalProgram :: Jalmot :> es => Program -> Eff es (List S.Datum)
-evalProgram (MkProgram lam) = case run (pure . AnswerValues) of
-  (AnswerError jm, _) -> throwError jm
-  (AnswerValues vs, st) -> traverse (S.toDatum $ eGrammar st) vs
-  where
-    run f = (`runState` emptyStore) . (`runContT` f) $ do
-      g <- setup
-      eval g MkDynPoints (ExpLetRec
-        [("_start",AbsLambda lam)]
-        (ExpApply (ValVar "_start") [] (KexpVar "halt")))
-
-
-
-setup :: M Answer Env
-setup = defines @List
-  [ ("halt", EProcedure prim_halt)
-  ]
-
-prim_halt :: Procedure
-prim_halt xs _dps = ContT \_ -> pure $ AnswerValues xs