더 간단한 신택스 annotations

doc/libraries.org

@@ -1,5 +1,7 @@
 #+title: on libraries
 
+* libraries and the file system
+
 R⁷RS leaves it unspecified how exactly libraries correspond to files:
 
 #+begin_quote
@@ -7,3 +9,11 @@ Programs and libraries are typically stored in files, although in some implement
 #+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

flake.nix

@@ -55,7 +55,7 @@
                 nodejs
                 wasm-tools
                 wac-cli
-                guile
+                gauche
                 rust-analyzer
                 wasmtime
                 # bashInteractive is necessary to work around an

golden/print/begin-nonempty-thin

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

golden/print/begin-nonempty-wide

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

golden/print/lambda-thin

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

golden/print/lambda-wide

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

golden/print/simple-list-thin

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

golden/print/simple-list-wide

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

golden/read/bool/read

@@ -1,6 +1,5 @@
 [ MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/bool/source.scm"
             , sourceLine = Pos 1
@@ -9,8 +8,7 @@
         )
     } :< SimpleF ( SimpleBoolean True )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/bool/source.scm"
             , sourceLine = Pos 1
@@ -19,8 +17,7 @@
         )
     } :< SimpleF ( SimpleBoolean True )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/bool/source.scm"
             , sourceLine = Pos 1
@@ -29,8 +26,7 @@
         )
     } :< SimpleF ( SimpleBoolean False )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/bool/source.scm"
             , sourceLine = Pos 1

golden/read/decimal/read

@@ -1,6 +1,5 @@
 [ MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/decimal/source.scm"
             , sourceLine = Pos 1
@@ -10,8 +9,7 @@
     } :< SimpleF
     ( SimpleNumber 45.0 )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/decimal/source.scm"
             , sourceLine = Pos 1
@@ -21,8 +19,7 @@
     } :< SimpleF
     ( SimpleNumber 5667.0 )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/decimal/source.scm"
             , sourceLine = Pos 1

golden/read/list-dot-flat/read

@@ -1,6 +1,5 @@
 [ MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/list-dot-flat/source.scm"
             , sourceLine = Pos 1
@@ -11,8 +10,7 @@
     ( DotListF
         (
             ( MkAnn
-                { syntax = SynNone
+                { position = Just
-                , position = Just
                     ( SourcePos
                         { sourceName = "golden/read/list-dot-flat/source.scm"
                         , sourceLine = Pos 1
@@ -23,8 +21,7 @@
                 ( SimpleSymbol "가" )
             ) :|
             [ MkAnn
-                { syntax = SynNone
+                { position = Just
-                , position = Just
                     ( SourcePos
                         { sourceName = "golden/read/list-dot-flat/source.scm"
                         , sourceLine = Pos 1
@@ -34,8 +31,7 @@
                 } :< SimpleF
                 ( SimpleSymbol "나" )
             , MkAnn
-                { syntax = SynNone
+                { position = Just
-                , position = Just
                     ( SourcePos
                         { sourceName = "golden/read/list-dot-flat/source.scm"
                         , sourceLine = Pos 1
@@ -47,8 +43,7 @@
             ]
         )
         ( MkAnn
-            { syntax = SynNone
+            { position = Just
-            , position = Just
                 ( SourcePos
                     { sourceName = "golden/read/list-dot-flat/source.scm"
                     , sourceLine = Pos 1

golden/read/list-flat/read

@@ -1,6 +1,5 @@
 [ MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/list-flat/source.scm"
             , sourceLine = Pos 1
@@ -8,10 +7,9 @@
             }
         )
     } :< CompoundF
-    ( ListF Ordinary
+    ( ListF StyleData
         [ MkAnn
-            { syntax = SynNone
+            { position = Just
-            , position = Just
                 ( SourcePos
                     { sourceName = "golden/read/list-flat/source.scm"
                     , sourceLine = Pos 1
@@ -21,8 +19,7 @@
             } :< SimpleF
             ( SimpleSymbol "가" )
         , MkAnn
-            { syntax = SynNone
+            { position = Just
-            , position = Just
                 ( SourcePos
                     { sourceName = "golden/read/list-flat/source.scm"
                     , sourceLine = Pos 1
@@ -32,8 +29,7 @@
             } :< SimpleF
             ( SimpleSymbol "나" )
         , MkAnn
-            { syntax = SynNone
+            { position = Just
-            , position = Just
                 ( SourcePos
                     { sourceName = "golden/read/list-flat/source.scm"
                     , sourceLine = Pos 1
@@ -43,8 +39,7 @@
             } :< SimpleF
             ( SimpleSymbol "다" )
         , MkAnn
-            { syntax = SynNone
+            { position = Just
-            , position = Just
                 ( SourcePos
                     { sourceName = "golden/read/list-flat/source.scm"
                     , sourceLine = Pos 1
@@ -54,8 +49,7 @@
             } :< SimpleF
             ( SimpleSymbol "라" )
         , MkAnn
-            { syntax = SynNone
+            { position = Just
-            , position = Just
                 ( SourcePos
                     { sourceName = "golden/read/list-flat/source.scm"
                     , sourceLine = Pos 1
@@ -65,8 +59,7 @@
             } :< SimpleF
             ( SimpleNumber 1.0 )
         , MkAnn
-            { syntax = SynNone
+            { position = Just
-            , position = Just
                 ( SourcePos
                     { sourceName = "golden/read/list-flat/source.scm"
                     , sourceLine = Pos 1
@@ -76,8 +69,7 @@
             } :< SimpleF
             ( SimpleNumber 2.0 )
         , MkAnn
-            { syntax = SynNone
+            { position = Just
-            , position = Just
                 ( SourcePos
                     { sourceName = "golden/read/list-flat/source.scm"
                     , sourceLine = Pos 1

golden/read/list/read

@@ -1,6 +1,5 @@
 [ MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/list/source.scm"
             , sourceLine = Pos 1
@@ -11,8 +10,7 @@
     ( DotListF
         (
             ( MkAnn
-                { syntax = SynNone
+                { position = Just
-                , position = Just
                     ( SourcePos
                         { sourceName = "golden/read/list/source.scm"
                         , sourceLine = Pos 1
@@ -23,8 +21,7 @@
                 ( SimpleSymbol "a" )
             ) :|
             [ MkAnn
-                { syntax = SynNone
+                { position = Just
-                , position = Just
                     ( SourcePos
                         { sourceName = "golden/read/list/source.scm"
                         , sourceLine = Pos 1
@@ -34,8 +31,7 @@
                 } :< SimpleF
                 ( SimpleSymbol "b" )
             , MkAnn
-                { syntax = SynNone
+                { position = Just
-                , position = Just
                     ( SourcePos
                         { sourceName = "golden/read/list/source.scm"
                         , sourceLine = Pos 1
@@ -43,10 +39,9 @@
                         }
                     )
                 } :< CompoundF
-                ( ListF Ordinary
+                ( ListF StyleData
                     [ MkAnn
-                        { syntax = SynNone
+                        { position = Just
-                        , position = Just
                             ( SourcePos
                                 { sourceName = "golden/read/list/source.scm"
                                 , sourceLine = Pos 1
@@ -56,8 +51,7 @@
                         } :< SimpleF
                         ( SimpleSymbol "c" )
                     , MkAnn
-                        { syntax = SynNone
+                        { position = Just
-                        , position = Just
                             ( SourcePos
                                 { sourceName = "golden/read/list/source.scm"
                                 , sourceLine = Pos 1
@@ -71,8 +65,7 @@
             ]
         )
         ( MkAnn
-            { syntax = SynNone
+            { position = Just
-            , position = Just
                 ( SourcePos
                     { sourceName = "golden/read/list/source.scm"
                     , sourceLine = Pos 1
@@ -80,10 +73,9 @@
                     }
                 )
             } :< CompoundF
-            ( ListF Ordinary
+            ( ListF StyleData
                 [ MkAnn
-                    { syntax = SynNone
+                    { position = Just
-                    , position = Just
                         ( SourcePos
                             { sourceName = "golden/read/list/source.scm"
                             , sourceLine = Pos 1
@@ -93,8 +85,7 @@
                     } :< SimpleF
                     ( SimpleSymbol "가" )
                 , MkAnn
-                    { syntax = SynNone
+                    { position = Just
-                    , position = Just
                         ( SourcePos
                             { sourceName = "golden/read/list/source.scm"
                             , sourceLine = Pos 1
@@ -105,8 +96,7 @@
                     ( DotListF
                         (
                             ( MkAnn
-                                { syntax = SynNone
+                                { position = Just
-                                , position = Just
                                     ( SourcePos
                                         { sourceName = "golden/read/list/source.scm"
                                         , sourceLine = Pos 1
@@ -118,8 +108,7 @@
                             ) :| []
                         )
                         ( MkAnn
-                            { syntax = SynNone
+                            { position = Just
-                            , position = Just
                                 ( SourcePos
                                     { sourceName = "golden/read/list/source.scm"
                                     , sourceLine = Pos 1
@@ -131,8 +120,7 @@
                         )
                     )
                 , MkAnn
-                    { syntax = SynNone
+                    { position = Just
-                    , position = Just
                         ( SourcePos
                             { sourceName = "golden/read/list/source.scm"
                             , sourceLine = Pos 1

golden/read/meta-expression/read

@@ -1,6 +1,5 @@
 [ MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/meta-expression/source.scm"
             , sourceLine = Pos 1

golden/read/meta-splice-expression/read

@@ -1,6 +1,5 @@
 [ MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/meta-splice-expression/source.scm"
             , sourceLine = Pos 1

golden/read/meta-splice-variable/read

@@ -1,6 +1,5 @@
 [ MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/meta-splice-variable/source.scm"
             , sourceLine = Pos 1

golden/read/meta-variable/read

@@ -1,6 +1,5 @@
 [ MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/meta-variable/source.scm"
             , sourceLine = Pos 1

golden/read/peculiar-identifier-dot/read

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

golden/read/peculiar-identifier-sign/read

@@ -1,6 +1,5 @@
 [ MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/peculiar-identifier-sign/source.scm"
             , sourceLine = Pos 1
@@ -10,8 +9,7 @@
     } :< SimpleF
     ( SimpleSymbol "+" )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/peculiar-identifier-sign/source.scm"
             , sourceLine = Pos 1
@@ -20,4 +18,54 @@
         )
     } :< 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 +1,3 @@
 + -
+
++. +.. -. -...abc -abc..

golden/read/string/read

@@ -1,6 +1,5 @@
 [ MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/string/source.scm"
             , sourceLine = Pos 1

golden/read/typical-identifier-token/read

@@ -1,6 +1,5 @@
 [ MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/typical-identifier-token/source.scm"
             , sourceLine = Pos 1
@@ -10,8 +9,7 @@
     } :< SimpleF
     ( SimpleSymbol "abc" )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/typical-identifier-token/source.scm"
             , sourceLine = Pos 1
@@ -21,8 +19,7 @@
     } :< SimpleF
     ( SimpleString "xyz" )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/typical-identifier-token/source.scm"
             , sourceLine = Pos 2
@@ -32,8 +29,7 @@
     } :< SimpleF
     ( SimpleSymbol "수학" )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/typical-identifier-token/source.scm"
             , sourceLine = Pos 2
@@ -41,10 +37,9 @@
             }
         )
     } :< CompoundF
-    ( ListF Ordinary
+    ( ListF StyleData
         [ MkAnn
-            { syntax = SynNone
+            { position = Just
-            , position = Just
                 ( SourcePos
                     { sourceName = "golden/read/typical-identifier-token/source.scm"
                     , sourceLine = Pos 2

golden/read/typical-identifier/read

@@ -1,6 +1,5 @@
 [ MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/typical-identifier/source.scm"
             , sourceLine = Pos 1
@@ -10,8 +9,7 @@
     } :< SimpleF
     ( SimpleSymbol "abc" )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/typical-identifier/source.scm"
             , sourceLine = Pos 1
@@ -21,8 +19,7 @@
     } :< SimpleF
     ( SimpleSymbol "bala-hwa$" )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/typical-identifier/source.scm"
             , sourceLine = Pos 1
@@ -32,8 +29,7 @@
     } :< SimpleF
     ( SimpleSymbol "x!!!" )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/typical-identifier/source.scm"
             , sourceLine = Pos 1
@@ -43,8 +39,7 @@
     } :< SimpleF
     ( SimpleSymbol "z" )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/typical-identifier/source.scm"
             , sourceLine = Pos 1
@@ -54,8 +49,7 @@
     } :< SimpleF
     ( SimpleSymbol "z123" )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/typical-identifier/source.scm"
             , sourceLine = Pos 1
@@ -65,8 +59,7 @@
     } :< SimpleF
     ( SimpleSymbol "나는너무졸리다" )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/typical-identifier/source.scm"
             , sourceLine = Pos 1
@@ -76,8 +69,7 @@
     } :< SimpleF
     ( SimpleSymbol "學" )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/typical-identifier/source.scm"
             , sourceLine = Pos 3
@@ -87,8 +79,7 @@
     } :< SimpleF
     ( SimpleSymbol "車室." )
 , MkAnn
-    { syntax = SynNone
+    { position = Just
-    , position = Just
         ( SourcePos
             { sourceName = "golden/read/typical-identifier/source.scm"
             , sourceLine = Pos 5

gyehoek.cabal

@@ -26,6 +26,7 @@ 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
@@ -54,23 +55,25 @@ 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.Contify
     Gyehoek.CPS.Convert
     Gyehoek.CPS.Eval
     Gyehoek.CPS.Hoist
-    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
@@ -79,9 +82,6 @@ library
     Gyehoek.Sexp.QQ
     Gyehoek.Sexp.Read
     Gyehoek.Sexp.Syntax
-    Gyehoek.Stack.Lower
-    Gyehoek.Stack.Syntax
-    Gyehoek.Stack.VM
     Gyehoek.Wasm
 
   build-depends:
@@ -114,14 +114,17 @@ library
     , process
     , recursion-schemes
     , scientific
+    , semialign
     , string-interpolate
+    , tardis
     , template-haskell
     , text
     , text-short
+    , these
     , typed-process
     , unordered-containers
     , vector
-    , tardis
+    , witherable
 
   hs-source-dirs:   src
   default-language: GHC2024
@@ -136,14 +139,11 @@ test-suite test
   -- cabal-fmt: expand test -Main
   other-modules:
     Gyehoek.Test.CPS.Eval
-    Gyehoek.Test.CPS.Stackify
     Gyehoek.Test.CPS.Syntax
-    Gyehoek.Test.Golden
     Gyehoek.Test.Scheme.Syntax
     Gyehoek.Test.Sexp.Print
     Gyehoek.Test.Sexp.QQ
     Gyehoek.Test.Sexp.Read
-    Gyehoek.Test.Stack.VM
     Gyehoek.TestUtil
     Root
 

macroexpand.scm

@@ -0,0 +1,11 @@
+(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)
+      ())))

src/Gyehoek/CPS/Close.hs

@@ -18,7 +18,7 @@ genCodeName f = gensym' @Name $ f ^. _Wrapped' . to (<> "-code")
 
 bindEnv :: List Name -> Exp -> Exp
 bindEnv frees m = [cps|
-  (prim (get-env) (κ #{frees} #{m}))
+  (builtin (get-env) (κ #{frees} #{m}))
 |]
 
 close1 :: forall es. GenSym :> es => Exp -> Eff es Exp
@@ -41,7 +41,7 @@ close1 = \case
     let codes = bs' ^.. each . _1 . to MkLabel
     pure [cps|
       (letrec #{bs'}
-        (prim (make-shared-closure #{codes} #{frees})
+        (builtin (make-shared-closure #{codes} #{frees})
           (κ #{boundNames}
             #{e})))
     |]

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

@@ -46,18 +46,13 @@ convert (Scm.ExpLit l) k = k . one . ValImm $ case l of
   LitBool b -> ImmBool b
   _ -> _
 
-convert (Scm.ExpPrim p) k =
+convert (Scm.ExpBuiltin p) k =
   telescope (convert1 @es) p \p' -> do
     r_l <- gensym' "r"
-    -- k_l <- gensym' @Name "prim-k"
     m <- k [ValVar r_l]
     pure [cps|
-      (prim #{p'} (κ (#{r_l}) #{m}))
+      (builtin #{p'} (κ (#{r_l}) #{m}))
     |]
-    -- pure [cps|
-    --   (letrec ((#{k_l} (κ (#{r_l}) #{m})))
-    --     (prim #{p'} #{k_l}))
-    -- |]
 
 convert (Scm.ExpLambda xs e) k = do
   f <- gensym' "lambda-body"
@@ -78,7 +73,7 @@ convert (Scm.ExpApply f xs) k =
 
 convert (Scm.ExpBegin xs) k = telescope (convert @es) xs (k . NE.last)
 
-convert (Scm.ExpIf c t f) k =
+convert (Scm.ExpIf c t (Just f)) k =
   convert1 c \c' -> do
     t_l <- gensym' @Name "truthy-cont"
     f_l <- gensym' @Name "falsey-cont"

src/Gyehoek/CPS/Eval.hs

@@ -226,7 +226,7 @@ eval g dps (ExpLetRec bs e) = do
   traverse_ (uncurry assign) $ zip ls (bs' ^.. each . _2)
   eval g' dps e
 
-eval g dps (ExpPrim (PrimCallCC withcc) k) = do
+eval g dps (ExpBuiltin (BuiltinCallCC withcc) k) = do
   withcc' <- evalVal g withcc >>= orWrong #_EProcedure
     [i|call/cc: 함수가 아닌 것을 받았다|]
   k' <- evalKexp g k
@@ -236,8 +236,8 @@ eval g dps (ExpPrim (PrimCallCC withcc) k) = do
         Nothing -> wrong [i|call/cc: 잘못하는데!|]
   withcc' [cc,k'] dps
 
-eval g dps (ExpPrim p k) = do
+eval g dps (ExpBuiltin p k) = do
-  p' <- evalPrim g dps =<< traverse (evalVal g) p
+  p' <- evalBuiltin g dps =<< traverse (evalVal g) p
   evalKexp g k >>= \case
     EProcedure fp -> fp p' dps
     _ -> wrong [i|prim(#{p})의 계속을 나쁘다|]
@@ -251,20 +251,20 @@ eval g dps (ExpIf c t f) = do
 
 eval g dps e = error [i|unimplemented #{e}|]
 
-evalPrim :: Env -> DynPoints -> Prim E -> M Answer (List E)
+evalBuiltin :: Env -> DynPoints -> Builtin E -> M Answer (List E)
-evalPrim g dps = \case
+evalBuiltin g dps = \case
-  PrimAdd x y -> arith2 (+) x y
+  BuiltinAdd x y -> arith2 (+) x y
-  PrimMul x y -> arith2 (*) x y
+  BuiltinMul x y -> arith2 (*) x y
-  PrimSub x y -> arith2 (-) x y
+  BuiltinSub x y -> arith2 (-) x y
-  PrimDiv x y -> arith2 div x y
+  BuiltinDiv x y -> arith2 div x y
-  PrimZeroP x -> pure1 . EBool . isJust $ x ^? #EInt . only 0
+  BuiltinZeroP x -> pure1 . EBool . isJust $ x ^? #EInt . only 0
-  PrimCons x y -> pcons x y >>= pure1
+  BuiltinCons x y -> pcons x y >>= pure1
-  PrimCar p -> cr p _2
+  BuiltinCar p -> cr p _2
-  PrimCdr p -> cr p _3
+  BuiltinCdr p -> cr p _3
-  PrimPairP p -> pure1 . EBool . maybe False (const True) $
+  BuiltinPairP p -> pure1 . EBool . maybe False (const True) $
     p ^? #_EPair
-  PrimValues xs -> pure xs
+  BuiltinValues xs -> pure xs
-  PrimList xs -> foldrM pcons ENull xs >>= pure1
+  BuiltinList xs -> foldrM pcons ENull xs >>= pure1
   p -> wrong [i|prim(#{p})은 벌써 나지 않다|]
   where
     pure1 x = pure [x]

src/Gyehoek/CPS/Stackify.hs

@@ -1,166 +0,0 @@
-{-# LANGUAGE OverloadedLists #-}
-module Gyehoek.CPS.Stackify
-  ( stackifyProgram
-  , module Gyehoek.CPS.Syntax
-  ) where
-
-import Gyehoek.CPS.Syntax
-import Gyehoek.Stack.Syntax qualified as Stk
-import Data.Sequence (Seq)
-import Data.Sequence qualified as Seq
-import Gyehoek.GenSym
-import Effectful.Writer.Static.Shared
-import Data.Foldable
-import qualified Data.HashMap.Strict as H
-import Data.List (elemIndex, nub, intersect)
-import Data.Text qualified as T
-import Gyehoek.Prelude
-import Debug.Pretty.Simple
-import qualified Gyehoek.Sexp as S
-import Data.Monoid
-
-
-data BlockBuilder
-  = Code (List Stk.Instr) BlockBuilder
-  | Tail Stk.Tail
-  deriving (Show, Generic)
-
-buildBlock :: BlockBuilder -> Stk.Block
-buildBlock = go [] where
-  go acc (Code xs bb) = go (acc ++ xs) bb
-  go acc (Tail t) = Stk.MkBlock acc t
-
--- affine
-_ValName :: Traversal' Val Name
-_ValName = failing #_ValVar (#_ValImm . #_ImmLabel . #_MkLabel)
-
-stackify
-  :: forall es. (GenSym :> es)
-  => Env -> Exp -> Eff es BlockBuilder
-
-stackify _ (ExpContinue (ValVar k) xs) =
-  Code [ ] _
-
-stackify _ (ExpPrim p k) = _
-
-stackify _ e = error [i|unimplemented exp: #{e}|]
-
-stackifyAbs :: (GenSym :> es) => Env -> Label -> Abs -> Eff es Stk.Routine
-
-stackifyAbs g lbl (MkAbs xs mtail e) =
-  Stk.MkRoutine lbl . buildBlock . preamble <$> stackify g e
-  where
-    preamble = Code (popArgs $ (mtail ^.. _Just) ++ xs)
-
-popArgs :: List Name -> List Stk.Instr
-popArgs = fmap (Stk.Pop . MkReg) . reverse
-
-pushArgs :: List Name -> List Stk.Instr
-pushArgs = _
-
-
-
-data Env = MkEnv
-  {
-  }
-  deriving (Show, Generic)
-
-emptyEnv :: Env
-emptyEnv = MkEnv
-  {
-  }
-
-
-
-stackifyProgram
-  :: forall es. GenSym :> es
-  => HoistedProgram -> Eff es Stk.Program
-stackifyProgram p = p
-  & ifoldMapOf
-    ((#bindings . itraversed)
-     <> (#body . to (H.singleton "start" . AbsLambda) . itraversed))
-    (\l -> Ap . stackifyBinding l)
-  & getAp
-  where
-    g = emptyEnv
-    stackifyBinding lbl ab =
-      Stk.MkProgram . H.singleton lbl <$> stackifyAbs @es g lbl ab
-
-p :: HoistedProgram
-p = [cps|
-(letrec (($r12-code32
-          (κ (x13)
-            (prim
-             (get-env)
-             (κ (r12 start-ktail0)
-               (continue start-ktail0 x13)))))
-         ($prim-k7-code22
-          (κ (r6)
-            (prim
-             (get-env)
-             (κ (prim-k7 lambda-tail1 n fac)
-               (prim
-                (make-shared-closure ($r8-code19) (lambda-tail1 n))
-                (κ (r8)
-                  (fac r6 r8)))))))
-         ($prim-k11-code16
-          (κ (r10)
-            (prim
-             (get-env)
-             (κ (prim-k11 lambda-tail1)
-               (continue lambda-tail1 r10)))))
-         ($falsey-cont5-code26
-          (κ ()
-            (prim
-             (get-env)
-             (κ (truthy-cont4 falsey-cont5 lambda-tail1 n fac)
-               (prim
-                (make-shared-closure ($prim-k7-code22) (lambda-tail1 n fac))
-                (κ (prim-k7)
-                  (prim (- n 1) prim-k7)))))))
-         ($r8-code19
-          (κ (x9)
-            (prim
-             (get-env)
-             (κ (r8 lambda-tail1 n)
-               (prim
-                (make-shared-closure ($prim-k11-code16) (lambda-tail1))
-                (κ (prim-k11)
-                  (prim (* n x9) prim-k11)))))))
-         ($truthy-cont4-code25
-          (κ ()
-            (prim
-             (get-env)
-             (κ (truthy-cont4 falsey-cont5 lambda-tail1 n fac)
-               (continue lambda-tail1 1)))))
-         ($fac-code35
-          (λ (n lambda-tail1)
-            (prim
-             (get-env)
-             (κ (fac)
-               (prim
-                (make-shared-closure ($prim-k3-code29) (lambda-tail1 n fac))
-                (κ (prim-k3)
-                  (prim (zero? n) prim-k3)))))))
-         ($prim-k3-code29
-          (κ (r2)
-            (prim
-             (get-env)
-             (κ (prim-k3 lambda-tail1 n fac)
-               (prim
-                (make-shared-closure
-                 ($truthy-cont4-code25 $falsey-cont5-code26)
-                 (lambda-tail1 n fac))
-                (κ (truthy-cont4 falsey-cont5)
-                  (if r2
-                    truthy-cont4
-                    falsey-cont5))))))))
-  (λ (start-ktail0)
-    (prim
-     (make-shared-closure ($fac-code35) ())
-     (κ (fac)
-       (prim
-        (make-shared-closure ($r12-code32) (start-ktail0))
-        (κ (r12)
-          (fac 20 r12)))))))
-|]

src/Gyehoek/CPS/Syntax.hs

@@ -5,6 +5,8 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE DeriveAnyClass #-}
+{- HLINT ignore "Avoid lambda using `infix`" -}
+{- HLINT ignore "Redundant $" -}
 module Gyehoek.CPS.Syntax
   ( Val(..)
   , Kappa(..)
@@ -13,7 +15,7 @@ module Gyehoek.CPS.Syntax
   , Kexp(..)
   , ExpF(..)
   , Name(..)
-  , Prim(..)
+  , Builtin(..)
   , Program(..)
   , HoistedProgram(..)
   , Lit(..)
@@ -25,7 +27,7 @@ module Gyehoek.CPS.Syntax
   , pattern Halt
   , pattern Halt1
   , _MkKappa
-  , _ExpPrim
+  , _ExpBuiltin
   , _ExpLetRec
   , _ExpApply
   , _AbsLambda'
@@ -50,7 +52,7 @@ module Gyehoek.CPS.Syntax
   )
   where
 
-import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primDatumIso, Lit(..))
+import Gyehoek.Scheme.Syntax (Name (..), Builtin(..), builtinDatumIso, Lit(..))
 import Gyehoek.Sexp qualified as S
 import Control.Category
 import Prelude hiding ((.), id)
@@ -59,15 +61,12 @@ import Data.Monoid (Endo)
 import Data.Functor.Foldable.TH
 import Data.Data.Lens (uniplate)
 import Gyehoek.Prelude hiding (op)
-import Gyehoek.Sexp (Datum)
+import Gyehoek.Sexp (G, (:-)(..), Datum)
-import Gyehoek.Sexp (G, (:-)(..))
 import qualified Data.InvertibleGrammar.Base as IG
 import Gyehoek.GenSym (Gen)
 import Data.String (IsString)
 import Control.Applicative
 import qualified Data.HashMap.Strict as H
-import GHC.Records (HasField (..))
-import Data.Bifunctor
 
 -- Data types
 
@@ -103,6 +102,7 @@ data Obj
   deriving stock (Show, Generic, Data, Eq)
   deriving anyclass (NFData)
 
+pattern ObjLabel :: Label -> Obj
 pattern ObjLabel l = ObjImm (ImmLabel l)
 
 -- | a heap object.
@@ -163,7 +163,7 @@ pattern ExpJump f xs ktail <- (preview _ExpJump -> Just (f,xs,ktail))
   where ExpJump f xs ktail = review _ExpJump (f,xs,ktail)
 
 data Exp
-  = ExpPrim (Prim Val) Kexp
+  = ExpBuiltin (Builtin Val) Kexp
   | ExpLetRec { binders :: List (Name, Abs), body :: Exp }
   | ExpContinue Val (List Val)
   | ExpIf Val Name Name
@@ -188,7 +188,7 @@ pattern Halt1 x = ExpContinue (ValLabel "halt") [x]
 data Def = DefConstant Name Exp
   deriving (Show, Generic, Data)
 
-data Program = MkProgram
+newtype Program = MkProgram
   { body :: Lambda
   }
   deriving (Show, Generic, Data)
@@ -272,7 +272,7 @@ instance S.DatumIso Imm where
 
 instance S.DatumIso Label where
   datumIso = S.with \g -> S.coproduct
-    [ S.decorate S.SynConstant >>> S.datumIso @Name >>> S.prismIso
+    [ S.datumIso @Name >>> S.prismIso
           (S.expected "label")
           (prefixed @Name "$")
     , S.list $ S.el (S.sym "$") >>> S.el (S.datumIso @Name)
@@ -281,7 +281,7 @@ instance S.DatumIso Label where
 
 instance S.DatumIso Reg where
   datumIso = S.with \g ->
-    S.decorate S.SynVariable >>> S.datumIso @Name >>> S.prismIso
+    S.datumIso @Name >>> S.prismIso
       (S.expected "register")
       (prefixed @Name "%")
     >>> g
@@ -335,16 +335,16 @@ instance S.DatumIso Abs where
 
 instance S.DatumIso Exp where
   datumIso = S.match
-    $ S.With (. prim)
+    $ S.With (. builtin)
     $ S.With (. letrec)
     $ S.With (. continue)
     $ S.With (. if_)
     $ S.With (. app)
     $ S.End
     where
-      continue = S.list $
+      continue = S.listWithStyle (S.StyleSyntax 1) $
-        S.el (S.decorate S.SynBuiltin >>> S.sym "continue")
+        S.el (S.sym "continue")
-        >>> S.el (S.decorate S.SynProcedure >>> S.datumIso)
+        >>> S.el S.datumIso
         >>> S.rest S.datumIso
       letrec = S.letLike "letrec" S.datumIso S.datumIso S.datumIso
       if_ = S.ifLike "if"
@@ -365,9 +365,9 @@ instance S.DatumIso Exp where
         >>> S.el (S.datumIso @Kexp)
         >>> S.rest (S.datumIso @Val)
         >>> S.onTail S.swap
-      prim = S.list $
+      builtin = S.listWithStyle (S.StyleSyntax 1) $
-        S.el (S.decorate S.SynBuiltin >>> S.sym "prim")
+        S.el (S.sym "builtin")
-        >>> S.el (primDatumIso id (S.datumIso @Val))
+        >>> S.el (builtinDatumIso id (S.datumIso @Val))
         >>> S.el S.datumIso
 
 instance S.DatumIso Kexp where
@@ -414,15 +414,9 @@ cps = S.makeSx' [| toCPS |]
 
 
 
-deleteFrom :: (Foldable f, Hashable a) => f a -> HashSet a -> HashSet a
-deleteFrom = flip $ foldr HS.delete
-
 insertFrom :: (Foldable f, Hashable a) => f a -> HashSet a -> HashSet a
 insertFrom = flip $ foldr HS.insert
 
-toHashSetOf :: Hashable a => Getting (Endo (HashSet a)) s a -> s -> HashSet a
-toHashSetOf l = foldrOf l HS.insert mempty
-
 class Free a where
   free :: a -> HashSet Name
   free = freeWithBound mempty
@@ -453,7 +447,7 @@ instance Free Kexp where
 
 instance Free Exp where
   freeWithBound' bound = \case
-    ExpPrim p k ->
+    ExpBuiltin p k ->
       (p ^.. folded . #ValVar . filtered (`notElem` bound))
       ++ freeWithBound' bound k
     ExpLetRec bs m ->

src/Gyehoek/Driver.hs

@@ -1,5 +1,5 @@
 module Gyehoek.Driver
-  (main, lower_e2e, convert_e2e, parse_e2e, readScm, eval_e2e, eval_cps_e2e, eval_cps2_e2e)
+  (main, convert_e2e, parse_e2e, readScm, eval_cps1_e2e, eval_cps2_e2e)
   where
 
 import Gyehoek.Options
@@ -17,7 +17,6 @@ import qualified Data.Text.Encoding as T
 import System.IO (Handle)
 import System.IO qualified as IO
 import Gyehoek.CPS.Convert
-import Gyehoek.Stack.Lower
 import Gyehoek.CPS.Eval qualified as CPS
 import Control.Monad
 import Text.Pretty.Simple (pShowNoColor)
@@ -25,10 +24,7 @@ import System.Process.Typed
 import System.Environment.Blank (getEnvDefault)
 import qualified Data.Text.IO as TIO
 import qualified Data.ByteString.Lazy as BS
-import Gyehoek.CPS.Stackify (stackifyProgram)
-import Gyehoek.Stack.VM (eval, writeObj, Obj, traceEval)
 import qualified Data.Text as T
-import Gyehoek.Stack.Syntax qualified as Stk
 import Gyehoek.CPS.Close (closeProgram)
 import Control.Lens.Extras (is)
 import Control.Arrow ((>>>))
@@ -36,7 +32,6 @@ import Gyehoek.Prelude
 import Gyehoek.Jalmot
 import qualified Gyehoek.Sexp as S
 import Gyehoek.CPS.Hoist (hoistProgram)
-import Gyehoek.CPS.Contify (contifyProgram)
 
 
 main :: IO ()
@@ -127,28 +122,13 @@ driver opts = do
   hoistedCps <- hoistProgram closedCps
   when opts.dumpHoisted do
     S.writeDatum hoistedCps
-  -- contifiedCps <- contifyProgram hoistedCps
-  -- when opts.dumpContified do
-  --   hPutStrLn FS.stdout =<< S.encodeWith S.datumIso contifiedCps
   let rt_is p = is (_Just . p) opts.runtime
-  dumpOrRun opts.dumpStackified (rt_is #Stackify)
-    (stackifyProgram hoistedCps)
-    (hPutStrLn FS.stdout <=< S.encodeDataWith S.dataIso)
-    (eval >=> fmap writeObj
-         >>> T.unwords
-         >>> hPutStrLn FS.stdout)
   when (rt_is #HigherOrderCPS) do
     CPS.evalProgram cps
       >>= S.writeData
   when (rt_is #CPS) do
     CPS.evalProgram closedCps
       >>= S.writeData
-  -- dumpOrRun opts.inspectWasm (rt_is #Wasm)
-  --   (lowerProgram cps)
-  --   inspectWasm
-  --   (\wat -> withFile opts.output FS.WriteMode \h -> hPutStrLn h wat)
-  when opts.traceStackified do
-    stackifyProgram hoistedCps >>= traceEval
 
 parse_e2e :: FilePath -> IO Scm.Program
 parse_e2e = runJalmotIO . runFileSystem . readScm
@@ -157,18 +137,8 @@ convert_e2e :: FilePath -> IO CPS.Program
 convert_e2e = runJalmotIO . runFileSystem . runGenSym
   . (closeProgram <=< convertProgram <=< readScm)
 
-lower_e2e :: FilePath -> IO Text
+eval_cps1_e2e :: FilePath -> IO Text
-lower_e2e =
+eval_cps1_e2e fp = runJalmotIO . runFileSystem . runGenSym $
-  runJalmotIO . runFileSystem . runGenSym
-  . (lowerProgram <=< closeProgram <=< convertProgram <=< readScm)
-
-eval_e2e :: FilePath -> IO (List Obj)
-eval_e2e fp = runJalmotIO . runFileSystem . runGenSym $ do
-  stk <- stackifyProgram <=< closeProgram <=< convertProgram <=< readScm $ fp
-  eval stk
-
-eval_cps_e2e :: FilePath -> IO Text
-eval_cps_e2e fp = runJalmotIO . runFileSystem . runGenSym $
   readScm fp
    >>= convertProgram
    >>= closeProgram

src/Gyehoek/Language/Common.hs

@@ -0,0 +1,62 @@
+{-# 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/Options.hs

@@ -13,14 +13,13 @@ import Data.Foldable
 import Gyehoek.Prelude hiding (argument)
 
 
-data Runtime = Stackify | Wasm | CPS | HigherOrderCPS
+data Runtime = Wasm | CPS | HigherOrderCPS
   deriving (Show, Generic, Eq)
 
 data Language
   = LanguageScheme
   | LanguageCPS
   | LanguageClosed
-  | LanguageStackified
   | LanguageWasm
   deriving (Show, Generic, Eq)
 
@@ -28,31 +27,27 @@ data Options = MkOptions
   { dumpClosed :: Bool
   , dumpCPS :: Bool
   , dumpParsed :: Bool
-  , dumpStackified :: Bool
   , dumpHoisted :: Bool
-  , dumpContified :: Bool
-  , traceStackified :: Bool
   , noColour :: Bool
   , runtime :: Maybe Runtime
   , inspectWasm :: Bool
   , output :: FilePath
   , sourceFile :: FilePath
   , sourceLanguage :: Language
+  , targetLanguage :: Language
   }
   deriving (Show, Generic)
 
-languageValues = ["scheme","cps","closed","stackified","wasm"]
+languageValues = ["scheme","cps","closed","wasm"]
 languageReader = maybeReader \case
   "scheme" -> Just LanguageScheme
   "cps" -> Just LanguageCPS
   "closed" -> Just LanguageClosed
-  "stackified" -> Just LanguageStackified
   "wasm" -> Just LanguageWasm
   _ -> Nothing
 
 runtimeValues = ["stackify","wasm","cps","none"]
 runtimeReader = maybeReader \case
-  "stackify" -> Just (Just Stackify)
   "wasm" -> Just (Just Wasm)
   "cps1" -> Just (Just CPS)
   ("cps";"higher-order-cps") -> Just (Just HigherOrderCPS)
@@ -63,11 +58,8 @@ 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")
-  dumpContified <- switch (long "dump-contified")
-  traceStackified <- switch (long "trace-stackified")
   noColour <- switch . fold $
     [ long "no-colour"
     , long "no-color"
@@ -89,6 +81,14 @@ 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/Scheme/Expand.hs

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

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

@@ -11,16 +11,23 @@
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE ViewPatterns #-}
+{- HLINT ignore "Avoid lambda using `infix`" -}
+{- HLINT ignore "Redundant $" -}
 module Gyehoek.Scheme.Syntax
   ( Name(..)
-  , Prim(..)
+  , Builtin(..)
   , Lit(..)
   , Def(..)
   , Exp(..)
   , ExpF(..)
   , Program(..)
   , CommandOrDef(..)
-  , primDatumIso
+  , Trans(..)
+  , Rule(..)
+  , Pat(..)
+  , Tem(..)
+  , El(..)
+  , builtinDatumIso
   , free
   , subst
   , getName
@@ -31,8 +38,6 @@ module Gyehoek.Scheme.Syntax
   )
   where
 
-import Data.List (intersperse)
-import Effectful
 import Prelude hiding ((.), id)
 import Control.Category
 import Gyehoek.Sexp qualified as GS
@@ -45,12 +50,7 @@ import Data.Functor.Foldable hiding (fold)
 import qualified Data.HashSet as HS
 import Data.Foldable (fold, toList)
 import Language.Haskell.TH.Quote (QuasiQuoter)
-import Effectful.FileSystem (runFileSystem)
-import qualified Effectful.FileSystem.IO as FS
-import qualified Data.Text.Encoding as T
-import qualified Effectful.FileSystem.IO.ByteString as FB
 import qualified Data.Set.Ordered as O
-import Gyehoek.Sexp.Grammar qualified as Sexp
 import Gyehoek.Sexp.Grammar qualified as S
 import Gyehoek.Sexp.Grammar (DatumIso, G, DataIso, (:-)((:-)))
 import Gyehoek.Prelude
@@ -69,36 +69,36 @@ instance Prefixed Name where
 getName :: Name -> Text
 getName (MkName x) = x
 
-data Prim e
+data Builtin e
-  = PrimAdd e e
+  = BuiltinAdd e e
-  | PrimSub e e
+  | BuiltinSub e e
-  | PrimMul e e
+  | BuiltinMul e e
-  | PrimDiv e e
+  | BuiltinDiv e e
-  | PrimCons e e
+  | BuiltinCons e e
-  | PrimCar e
+  | BuiltinCar e
-  | PrimCdr e
+  | BuiltinCdr e
-  | PrimImmediateP e
+  | BuiltinImmediateP e
-  | PrimConsP e
+  | BuiltinConsP e
-  | PrimIntegerP e
+  | BuiltinIntegerP e
-  | PrimWrite e
+  | BuiltinWrite e
-  | PrimZeroP e
+  | BuiltinZeroP e
-  | PrimNewline
+  | BuiltinNewline
-  | PrimMakeClosure { code :: e, env :: List e }
+  | BuiltinMakeClosure { code :: e, env :: List e }
-  | PrimMakeSharedClosure { codes :: List e, env :: List e }
+  | BuiltinMakeSharedClosure { codes :: List e, env :: List e }
-  | PrimGetEnv
+  | BuiltinGetEnv
-  | PrimEnv
+  | BuiltinEnv
-  | PrimEnvRef Int
+  | BuiltinEnvRef Int
-  | PrimCallCC e
+  | BuiltinCallCC e
-  | PrimCaptureCC
+  | BuiltinCaptureCC
-  | PrimInvokeCC e (List e)
+  | BuiltinInvokeCC e (List e)
-  | PrimValues (List e)
+  | BuiltinValues (List e)
-  | PrimCallWithValues e e
+  | BuiltinCallWithValues e e
-  | PrimPairP e
+  | BuiltinPairP e
-  | PrimList (List e)
+  | BuiltinList (List e)
   deriving stock (Show, Generic, Functor, Foldable, Traversable, Data, Eq)
   deriving anyclass (NFData)
 
-instance Each (Prim e) (Prim e') e e'
+instance Each (Builtin e) (Builtin e') e e'
 
 data Lit
   = LitInt Int
@@ -113,19 +113,79 @@ data Def
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
 
+data Formals a
+  = FormalsFixed (List a)
+  | FormalsVar (List a) a
+  deriving stock (Show, Generic, Data, Functor, Foldable, Traversable)
+  deriving anyclass (NFData)
+
 data Exp
   = ExpLet (List (Name, Exp)) Exp
+  | ExpLetSyntax (List (Name, Trans)) Exp
   | ExpLetRec (List (Name, Exp)) Exp
-  | ExpPrim (Prim Exp)
+  | ExpBuiltin (Builtin Exp)
   | ExpBegin (NonEmpty Exp)
-  | ExpIf Exp Exp Exp
+  | ExpIf Exp Exp (Maybe Exp)
   | ExpLit Lit
   | ExpLambda (List Name) Exp
   | ExpVar Name
+  | ExpSyntaxRules Trans
   | ExpApply Exp (List Exp)
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
 
+data Trans = MkTrans
+  { ellipsis :: Name
+  , keywords :: List Name
+  , rules :: List Rule
+  }
+  deriving stock (Show, Generic, Data)
+  deriving anyclass (NFData)
+
+data Rule = MkRule
+  { rhs :: Pat
+  , lhs :: Tem
+  }
+  deriving (Show, Generic, Data)
+  deriving anyclass (NFData)
+
+data Pat
+  = PatWildcard
+  | PatVar Name
+  | PatList
+    { init :: List Pat
+    , ellipsis :: Maybe (List Pat)
+    , tail :: Maybe Pat
+    }
+  -- | PatVec
+  --   { init :: List Pat
+  --   , ellipsis :: Maybe (List Pat)
+  --   }
+  deriving (Show, Generic, Data)
+  deriving anyclass (NFData)
+
+data Tem
+  -- | @(⟨element⟩ …)@
+  -- @(⟨element⟩ ⟨element⟩ … . ⟨element⟩)@
+  = TemList
+    { init :: List El
+    , tail :: Maybe Tem
+    }
+  -- | @(⟨ellipsis⟩ ⟨template⟩)@
+  | TemTrail Tem
+  | TemLit Lit
+  | TemVar Name
+  deriving (Show, Generic, Data)
+  deriving anyclass (NFData)
+
+data El
+  -- | @⟨template⟩ ⟨ellipsis⟩@
+  = Ellipsis Tem
+  -- | @⟨template⟩@
+  | El Tem
+  deriving (Show, Generic, Data)
+  deriving anyclass (NFData)
+
 data CommandOrDef
   = Command Exp
   | Definition Def
@@ -182,14 +242,12 @@ makeBaseFunctor ''Exp
 
 
 instance DatumIso Name where
-  datumIso = S.decorate S.SynVariable
+  datumIso = S.symbol >>> S.iso coerce coerce
-    >>> S.symbol
-    >>> S.iso coerce coerce
 
-primDatumIso
+builtinDatumIso
   :: (Text -> Text)
-  -> S.DatumGrammar a -> S.DatumGrammar (Prim a)
+  -> S.DatumGrammar a -> S.DatumGrammar (Builtin a)
-primDatumIso namefn a = S.match
+builtinDatumIso namefn a = S.match
     $ S.With (. ht2 "+")
     $ S.With (. ht2 "-")
     $ S.With (. ht2 "*")
@@ -226,8 +284,8 @@ primDatumIso namefn a = S.match
       ht1' s = S.headTagged1' (namefn s) a a
       ht0' s = S.headTagged0' (namefn s) a
 
-instance DatumIso a => DatumIso (Prim a) where
+instance DatumIso a => DatumIso (Builtin a) where
-  datumIso = primDatumIso id S.datumIso
+  datumIso = builtinDatumIso id S.datumIso
 
 instance DatumIso Lit where
   datumIso = S.match
@@ -248,20 +306,42 @@ instance DatumIso Def where
         >>> S.el args >>> S.rest S.datumIso
       args = S.list $ S.el S.datumIso >>> S.rest S.datumIso
   
+instance DatumIso Trans where
+  datumIso = S.with \g ->
+    S.listWithStyle
+      (S.StyleSyntax 1)
+      ( S.el (S.sym "syntax-rules")
+      >>> S.Iso (\(ctx:-t) -> ctx:-"...":-t) (\(ctx:-_:-t) -> ctx:-t)
+      >>> S.el (S.list $ S.rest (S.datumIso @Name))
+      >>> S.rest (S.datumIso @Rule)
+      )
+    >>> g
+
 instance DatumIso Exp where
   datumIso = S.match
     $ S.With (. S.letLike "let" S.datumIso S.datumIso S.datumIso)
+    $ S.With (letsyntax >>>)
     $ S.With (. S.letLike "letrec" S.datumIso S.datumIso S.datumIso)
     $ S.With (. S.datumIso)
     $ S.With (. begin)
-    $ S.With (. S.ifLike "if" S.datumIso S.datumIso S.datumIso)
+    $ 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) $
+        S.el (S.sym "let-syntax")
+        >>> S.el (S.list $ S.rest $ S.datumIso)
+        >>> S.el S.datumIso
       lam = S.lambdaLike S.lambdaKeyword S.datumIso (S.el S.datumIso)
+      if_ = S.ifLike "if" S.datumIso S.datumIso $ S.datumIso @Exp >>> S.iso
+        Just
+        \case
+          Just x -> x
+          Nothing -> error "안 괜찮다ㅠㅠ"
       begin :: forall t. G (S.Datum :- t) (NonEmpty Exp :- t)
       begin = S.beginLike "begin" $
         S.el (S.datumIso @Exp) >>> S.rest (S.datumIso @Exp)
@@ -269,6 +349,101 @@ instance DatumIso Exp where
           (\(xs:-x:-t) -> (x:|xs):-t)
           (\((x:|xs):-t) -> xs:-x:-t))
 
+instance S.DatumIso Rule where
+  datumIso = S.with \g ->
+    S.list (S.el S.datumIso >>> S.el S.datumIso) >>> g
+
+instance S.DatumIso Pat where
+  datumIso = S.match
+    $ S.With (S.sym "_" >>>)
+    $ S.With (S.datumIso >>>)
+    $ S.With (lst >>>)
+    $ S.End
+    where
+      lst :: S.G (S.Datum :- t) (Maybe Pat :- Maybe (List Pat) :- List Pat :- t)
+      lst = S.coproduct
+        [ S.list $
+            ellipsis
+            >>> S.onTail (S.push Nothing (is _Nothing) (const mempty))
+        , S.dottedList
+            ellipsis
+            ( S.datumIso @Pat
+              >>> S.partialIso Just (maybe (Left mempty) Right) )
+        ]
+      ellipsis =
+        S.restData split
+            >>> S.onTail
+              ( S.onHead (S.traversed . S.traversed . S.sealed $
+                S.datumIso @Pat)
+              >>> S.onTail (S.onHead . S.traversed . S.sealed $
+                S.datumIso @Pat)
+              )
+      split
+        :: forall t. S.G (List S.Datum :- t)
+            (Maybe (List S.Datum) :- List S.Datum :- t)
+      split = S.Iso
+        (\(ps0:-t) ->
+          let (ps,ell) = splitEllipsis ps0
+          in ell :- ps :- t)
+        (\(ell:-ps:-t) -> (ps ++ foldMap ([S.Symbol "..."]++) ell) :- t)
+
+splitEllipsis :: List S.Datum -> (List S.Datum, Maybe (List S.Datum))
+splitEllipsis [] = ([], Nothing)
+splitEllipsis (S.Symbol "..." : xs) = ([], Just xs)
+splitEllipsis (x:xs) = splitEllipsis xs & _1 %~ (x:)
+
+instance S.DataIso El where
+  dataIso = S.match
+    $ S.With (ellipsis >>>)
+    $ S.With (noellipsis >>>)
+    $ S.End
+    where
+      ellipsis = S.recontextualise $
+        S.el (S.datumIso @Tem) >>> S.el (S.sym "...")
+      noellipsis = S.recontextualise $ S.el (S.datumIso @Tem)
+
+instance S.DatumIso Tem where
+  datumIso = S.match
+    $ S.With (lst >>>)
+    $ S.With (trail >>>)
+    $ S.With (S.datumIso @Lit >>>)
+    $ S.With (S.datumIso @Name >>>)
+    $ S.End
+    where
+      trail = S.list $ S.el (S.sym "...") >>> S.el (S.datumIso @Tem)
+
+      lst :: S.G (S.Datum :- t) (Maybe Tem :- List El :- t)
+      lst = S.coproduct
+        [ S.list els
+          >>> (S.push Nothing (is _Nothing) (const mempty))
+        , S.dottedList els $
+            S.datumIso @Tem
+            >>> S.partialIso Just (maybe (Left mempty) Right)
+        ]
+      els :: S.G (S.ListContext :- t) (S.ListContext :- List El :- t)
+      els =
+        S.iso
+          (\(S.MkListContext ds) -> affixEllipses ds)
+          (S.MkListContext . foldMap \(d,b) ->
+            d : if b then [S.Symbol "..."] else [])
+        >>> S.onHead (S.traversed . S.sealed $
+          S.flipped S.pair
+          >>> S.onTail (S.datumIso @Tem)
+          >>> S.pair
+          >>> S.iso
+            (\(t,b) -> if b then Ellipsis t else El t)
+            (\case
+              Ellipsis t -> (t,True)
+              El t -> (t,False)))
+        >>> S.push (S.MkListContext [])
+          (\(S.MkListContext xs) -> null xs)
+          (const mempty)
+      affixEllipses :: List S.Datum -> List (S.Datum, Bool)
+      affixEllipses (x : S.Symbol "..." : xs) = (x,True) : affixEllipses xs
+      affixEllipses (x : xs) = (x,False) : affixEllipses xs
+      affixEllipses [] = []
+
+
 instance DatumIso CommandOrDef where
   datumIso = S.match
     $ S.With (\_Command -> _Command . S.datumIso)
@@ -299,16 +474,16 @@ instance DatumIso ImportSet where
     $ S.With (imp "rename" >>>)
     $ S.End
     where
-      imp s = S.list $ S.el (S.symBuiltin s)
+      imp s = S.list $ S.el (S.sym s)
         >>> S.el S.datumIso >>> S.restData S.dataIso
       imp' s = S.list $
-        S.el (S.symBuiltin s)
+        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.symBuiltin "import") >>> S.restData S.dataIso)
+    S.list (S.el (S.sym "import") >>> S.restData S.dataIso)
     >>> decl
 
 instance DataIso Program where

src/Gyehoek/Sexp/Grammar.hs

@@ -179,6 +179,14 @@ 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

src/Gyehoek/Sexp/Grammar/Base.hs

@@ -1,3 +1,4 @@
+{- HLINT ignore "Avoid lambda" -}
 -- | cribbed from sexp-grammar:Language.SexpGrammar.Base
 module Gyehoek.Sexp.Grammar.Base
   ( module Gyehoek.Sexp.Syntax
@@ -8,12 +9,11 @@ module Gyehoek.Sexp.Grammar.Base
   , Grammar(..)
   , DatumGrammar
   , DataGrammar
-  , Grammar
   , ListContext(..)
   , (:-)((:-))
   -- * lists
   , list
-  , listWithIndentation
+  , listWithStyle
   , el
   , rest
   , restData
@@ -23,6 +23,7 @@ module Gyehoek.Sexp.Grammar.Base
   , headTagged1'
   , headTagged1
   , headTagged2
+  , headTagged2'
   -- * atoms
   , simple
   , string
@@ -33,32 +34,29 @@ module Gyehoek.Sexp.Grammar.Base
   , integer
   , int
   , unreadable
-  -- ** symbols
-  , symBuiltin
   -- * TODO: sort lol
   , prismIso
-  , isoIso, decorate
+  , isoIso
   , snoced
   , letLike
   , ifLike
   , lambdaLike
   , lambdaKeyword
   , kappaKeyword
-  , beginLike, headTagged2', dottedList
+  , beginLike
+  , dottedList
+  , reifyContext, recontextualise, decontextualise, redecorate
   ) where
 
 import Data.InvertibleGrammar
 import Data.InvertibleGrammar.Base
-import Data.InvertibleGrammar.Base as Re
-  ( Grammar(..))
 import Data.InvertibleGrammar.Combinators
-import Gyehoek.Prelude hiding (traversed, iso, cons, coerced, Iso, Simple, simple)
+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 Control.Monad.RWS (modify)
 import qualified Data.List.NonEmpty as NE
 import Data.Foldable (toList)
 
@@ -89,14 +87,6 @@ locate =
     (\(_ :- t) -> t)
     (\t -> noAnn :- t)
 
-modifyAnn :: (Ann -> Ann) -> G (Datum :- t) (Datum :- t)
-modifyAnn f = Iso
-  (\(d:-t) -> (d & ann %~ f) :- t)
-  (\(d:-t) -> (d & ann %~ f) :- t)
-
-decorate :: Syn -> G (Datum :- t) (Datum :- t)
-decorate s = modifyAnn $ #syntax .~ s
-
 newtype ListContext = MkListContext { inner :: List Datum }
 
 unexpectedSimple :: Simple -> Mismatch
@@ -108,7 +98,7 @@ unexpectedDatum = unexpected . printDatum'
 list
   :: G (ListContext :- t) (ListContext :- t')
   -> G (Datum :- t) t'
-list = listWithIndentation Ordinary
+list = listWithStyle StyleData
 
 -- |
 -- >>> let grammar = with \g -> dottedList (el int) int >>> g
@@ -143,11 +133,11 @@ dottedList g final = begin >>> Dive (onTail (g >>> end) >>> final)
            [] -> Right t
            d:_ -> Left $ unexpectedDatum d)
 
-listWithIndentation
+listWithStyle
-  :: Indentation
+  :: Style
   -> G (ListContext :- t) (ListContext :- t')
   -> G (Datum :- t) t'
-listWithIndentation ind g = begin >>> Dive (g >>> end)
+listWithStyle ind g = begin >>> Dive (g >>> end)
   where
     begin = locate >>> partialOsi
       (\case
@@ -169,6 +159,33 @@ el
   -> G (ListContext :- t) (ListContext :- t')
 el g = coerced (Flip cons >>> onTail g >>> Step)
 
+reifyContext :: G (ListContext :- t) (List Datum :- t)
+reifyContext = iso coerce coerce
+
+decontextualise
+  :: G (List Datum :- t) (List Datum :- t')
+  -> G (ListContext :- t) t'
+decontextualise g = reifyContext >>> g >>> end
+  where
+    end = Flip $ PartialIso
+      (\t -> [] :- t)
+      (\(lst :- t) ->
+         case lst of
+           [] -> Right t
+           d:_ -> Left $ unexpectedDatum d)
+
+recontextualise
+  :: G (ListContext :- t) (ListContext :- t')
+  -> G (List Datum :- t) t'
+recontextualise g = flipped reifyContext >>> g >>> end
+  where
+    end = Flip $ PartialIso
+      (\t -> MkListContext [] :- t)
+      (\(MkListContext lst :- t) ->
+         case lst of
+           [] -> Right t
+           d:_ -> Left $ unexpectedDatum d)
+
 -- | matches the remainder of a list as repetition of a given
 -- grammar.
 --
@@ -235,8 +252,8 @@ rest g =
 -- >>> encodeTest dataRestGrammar $ MkExample [1,2,3] "end"
 -- (1 2 3 end)
 restData
-  :: G (List Datum :- t) (a :- t)
+  :: G (List Datum :- t) t'
-  -> G (ListContext :- t) (ListContext :- a :- t)
+  -> G (ListContext :- t) (ListContext :- t')
 restData g =
   iso coerce coerce
   >>> g
@@ -351,33 +368,36 @@ 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 = list $ el (symProcedure s)
+headTagged0 s = listWithStyle StyleCode $ el (sym s)
 
 headTagged0' :: Text -> DatumGrammar a -> G (Datum :- t) (List a :- t)
-headTagged0' s gt = list $ el (symProcedure s) >>> rest gt
+headTagged0' s gt = listWithStyle StyleCode $ el (sym s) >>> rest gt
 
 headTagged1 :: Text -> DatumGrammar a -> G (Datum :- t) (a :- t)
-headTagged1 s g1 = list $ el (symProcedure s) >>> el g1
+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 (symProcedure s) >>> el g1 >>> rest gt
+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 = list $ el (symProcedure s) >>> el g1 >>> el g2
+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 =
-  list $ el (symProcedure s) >>> el g1 >>> el g2 >>> rest gt
+  listWithStyle StyleCode $ el (sym s) >>> el g1 >>> el g2 >>> rest gt
 
 ifLike
   -- | keyword
@@ -390,21 +410,17 @@ ifLike
   -> DatumGrammar c
   -> G (Datum :- t) (c :- b :- a :- t)
 ifLike kw c t f =
-  listWithIndentation (NSpecial 1) $
+  listWithStyle (StyleSyntax 1) $
-    el (symBuiltin kw) >>> el c >>> el t >>> el f
+    el (sym kw) >>> el c >>> el t >>> el f
-
-symBuiltin, symProcedure :: Text -> G (Datum :- t) t
-symBuiltin s = decorate SynBuiltin >>> sym s
-symProcedure s = decorate SynProcedure >>> sym s
 
 letLike
   :: Text
   -> (forall t. G (Datum :- t) (a :- t))
   -> (forall t. G (Datum :- t) (b :- t))
-  -> G (Datum :- (List (a, b) :- t1)) t2
+  -> G (Datum :- List (a, b) :- t1) t2
   -> G (Datum :- t1) t2
-letLike kw name rhs e = listWithIndentation (NSpecial 1) $
+letLike kw name rhs e = listWithStyle (StyleSyntax 1) $
-  el (symBuiltin kw) >>> el bindings >>> el e
+  el (sym kw) >>> el bindings >>> el e
   where
     bindings = list $ rest binding
     binding :: G (Datum :- t) ((_, _) :- t)
@@ -415,8 +431,8 @@ lambdaLike
   -> G (Datum :- t1) (a :- t2)
   -> G (ListContext :- a :- t2) (ListContext :- t3)
   -> G (Datum :- t1) t3
-lambdaLike kw formals body = listWithIndentation (NSpecial 1) $
+lambdaLike kw formals body = listWithStyle (StyleSyntax 1) $
-  el (decorate SynBuiltin >>> kw)
+  el kw
   >>> el formals
   >>> body
 
@@ -431,8 +447,8 @@ beginLike
   -> G (ListContext :- t) (ListContext :- t')
   -> G (Datum :- t) t'
 beginLike kw g =
-  listWithIndentation (NSpecial 0) $
+  listWithStyle (StyleSyntax 0) $
-    el (symBuiltin kw) >>> g
+    el (sym kw) >>> g
 
 -- | define a printed syntax for an object which cannot be read.
 unreadable

src/Gyehoek/Sexp/Print.hs

@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
 module Gyehoek.Sexp.Print
   ( printDatum
   , printDatumW
@@ -6,26 +7,34 @@ module Gyehoek.Sexp.Print
   , printData'
   , htmlDatum
   , htmlData
+  , putDoc
   ) where
 
 import Gyehoek.Sexp.Syntax
 import Prettyprinter
-import Data.Functor.Foldable
+import Gyehoek.Prelude hiding (Simple)
-import qualified Control.Comonad.Trans.Cofree as F
-import Prettyprinter.Util
-import Gyehoek.Prelude hiding (Simple, (:<))
-import Data.Foldable (traverse_, toList)
 import qualified Prettyprinter.Render.Terminal as ANSI
 import System.IO (stdout)
 import Prettyprinter.Render.Terminal (Color(..), color, italicized, AnsiStyle, bold, colorDull)
 import Prettyprinter.Render.Text (renderStrict)
-import qualified Data.Scientific as Sci
 import Data.List (intersperse)
 import Lucid
 import Prettyprinter.Render.Util.SimpleDocTree (treeForm)
 import Prettyprinter.Lucid (renderHtml)
+import Data.Foldable (toList)
+import qualified Data.Scientific as Sci
 
 
+data Syn
+  = SynSyntax
+  | SynProcedure
+  | SynParen Int
+  | SynString
+  | SynConstant
+  | SynVariable
+  | SynNone
+  deriving (Show, Read, Data, Generic, Eq)
+
 printDatum' :: Datum -> Text
 printDatum' =
   prettyDatum 0
@@ -83,7 +92,7 @@ printDatumW w =
 
 prettyDatum :: Int -> Datum -> Doc Syn
 prettyDatum depth datum = case datum of
-  Simple simp -> annotate (datum ^. syntax) $ prettySimple depth simp
+  Simple simp -> prettySimple depth simp
   DotList xs x ->
     pparen depth . group . align $
       vsep [ vsep (prettyDatum (depth+1) <$> toList xs)
@@ -91,19 +100,21 @@ prettyDatum depth datum = case datum of
            , prettyDatum (depth+1) x
            ]
       
-  List' indent xs ->
+  List' sty xs -> case sty of
-    case indent of
+    StyleSyntax n | keyword:args <- xs ->
-      NSpecial n | keyword:args <- xs ->
       let (specialArgs,body) = splitAt n args
       in pparen depth . nest 2 . vsep $
           [ group . nest 2 . hcat $
-              [ prettyDatum (depth+1) keyword
+            [ annotate SynSyntax $ prettyDatum (depth+1) keyword
             , if null specialArgs then mempty else softline
             , hsep $ prettyDatum (depth+1) <$> specialArgs
             ]
           , vsep $ prettyDatum (depth+1) <$> body
           ]
-      Ordinary; NSpecial _ -> pparen depth $
+    StyleCode | f:args <- xs -> pparen depth $
+      group . align . vsep . (_head %~ annotate SynProcedure) $
+        prettyDatum (depth+1) <$> xs
+    StyleData; StyleSyntax _; StyleCode -> pparen depth $
       group . align . vsep $
         prettyDatum (depth+1) <$> xs
   _ -> error [i|unimplemented: #{datum}|]
@@ -111,15 +122,11 @@ prettyDatum depth datum = case datum of
 pparen depth = enclose (delim depth "(") (delim depth ")")
 delim depth = annotate (SynParen depth)
 
-delimited :: Int -> Doc Syn -> Doc Syn -> List (Doc Syn) -> Doc Syn
-delimited depth open close =
-  encloseSep (delim depth open) (delim depth close) softline
-
 prettySimple :: Int -> Simple -> Doc Syn
 prettySimple depth = \case
   SimpleBoolean b -> annotate SynConstant $ if b then "#t" else "#f"
-  SimpleNumber n ->
+  SimpleNumber n -> n
-    Sci.floatingOrInteger n
+    & Sci.floatingOrInteger @Double @Integer
     & either viaShow viaShow
     & annotate SynConstant
   SimpleString s -> annotate SynString $ viaShow s
@@ -132,7 +139,7 @@ putDoc = ANSI.renderIO stdout
 
 highlightAnsi :: Syn -> AnsiStyle
 highlightAnsi = \case
-  (SynBuiltin; SynMacro) -> color Magenta <> italicized <> bold
+  SynSyntax -> color Magenta <> italicized <> bold
   SynProcedure -> color Blue
   SynConstant -> color Yellow
   SynParen n -> colorDull $ rainbow ^?! ix n
@@ -144,8 +151,7 @@ highlightHtml :: Syn -> Html () -> Html ()
 highlightHtml syn = span_ [class_ synClass]
   where
     synClass = case syn of
-      SynBuiltin -> "syn-builtin"
+      SynSyntax -> "syn-builtin"
-      SynMacro -> "syn-macro"
       SynConstant -> "syn-constant"
       SynString -> "syn-string"
       SynProcedure -> "syn-procedure"

src/Gyehoek/Sexp/Read.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE ApplicativeDo #-}
 module Gyehoek.Sexp.Read
   ( readFile
   , readString
@@ -20,6 +21,7 @@ import qualified Data.Text as T
 import Data.Char (GeneralCategory(..), generalCategory)
 import Data.Scientific (Scientific)
 import Gyehoek.Jalmot
+import Data.Foldable
 
 
 readFile :: (Jalmot :> es, IOE :> es) => FilePath -> Eff es (List Datum)
@@ -104,18 +106,51 @@ verb = L.symbol sc
 
 identifier :: P Text
 identifier = label "identifier" . lexeme . choice $
-  [ typical-- , delimited, peculiar
+  [ typical
+  -- , delimited
+  , peculiar
   ]
   where
     typical = T.cons <$> initial <*> subsequent
-      where
     subsequent = takeWhileP Nothing \c ->
       isInitial c ||
       c `hasCategory` [SpacingCombiningMark, EnclosingMark, DecimalNumber]
       || c == '.' || c == '@' || c == '+' || c == '-'
     initial = satisfy isInitial
     delimited = _
-    peculiar = _
+    peculiar = peculiarSign <|> peculiarDot
+
+    -- peculiarSign과 R⁷RS의 이 production 새 개들은 같음:
+    --   ⟨explicit sign⟩
+    --   ⟨explicit sign⟩ ⟨sign subsequent⟩ ⟨subsequent⟩*
+    --   ⟨explicit sign⟩ . ⟨dot subsequent⟩ ⟨subsequent⟩*
+    -- 같음:
+    --   ⟨explicit sign⟩
+    --     ((⟨sign subsequent⟩ | . ⟨dot subsequent⟩) ⟨subsequent⟩*)?
+    peculiarSign = do
+      sign <- explicitSign
+      r <- fold <$> optional do
+        neck <- choice
+          [ T.singleton <$> signSubsequent
+          , T.cons <$> single '.' <*> (T.singleton <$> dotSubsequent)
+          ]
+        subs <- subsequent
+        pure $ neck <> subs
+      pure $ T.cons sign r
+
+    -- . ⟨dot subsequent⟩ ⟨subsequent⟩*
+    peculiarDot = do
+      dot <- single '.'
+      dotSub <- dotSubsequent
+      subs <- subsequent
+      pure $ T.cons dot $ T.cons dotSub subs
+
+    dotSubsequent = single '.' <|> signSubsequent
+      <?> "dot subsequent"
+    explicitSign = (satisfy \c -> c == '+' || c == '-')
+      <?> "explicit sign"
+    signSubsequent = initial <|> explicitSign <|> satisfy (=='@')
+      <?> "sign subsequent"
 
     hasCategory c xs = generalCategory c `elem` xs
     isInitial c = (c `hasCategory`
@@ -207,7 +242,7 @@ simpleDatum = choice
   , SimpleNumber <$> try number
   -- , SimpleCharacter <$> character
   , SimpleString <$> string
-  , SimpleSymbol <$> symbol
+  , SimpleSymbol <$> try symbol
   -- , SimpleBytevector <$> bytevector
   ]
 
@@ -219,9 +254,9 @@ compoundDatum = choice
 list :: P Compound
 list = label "list" . between lparen rparen $ do
   optional datum >>= \case
-    Nothing -> pure $ ListF Ordinary []
+    Nothing -> pure $ ListF StyleData []
     Just x -> do
       xs <- many datum
       optional (dot *> datum) >>= \case
-        Nothing -> pure $ ListF Ordinary (x:xs)
+        Nothing -> pure $ ListF StyleData (x:xs)
         Just y -> pure $ DotListF (x:|xs) y

src/Gyehoek/Sexp/Syntax.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE ApplicativeDo #-}
+{- HLINT ignore "Use newtype instead of data" -}
 module Gyehoek.Sexp.Syntax
   ( DatumF(..)
   , Simple(..)
@@ -13,8 +14,7 @@ module Gyehoek.Sexp.Syntax
   , Cofree((:<))
   , Fix(..)
   , Compound
-  , Indentation(..)
+  , Style(..)
-  , Syn(..)
   , pattern Simple
   , pattern Compound
   , pattern Labeled
@@ -25,10 +25,8 @@ module Gyehoek.Sexp.Syntax
   , pattern Vector
   , pattern DotList
   , pattern Gyehoek.Sexp.Syntax.List
-  , syntax
+  , style
-  , indentation
+  , styleWith
-  , adorn
-  , indentWith
   , pattern Unreadable
   , pattern Bytevector
   , pattern Symbol
@@ -39,15 +37,16 @@ module Gyehoek.Sexp.Syntax
   , Ann(..)
   , noAnn
   , ann
+  , dat
   , pattern List'
   , position
   , stripAnn
   ) where
 
-import Language.Haskell.TH.Syntax (Lift (lift), liftData)
+import Language.Haskell.TH.Syntax (Lift (lift))
 import Data.Scientific (Scientific)
 import Data.ByteString (ByteString)
-import Gyehoek.Prelude hiding ((:<), Simple)
+import Gyehoek.Prelude hiding (Simple)
 import Text.Megaparsec.Pos (SourcePos(..), sourcePosPretty)
 import Control.Comonad.Cofree (Cofree((:<)), _extract, _unwrap)
 import Data.Fix (Fix (..))
@@ -68,7 +67,9 @@ data DatumF a
   | CompoundF (CompoundF a)
   | LabeledF Label a
   | LabelRefF Label
+  -- | Should not be used outside of the "Gyehoek.Sexp.QQ" implementation.
   | MetaF Text
+  -- | Should not be used outside of the "Gyehoek.Sexp.QQ" implementation.
   | MetaSpliceF Text
   deriving stock (Show, Eq, Data, Generic, Lift, Functor, Foldable, Traversable)
   deriving anyclass (NFData)
@@ -85,7 +86,7 @@ data Simple
   deriving anyclass (NFData)
 
 data CompoundF a
-  = ListF Indentation (List a)
+  = ListF Style (List a)
   | DotListF (NonEmpty a) a
   | VectorF (List a)
   | AbbrevF Prefix a
@@ -93,7 +94,12 @@ data CompoundF a
   deriving anyclass (NFData)
 
 data Prefix
-  = Quote | Backtick | Comma | CommaAt
+  = Quote -- ^ @'@
+  | Backtick -- ^ @`@
+  | Comma -- ^ @,@
+  | CommaAt -- ^ @,\@@
+  | PoundQuote -- ^ @#'@
+  | PoundBacktick -- ^ @#`@
   deriving stock (Show, Eq, Data, Generic, Lift)
   deriving anyclass (NFData)
 
@@ -114,33 +120,21 @@ newtype Label = MkLabel Natural
 type Datum = Cofree DatumF Ann
 type Compound = CompoundF Datum
 
-data Indentation
+data Style
-  = NSpecial Int
+  = StyleSyntax Int
-  | Ordinary
+  | StyleCode
+  | StyleData
   deriving stock (Data, Eq, Generic, Show, Lift, Read)
   deriving anyclass (NFData)
 
-data Syn
-  = SynMacro
-  | SynBuiltin
-  | SynProcedure
-  | SynParen Int
-  | SynString
-  | SynConstant
-  | SynVariable
-  | SynNone
-  deriving (Show, Read, Data, Generic, Eq, Lift)
-
 data Ann = MkAnn
-  { syntax :: Syn
+  { position :: Maybe SourcePos
-  , position :: Maybe SourcePos
   }
   deriving (Show, Data, Eq, Generic)
 
 noAnn :: Ann
 noAnn = MkAnn
-  { syntax = SynNone
+  { position = Nothing
-  , position = Nothing
   }
 
 -- requisite of the Pretty instance for invertible-grammar's error type.
@@ -158,23 +152,21 @@ deriveEq1 ''DatumF
 ann :: Lens' Datum Ann
 ann = _extract
 
-syntax :: Lens' Datum Syn
+dat :: Lens' Datum (DatumF Datum)
-syntax = ann . #syntax
+dat = _unwrap
 
 position :: Lens' Datum (Maybe SourcePos)
 position = ann . #position
 
-indentation :: Traversal' Datum Indentation
+-- affine
-indentation k (syn :< CompoundF (ListF ind xs)) = do
+style :: Traversal' Datum Style
+style k (syn :< CompoundF (ListF ind xs)) = do
   ind' <- k ind
   pure $ syn :< CompoundF (ListF ind' xs)
-indentation k a = pure a
+style k a = pure a
 
-adorn :: Syn -> Datum -> Datum
+styleWith :: Style -> Datum -> Datum
-adorn = set syntax
+styleWith = set style
-
-indentWith :: Indentation -> Datum -> Datum
-indentWith = set indentation
 
 stripAnn :: Datum -> Fix DatumF
 stripAnn = hoist tailF
@@ -208,9 +200,9 @@ pattern Meta x <- _ :< MetaF x
 
 pattern List :: List Datum -> Datum
 pattern List a <- _ :< CompoundF (ListF _ a)
-  where List a = noAnn :< CompoundF (ListF Ordinary a)
+  where List a = noAnn :< CompoundF (ListF StyleData a)
 
-pattern List' :: Indentation -> List Datum -> Datum
+pattern List' :: Style -> List Datum -> Datum
 pattern List' ind a <- _ :< CompoundF (ListF ind a)
   where List' ind a = noAnn :< CompoundF (ListF ind a)
 
@@ -226,12 +218,25 @@ pattern Abbrev :: Prefix -> Datum -> Datum
 pattern Abbrev p a <- _ :< CompoundF (AbbrevF p a)
   where Abbrev p a = noAnn :< CompoundF (AbbrevF p a)
 
+pattern Boolean :: Bool -> Datum
 pattern Boolean a = Simple (SimpleBoolean a)
+
+pattern Number :: Scientific -> Datum
 pattern Number a = Simple (SimpleNumber a)
+
+pattern Character :: Char -> Datum
 pattern Character a = Simple (SimpleCharacter a)
+
+pattern String :: Text -> Datum
 pattern String a = Simple (SimpleString a)
+
+pattern Symbol :: Text -> Datum
 pattern Symbol a = Simple (SimpleSymbol a)
+
+pattern Bytevector :: ByteString -> Datum
 pattern Bytevector a = Simple (SimpleBytevector a)
+
+pattern Unreadable :: Text -> Datum
 pattern Unreadable a = Simple (SimpleUnreadable a)
 
 

src/Gyehoek/Stack/Lower.hs

@@ -1,29 +0,0 @@
-module Gyehoek.Stack.Lower
-  ( lowerProgram
-  ) where
-
-import Gyehoek.Stack.Syntax
-import Gyehoek.Wasm qualified as Wasm
-import Gyehoek.Prelude
-import Gyehoek.Wasm (wat, watM)
-
-
-lowerRoutine :: Routine -> Wasm.Function
-lowerRoutine rt = _
-
-lowerBlock :: Block -> Wasm.Expr
-lowerBlock = _
-
-lowerInstr :: Instr -> Wasm.Expr
-lowerInstr = \case
-  -- PopCont ktail -> [wat|
-    
-  -- |]
-
-lowerProgram :: Program -> Eff es Wasm.Module
-lowerProgram p = pure [watM|
-  (module
-    ##{rs})
-|]
-  where
-    rs = p ^.. #routines . each . to lowerRoutine

src/Gyehoek/Stack/Syntax.hs

@@ -1,150 +0,0 @@
-{-# LANGUAGE TemplateHaskellQuotes #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE DeriveAnyClass #-}
-module Gyehoek.Stack.Syntax
-  ( Program(..)
-  , Routine(..)
-  , Instr(..)
-  , Block(..)
-  , Tail(..)
-  , Val(..)
-  , Lit(..)
-  , Obj(..)
-  , Imm(..)
-  , Hob(..)
-  , Prim(..)
-  , Name(..)
-  , Reg(..)
-  , Label(..)
-  , pattern ValLabel
-  , pattern ObjLabel
-  , stkP
-  ) where
-
-import Control.Lens
-import qualified Gyehoek.Sexp as S
-import Gyehoek.Scheme.Syntax (Name(..), Lit(..), Prim(..))
-import GHC.Exts (IsList(..))
-import Data.List (intersperse)
-import Gyehoek.CPS.Syntax (Imm(..), Obj(..), Hob(..), pattern ObjLabel, Reg, Label)
-import Gyehoek.Prelude
-import Gyehoek.Sexp ((:-)((:-)))
-
-
-newtype Program = MkProgram
-  { routines :: HashMap Label Routine
-  }
-  deriving stock (Show, Generic, Data)
-  deriving newtype (Semigroup, Monoid)
-  deriving anyclass (NFData)
-
-instance IsList Program where
-  type Item Program = Routine
-  fromList rs = MkProgram
-    { routines = fromList [ (r.label, r) | r <- rs ]
-    }
-  toList = toListOf $ #routines . each
-
-data Routine = MkRoutine
-  { label :: Label
-  , start :: Block
-  }
-  deriving stock (Show, Generic, Data)
-  deriving anyclass (NFData)
-
-data Block = MkBlock
-  { code :: List Instr
-  , tail :: Tail
-  }
-  deriving stock (Show, Generic, Data)
-  deriving anyclass (NFData)
-
-data Tail
-  -- | call the procedure at stack index `n` supplied with `n`
-  -- arguments on top of the stack, then return by calling the
-  -- continuation at stack index `n+1`.
-  = TailCall Int
-  | Call Int
-  | If Val Block Block
-  | Return Int
-  | CallCC
-  deriving stock (Show, Generic, Data)
-  deriving anyclass (NFData)
-
-data Instr
-  = Pop Reg
-  | Push Val
-  | Load Reg Int
-  | Prim Reg (Prim Val)
-  deriving stock (Show, Generic, Data)
-  deriving anyclass (NFData)
-
-data Val
-  = ValReg Reg
-  | ValImm Imm
-  deriving stock (Show, Generic, Data, Eq)
-  deriving anyclass (NFData)
-
-pattern ValLabel :: Label -> Val
-pattern ValLabel x = ValImm (ImmLabel x)
-
-
---- sexp work
-
-pure []
-
-instance S.DatumIso Instr where
-  datumIso = S.match
-    $ S.With (S.headTagged1 "pop!" S.datumIso >>>)
-    $ S.With (S.headTagged1 "push!" S.datumIso >>>)
-    $ S.With (S.headTagged2 "load" S.datumIso S.datumIso >>>)
-    $ S.With (S.headTagged2 "prim" S.datumIso S.datumIso >>>)
-    $ S.End
-    where
-
-instance S.DataIso Block where
-  dataIso = S.with \g ->
-    S.flipped S.snoced
-    >>> S.onHead (S.traversed $ S.sealed S.datumIso)
-    >>> S.onTail (S.datumIso @Tail)
-    >>> S.swap
-    >>> g
-
-instance S.DatumIso Tail where
-  datumIso = S.match
-    $ S.With (S.headTagged1 "tail-call" S.datumIso >>>)
-    $ S.With (S.headTagged1 "call" S.datumIso >>>)
-    $ S.With (if_ >>>)
-    $ S.With (S.headTagged1 "return" S.datumIso >>>)
-    $ S.With (S.headTagged0 "call/cc" >>>)
-    $ S.End
-    where
-      -- if_ = S.ifLike "if" (S.datumIso @Val) S.datumIso S.datumIso
-      if_ = S.ifLike "if" (S.datumIso @Val) (branch "then") (branch "else")
-      branch :: Text -> S.DatumGrammar Block
-      branch s =
-        S.listWithIndentation (S.NSpecial 0) $
-            S.el (S.decorate S.SynBuiltin >>> S.sym s)
-            >>> S.restData (S.dataIso @Block)
-
-instance S.DatumIso Val where
-  datumIso = S.match
-    $ S.With (S.datumIso >>>)
-    $ S.With (S.datumIso >>>)
-    $ S.End
-
-instance S.DatumIso Routine where
-  datumIso = S.with \rout ->
-      S.listWithIndentation (S.NSpecial 1)
-       ( S.el (S.decorate S.SynBuiltin >>> S.sym "define")
-       >>> S.el (S.datumIso @Label)
-       >>> S.restData (S.dataIso @Block)
-       )
-      >>> rout
-
-instance S.DataIso Program where
-  dataIso = S.dataIso @(List Routine) >>> S.iso fromList toList
-
-stkP :: S.QuasiQuoter
-stkP = S.makeSxs [|| S.fromDataUnsafe (S.dataIso @Program) ||]

src/Gyehoek/Stack/VM.hs

@@ -1,507 +0,0 @@
-{-# LANGUAGE ViewPatterns, MultilineStrings #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE DeriveAnyClass #-}
-module Gyehoek.Stack.VM
-  ( VM(..)
-  , Env(..)
-  , eval
-  , trace
-  , module Gyehoek.Stack.Syntax
-  , writeObj
-  , traceEval
-  ) where
-
-import Gyehoek.Stack.Syntax
-import Control.Lens
-import qualified Data.HashMap.Strict as H
-import Data.List (unfoldr, intersperse, compareLength)
-import Gyehoek.Prelude
-import qualified Data.List.NonEmpty as NE
-import Lucid
-import Data.Foldable (traverse_)
-import qualified Gyehoek.Sexp as S
-import Gyehoek.Jalmot
-import Text.Pretty.Simple (pStringNoColor, pShowNoColor)
-import Effectful.State.Static.Local (runState, evalState, get)
-import Data.Traversable
-import Control.Applicative (Alternative(..))
-import Gyehoek.Sexp.Print (htmlData)
-import Control.DeepSeq (deepseq, ($!!))
-import Gyehoek.Sexp.Print (htmlData, htmlDatum)
-import Control.DeepSeq (deepseq, ($!!))
-import Data.String (fromString)
-import Data.Monoid (First)
-import GHC.Stack (popCallStack)
-import Data.Maybe (fromMaybe)
-
-
--- | non-essential information maintained only to aide in debugging.
-data DebugVM = MkDebugVM
-  { activeRoutine :: Label
-  }
-  deriving (Show, Generic)
-
-newtype Frame = MkFrame { locals :: List Obj }
-  deriving stock (Show, Generic)
-
--- affine
-returnAddress :: Traversal' Frame Obj
-returnAddress = #locals . _last
-
--- affine
-activeProcedure :: Traversal' Frame Obj
-activeProcedure = #locals . _init . _last
-
-newtype Stack = MkStack { frames :: NonEmpty Frame }
-  deriving stock (Show, Generic)
-
-data VM = MkVM
-  { stack :: Stack
-  , code :: List Instr
-  , tail :: Tail
-  , registers :: HashMap Reg Obj
-  , stdout :: Text
-  , result :: Maybe (List Obj)
-  , debug :: DebugVM
-  }
-  deriving (Show, Generic)
-
-type instance Index Frame = Int
-type instance IxValue Frame = Obj
-
-instance Ixed Frame where
-  ix j = wrappedIso . ix j
-
-instance Cons Frame Frame Obj Obj where
-  _Cons = prism'
-    (\(x,MkFrame xs) -> MkFrame (x:xs))
-    \case
-      MkFrame (x:xs) -> Just (x, MkFrame xs)
-      MkFrame [] -> Nothing
-
-instance Each Frame Frame Obj Obj where each = wrappedIso . each
-
-instance Each Stack Stack Frame Frame where each = wrappedIso . each
-
-pushes :: Foldable f => f Obj -> Frame -> Frame
-pushes = flip $ foldr cons
-
-_NonEmpty :: Iso (NonEmpty a) (NonEmpty b) (a, List a) (b, List b)
-_NonEmpty = iso
-  (\(x:|xs) -> (x,xs))
-  (\(x,xs) -> x:|xs)
-
-pushFrame :: Frame -> Stack -> Stack
-pushFrame f (MkStack xs) = MkStack $ NE.cons f xs
-
-activeFrame :: Lens' VM Frame
-activeFrame = #stack . #frames . _NonEmpty . _1
-
-data Env = MkEnv
-  { labels :: HashMap Label Routine
-  }
-  deriving (Show, Generic)
-
-step :: Jalmot :> es => Env -> VM -> Eff es VM
-step g vm = case vm ^. #code of
-  c:cs -> stepI g (vm & #code .~ cs) c
-  [] -> stepT g vm vm.tail
-
-vmerror :: (HasCallStack, Jalmot :> es) => Text -> Eff es a
-vmerror = throwError . VMError
-
-stepI :: Jalmot :> es => Env -> VM -> Instr -> Eff es VM
-
-stepI e vm ins = vmerror [i|unimplemented instruction: #{ins}|]
-
-stepT :: Jalmot :> es => Env -> VM -> Tail -> Eff es VM
-
-stepT g vm tc@(Call nargs) = do
-  (args,f,ret,frm) <- parseCall nargs (vm ^. activeFrame)
-    & expectOf [i|bad call: #{show tc}|] _Just
-  rt <- getRoutine g f
-  let newFrame = MkFrame $ args ++ [f,ret]
-  pure $ vm
-    & jumpToRoutine rt
-    & activeFrame .~ frm
-    -- it is not essential we clear the registers, but it'll
-    -- make bugs more obvious.
-    & #registers .~ mempty
-    & #stack %~ \stk ->
-      case f of
-        ObjHob (HobContinuation {stack}) ->
-          coerce $ stack & _NonEmpty . _1 <>:~ (args ++ [f])
-        _ -> pushFrame newFrame stk
-
-stepT g vm tc@(Return nret) = do
-  (xs,_) <- splitAtExact nret (vm ^. activeFrame . #locals)
-    & expectOf [i|bad return: #{show tc}|] _Just
-  expectOf [i|no return addr|] (activeFrame . returnAddress) vm >>= \case
-    ObjLabel "halt" -> pure $ vm & #result ?~ xs
-    ra -> do
-      rt <- getRoutine g ra
-      vm & traverseOf #stack (fmap snd . popFrame)
-         & mapped . activeFrame %~ pushes xs
-         & mapped %~ jumpToRoutine rt
-         -- it is not essential we clear the registers, but it'll make
-         -- bugs more obvious.
-         & mapped . #registers .~ mempty
-
-stepT g vm tc@(TailCall nargs) = do
-  (args,f,ra) <- parseTailCall nargs (vm ^. activeFrame)
-    & expectOf [i|bad call: #{show tc}|] _Just
-  case f of
-    ObjLabel "halt" -> pure $ vm & #result ?~ args
-    _ -> do
-      rt <- getRoutine g f
-      let newFrame = MkFrame $ args ++ [f, ra]
-      pure $ vm
-        & jumpToRoutine rt
-        -- replace the active frame; don't push a new one.
-        & activeFrame .~ newFrame
-        -- it is not essential we clear the registers, but it'll make
-        -- bugs more obvious.
-        & #registers .~ mempty
-
-stepT g vm (If c t f) = do
-  branch <- evalVal g vm c <&> \case
-      ObjImm (ImmBool False) -> f
-      _ -> t
-  pure $ jumpToBlock branch vm
-
-stepT g vm CallCC = do
-  (cc,withcc,frm) <- parseCallCC (vm ^. activeFrame)
-    & expectOf "bad call/cc" _Just
-  let stk = vm.stack & #frames . _NonEmpty . _1 .~ frm
-  let reified_cc = ObjHob $ HobContinuation cc (coerce stk)
-  let newFrame = MkFrame [reified_cc, withcc, cc]
-  rt <- getRoutine g withcc
-  pure $ vm
-    & jumpToRoutine rt
-    -- replace the active frame; don't push a new one.
-    & activeFrame .~ newFrame
-    -- it is not essential we clear the registers, but it'll make
-    -- bugs more obvious.
-    & #registers .~ mempty
-
-stepP :: Jalmot :> es => Env -> VM -> Prim Val -> Eff es VM
-stepP g vm p = traverse (evalVal g vm) p >>= \case
-  PrimZeroP x -> case x of
-    ObjImm (ImmInt n) -> ret1 . ObjImm . ImmBool $ n == 0
-    _ -> vmerror [i|bad arg to zero?: #{x}|]
-  PrimAdd x y -> arith_binop (+) x y
-  PrimMul x y -> arith_binop (*) x y
-  PrimSub x y -> arith_binop (-) x y
-  PrimDiv x y -> arith_binop div x y
-  PrimMakeClosure f env ->
-    case f of
-      ObjImm (ImmLabel l) -> ret1 . ObjHob $ HobClosure l env
-      _ -> vmerror [i|expected label, got #{f}|]
-  PrimEnv -> do
-    x <- vm & expectOf "expected closure" (activeFrame . activeProcedure)
-    ret1 x
-  PrimEnvRef n -> do
-    (label,env) <- vm & expectOf "expected closure"
-        (activeFrame . activeProcedure . #_ObjHob . #_HobClosure) 
-    x <- env & expectOf "expected upval" (ix n)
-    ret1 x
-  PrimCons x y -> ret1 $ ObjHob $ HobPair x y
-  PrimCar x -> case x of
-      ObjHob (HobPair car _) -> ret1 car
-      _ -> vmerror [i|expected pair, got ${x}|]
-  PrimCdr x -> case x of
-      ObjHob (HobPair _ cdr) -> ret1 cdr
-      _ -> vmerror [i|expected pair, got ${x}|]
-  -- PrimCaptureCC -> do
-  --   label <- vm & expectOf [i|bad stack, no return addr|]
-  --     (activeFrame . returnAddress . #_ObjImm . #_ImmLabel)
-  --   ret1 . ObjHob $ HobContinuation { label }
-  x -> vmerror [i|unimplemented prim: #{p}|]
-  where
-    ret vs = pure $ vm & activeFrame . #locals <>:~ vs
-    ret1 v = ret [v]
-    arith_binop op (ObjImm (ImmInt x)) (ObjImm (ImmInt y)) =
-      ret1 $ ObjImm (ImmInt (op x y))
-    arith_binop _ x y = vmerror [i|bad arith: #{x}, #{y}|]
-
-
-
-popFrame :: (HasCallStack, Jalmot :> es) => Stack -> Eff es (Frame, Stack)
-popFrame stk = case stk ^. #frames . to NE.uncons of
-  (_, Nothing) -> vmerror "no frame to pop"
-  (f, Just fs) -> pure (f, stk & #frames .~ fs)
-
-jumpToBlock :: Block -> VM -> VM
-jumpToBlock b vm = vm
-  & #code .~ b.code
-  & #tail .~ b.tail
-
-jumpToRoutine :: Routine -> VM -> VM
-jumpToRoutine rt vm = vm
-  & jumpToBlock rt.start
-  & #debug . #activeRoutine .~ rt.label
-
-getLabel :: Obj -> Maybe Label
-getLabel = \case
-  ObjHob (HobClosure {label}) -> Just label
-  ObjHob (HobContinuation {cont}) -> getLabel cont
-  ObjImm (ImmLabel label) -> Just label
-  x -> Nothing
-
-getRoutine :: (HasCallStack, Jalmot :> es) => Env -> Obj -> Eff es Routine
-getRoutine g f = do
-  l <- getLabel f & expectOf [i|no label for #{f}|] _Just
-  case g ^. #labels . at l of
-    Just rt -> pure rt
-    Nothing -> vmerror [i|undefined label #{l}|]
-
-expectOf
-  :: (HasCallStack, Jalmot :> es)
-  => Text -> Getting (First a) s a -> s -> Eff es a
-expectOf msg l = maybe (vmerror msg) pure . preview l
-
-evalToLabel :: Jalmot :> es => Env -> VM -> Val -> Eff es Label
-evalToLabel e vm v =
-  evalVal e vm v >>= \case
-    ObjImm (ImmLabel x) -> pure x
-    x -> vmerror [i|not a label: #{x}|]
-
-evalVal :: Jalmot :> es => Env -> VM -> Val -> Eff es Obj
-evalVal e vm = \case
-  ValImm imm -> pure $ ObjImm imm
-  ValReg r -> case vm ^. #registers . at r of
-    Just x -> pure x
-    Nothing -> vmerror [i|undefined register: #{r}|]
-
-splitAtExact :: Int -> List a -> Maybe (List a, List a)
-splitAtExact n xs = case compareLength xs n of
-  (EQ;GT) -> Just $ splitAt n xs
-  LT -> Nothing
-
-takeExact :: Int -> List a -> Maybe (List a)
-takeExact n xs = case compareLength xs n of
-  (EQ;GT) -> Just $ take n xs
-  LT -> Nothing
-
-parseCallCC :: Frame -> Maybe (Obj, Obj, Frame)
-parseCallCC frm = do
-  ([cc,withcc],ys) <- splitAtExact 2 (frm ^. #locals)
-  pure (cc,withcc,MkFrame ys)
-
-parseCall :: Int -> Frame -> Maybe (List Obj, Obj, Obj, Frame)
-parseCall nargs frm = do
-  (xs,ys) <- splitAtExact (nargs+2) (frm ^. #locals)
-  let (xs',[f,ret]) = splitAt nargs xs
-  pure (xs',f,ret,MkFrame ys)
-
-parseTailCall :: Int -> Frame -> Maybe (List Obj, Obj, Obj)
-parseTailCall nargs frm = do
-  (xs,_) <- splitAtExact (nargs+1) (frm ^. #locals)
-  let (xs',f) = xs ^?! _Snoc
-  pure (xs',f,frm ^?! returnAddress)
-
-initialVM :: VM
-initialVM = MkVM
-  { stack = MkStack . NE.singleton . MkFrame $
-    [ ObjLabel "start"
-    , ObjLabel "<nowhere at all>"
-    , ObjLabel "halt"
-    ]
-  , tail = TailCall 0
-  , code = []
-  , registers = mempty
-  , stdout = ""
-  , result = Nothing
-  , debug = MkDebugVM
-    { activeRoutine = "<nowhere>"
-    }
-  }
-
-initialEnv :: Program -> Env
-initialEnv p = MkEnv
-  { labels = p.routines
-  }
-
-loop :: (a -> Either b a) -> a -> b
-loop f a = case f a of
-  Right a' -> loop f a'
-  Left b -> b
-
-loopM :: Monad m => (a -> m (Either b a)) -> a -> m b
-loopM f a = f a >>= \case
-  Right a' -> loopM f a'
-  Left b -> pure b
-
-eval :: Jalmot :> es => Program -> Eff es (List Obj)
-eval p = initialVM & loopM \vm -> case vm ^. #result of
-  Nothing -> Right <$> step (initialEnv p) vm
-  Just rs -> pure . Left $ rs
-
-data Trace
-  = Step { vm :: VM, next :: Trace }
-  | StepToSuccess { vm :: VM, result :: List Obj }
-  | StepToFailure { vm :: VM, err :: AJalmotCS }
-  deriving (Show)
-
-trace :: Program -> Trace
-trace p = go (initialEnv p) initialVM
-  where
-    go g vm =
-      case vm.result of
-        Just rs -> StepToSuccess vm rs
-        Nothing ->
-          case runPureEff . runJalmotCS $ step g vm of
-            Left err -> StepToFailure vm err
-            Right vm' -> Step vm (go g vm')
-
-writeObj :: Obj -> Text
-writeObj = runJalmotUnsafe . S.encodeWith' S.datumIso
-
-traceEval :: IOE :> es => Program -> Eff es ()
-traceEval p = do
-  let t = trace p
-  liftIO . renderToFile "trace.html" . ppDoc p $ t
-
-ppDoc :: Program -> Trace -> Html ()
-ppDoc p t =
-  html_ do
-    head_ do
-      title_ "stackify trace"
-      style_ """
-        pre {
-          max-width: 95vw;
-          overflow: scroll;
-        }
-        table {
-          max-width: 95vw;
-        }
-        tbody > tr:nth-of-type(even) {
-            background-color: rgb(237 238 242);
-        }
-        .loc {
-            font-size: 0.8rem;
-        }
-        .syn-builtin, .syn-macro {
-            color: purple;
-            font-style: italic;
-            font-weight: bold;
-        }
-        .syn-constant {
-            color: olive;
-        }
-        .syn-procedure {
-            color: teal;
-        }
-        td pre {
-          display: inline
-        }
-        .syn-paren-0 { color: maroon; }
-        .syn-paren-1 { color: olive; }
-        .syn-paren-2 { color: green; }
-        .syn-paren-3 { color: navy; }
-        .syn-paren-4 { color: purple; }
-        .stack-frame
-        { display: inline-flex
-        ; flex-direction: row
-        ; column-gap: 0.5em
-        }
-      """
-    body_ do
-      details_ do
-        summary_ "stack code"
-        pre_ $ code_ do
-          htmlData . runJalmotUnsafe . S.toData S.dataIso $ p
-      ppTrace t
-
-ppTrace :: Trace -> Html ()
-ppTrace trace =
-  table_ do
-    thead_ $ tr_ do
-      traverse_ (th_ [scope_ "col"])
-        ["routine","next instruction","stack frame"]
-    tbody_ do
-      go trace
-  where
-    go :: Trace -> Html ()
-    go = \case
-      Step vm next -> ppVM vm >> go next
-      StepToSuccess vm rs -> do
-        tr_ [class_ "trace-result"] do
-          td_ do
-            details_ do
-              summary_ "result"
-              pre_ do
-                code_ . toHtml . pShowNoColor $ vm
-          td_ [colspan_ "2"] do
-            sequence_ . intersperse " | " $ code_ . ppDatum <$> rs
-      StepToFailure vm err -> do
-        ppVM vm
-        tr_ [class_ "trace-failure"] do
-          td_ [colspan_ "3"] do
-            details_ do
-              summary_ "error"
-              pre_ do
-                samp_ do
-                  fromString $ displayException err
-
-ppVM :: VM -> Html ()
-ppVM vm = do
-  tr_ do
-    td_ do
-      details_ do
-        summary_ do
-          var_ [class_ "loc"] do
-            vm ^. #debug . #activeRoutine . to ppDatum
-        pre_ do
-          code_ . toHtml . pShowNoColor $ vm
-    td_ do
-      code_ curi
-    td_ do
-      ppStack vm.stack
-  where
-    curi = vm ^?! failing (#code . _head . to ppDatum) (#tail . to ppDatum)
-
-ppStack :: Stack -> Html ()
-ppStack stk = do
-  span_ [class_ "stack"] do
-    stk ^.. each
-      & fmap ppFrame
-      & intersperse " | "
-      & sequence_
-
-ppFrame :: Frame -> Html ()
-ppFrame frm = do
-  span_ [class_ "stack-frame"] do
-    sequence_ $ frm ^.. #locals . each . to ppDatum
-
-ppData :: S.DataIso a => a -> Html ()
-ppData = htmlData . runJalmotUnsafe . S.toData S.dataIso
-
-ppDatum :: S.DatumIso a => a -> Html ()
-ppDatum = htmlDatum . runJalmotUnsafe . S.toDatum S.datumIso
-
-fac (n :: Int) = [stkP|
-(define $start
-  (push! $fac)
-  (push! #{n})
-  (tail-call 1))
-
-(define $fac
-  (load %n 0)
-  (prim %x0 (zero? %n))
-  (if %x0
-      (then (push! 1)
-            (return 1))
-      (else (prim %x1 (- %n 1))
-            (push! $fac-c0)
-            (push! $fac)
-            (push! %x1)
-            (call 1))))
-
-(define $fac-c0
-  (pop! %x2)
-  (pop! %n)
-  (prim %x3 (* %n %x2))
-  (push! %x3)
-  (return 1))
-|]

src/Gyehoek/Wasm.hs

@@ -1,4 +1,3 @@
-{- HLINT ignore "Use newtype instead of data" -}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE TemplateHaskellQuotes #-}

t.scm

@@ -1,5 +1,4 @@
-((λ ()
+(import (scheme eval))
-   (* 2 (call/cc
+
-         (λ (k)
+(eval '(λ (x) x)
-           (begin (k 6)
+      (environment))
-                  3))))))

test/Gyehoek/Test/CPS/Eval.hs

@@ -58,7 +58,7 @@ test_eval = do
       <&> fmap ("golden/exec" </>)
   pure $ testGroup "cps interpreter"
     [ testGroup "higher-order" $ cpsCase Driver.eval_cps2_e2e <$> cs
-    -- , testGroup "first-order" $ cpsCase Driver.eval_cps_e2e <$> cs
+    -- , testGroup "first-order" $ cpsCase Driver.eval_cps1_e2e <$> cs
     ]
 
 maybeBroken name broken = applyWhen (name `elem` broken) expectFail

test/Gyehoek/Test/CPS/Stackify.hs

@@ -1,96 +0,0 @@
-module Gyehoek.Test.CPS.Stackify where
-
-import Test.Tasty (TestTree, testGroup)
-import Test.Tasty.HUnit
-import qualified Gyehoek.CPS.Stackify as Sut
-import Gyehoek.Stack.VM as Stk
-import Gyehoek.CPS.Syntax (cps)
-import Gyehoek.CPS.Syntax qualified as CPS
-import Gyehoek.GenSym (runGenSym)
-import Effectful
-import Gyehoek.Prelude
-import Gyehoek.Jalmot
-import Test.Tasty.ExpectedFailure (expectFail, ignoreTestBecause)
-
-
--- test_stackify =
---   [ trivialReturn
---   , tailCall
---   , prim
---   , condition
---   , procedure
---   ]
-
--- evalsTo :: HasCallStack => List Obj -> Sut.Program -> Assertion
--- evalsTo rs e = runJalmotUnsafe (Stk.eval e') @?= rs
---   where
---     e' = e & Sut.stackifyProgram & runGenSym & runPureEff
-
--- trivialReturn = testGroup "trivial return"
---   [ testCase "return int" do
---       evalsTo [ObjImm (ImmInt 4)]
---         [cps|(λ (ktail) (continue ktail 4))|]
---   , testCase "return bool" do
---       evalsTo [ObjImm (ImmBool True)]
---         [cps|(λ (ktail) (continue ktail #t))|]
---       evalsTo [ObjImm (ImmBool False)]
---         [cps|(λ (ktail) (continue ktail #f))|]
---   ]
-
--- tailCall = testGroup "tail call"
---   [ testCase "square" do
---       evalsTo [ObjImm (ImmInt 16)] [cps|
---         (λ (ktail0)
---           (letrec ((square (λ (x ktail)
---                              (prim (* x x)
---                                (κ (x0) (continue ktail x0))))))
---             (square 4 halt)))
---       |]
---   ]
-
--- prim = testGroup "prim"
---   [ testCase "multiply" do
---       evalsTo [ObjImm (ImmInt 20)]
---         [cps|(λ (ktail0)
---             (prim (* 4 5)
---                (κ (x) (continue ktail0 x))))|]
---   , testCase "add" do
---       evalsTo [ObjImm (ImmInt 9)]
---         [cps|(λ (ktail0)
---         (prim (+ 4 5)
---                (κ (x) (continue ktail0 x))))|]
---   -- , testGroup "call/cc"
---   --   [ testCase "trivial" do
---   --       evalsTo [ObjImm (ImmInt 123)]
---   --         [cps|(letrec ((f (λ (cc ktail) (continue cc 123))))
---   --                (prim (call/cc f)))|]
---   --   ]
---   ]
-
--- condition = testCase "if" do
---   evalsTo [ObjImm (ImmInt 123)]
---     [cps|(λ (ktail0)
---       (if #t (continue ktail0 123) (continue ktail0 456)))|]
---   evalsTo [ObjImm (ImmInt 456)]
---     [cps|(λ (ktail0)
---       (if #f (continue ktail0 123) (continue ktail0 456)))|]
-
--- procedure = testGroup "procedure"
---   [ testCase "factorial" do
---       evalsTo [ObjImm (ImmInt 720)]
---         [cps|(λ (ktail0)
---           (letrec ((fac (λ (n ktail)
---                              (prim (zero? n)
---                                (κ (x0)
---                                  (if x0
---                                    (continue ktail 1)
---                                    (prim (- n 1)
---                                      (κ (x1)
---                                        (letrec ((fac-k0
---                                                   (κ (x2)
---                                                     (prim (* n x2)
---                                                       (κ (x3)
---                                                         (continue ktail x3))))))
---                                          (fac x1 fac-k0))))))))))
---                (fac 6 halt)))|]
---   ]

test/Gyehoek/Test/Golden.hs

@@ -1,85 +0,0 @@
-module Gyehoek.Test.Golden where
-
-import Test.Tasty (TestTree, testGroup)
-import Test.Tasty.Silver
-import Gyehoek.Driver qualified as Driver
-import System.FilePath
-import Data.List (List)
-import Data.Functor ((<&>))
-import System.Directory
-import Data.Function
-import System.Environment.Blank (getEnvDefault)
-import qualified System.Process.Text as PT
-import Control.Exception (SomeException (SomeException), Exception (..), catch)
-import Gyehoek.Stack.VM (writeObj)
-import Data.Text qualified as T
-import System.Exit (ExitCode(..))
-import Test.Tasty.ExpectedFailure (expectFail, ignoreTestBecause)
-import Control.DeepSeq (($!!))
-import Text.Pretty.Simple (pShow, pShowNoColor)
-import Control.Lens (strict, view)
-import Gyehoek.Sexp.Read qualified as Read
-import Effectful
-
-
-brokenWasmTests :: List String
-brokenWasmTests =
-  [
-  ]
-
-brokenStackifyTests :: List String
-brokenStackifyTests =
-  [
-  ]
-
-test_root :: IO TestTree
-test_root = do
-  all_cases <- listDirectory "golden/exec"
-  let tests = all_cases
-            & fmap ("golden/exec"</>)
-  testGroup "execution" <$> sequenceA
-    [ ignoreTestBecause "wasm codegen is on the backburner"
-      <$> wasmTests tests
-    , ignoreTestBecause "i'm killing myself"
-      <$> stackifyTests tests
-    ]
-
-maybeBroken name broken = applyWhen (name `elem` broken) expectFail
-
-wasmTests :: List FilePath -> IO TestTree
-wasmTests files = do
-  cmd <- getEnvDefault "GYEHOEK_WASM_RUNTIME"
-    "runtime/target/debug/gyehoek-wasm-runtime"
-  pure $ testGroup "wasm" $ files <&> \test ->
-    let testname = takeFileName test
-        scmfile = test </> "source.scm"
-        resultfile = test </> "exec"
-        action = do
-          t <- Driver.lower_e2e scmfile
-          PT.readProcessWithExitCode cmd ["-"] t
-    in maybeBroken testname brokenWasmTests $
-      goldenVsAction
-       testname
-       resultfile
-       action
-       printProcResult
-
-stackifyTests :: List FilePath -> IO TestTree
-stackifyTests files = do
-  pure $ testGroup "stackified" $ files <&> \test ->
-    let testname = takeFileName test
-        scmfile = test </> "source.scm"
-        resultfile = test </> "exec"
-        action =
-          catch @SomeException
-            (do rs <- Driver.eval_e2e scmfile
-                pure $!! ( ExitSuccess
-                     , T.unwords . fmap writeObj $ rs
-                     , "" ))
-            \e -> pure (ExitFailure 1, "", T.pack $ displayException e)
-    in maybeBroken testname brokenStackifyTests $
-     goldenVsAction
-       testname
-       resultfile
-       action
-       printProcResult

test/Gyehoek/Test/Sexp/Print.hs

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

test/Gyehoek/Test/Sexp/Read.hs

@@ -20,7 +20,6 @@ brokenReaderTests :: List String
 brokenReaderTests =
   [ "delimited-identifier"
   , "string-line-continuation"
-  , "peculiar-identifier-dot"
   , "meta-splice-expression-interior-brace"
   , "datum-comment"
   ]

test/Gyehoek/Test/Stack/VM.hs

@@ -1,112 +0,0 @@
-{-# LANGUAGE OverloadedLists #-}
-module Gyehoek.Test.Stack.VM where
-
-import Test.Tasty (TestTree, testGroup)
-import Test.Tasty.HUnit
-import Gyehoek.Stack.Syntax
-import Gyehoek.Stack.VM qualified as Sut
-import Data.List (List)
-import Gyehoek.Jalmot
-import Gyehoek.Prelude (i)
-import Test.Tasty.ExpectedFailure (expectFail, ignoreTestBecause)
-
-
-evalsTo :: List Obj -> Program -> Assertion
-evalsTo rs p = runJalmotUnsafe (Sut.eval p) @?= rs
-
-test_root = ignoreTestBecause "i'm super-killing myself" $ testGroup "stack machine"
-  [ testCase "immediate halt" do
-      evalsTo [] [stkP|
-        (define $start
-          (return 0))
-      |]
-  , testCase "lit int" do
-      evalsTo [ObjImm (ImmInt 3)] [stkP|
-        (define $start
-          (push! 3)
-          (return 1))
-      |]
-  , testCase "non-tail identity function" do
-      evalsTo [ObjImm (ImmInt 123)] [stkP|
-        (define $id
-          (return 1))
-        (define $c
-          (return 1))
-        (define $start
-          (push! $c)
-          (push! $id)
-          (push! 123)
-          (call 1))
-      |]
-  , testCase "tail identity function" do
-      evalsTo [ObjImm (ImmInt 123)] [stkP|
-        (define $id
-          (return 1))
-        (define $start
-          (push! $id)
-          (push! 123)
-          (tail-call 1))
-      |]
-  , testCase "return constant" do
-      evalsTo [ObjImm (ImmInt 123)] [stkP|
-        (define $start
-          (push! $silly)
-          (tail-call 1))
-        (define $silly
-          (push! 123)
-          (return 1))
-      |]
-  , testCase "return multiple" do
-      evalsTo [ObjImm (ImmInt n) | n <- [1,2,3]] [stkP|
-        (define $start
-          (push! 3)
-          (push! 2)
-          (push! 1)
-          (return 3))
-      |]
-  , testCase "return none" do
-      evalsTo [] [stkP|
-        (define $start
-          (return 0))
-      |]
-  , testCase "square" do
-      evalsTo [ObjImm (ImmInt 16)] [stkP|
-        (define $start
-          (push! $square)
-          (push! 4)
-          (tail-call 1))
-        (define $square
-          (pop! %x)
-          (prim (* %x %x))
-          (return 1))
-      |]
-  , testGroup "factorial"
-      let
-        hsfac (n :: Int) = foldr @List (*) 1 [1..n]
-        fac (n :: Int) = [stkP|
-          (define $start
-            (push! $fac)
-            (push! #{n})
-            (tail-call 1))
-          (define $fac
-            (load %n 0)
-            (prim (zero? %n))
-            (pop! %x0)
-            (if %x0
-                (then (push! 1)
-                      (return 1))
-                (else (push! $fac-c0)
-                      (push! $fac)
-                      (prim (- %n 1))
-                      (call 1))))
-          (define $fac-c0
-            (pop! %x2)
-            (pop! %n)
-            (prim (* %n %x2))
-            (return 1))
-      |]
-        mkcase n = testCase [i|#{n}|] do
-          evalsTo [ObjImm . ImmInt $ hsfac n] $ fac n
-      -- 20 is the greatest `n` for which n! ≤ maxBount @Int
-      in [ mkcase n | n <- [0,1,6,20] ]
-  ]