.dir-locals.el

@@ -8,4 +8,9 @@
   . ((eval
       . (progn (defun apply-cabal-fmt-h ()
                  (haskell-mode-buffer-apply-command "cabal-fmt"))
-               (add-hook 'before-save-hook #'apply-cabal-fmt-h nil t))))))
+               (add-hook 'before-save-hook #'apply-cabal-fmt-h nil t)))))
+ (nil
+  . ((eval
+      . (progn (defun display-ansi ()
+                 (interactive)
+                 (ansi-color-apply-on-region (point-min) (point-max))))))))

cabal.project

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

golden/print/begin-nonempty-thin

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

golden/print/begin-nonempty-wide

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

golden/print/lambda-thin

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

golden/print/lambda-wide

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

golden/print/null

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

golden/print/rainbow

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

golden/print/simple-list-thin

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

golden/print/simple-list-wide

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

golden/read/bool/read

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

golden/read/bool/source.scm

@@ -0,0 +1 @@
+#t #true #f #false

golden/read/datum-comment/source.scm

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

golden/read/decimal/read

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

golden/read/decimal/source.scm

@@ -0,0 +1 @@
+45 +5667 -123

golden/read/delimited-identifier/read

@@ -0,0 +1,5 @@
+[ Fix
+    ( SimpleF
+        ( Symbol "aaaa bc" )
+    )
+]

golden/read/delimited-identifier/source.scm

@@ -0,0 +1 @@
+|aaaa bc|

golden/read/empty/read

@@ -0,0 +1 @@
+[]

golden/read/list-dot-flat/read

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

golden/read/list-dot-flat/source.scm

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

golden/read/list-flat/read

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

golden/read/list-flat/source.scm

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

golden/read/list/read

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

golden/read/list/source.scm

@@ -0,0 +1 @@
+(a b (c d) . (가 (나 . 다) 라))

golden/read/meta-expression/read

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

golden/read/meta-expression/source.scm

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

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

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

golden/read/meta-splice-expression/read

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

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

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

golden/read/meta-splice-variable/read

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

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

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

golden/read/meta-variable/read

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

golden/read/meta-variable/source.scm

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

golden/read/peculiar-identifier-dot/read

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

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

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

golden/read/peculiar-identifier-sign/read

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

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

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

golden/read/string-line-continuation/read

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

golden/read/string-line-continuation/source.scm

@@ -0,0 +1,2 @@
+"가나다\
+      라마바"

golden/read/string/read

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

golden/read/string/source.scm

@@ -0,0 +1 @@
+"가나다라"

golden/read/typical-identifier-token/read

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

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

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

golden/read/typical-identifier/read

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

golden/read/typical-identifier/source.scm

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

gyehoek.cabal

@@ -60,24 +60,36 @@ library
     Gyehoek.CPS.Syntax
     Gyehoek.Driver
     Gyehoek.GenSym
+    Gyehoek.Jalmot
+    Gyehoek.Lift1
     Gyehoek.Options
     Gyehoek.Prelude
     Gyehoek.Scheme.Syntax
     Gyehoek.Sexp
+    Gyehoek.Sexp.Grammar
+    Gyehoek.Sexp.Grammar.Base
+    Gyehoek.Sexp.Print
+    Gyehoek.Sexp.QQ
+    Gyehoek.Sexp.Read
+    Gyehoek.Sexp.Syntax
     Gyehoek.Stack.Syntax
     Gyehoek.Stack.VM
     Gyehoek.Wasm
 
   build-depends:
-    , base                  ^>=4.21.2.0
+    , base                         ^>=4.21.2.0
     , binary
     , bytestring
+    , comonad
     , containers
+    , data-fix
     , deepseq
+    , deriving-compat
     , effectful
     , effectful-core
     , effectful-plugin
     , filepath
+    , free
     , generic-lens
     , hashable
     , invertible-grammar
@@ -88,9 +100,10 @@ library
     , ordered-containers
     , pretty-simple
     , prettyprinter
+    , prettyprinter-ansi-terminal
     , process
     , recursion-schemes
-    , sexp-grammar
+    , scientific
     , string-interpolate
     , template-haskell
     , text
@@ -108,14 +121,19 @@ test-suite test
   hs-source-dirs:     test
   main-is:            Main.hs
   build-tool-depends: tasty-discover:tasty-discover
+
+  -- cabal-fmt: expand test -Main
   other-modules:
     Gyehoek.Test.CPS.Eval
     Gyehoek.Test.CPS.Stackify
     Gyehoek.Test.CPS.Syntax
     Gyehoek.Test.Golden
     Gyehoek.Test.Scheme.Syntax
-    Gyehoek.Test.Sexp
+    Gyehoek.Test.Sexp.Print
+    Gyehoek.Test.Sexp.QQ
+    Gyehoek.Test.Sexp.Read
     Gyehoek.Test.Stack.VM
+    Gyehoek.TestUtil
     Root
 
   build-depends:
@@ -127,8 +145,8 @@ test-suite test
     , generic-lens
     , gyehoek
     , lens
+    , pretty-simple
     , process-extras
-    , sexp-grammar
     , tasty
     , tasty-expected-failure
     , tasty-hunit
@@ -136,3 +154,14 @@ test-suite test
     , text
 
   default-language:   GHC2024
+
+-- https://github.com/martijnbastiaan/doctest-parallel/pull/66
+-- 
+-- test-suite doctest
+--   import:         ghcstuffs, ghcstuffs-dev
+--   type:           exitcode-stdio-1.0
+--   hs-source-dirs: test
+--   main-is:        doctest.hs
+--   build-depends:
+--     , base
+--     , doctest-parallel  >=0.1

src/Gyehoek/CPS/Lower.hs

@@ -17,12 +17,11 @@ import Numeric.Natural
 import qualified Data.Vector.Strict as V
 import Gyehoek.Wasm qualified as Wasm
 import Gyehoek.Wasm hiding (Expr)
-import Language.Sexp.Located qualified as SL
 import Control.Monad.Fix
-import qualified Gyehoek.Sexp
 import Data.Text qualified as T
 import Data.Foldable (fold)
-import Gyehoek.Sexp (encodeOrShow)
+import Gyehoek.Jalmot
+import Gyehoek.Sexp qualified as S
 import Gyehoek.Prelude
 
 
@@ -53,8 +52,8 @@ makeSmallFixnum = [expr|
     ref.i31
   |]
 
-getArgRegister :: Natural -> SL.Sexp
+getArgRegister :: Natural -> S.Datum
-getArgRegister n = SL.Symbol [i|$arg#{n}|]
+getArgRegister n = S.Symbol [i|$arg#{n}|]
 
 -- | Given an expression @e@ leaving a @ref eq@ atop the stack,
 -- @pushArg rt n e@ sets the nth slot of the arg-passing array to the
@@ -110,11 +109,9 @@ lower' g (Halt [v]) = do
   |]
 
 lower' g e@(ExpPrim p k) =
-  ([expr|(@gyehoek :origin #{origin})|]<>)
+  case p of
-  <$> case p of
     PrimAdd x y -> lowerBinOp "i32.add" g x y k
     PrimMul x y -> lowerBinOp "i32.mul" g x y k
-  where origin = encodeOrShow @_ @Text e
 
 lower' g (ExpIf c t f) = do
   c' <- lowerVal g c
@@ -131,9 +128,7 @@ lower' g (ExpLetRec [(r,AbsKappa kap)] e) = do
   idx <- lowerKappa g kap
   let g' = g & #kvars <>~ [r]
   e' <- lower' g' e
-  let origin = encodeOrShow @_ @Text e
   pure [expr|
-    (@gyehoek :origin #{origin})
     (@gyehoek "push cont" :idx #{idx})
     (array.set $cont-stack-type
                (global.get $cont-stack)
@@ -165,9 +160,7 @@ lower' g e@(ExpApply f xs ktail) = do
   let l = succ $ V.elemIndex ktail g.kvars ^?! _Just
   args <- fold <$>
     itraverse (\i -> fmap (pushArg $ tonat i) . lowerVal g) xs
-  let origin = encodeOrShow @_ @Text e
   pure [expr|
-    (@gyehoek :origin #{origin})
     (@gyehoek "load args")
     ##{args}
     (i32.const 1)
@@ -184,9 +177,7 @@ lower' g e@(ExpContinue k xs) = do
   let nargs = length xs
   args <- fold <$>
     itraverse (\i -> fmap (pushArg $ tonat i) . lowerVal g) xs
-  let origin = encodeOrShow @_ @Text e
   pure [expr|
-    (@gyehoek :origin #{origin})
     (@gyehoek "push args")
     ##{args}
     (@gyehoek "nargs")
@@ -205,18 +196,14 @@ lower' g e@(ExpContinue k xs) = do
   where
     l = succ $ V.elemIndex k g.kvars ^?! _Just
 
-lower' g e = error $ case Gyehoek.Sexp.encode e of
+lower' g e = error . S.encodeOrShow' S.datumIso $ e
-  Left _ -> show e
-  Right x -> T.unpack x
 
 lowerKappa :: GenMod :> es => Env -> Kappa -> Eff es Idx
 lowerKappa g e@(MkKappa xs m) = do
   let g' = g & #vars <>~ V.fromList xs
   m' <- lower' g' m
-  let origin = encodeOrShow @_ @Text e
   idx <- Wasm.defineFunction [wat|
     (func (param i32)
-      (@gyehoek :origin #{origin})
       (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
       ##{m'})
   |]
@@ -228,10 +215,8 @@ lowerLambda g e@(MkLambda xs ktail m) = do
   let g' = g & #vars .~ V.fromList xs
              & #kvars <>~ [ktail]
   m' <- lower' g' m
-  let origin = encodeOrShow @_ @Text e
   idx <- Wasm.defineFunction [wat|
     (func (param i32)
-      (@gyehoek :origin #{origin})
       (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
       ##{m'})
   |]
@@ -242,7 +227,7 @@ lowerBinOp
   :: (GenMod :> es)
   => Text -> Env -> Val -> Val -> Kappa -> Eff es Wasm.Expr
 lowerBinOp op g x y (MkKappa [r] e) = do
-  let op' = SL.Symbol op
+  let op' = S.Symbol op
   let g' = g & #vars <>~ [r]
   let n = succ $ length (g ^. #vars)
   let reg = getArgRegister . fromIntegral $ n
@@ -325,10 +310,8 @@ lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do
   runtime <- emitRuntime
   let g = MkEnv mempty mempty
   e' <- lower' g e
-  let origin = encodeOrShow @_ @Text e
   Wasm.defineFunction [wat|
     (func $scm-entry (param i32)
-      (@gyehoek :origin #{origin})
       (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
       ##{e'})
   |]

src/Gyehoek/CPS/Syntax.hs

@@ -18,7 +18,6 @@ module Gyehoek.CPS.Syntax
   , Imm(..)
   , Obj(..)
   , Hob(..)
-  , pattern Void
   , pattern Halt
   , pattern Halt1
   , _MkKappa
@@ -41,23 +40,18 @@ module Gyehoek.CPS.Syntax
   )
   where
 
-import Language.SexpGrammar qualified as S
+import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primDatumIso, Lit(..))
-import Gyehoek.Sexp qualified
+import Gyehoek.Sexp qualified as S
-import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primSexpIso, Lit(..), pattern Void)
-import Language.SexpGrammar.Generic
 import Control.Category
 import Prelude hiding ((.), id)
-import Language.Haskell.TH.Quote (QuasiQuoter)
-import Language.Sexp.Located (Sexp)
-import qualified Data.InvertibleGrammar.Base as IG
-import Data.InvertibleGrammar.Base (type (:-)((:-)))
 import qualified Data.HashSet as HS
 import Data.Monoid (Endo)
 import Data.Functor.Foldable.TH
-import qualified Gyehoek.Sexp as GS
-import qualified Language.Sexp.Located as SL
 import Data.Data.Lens (uniplate)
 import Gyehoek.Prelude hiding (op)
+import Gyehoek.Sexp (Datum)
+import Gyehoek.Sexp (G, (:-)(..))
+import qualified Data.InvertibleGrammar.Base as IG
 
 -- Data types
 
@@ -132,13 +126,7 @@ data Program = MkProgram
   deriving (Show, Generic, Data)
 
 makePrisms ''Kappa
--- makeLenses ''Kappa
 makePrisms ''Exp
--- makeLenses ''Exp
--- makeFieldsNoPrefix ''Exp
--- makeFieldsNoPrefix ''Kappa
--- makeLensesWith abbreviatedFields ''Exp
--- makeLensesFor [("binders", "_binders"), ("body", "_body")] ''Exp
 makeFieldsId ''Exp
 makeFieldsId ''Kappa
 makeFieldsId ''Lambda
@@ -158,69 +146,61 @@ _AbsLambda' = prism'
   (\case AbsLambda' bs ktail e -> Just (bs,ktail,e)
          _ -> Nothing)
 
-instance Plated Exp where
+instance Plated Exp where plate = uniplate
-  plate = uniplate
-  -- plate k = \case
-  --   ExpPrim p kap -> ExpPrim p <$> body k kap
-  --   ExpLetRec bs e -> ExpLetRec <$> (each . _2 . body) k bs <*> k e
-  --   ExpContinue c xs -> pure $ ExpContinue c xs
-  --   ExpIf c t f -> ExpIf c <$> k t <*> k f
-  --   ExpApply f xs ktail -> pure $ ExpApply f xs ktail
 
 
--- SexpIso instances
+-- DatumIso instances
 
-instance S.SexpIso Val where
+instance S.DatumIso Val where
-  sexpIso = match
+  datumIso = S.match
-    $ With (\imm -> imm . S.sexpIso)
+    $ S.With (\imm -> imm . S.datumIso)
-    $ With (\var -> var . S.sexpIso)
+    $ S.With (\var -> var . S.datumIso)
-    $ End
+    $ S.End
 
-instance S.SexpIso Obj where
+instance S.DatumIso Obj where
-  sexpIso = match
+  datumIso = S.match
-    $ With (\imm -> imm . S.sexpIso)
+    $ S.With (\imm -> imm . S.datumIso)
-    $ With (\hob -> hob . S.sexpIso)
+    $ S.With (\hob -> hob . S.datumIso)
-    $ End
+    $ S.End
 
-instance S.SexpIso Imm where
+instance S.DatumIso Imm where
-  sexpIso = match
+  datumIso = S.match
-    $ With (. S.int)
+    $ S.With (. S.int)
-    $ With (. GS.schemeBool)
+    $ S.With (. S.datumIso)
-    $ With (. labelName)
+    $ S.With (. labelName)
-    $ End
+    $ S.End
 
-labelName :: S.SexpGrammar Name
+labelName :: S.DatumGrammar Name
 labelName = S.coproduct
-  [ S.sexpIso @Name >>> Gyehoek.Sexp.prismIso
+  [ S.datumIso @Name >>> S.prismIso
         (S.expected "label")
         (prefixed @Name "$")
-  , S.list $ S.el (S.sym "$") >>> S.el (S.sexpIso @Name)
+  , S.list $ S.el (S.sym "$") >>> S.el (S.datumIso @Name)
   ]
 
-instance S.SexpIso Hob where
+instance S.DatumIso Hob where
-  sexpIso = match
+  datumIso = S.match
-    $ With (. closure)
+    $ S.With (. closure)
-    $ End
+    $ S.End
     where
       -- closures can be printed, but not parsed.
-      closure :: S.Grammar S.Position (Sexp :- t) (List Obj :- Name :- t)
+      closure :: G (Datum :- t) (List Obj :- Name :- t)
       closure = IG.Flip $ IG.PartialIso
-        (\(env:-code:-t) -> SL.Modified SL.Hash [GS.sx|(#{code} ##{env})|] :- t)
+        (\(env:-code:-t) -> [S.sx|(<closure> #{code} ##{env})|] :- t)
         (const . Left $ mempty)
 
-instance S.SexpIso Lambda where
+instance S.DatumIso Lambda where
-  sexpIso = match
+  datumIso = S.match
-    $ With (. lambda)
+    $ S.With (. lambda)
-    $ End
+    $ S.End
     where
       lambda = S.list $
-        S.el Gyehoek.Sexp.lambdaKeyword
+        S.el S.lambdaKeyword
         >>> S.el binders
-        >>> S.el S.sexpIso
+        >>> S.el S.datumIso
-      binders :: forall t.
+      binders :: forall t. G (Datum :- t) (Name :- List Name :- t)
-        IG.Grammar S.Position (Sexp :- t) (Name :- List Name :- t)
       binders = S.list $
-        S.rest (S.sexpIso @Name)
+        S.rest (S.datumIso @Name)
         >>> S.onTail (S.flipped $ IG.PartialIso
                      (\(ktail:-args:-t) -> (args ++ [ktail]) :- t)
                      (\(args:-t) -> case args ^? _Snoc of
@@ -228,43 +208,43 @@ instance S.SexpIso Lambda where
                          Nothing -> Left $ S.expected "cont param")
                      )
 
-instance S.SexpIso Kappa where
+instance S.DatumIso Kappa where
-  sexpIso = match
+  datumIso = S.match
-    $ With (. kappa)
+    $ S.With (. kappa)
-    $ End
+    $ S.End
     where
       kappa = S.list $
-        S.el Gyehoek.Sexp.kappaKeyword
+        S.el S.kappaKeyword
-        >>> S.el (S.list $ S.rest S.sexpIso)
+        >>> S.el (S.list $ S.rest S.datumIso)
-        >>> S.el S.sexpIso
+        >>> S.el S.datumIso
 
-instance S.SexpIso Abs where
+instance S.DatumIso Abs where
-  sexpIso = match
+  datumIso = S.match
-    $ With (\lambda -> lambda . S.sexpIso)
+    $ S.With (\lambda -> lambda . S.datumIso)
-    $ With (\kappa -> kappa . S.sexpIso)
+    $ S.With (\kappa -> kappa . S.datumIso)
-    $ End
+    $ S.End
 
-instance S.SexpIso Exp where
+instance S.DatumIso Exp where
-  sexpIso = match
+  datumIso = S.match
-    $ With (. prim)
+    $ S.With (. prim)
-    $ With (. letrec)
+    $ S.With (. letrec)
-    $ With (. continue)
+    $ S.With (. continue)
-    $ With (. if_)
+    $ S.With (. if_)
-    $ With (. app)
+    $ S.With (. app)
-    $ End
+    $ S.End
     where
       continue = S.list $
         S.el (S.sym "continue")
-        >>> S.el S.sexpIso
+        >>> S.el S.datumIso
-        >>> S.rest S.sexpIso
+        >>> S.rest S.datumIso
-      letrec = Gyehoek.Sexp.let_ "letrec" S.sexpIso S.sexpIso S.sexpIso
+      letrec = S.letLike "letrec" S.datumIso S.datumIso S.datumIso
-      if_ = S.list $ S.el (S.sym "if")
+      if_ = S.ifLike "if"
-        >>> S.el S.sexpIso >>> S.el S.sexpIso >>> S.el S.sexpIso
+        S.datumIso S.datumIso S.datumIso
       app :: forall t.
-        IG.Grammar S.Position (Sexp :- t) (Name :- ([Val] :- (Val :- t)))
+        G (Datum :- t) (Name :- ([Val] :- (Val :- t)))
-      app = S.list $ S.el (S.sexpIso @Val)
+      app = S.list $ S.el (S.datumIso @Val)
-        -- >>> S.flipped Gyehoek.Sexp.nonEmptyGrammar
+        -- >>> S.flipped Gyehoek.Datum.nonEmptyGrammar
-        >>> S.rest (S.sexpIso @Val)
+        >>> S.rest (S.datumIso @Val)
         -- >>> _
         >>> S.onTail (S.flipped $ IG.PartialIso
                       (\(karg :- args :- op :- t) ->
@@ -274,31 +254,29 @@ instance S.SexpIso Exp where
                             Right $ karg:- args :- op :- t
                           _ -> Left $ S.expected "continuation arg"
                       ))
-        where
-          _ = S.flipped $ Gyehoek.Sexp.nonEmptyGrammar @S.Position @Val
       prim = S.list $
         S.el (S.sym "prim")
-        >>> S.el (primSexpIso id (S.sexpIso @Val))
+        >>> S.el (primDatumIso id (S.datumIso @Val))
-        >>> S.el S.sexpIso
+        >>> S.el S.datumIso
 
-instance S.SexpIso Program where
+instance S.DatumIso Program where
-  sexpIso = with \prog -> S.sexpIso @Exp >>> prog
+  datumIso = S.with \prog -> S.datumIso @Exp >>> prog
 
 
 -- quasiquoters
 
 class Data a => CPS a where
-  toCPS :: Sexp -> a
+  toCPS :: Datum -> a
 
-instance CPS Exp where toCPS = Gyehoek.Sexp.fromSexp
+instance CPS Exp where toCPS = S.fromDatumUnsafe S.datumIso
-instance CPS Val where toCPS = Gyehoek.Sexp.fromSexp
+instance CPS Val where toCPS = S.fromDatumUnsafe S.datumIso
-instance CPS Kappa where toCPS = Gyehoek.Sexp.fromSexp
+instance CPS Kappa where toCPS = S.fromDatumUnsafe S.datumIso
-instance CPS Lambda where toCPS = Gyehoek.Sexp.fromSexp
+instance CPS Lambda where toCPS = S.fromDatumUnsafe S.datumIso
-instance CPS Abs where toCPS = Gyehoek.Sexp.fromSexp
+instance CPS Abs where toCPS = S.fromDatumUnsafe S.datumIso
-instance CPS Program where toCPS = Gyehoek.Sexp.fromSexp
+instance CPS Program where toCPS = S.fromDatumUnsafe S.datumIso
 
-cps :: QuasiQuoter
+cps :: S.QuasiQuoter
-cps = Gyehoek.Sexp.makeSx' [| toCPS |]
+cps = S.makeSx' [| toCPS |]
 
 
 

src/Gyehoek/Driver.hs

@@ -1,7 +1,7 @@
 module Gyehoek.Driver
   (main, lower_e2e, convert_e2e, parse_e2e, readScm, eval_e2e)
   where
-
+
 import Gyehoek.Options
 import Prelude hiding (readFile)
 import Options.Applicative
@@ -33,14 +33,16 @@ import Gyehoek.CPS.Close (closeProgram)
 import Control.Lens.Extras (is)
 import Control.Arrow ((>>>))
 import Gyehoek.Prelude
-
+import Gyehoek.Jalmot
+import qualified Gyehoek.Sexp as S
+
 
 main :: IO ()
 main = do
   opts <- execParser $ info (helper <*> parser) fullDesc
-  runEff . runFileSystem . runGenSym . driver $ opts
+  runJalmotIO . runFileSystem . runGenSym . driver $ opts
+
 
-
 
 -- hPutStr :: FileSystem :> es => Handle -> Text -> Eff es ()
 -- hPutStr h = FB.hPutStr h . T.encodeUtf8
@@ -65,11 +67,12 @@ fileName :: FilePath -> FilePath
 fileName "-" = "<interactive>"
 fileName e = e
 
-readScm :: FileSystem :> es => FilePath -> Eff es Scm.Program
+readScm
+  :: forall es. (Jalmot :> es, FileSystem :> es)
+  => FilePath -> Eff es Scm.Program
 readScm f =
   withFile f FS.ReadMode $ \h ->
-    Sexp.parseSexps @Scm.CommandOrDef (fileName f) <$> hGetContents h
+    S.decodeDataWith @es S.dataIso =<< hGetContents h
-     >>= either error (pure . Scm.MkProgram)
 
 inspectWasm :: IOE :> es => Text -> Eff es ()
 inspectWasm wat = do
@@ -107,7 +110,7 @@ dumpOrRun dump run acquire do_dump do_run =
     when run (do_run x)
 
 driver
-  :: (GenSym :> es, FileSystem :> es, IOE :> es)
+  :: (GenSym :> es, FileSystem :> es, Jalmot :> es, IOE :> es)
   => Options -> Eff es ()
 driver opts = do
   scm <- readScm opts.sourceFile
@@ -115,14 +118,14 @@ driver opts = do
     hPutStrLn FS.stdout . view strict . pShowNoColor $ scm
   cps <- convertProgram scm
   when opts.dumpCPS do
-    hPutStrLn FS.stdout $ Sexp.encodePretty cps ^?! _Right
+     hPutStrLn FS.stdout =<< S.encodeWith S.datumIso cps
   closedCps <- closeProgram cps
   when opts.dumpClosed do
-    hPutStrLn FS.stdout $ Sexp.encodePretty closedCps ^?! _Right
+    hPutStrLn FS.stdout =<< S.encodeWith S.datumIso closedCps
   let rt_is p = is (_Just . p) opts.runtime
   dumpOrRun opts.dumpStackified (rt_is #Stackify)
     (stackifyProgram closedCps)
-    (hPutStrLn FS.stdout . Stk.encodeProgram)
+    (hPutStrLn FS.stdout <=< S.encodeDataWith S.dataIso)
     (eval >>> fmap writeObj
          >>> T.unwords
          >>> hPutStrLn FS.stdout)
@@ -138,18 +141,18 @@ driver opts = do
     (\wat -> withFile opts.output FS.WriteMode \h -> hPutStrLn h wat)
 
 parse_e2e :: FilePath -> IO Scm.Program
-parse_e2e = runEff . runFileSystem . readScm
+parse_e2e = runJalmotIO . runFileSystem . readScm
 
 convert_e2e :: FilePath -> IO CPS.Program
-convert_e2e = runEff . runFileSystem . runGenSym
+convert_e2e = runJalmotIO . runFileSystem . runGenSym
   . (closeProgram <=< convertProgram <=< readScm)
 
 lower_e2e :: FilePath -> IO Text
 lower_e2e =
-  runEff . runFileSystem . runGenSym
+  runJalmotIO . runFileSystem . runGenSym
   . (lowerProgram <=< closeProgram <=< convertProgram <=< readScm)
 
 eval_e2e :: FilePath -> IO (List Obj)
-eval_e2e fp = runEff . runFileSystem . runGenSym $ do
+eval_e2e fp = runJalmotIO . runFileSystem . runGenSym $ do
   stk <- stackifyProgram <=< closeProgram <=< convertProgram <=< readScm $ fp
   pure . eval $ stk

src/Gyehoek/Jalmot.hs

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

src/Gyehoek/Lift1.hs

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

src/Gyehoek/Options.hs

@@ -2,8 +2,9 @@
 {-# LANGUAGE RecordWildCards #-}
 module Gyehoek.Options
   ( Options(..)
-  , Runtime(..)
   , parser
+  , Runtime(..)
+  , Language(..)
   )
   where
 
@@ -13,7 +14,15 @@ import Gyehoek.Prelude hiding (argument)
 
 
 data Runtime = Stackify | Wasm | CPS
-  deriving (Show, Generic)
+  deriving (Show, Generic, Eq)
+
+data Language
+  = LanguageScheme
+  | LanguageCPS
+  | LanguageClosed
+  | LanguageStackified
+  | LanguageWasm
+  deriving (Show, Generic, Eq)
 
 data Options = MkOptions
   { dumpClosed :: Bool
@@ -24,9 +33,20 @@ data Options = MkOptions
   , inspectWasm :: Bool
   , output :: FilePath
   , sourceFile :: FilePath
+  , sourceLanguage :: Language
   }
   deriving (Show, Generic)
 
+languageValues = ["scheme","cps","closed","stackified","wasm"]
+languageReader = maybeReader \case
+  "scheme" -> Just LanguageScheme
+  "cps" -> Just LanguageCPS
+  "closed" -> Just LanguageClosed
+  "stackified" -> Just LanguageStackified
+  "wasm" -> Just LanguageWasm
+  _ -> Nothing
+
+runtimeValues = ["stackify","wasm","cps","none"]
 runtimeReader = maybeReader \case
   "stackify" -> Just (Just Stackify)
   "wasm" -> Just (Just Wasm)
@@ -45,8 +65,17 @@ parser = do
     [ long "runtime"
     , short 'R'
     , value (Just Stackify)
-    , completeWith ["stackify","wasm","cps","none"]
+    , completeWith runtimeValues
     , showDefaultWith $ const "stackify"
+    , metavar "RUNTIME"
+    ]
+  sourceLanguage <- option languageReader . fold $
+    [ long "source"
+    , short 'S'
+    , value LanguageScheme
+    , completeWith languageValues
+    , showDefaultWith $ const "scheme"
+    , metavar "LANGUAGE"
     ]
   output <- strOption . fold $
     [ long "output"

src/Gyehoek/Prelude.hs

@@ -14,12 +14,17 @@ module Gyehoek.Prelude
   , IsList(fromList)
   , HasCallStack
   , Hashable
+  , NonEmpty((:|))
+  , Natural
+  , (>>>)
+  , (>=>)
+  , (<=<)
   ) where
 
-import Control.Lens
+import Control.Lens hiding (List, (:<))
 import Data.List (List)
 import Data.Text (Text)
-import Effectful (Eff, runEff, runPureEff, (:>))
+import Effectful
 import GHC.Generics (Generic)
 import Data.Data (Data)
 import Control.DeepSeq (NFData)
@@ -31,4 +36,8 @@ import Data.Generics.Labels ()
 import Data.String.Interpolate
 import GHC.Stack (HasCallStack)
 import Data.Hashable (Hashable)
+import Data.List.NonEmpty (NonEmpty((:|)))
+import Numeric.Natural (Natural)
+import Control.Category ((>>>))
+import Control.Monad
 

src/Gyehoek/Scheme/Syntax.hs

@@ -17,29 +17,20 @@ module Gyehoek.Scheme.Syntax
   , Def(..)
   , Exp(..)
   , ExpF(..)
-  , Sexp(..)
   , Program(..)
   , CommandOrDef(..)
-  , primSexpIso
+  , primDatumIso
-  , pattern Void
   , free
   , subst
   , getName
   , scm
-  , readExp
-  , readProgram
   , free'
   , freeWithBound'
   , freeO
-  , encodeProgram
   )
   where
 
 import Data.List (intersperse)
-import Language.SexpGrammar
-  ( SexpIso(..), list, el, rest, sym, symbol )
-import Language.SexpGrammar qualified as Sexp
-import Language.SexpGrammar.Generic
 import Effectful
 import Prelude hiding ((.), id)
 import Control.Category
@@ -58,6 +49,9 @@ import qualified Effectful.FileSystem.IO as FS
 import qualified Data.Text.Encoding as T
 import qualified Effectful.FileSystem.IO.ByteString as FB
 import qualified Data.Set.Ordered as O
+import Gyehoek.Sexp.Grammar qualified as Sexp
+import Gyehoek.Sexp.Grammar qualified as S
+import Gyehoek.Sexp.Grammar (DatumIso, DataIso)
 import Gyehoek.Prelude
 
 
@@ -97,16 +91,11 @@ instance Each (Prim e) (Prim e') e e'
 
 data Lit
   = LitInt Int
-  | LitNil
   | LitBool Bool
   | LitString Text
-  | LitQuote Sexp
   deriving stock (Show, Generic, Data, Eq)
   deriving anyclass (NFData)
 
-pattern Void :: Lit
-pattern Void = LitNil
-
 data Def
   = DefConstant Name Exp
   | DefProcedure Name (List Name) (List Exp)
@@ -126,13 +115,6 @@ data Exp
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
 
-data Sexp
-  = SexpCons Sexp Sexp
-  | SexpSymbol Text
-  | SexpLit Lit
-  deriving stock (Show, Generic, Data, Eq)
-  deriving anyclass (NFData)
-
 data CommandOrDef
   = Command Exp
   | Definition Def
@@ -140,7 +122,7 @@ data CommandOrDef
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
 
-data Program = MkProgram
+newtype Program = MkProgram
   { commandsAndDefs :: List CommandOrDef
   }
   deriving stock (Show, Generic, Data)
@@ -159,102 +141,91 @@ makeBaseFunctor ''Exp
 
 
 
-instance SexpIso Name where
+instance DatumIso Name where
-  sexpIso = symbol >>> Sexp.partialOsi f g
+  datumIso = S.symbol >>> S.iso MkName (review _Unwrapped')
+
+primDatumIso
+  :: (Text -> Text)
+  -> S.DatumGrammar a -> S.DatumGrammar (Prim a)
+primDatumIso namefn a = S.match
+    $ S.With (. ht2 "+")
+    $ S.With (. ht2 "-")
+    $ S.With (. ht2 "*")
+    $ S.With (. ht2 "/")
+    $ S.With (. ht2 "cons")
+    $ S.With (. ht1 "car")
+    $ S.With (. ht1 "cdr")
+    $ S.With (. ht1 "immediate?")
+    $ S.With (. ht1 "cons?")
+    $ S.With (. ht1 "integer?")
+    $ S.With (. ht1 "write")
+    $ S.With (. ht1 "zero?")
+    $ S.With (. nullop "newline")
+    $ S.With (. ht1' "make-closure")
+    $ S.With (. S.headTagged2 (namefn "env-ref") a S.int)
+    $ S.With (. ht1 "env-code")
+    $ S.With (. ht1 "call/cc")
+    $ S.End
     where
-      f = Right . MkName
+      idn = S.el . S.sym . namefn
-      g (MkName s) = s
+      nullop s = S.list $ idn s
+      ht1 s = S.headTagged1 (namefn s) a
+      ht2 s = S.headTagged2 (namefn s) a a
+      ht1' s = S.headTagged1' (namefn s) a a
 
-primSexpIso :: (Text -> Text) -> Sexp.SexpGrammar a -> Sexp.SexpGrammar (Prim a)
+instance DatumIso a => DatumIso (Prim a) where
-primSexpIso namefn a = match
+  -- datumIso = primDatumIso ("prim:"<>) datumIso
-    $ With (. ht2 "+")
+  datumIso = primDatumIso id S.datumIso
-    $ With (. ht2 "-")
+
-    $ With (. ht2 "*")
+instance DatumIso Lit where
-    $ With (. ht2 "/")
+  datumIso = S.match
-    $ With (. ht2 "cons")
+    $ S.With (. S.int)
-    $ With (. ht1 "car")
+    $ S.With (. S.boolean)
-    $ With (. ht1 "cdr")
+    $ S.With (. S.string)
-    $ With (. ht1 "immediate?")
+    $ S.End
-    $ With (. ht1 "cons?")
+
-    $ With (. ht1 "integer?")
+instance DatumIso Def where
-    $ With (. ht1 "write")
+  datumIso = S.match
-    $ With (. ht1 "zero?")
+    $ S.With (. defconst)
-    $ With (. nullop "newline")
+    $ S.With (. defun)
-    $ With (. ht1' "make-closure")
+    $ S.End
-    $ With (. GS.headTagged2 (namefn "env-ref") a Sexp.int)
-    $ With (. ht1 "env-code")
-    $ With (. ht1 "call/cc")
-    $ End
     where
-      idn s = el (sym (namefn s))
+      defconst = S.list $ S.el (S.sym "define")
-      nullop s = list $ idn s
+        >>> S.el S.datumIso >>> S.el S.datumIso
-      ht1 s = GS.headTagged1 (namefn s) a
+      defun = S.list $ S.el (S.sym "define")
-      ht2 s = GS.headTagged2 (namefn s) a a
+        >>> S.el args >>> S.rest S.datumIso
-      ht1' s = GS.headTagged1' (namefn s) a a
+      args = S.list $ S.el S.datumIso >>> S.rest S.datumIso
   
-instance SexpIso a => SexpIso (Prim a) where
+instance DatumIso Exp where
-  -- sexpIso = primSexpIso ("prim:"<>) sexpIso
+  datumIso = S.match
-  sexpIso = primSexpIso id sexpIso
+    $ S.With (. S.letLike "let" S.datumIso S.datumIso S.datumIso)
-
+    $ S.With (. S.letLike "letrec" S.datumIso S.datumIso S.datumIso)
-instance SexpIso Lit where
+    $ S.With (. S.datumIso)
-  sexpIso = match
+    $ S.With (. S.beginLike "begin" S.datumIso)
-    $ With (. sexpIso)
+    $ S.With (. S.ifLike "if" S.datumIso S.datumIso S.datumIso)
-    $ With (. sym "nil")
+    $ S.With (. S.datumIso)
-    $ With (. GS.schemeBool)
+    $ S.With (. lam)
-    $ With (. sexpIso)
+    $ S.With (. S.datumIso)
-    $ With (. GS.prefixSugar "quote" Sexp.Quote sexpIso)
+    $ S.With (\app -> app . S.list (S.el S.datumIso >>> S.rest S.datumIso))
-    $ End
+    $ S.End
-
-instance SexpIso Sexp where
-  sexpIso = match
-    $ With (\conss -> conss . GS.todo)
-    $ With (\s -> s . symbol)
-    $ With (\lit -> lit . sexpIso)
-    $ End
-
-instance SexpIso Def where
-  sexpIso = match
-    $ With (. defconst)
-    $ With (. defun)
-    $ End
     where
-      defconst = list $ el (sym "define") >>> el sexpIso >>> el sexpIso
+      lam = S.lambdaLike S.lambdaKeyword S.datumIso (S.el S.datumIso)
-      defun = list $ el (sym "define") >>> el args >>> rest sexpIso
-      args = list $ el sexpIso >>> rest sexpIso
 
-instance SexpIso Exp where
+instance DatumIso CommandOrDef where
-  sexpIso = match
+  datumIso = S.match
-    $ With (. GS.let_ "let" sexpIso sexpIso sexpIso)
+    $ S.With (\_Command -> _Command . S.datumIso)
-    $ With (. GS.let_ "letrec" sexpIso sexpIso sexpIso)
+    $ S.With (\_Definition -> _Definition . S.datumIso)
-    $ With (. sexpIso)
+    $ S.With (\_Begin -> _Begin . S.beginLike "begin" S.datumIso)
-    $ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso))
+    $ S.End
-    $ With (. if_)
-    $ With (. sexpIso)
-    $ With (. lam)
-    $ With (. sexpIso)
-    $ With (\app -> app . list (el sexpIso >>> rest sexpIso))
-    $ End
-    where
-      if_ = list $ el (sym "if") >>> el sexpIso >>> el sexpIso >>> el sexpIso
-      lam = list
-        ( el GS.lambdaKeyword
-          >>> el (sexpIso @(List Name))
-          >>> el sexpIso )
 
-instance SexpIso CommandOrDef where
+instance DataIso Program where
-  sexpIso = match
+  dataIso = S.dataIso @(List CommandOrDef) >>> S.iso coerce coerce
-    $ With (\_Command -> _Command . sexpIso)
-    $ With (\_Definition -> _Definition . sexpIso)
-    $ With (\_Begin -> _Begin . bgn)
-    $ End
-    where
-      bgn = list $ el (sym "begin") >>> rest sexpIso
 
 
 -- utilities
 
 scm :: QuasiQuoter
-scm = GS.makeSx [|| GS.fromSexp @Exp ||]
+scm = GS.makeSx [|| S.fromDatumUnsafe @Exp S.datumIso ||]
 
 freeWithBound' :: Foldable f => f Name -> Exp -> List Name
 freeWithBound' bound = filter (`elem` bound) . free'
@@ -309,27 +280,3 @@ subst f = \e -> cata go e mempty where
   go (ExpLetF _ _) _ = error "todo lol"
   go (ExpLambdaF bs e) bound = e $ insertFrom bs bound
   go e bound = embed $ fmap ($ bound) e
-
-
-
-fileName :: FilePath -> FilePath
-fileName "-" = "<interactive>"
-fileName e = e
-
-hGetContents :: FS.FileSystem :> es => FS.Handle -> Eff es Text
-hGetContents h = T.decodeUtf8 <$> FB.hGetContents h
-
-readProgram :: IOE :> es => FilePath -> Eff es Program
-readProgram fp = runFileSystem $
-  FS.withFile fp FS.ReadMode $ \h ->
-    GS.parseSexps @CommandOrDef (fileName fp) <$> hGetContents h
-     >>= either error (pure . MkProgram)
-
-readExp :: IOE :> es => FilePath -> Eff es Exp
-readExp fp = readProgram fp <&> (^?! #commandsAndDefs . _head . #Command)
-
-encodeProgram :: Program -> Text
-encodeProgram p = p.commandsAndDefs
-  & fmap ((^?! _Right) . GS.encodePretty)
-  & intersperse "\n\n"
-  & mconcat

src/Gyehoek/Sexp.hs

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

src/Gyehoek/Sexp/Grammar.hs

@@ -0,0 +1,131 @@
+module Gyehoek.Sexp.Grammar
+  ( module Gyehoek.Sexp.Grammar.Base
+  , module Data.InvertibleGrammar.Combinators
+  , (>>>)
+  , toDatum
+  , fromDatum
+  , toData
+  , fromData
+  , encodeWith
+  , encodeWith'
+  , encodeDataWith
+  , decodeWith
+  , encodeTest
+  , encodeTestColour
+  , decodeTest
+  , DataIso(..)
+  , DatumIso(..)
+  -- * generics
+  , with
+  , match
+  , Coproduct (..)
+  , fromDatumUnsafe
+  , Control.Category.id
+  , encodeOrShow'
+  , decodeDataWith
+  )
+  where
+
+import Gyehoek.Sexp.Grammar.Base
+import Gyehoek.Prelude hiding (traversed, iso)
+import Data.InvertibleGrammar (backward, sealed, forward, runGrammar)
+import Gyehoek.Sexp.Print (printDatum, printDatum', printData)
+import Gyehoek.Jalmot
+import Data.InvertibleGrammar.Combinators
+import qualified Gyehoek.Sexp.Read as Read
+import qualified Data.Text.IO as TIO
+import Text.Pretty.Simple (pPrintNoColor)
+import Data.InvertibleGrammar.Generic
+import qualified Control.Category
+import qualified Data.Vector as V
+import Data.String (IsString (fromString))
+import qualified Data.Text as T
+
+
+toDatum :: Jalmot :> es => DatumGrammar a -> a -> Eff es Datum
+toDatum g =
+  backward (sealed g)
+  >>> runGrammar noAnn
+  >>> either (throwError . GrammarError) pure
+
+toData :: Jalmot :> es => DataGrammar a -> a -> Eff es (List Datum)
+toData g =
+  backward (sealed g)
+  >>> runGrammar noAnn
+  >>> either (throwError . GrammarError) pure
+
+fromDatum :: Jalmot :> es => DatumGrammar a -> Datum -> Eff es a
+fromDatum g =
+  forward (sealed g)
+  >>> runGrammar noAnn
+  >>> either (throwError . GrammarError) pure
+
+fromDatumUnsafe :: DatumGrammar a -> Datum -> a
+fromDatumUnsafe g = runJalmotUnsafe . fromDatum g
+
+fromData :: Jalmot :> es => DataGrammar a -> List Datum -> Eff es a
+fromData g =
+  forward (sealed g)
+  >>> runGrammar noAnn
+  >>> either (throwError . GrammarError) pure
+
+encodeWith :: Jalmot :> es => DatumGrammar a -> a -> Eff es Text
+encodeWith g = toDatum g >>> fmap printDatum
+
+encodeDataWith :: Jalmot :> es => DataGrammar a -> a -> Eff es Text
+encodeDataWith g = toData g >>> fmap printData
+
+encodeWith' :: Jalmot :> es => DatumGrammar a -> a -> Eff es Text
+encodeWith' g = toDatum g >>> fmap printDatum'
+
+decodeWith :: forall es a. Jalmot :> es => DatumGrammar a -> Text -> Eff es a
+decodeWith g = Read.readString1 @es >=> fromDatum g
+
+decodeDataWith
+  :: forall es a. Jalmot :> es => DataGrammar a -> Text -> Eff es a
+decodeDataWith g = Read.readString @es >=> fromData g
+
+-- | run a grammar, quick and dirty.
+decodeTest :: Show a => DatumGrammar a -> Text -> IO ()
+decodeTest g = pPrintNoColor <=< (runJalmotIO . decodeWith g)
+
+-- | run a grammar, quick and dirty.
+encodeTest :: DatumGrammar a -> a -> IO ()
+encodeTest g = TIO.putStrLn <=< (runJalmotIO . encodeWith' g)
+
+-- | run a grammar, quick and dirty.
+encodeTestColour :: DatumGrammar a -> a -> IO ()
+encodeTestColour g = TIO.putStrLn <=< (runJalmotIO . encodeWith g)
+
+encodeOrShow' :: (IsString s, Show a) => DatumGrammar a -> a -> s
+encodeOrShow' g x = fromString $
+  case runPureEff . runJalmot . encodeWith' g $ x of
+    Left _ -> show x
+    Right t -> T.unpack t
+
+class DatumIso a where
+  datumIso :: DatumGrammar a
+
+class DataIso a where
+  dataIso :: DataGrammar a
+
+
+
+instance DatumIso a => DatumIso (List a) where
+  datumIso = list $ rest datumIso
+
+instance DatumIso Bool where datumIso = boolean
+
+instance DatumIso Int where datumIso = int
+
+instance DatumIso Datum where datumIso = Control.Category.id
+
+instance DatumIso a => DataIso (List a) where
+  dataIso = onHead . traversed . sealed $ datumIso @a
+
+instance DatumIso a => DataIso (V.Vector a) where
+  dataIso = iso fromList V.toList
+    >>> (onHead . traversed . sealed $ datumIso @a)
+
+instance (DatumIso a, DatumIso b) => DatumIso (a, b) where
+  datumIso = with \tup2 -> list (el datumIso >>> el datumIso) >>> tup2

src/Gyehoek/Sexp/Grammar/Base.hs

@@ -0,0 +1,308 @@
+-- | cribbed from sexp-grammar:Language.SexpGrammar.Base
+module Gyehoek.Sexp.Grammar.Base
+  ( module Gyehoek.Sexp.Syntax
+  , module Data.InvertibleGrammar.Combinators
+  , expected, unexpected
+  -- * types
+  , G
+  , Grammar
+  , DatumGrammar
+  , DataGrammar
+  , Grammar
+  , ListContext
+  , (:-)((:-))
+  -- * lists
+  , list
+  , el
+  , rest
+  -- * atoms
+  , simple
+  , string
+  , symbol
+  , sym
+  , boolean
+  , number
+  , integer
+  , headTagged1'
+  , headTagged1
+  , headTagged2
+  , int
+  , letLike
+  , ifLike
+  , headTagged0'
+  , headTagged0
+  , lambdaLike
+  , lambdaKeyword
+  , kappaKeyword
+  , beginLike
+  , prismIso
+  , isoIso
+  ) where
+
+import Data.InvertibleGrammar
+import Data.InvertibleGrammar.Base
+import Data.InvertibleGrammar.Combinators
+import Gyehoek.Prelude hiding (iso, cons, coerced, Iso, Simple, simple)
+import Gyehoek.Sexp.Syntax hiding (position)
+import Gyehoek.Sexp.Print (printDatum')
+import Data.Scientific (Scientific)
+import qualified Data.Scientific as Sci
+import qualified Data.Text as T
+import Control.Monad.RWS (modify)
+
+
+-- $setup
+-- >>> :set -XOverloadedStrings
+-- >>> import Gyehoek.Sexp.Grammar
+
+type G = Grammar Ann
+
+type DatumGrammar a = forall t. G (Datum :- t) (a :- t)
+type DataGrammar a = forall t. G (List Datum :- t) (a :- t)
+
+-- | extract\/inject an annotation from\/into a 'Datum'.
+position :: G (Datum :- t) (Ann :- Datum :- t)
+position = Iso
+  (\(s :- t) -> view ann s :- s :- t)
+  (\(a :- s :- t) -> (s & ann .~ a) :- t)
+
+locate :: G (Datum :- t) (Datum :- t)
+locate =
+  position
+  >>> onHead Locate
+  >>> Iso
+    (\(_ :- t) -> t)
+    (\t -> noAnn :- t)
+
+modifyAnn :: (Ann -> Ann) -> G (Datum :- t) (Datum :- t)
+modifyAnn f = Iso
+  (\(d:-t) -> (d & ann %~ f) :- t)
+  (\(d:-t) -> (d & ann %~ f) :- t)
+
+newtype ListContext = MkListContext (List Datum)
+
+unexpectedSimple :: Simple -> Mismatch
+unexpectedSimple = unexpected . printDatum' . Simple
+
+unexpectedDatum :: Datum -> Mismatch
+unexpectedDatum = unexpected . printDatum'
+
+list
+  :: G (ListContext :- t) (ListContext :- t')
+  -> G (Datum :- t) t'
+list = listWithIndentation Ordinary
+
+listWithIndentation
+  :: Indentation
+  -> G (ListContext :- t) (ListContext :- t')
+  -> G (Datum :- t) t'
+listWithIndentation ind g = begin >>> Dive (g >>> end)
+  where
+    begin = locate >>> partialOsi
+      (\case
+          List xs -> Right . MkListContext $ xs
+          _ -> Left $ expected "list")
+      (List' ind . coerce)
+    end = Flip $ PartialIso
+      (\t -> MkListContext [] :- t)
+      (\(MkListContext lst :- t) ->
+         case lst of
+           [] -> Right t
+           d:_ -> Left $ unexpectedDatum d)
+
+-- |
+-- >>> decodeTest (list $ el simple) "(in-here!)"
+-- SimpleSymbol "in-here!"
+el
+  :: G (Datum :- t) t'
+  -> G (ListContext :- t) (ListContext :- t')
+el g = coerced (Flip cons >>> onTail g >>> Step)
+
+-- | matches the remainder of a list
+--
+-- >>> decodeTest (list $ rest simple) "(ga na da ra)"
+-- [ SimpleSymbol "ga"
+-- , SimpleSymbol "na"
+-- , SimpleSymbol "da"
+-- , SimpleSymbol "ra"
+-- ]
+rest
+  :: (forall t'. G (Datum :- t') (a :- t'))
+  -> G (ListContext :- t) (ListContext :- List a :- t)
+rest g =
+  iso coerce coerce >>>
+  onHead (Traverse (sealed g >>> Step)) >>>
+  Iso (\a -> MkListContext [] :- a) (\(_ :- a) -> a)
+
+
+-- atoms
+
+-- | matches simple forms — atomic S-expressions.
+--
+-- >>> decodeTest simple "call/cc"
+-- SimpleSymbol "call/cc"
+simple :: G (Datum :- t) (Simple :- t)
+simple = locate >>> partialOsi
+  (\case Simple s -> Right s
+         _ -> Left . expected $ "atom")
+  Simple
+
+prismGrammar
+  -- | expected
+  :: Text
+  -- | unexpected
+  -> (s -> Mismatch)
+  -> Prism' s a
+  -> Grammar p (s :- t) (a :- t)
+prismGrammar exp unexp p =
+  partialOsi
+    ((_Left %~ \x -> expected exp <> unexp x) . matching p)
+    (review p)
+
+-- |
+-- >>> decodeTest symbol "symbolic-of-what???"
+-- "symbolic-of-what???"
+symbol :: G (Datum :- t) (Text :- t)
+symbol = simple >>> prismGrammar "symbol" unexpectedSimple #SimpleSymbol
+
+-- |
+-- >>> let grammar = list $ el (sym "a-specific-symbol") >>> el string
+-- >>> decodeTest grammar "(a-specific-symbol \"this works\")"
+-- "this works"
+-- >>> decodeTest grammar "(some-other-symbol \"this does not\")"
+-- *** Exception:
+-- <none>:1:2: mismatch:
+--     Expected: symbol a-specific-symbol
+--     But got:  some-other-symbol
+-- ...
+sym :: Text -> G (Datum :- t) t
+sym s = simple >>> Flip (PartialIso
+  (SimpleSymbol s :-)
+  (\(a :- t) ->
+      case a of
+        SimpleSymbol s' | s == s' -> Right t
+        other -> Left $ expected ("symbol " <> s) <>
+                        unexpectedSimple other))
+
+-- |
+-- >>> decodeTest string "\"these r annoying to escape\""
+-- "these r annoying to escape"
+-- >>> encodeTest string "john Haskell"
+-- "john Haskell"
+string :: G (Datum :- t) (Text :- t)
+string = simple >>> prismGrammar "string" unexpectedSimple #SimpleString
+
+-- |
+-- >>> decodeTest boolean "#t"
+-- True
+-- >>> decodeTest boolean "#false"
+-- False
+-- >>> encodeTest boolean True
+-- #t
+boolean :: G (Datum :- t) (Bool :- t)
+boolean = simple >>> prismGrammar "boolean" unexpectedSimple #SimpleBoolean
+
+-- |
+-- >>> decodeTest number "123"
+-- 123.0
+-- >>> encodeTest number (fromInteger 456)
+-- 456
+number :: G (Datum :- t) (Scientific :- t)
+number = simple >>> prismGrammar "number" unexpectedSimple #SimpleNumber
+
+-- |
+-- >>> decodeTest integer "123"
+-- 123
+-- >>> encodeTest number 456
+-- 456
+integer :: G (Datum :- t) (Integer :- t)
+integer = number >>> partialOsi
+  ((_Left %~ (unexpected . T.pack . show @Double)) . Sci.floatingOrInteger)
+  fromIntegral
+
+int :: G (Datum :- t) (Int :- t)
+int = integer >>> iso fromIntegral fromIntegral
+
+
+-- high-level combinators
+
+headTagged0 :: Text -> G (Datum :- t) t
+headTagged0 s = list $ el (sym s)
+
+headTagged0' :: Text -> DatumGrammar a -> G (Datum :- t) (List a :- t)
+headTagged0' s gt = list $ el (sym s) >>> rest gt
+
+headTagged1 :: Text -> DatumGrammar a -> G (Datum :- t) (a :- t)
+headTagged1 s g1 = list $ el (sym s) >>> el g1
+
+headTagged1'
+  :: Text
+  -> DatumGrammar a -> DatumGrammar b
+  -> G (Datum :- t) (List b :- a :- t)
+headTagged1' s g1 gt = list $ el (sym s) >>> el g1 >>> rest gt
+
+headTagged2
+  :: Text
+  -> DatumGrammar a -> DatumGrammar b
+  -> G (Datum :- t) (b :- a :- t)
+headTagged2 s g1 g2 = list $ el (sym s) >>> el g1 >>> el g2
+
+ifLike
+  -- | keyword
+  :: Text
+  -- | condition
+  -> DatumGrammar a
+  -- | consequent (then-branch)
+  -> DatumGrammar b
+  -- | alternative (else-branch)
+  -> DatumGrammar c
+  -> G (Datum :- t) (c :- b :- a :- t)
+ifLike kw c t f = list $ el (symBuiltin kw) >>> el c >>> el t >>> el f
+
+symBuiltin :: Text -> G (Datum :- t) t
+symBuiltin s = modifyAnn (#syntax .~ SynBuiltin) >>> sym s
+
+letLike
+  :: Text
+  -> (forall t. G (Datum :- t) (a :- t))
+  -> (forall t. G (Datum :- t) (b :- t))
+  -> G (Datum :- (List (a, b) :- t1)) t2
+  -> G (Datum :- t1) t2
+letLike kw name rhs e = listWithIndentation (NSpecial 1) $
+  el (symBuiltin kw) >>> el bindings >>> el e
+  where
+    bindings = list $ rest binding
+    binding :: G (Datum :- t) ((_, _) :- t)
+    binding = list (el name >>> el rhs) >>> pair
+
+lambdaLike
+  :: (forall t. G (Datum :- t) t)
+  -> DatumGrammar a
+  -> G (ListContext :- a :- t) (ListContext :- t')
+  -> G (Datum :- t) t'
+lambdaLike kw formals body = listWithIndentation (NSpecial 1) $
+  el (modifyAnn (#syntax .~ SynBuiltin) >>> kw)
+  >>> el formals
+  >>> body
+
+lambdaKeyword :: G (Datum :- t) t
+lambdaKeyword = coproduct [ sym "λ", sym "lambda" ]
+
+kappaKeyword :: G (Datum :- t) t
+kappaKeyword = coproduct [ sym "κ", sym "kappa" ]
+
+beginLike
+  :: Text
+  -> DatumGrammar a
+  -> G (Datum :- t) (List a :- t)
+beginLike kw g =
+  listWithIndentation (NSpecial 0) $
+    el (symBuiltin kw) >>> rest g
+
+isoIso :: Iso' s a -> Grammar p (s :- t) (a :- t)
+isoIso l = iso (view l) (review l)
+
+prismIso :: Mismatch -> Prism' s a -> Grammar p (s :- t) (a :- t)
+prismIso mm p = partialOsi
+  (maybe (Left mm) Right . preview p)
+  (review p)

src/Gyehoek/Sexp/Print.hs

@@ -0,0 +1,97 @@
+module Gyehoek.Sexp.Print
+  ( printDatum
+  , printDatumW
+  , printDatum'
+  , printData
+  ) where
+
+import Gyehoek.Sexp.Syntax
+import Data.Text.Prettyprint.Doc
+import Data.Functor.Foldable
+import qualified Control.Comonad.Trans.Cofree as F
+import Prettyprinter.Util
+import Gyehoek.Prelude hiding (Simple, (:<))
+import Data.Foldable (traverse_)
+import qualified Prettyprinter.Render.Terminal as ANSI
+import System.IO (stdout)
+import Prettyprinter.Render.Terminal (Color(..), color, italicized, AnsiStyle, bold)
+import Prettyprinter.Render.Text (renderStrict)
+import qualified Data.Scientific as Sci
+import Data.List (intersperse)
+
+
+printDatum' :: Datum -> Text
+printDatum' =
+  prettyDatum 0
+  >>> layoutSmart opts
+  >>> renderStrict
+  where
+    opts = LayoutOptions
+      { layoutPageWidth = AvailablePerLine 80 1.0
+      }
+
+printDatum :: Datum -> Text
+printDatum = printDatumW 80
+
+printData :: List Datum -> Text
+printData = mconcat . intersperse "\n\n" . fmap printDatum
+
+printDatumW :: Int -> Datum -> Text
+printDatumW w =
+  prettyDatum 0
+  >>> layoutSmart opts
+  >>> reAnnotateS highlight
+  >>> ANSI.renderStrict
+  where
+    opts = LayoutOptions
+      { layoutPageWidth = AvailablePerLine w 1.0
+      }
+
+prettyDatum :: Int -> Datum -> Doc Syn
+prettyDatum depth datum = case datum of
+  Simple simp -> annotate (datum ^. syntax) $ prettySimple depth simp
+  List' indent xs ->
+    case indent of
+      NSpecial n | keyword:args <- xs ->
+        let (specialArgs,body) = splitAt n args
+        in pparen depth . nest 2 . vsep $
+            [ group . nest 2 . hcat $
+              [ prettyDatum (depth+1) keyword
+              , if null specialArgs then mempty else softline
+              , hsep $ prettyDatum (depth+1) <$> specialArgs
+              ]
+            , vsep $ prettyDatum (depth+1) <$> body
+            ]
+      Ordinary; NSpecial _ -> pparen depth $
+        group . align . vsep $
+          prettyDatum (depth+1) <$> xs
+  _ -> error [i|unimplemented: #{datum}|]
+
+pparen depth = enclose (delim depth "(") (delim depth ")")
+delim depth = annotate (SynParen depth)
+
+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 ->
+    Sci.floatingOrInteger n
+    & either viaShow viaShow
+    & annotate SynConstant
+  SimpleString s -> annotate SynString $ viaShow s
+  SimpleSymbol s -> pretty s
+
+putDoc :: Doc Syn -> IO ()
+putDoc = ANSI.renderIO stdout
+  . reAnnotateS highlight . layoutSmart defaultLayoutOptions . (<>"\n")
+
+highlight :: Syn -> AnsiStyle
+highlight = \case
+  (SynBuiltin; SynMacro) -> color Magenta <> italicized <> bold
+  SynParen n -> color $ rainbow ^?! ix n
+  _ -> mempty
+  where
+    rainbow = cycle [Red,Yellow,Green,Blue,Magenta,Cyan]

src/Gyehoek/Sexp/QQ.hs

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

src/Gyehoek/Sexp/Read.hs

@@ -0,0 +1,227 @@
+module Gyehoek.Sexp.Read
+  ( readFile
+  , readString
+  , readString1
+  , SourcePos(..)
+  , readStringWithPos
+  , readStringWithPos1
+  ) where
+
+import Text.Megaparsec
+import Text.Megaparsec.Char hiding (string)
+import qualified Text.Megaparsec.Char.Lexer as L
+import Data.Void (Void)
+import Gyehoek.Sexp.Syntax
+import Gyehoek.Prelude hiding (Simple, (:<))
+import qualified Data.Text.IO as T
+import Prelude hiding (readFile)
+import Data.Functor (($>))
+import qualified Data.Text as T
+import Data.Char (GeneralCategory(..), generalCategory)
+import Data.Scientific (Scientific)
+import Gyehoek.Jalmot
+
+
+readFile :: (Jalmot :> es, IOE :> es) => FilePath -> Eff es (List Datum)
+readFile f = do
+  s <- liftIO . T.readFile $ f
+  case runParser file f s of
+    Right x -> pure x
+    Left eb -> throwError . ReaderError $ eb
+
+readString :: Jalmot :> es => Text -> Eff es (List Datum)
+readString s = 
+  case runParser file "<none>" s of
+    Right x -> pure x
+    Left eb -> throwError . ReaderError $ eb
+
+readString1 :: Jalmot :> es => Text -> Eff es Datum
+readString1 s = 
+  case runParser file1 "<none>" s of
+    Right x -> pure x
+    Left eb -> throwError . ReaderError $ eb
+
+initialStateFromSourcePos :: SourcePos -> s -> State s e
+initialStateFromSourcePos pos s = State
+  { stateInput = s
+  , stateOffset = 0
+  , stateParseErrors = []
+  , statePosState = PosState
+    { pstateInput = s
+    , pstateOffset = 0
+    , pstateSourcePos = pos
+    , pstateTabWidth = defaultTabWidth
+    , pstateLinePrefix = ""
+    }
+  }
+
+readStringWithPos1
+  :: Jalmot :> es
+  => SourcePos
+  -> Text
+  -> Eff es Datum
+readStringWithPos1 pos s =
+  case snd $ runParser' file1 st of
+    Right x -> pure x
+    Left eb -> throwError . ReaderError $ eb
+  where
+    st = initialStateFromSourcePos pos s
+
+readStringWithPos
+  :: Jalmot :> es
+  => SourcePos
+  -> Text
+  -> Eff es (List Datum)
+readStringWithPos pos s =
+  case snd $ runParser' file st of
+    Right x -> pure x
+    Left eb -> throwError . ReaderError $ eb
+  where
+    st = initialStateFromSourcePos pos s
+
+type P = Parsec Void Text
+
+
+--- lexer helpers
+
+-- TODO: check R⁷RS's definition of ⟨atmosphere⟩.
+-- TODO: datum comments.
+-- | whitespace consumer.
+sc :: P ()
+sc = L.space space1
+  (L.skipLineComment ";")
+  (L.skipBlockCommentNested "#|" "|#")
+
+lexeme :: P a -> P a
+lexeme = L.lexeme sc
+
+-- | verbatim text.
+verb :: Text -> P Text
+verb = L.symbol sc
+
+
+--- tokens
+
+identifier :: P Text
+identifier = label "identifier" . lexeme . choice $
+  [ 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 = _
+
+    hasCategory c xs = generalCategory c `elem` xs
+    isInitial c = (c `hasCategory`
+      [ UppercaseLetter, LowercaseLetter, TitlecaseLetter, ModifierLetter
+      , OtherLetter
+      -- , SpacingCombiningMark, EnclosingMark, DecimalNumber
+      , LetterNumber, OtherNumber, DashPunctuation, ConnectorPunctuation
+      , CurrencySymbol, OtherPunctuation, MathSymbol
+      , ModifierSymbol, OtherSymbol, PrivateUse ]
+      || c == '\x200c' || c == '\x200d')
+      && c /= ';' && c /= '|' && c /= '"' && c /= '.'
+      && c /= ',' && c /= '#'
+
+boolean :: P Bool
+boolean = label "boolean" . lexeme $ choice
+  [ ("#true" <|> "#t") $> True
+  , ("#false" <|> "#f") $> False
+  ]
+
+symbol = identifier
+
+number :: P Scientific
+number = label "number" . lexeme $ num
+  where
+    num = L.signed (pure ()) L.decimal
+    -- prefix r = _
+    -- radix = \case
+    --   2 -> "#b"
+    --   8 -> "#o"
+    --   10 -> "" <|> "#d"
+    --   16 -> "#x"
+
+lparen = lexeme $ char '('
+rparen = lexeme $ char ')'
+dot = lexeme $ char '.'
+verticalLine = lexeme $ char '|'
+
+-- delimiter :: P ()
+-- delimiter = choice
+--   [ sc
+--   , void verticalLine
+--   , void lparen
+--   , void rparen
+--   , void (char '"')
+--   , void (char ';')
+--   ]
+
+string :: P Text
+string = label "string" . lexeme $
+  char '"' *> (T.pack <$> many element) <* char '"'
+  where
+    element = choice
+      [ satisfy (\c -> c /= '"' && c /= '\\')
+      , "\\\"" $> '"'
+      , "\\\\" $> '\\'
+      ]
+
+metaSplice :: P Text
+metaSplice = label "splicing meta" . lexeme . between "##{" "}" $
+  takeWhile1P Nothing (/= '}')
+
+meta :: P Text
+meta = label "meta" . lexeme . between "#{" "}" $
+  takeWhile1P Nothing (/= '}')
+
+
+
+file :: P (List Datum)
+file = sc *> many datum <* eof
+
+file1 :: P Datum
+file1 = sc *> datum <* eof
+
+datum :: P Datum
+datum = do
+  pos <- getSourcePos
+  (position ?~ pos) <$> choice
+    [ Compound <$> compoundDatum
+    , Simple <$> simpleDatum
+    -- , labeled
+    -- , labelRef
+    , MetaSplice <$> metaSplice
+    , Meta <$> meta
+    ]
+
+simpleDatum :: P Simple
+simpleDatum = choice
+  [ SimpleBoolean <$> boolean
+  , SimpleNumber <$> try number
+  -- , SimpleCharacter <$> character
+  , SimpleString <$> string
+  , SimpleSymbol <$> symbol
+  -- , SimpleBytevector <$> bytevector
+  ]
+
+compoundDatum :: P Compound
+compoundDatum = choice
+  [ list
+  ]
+
+list :: P Compound
+list = label "list" . between lparen rparen $ do
+  optional datum >>= \case
+    Nothing -> pure $ ListF Ordinary []
+    Just x -> do
+      xs <- many datum
+      optional (dot *> datum) >>= \case
+        Nothing -> pure $ ListF Ordinary (x:xs)
+        Just y -> pure $ DotListF (x:|xs) y

src/Gyehoek/Sexp/Syntax.hs

@@ -0,0 +1,250 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ApplicativeDo #-}
+module Gyehoek.Sexp.Syntax
+  ( DatumF(..)
+  , Simple(..)
+  , CompoundF(..)
+  , Prefix(..)
+  , Delimiter(..)
+  , Label(..)
+  , SourcePos(..)
+  , Datum
+  , Cofree((:<))
+  , Fix(..)
+  , Compound
+  , Indentation(..)
+  , Syn(..)
+  , pattern Simple
+  , pattern Compound
+  , pattern Labeled
+  , pattern LabelRef
+  , pattern Meta
+  , pattern MetaSplice
+  , pattern Abbrev
+  , pattern Vector
+  , pattern DotList
+  , pattern Gyehoek.Sexp.Syntax.List
+  , syntax
+  , indentation
+  , adorn
+  , indentWith
+  , pattern Bytevector
+  , pattern Symbol
+  , pattern String
+  , pattern Character
+  , pattern Number
+  , pattern Boolean
+  , Ann(..)
+  , noAnn
+  , ann
+  , pattern List'
+  , position
+  , stripAnn
+  ) where
+
+import Language.Haskell.TH.Syntax (Lift (lift), liftData)
+import Data.Scientific (Scientific)
+import Data.ByteString (ByteString)
+import Gyehoek.Prelude hiding ((:<), Simple)
+import Text.Megaparsec.Pos (SourcePos(..), sourcePosPretty)
+import Control.Comonad.Cofree (Cofree((:<)), _extract, _unwrap)
+import Data.Fix (Fix (..))
+import Data.Functor.Foldable
+import Text.Show.Deriving (deriveShow1)
+import Data.Eq.Deriving (deriveEq1)
+import qualified Control.Comonad.Trans.Cofree as F
+import Prettyprinter (Pretty (pretty), viaShow)
+import Gyehoek.Lift1 (Lift1 (liftLift))
+import Data.Data (Typeable, cast)
+import Language.Haskell.TH
+import qualified Data.Text as T
+import Control.Comonad.Trans.Cofree (tailF)
+
+
+data DatumF a
+  = SimpleF Simple
+  | CompoundF (CompoundF a)
+  | LabeledF Label a
+  | LabelRefF Label
+  | MetaF Text
+  | MetaSpliceF Text
+  deriving stock (Show, Eq, Data, Generic, Lift, Functor, Foldable, Traversable)
+  deriving anyclass (NFData)
+
+data Simple
+  = SimpleBoolean Bool
+  | SimpleNumber Scientific
+  | SimpleCharacter Char
+  | SimpleString Text
+  | SimpleSymbol Text
+  | SimpleBytevector ByteString
+  deriving stock (Show, Eq, Data, Generic, Lift)
+  deriving anyclass (NFData)
+
+data CompoundF a
+  = ListF Indentation (List a)
+  | DotListF (NonEmpty a) a
+  | VectorF (List a)
+  | AbbrevF Prefix a
+  deriving stock (Show, Eq, Data, Generic, Lift, Functor, Foldable, Traversable)
+  deriving anyclass (NFData)
+
+data Prefix
+  = Quote | Backtick | Comma | CommaAt
+  deriving stock (Show, Eq, Data, Generic, Lift)
+  deriving anyclass (NFData)
+
+data Delimiter
+  = Paren
+  | Square
+  | Curly
+  deriving stock (Show, Eq, Data, Generic, Lift)
+  deriving anyclass (NFData)
+
+newtype Label = MkLabel Natural
+  deriving stock (Data, Generic, Lift)
+  deriving newtype (Eq, Ord, Show)
+  deriving anyclass (NFData)
+
+
+
+type Datum = Cofree DatumF Ann
+type Compound = CompoundF Datum
+
+data Indentation
+  = NSpecial Int
+  | Ordinary
+  deriving stock (Data, Eq, Generic, Show, Lift, Read)
+  deriving anyclass (NFData)
+
+data Syn
+  = SynMacro
+  | SynBuiltin
+  | SynProcedure
+  | SynParen Int
+  | SynString
+  | SynConstant
+  | SynNone
+  deriving (Show, Read, Data, Generic, Eq, Lift)
+
+data Ann = MkAnn
+  { syntax :: Syn
+  , position :: Maybe SourcePos
+  }
+  deriving (Show, Data, Eq, Generic)
+
+noAnn :: Ann
+noAnn = MkAnn
+  { syntax = SynNone
+  , position = Nothing
+  }
+
+-- requisite of the Pretty instance for invertible-grammar's error type.
+instance Pretty Ann where
+  pretty = pretty . maybe "<unknown>" sourcePosPretty . view #position
+
+deriveShow1 ''CompoundF
+deriveEq1 ''CompoundF
+deriveShow1 ''DatumF
+deriveEq1 ''DatumF
+
+
+--- modification and extraction of annotations
+
+ann :: Lens' Datum Ann
+ann = _extract
+
+syntax :: Lens' Datum Syn
+syntax = ann . #syntax
+
+position :: Lens' Datum (Maybe SourcePos)
+position = ann . #position
+
+indentation :: Traversal' Datum Indentation
+indentation k (syn :< CompoundF (ListF ind xs)) = do
+  ind' <- k ind
+  pure $ syn :< CompoundF (ListF ind' xs)
+indentation k a = pure a
+
+adorn :: Syn -> Datum -> Datum
+adorn = set syntax
+
+indentWith :: Indentation -> Datum -> Datum
+indentWith = set indentation
+
+stripAnn :: Datum -> Fix DatumF
+stripAnn = hoist tailF
+
+
+--- pattern synonyms
+
+pattern Simple :: Simple -> Datum
+pattern Simple a <- _ :< SimpleF a
+  where Simple a = noAnn :< SimpleF a
+
+pattern Compound :: CompoundF Datum -> Datum
+pattern Compound a <- _ :< CompoundF a
+  where Compound a = noAnn :< CompoundF a
+
+pattern Labeled :: Label -> Datum -> Datum
+pattern Labeled l a <- _ :< LabeledF l a
+  where Labeled l a = noAnn :< LabeledF l a
+
+pattern LabelRef :: Label -> Datum
+pattern LabelRef l <- _ :< LabelRefF l
+  where LabelRef l = noAnn :< LabelRefF l
+
+pattern MetaSplice :: Text -> Datum
+pattern MetaSplice x <- _ :< MetaSpliceF x
+  where MetaSplice x = noAnn :< MetaSpliceF x
+
+pattern Meta :: Text -> Datum
+pattern Meta x <- _ :< MetaF x
+  where Meta x = noAnn :< MetaF x
+
+pattern List :: List Datum -> Datum
+pattern List a <- _ :< CompoundF (ListF _ a)
+  where List a = noAnn :< CompoundF (ListF Ordinary a)
+
+pattern List' :: Indentation -> List Datum -> Datum
+pattern List' ind a <- _ :< CompoundF (ListF ind a)
+  where List' ind a = noAnn :< CompoundF (ListF ind a)
+
+pattern DotList :: NonEmpty Datum -> Datum -> Datum
+pattern DotList xs x <- _ :< CompoundF (DotListF xs x)
+  where DotList xs x = noAnn :< CompoundF (DotListF xs x)
+
+pattern Vector :: [Datum] -> Datum
+pattern Vector xs <- _ :< CompoundF (VectorF xs)
+  where Vector xs = noAnn :< CompoundF (VectorF xs)
+
+pattern Abbrev :: Prefix -> Datum -> Datum
+pattern Abbrev p a <- _ :< CompoundF (AbbrevF p a)
+  where Abbrev p a = noAnn :< CompoundF (AbbrevF p a)
+
+pattern Boolean a = Simple (SimpleBoolean a)
+pattern Number a = Simple (SimpleNumber a)
+pattern Character a = Simple (SimpleCharacter a)
+pattern String a = Simple (SimpleString a)
+pattern Symbol a = Simple (SimpleSymbol a)
+pattern Bytevector a = Simple (SimpleBytevector a)
+
+
+--- Lift1 instances
+
+instance Lift1 DatumF where
+  liftLift l = \case
+    SimpleF s -> [|SimpleF $(lift s)|]
+    CompoundF c -> [|CompoundF $(liftLift l c)|]
+    LabeledF lbl x -> [|LabeledF $(lift lbl) $(l x)|]
+    LabelRefF lbl -> [|LabelRefF $(lift lbl)|]
+    MetaF x -> [|MetaF $(lift x)|]
+    MetaSpliceF x -> [|MetaSpliceF $(lift x)|]
+
+instance Lift1 CompoundF where
+  liftLift l = \case
+    ListF ind xs -> [|ListF $(lift ind) $(liftLift l xs)|]
+    DotListF xs t -> [|DotListF $(liftLift l xs) $(l t)|]
+    VectorF xs -> [|VectorF $(liftLift l xs)|]
+    AbbrevF p x -> [|AbbrevF $(lift p) $(l x)|]