diff --git a/.dir-locals.el b/.dir-locals.el index 8348b19..fc1236c 100644 --- a/.dir-locals.el +++ b/.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)))))))) diff --git a/cabal.project b/cabal.project index b50cb5f..44f12dd 100644 --- a/cabal.project +++ b/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 diff --git a/golden/adder/exec b/golden/exec/adder/exec similarity index 100% rename from golden/adder/exec rename to golden/exec/adder/exec diff --git a/golden/adder/source.scm b/golden/exec/adder/source.scm similarity index 100% rename from golden/adder/source.scm rename to golden/exec/adder/source.scm diff --git a/golden/apply-twice/exec b/golden/exec/apply-twice/exec similarity index 100% rename from golden/apply-twice/exec rename to golden/exec/apply-twice/exec diff --git a/golden/apply-twice/source.scm b/golden/exec/apply-twice/source.scm similarity index 100% rename from golden/apply-twice/source.scm rename to golden/exec/apply-twice/source.scm diff --git a/golden/apply2/exec b/golden/exec/apply2/exec similarity index 100% rename from golden/apply2/exec rename to golden/exec/apply2/exec diff --git a/golden/apply2/source.scm b/golden/exec/apply2/source.scm similarity index 100% rename from golden/apply2/source.scm rename to golden/exec/apply2/source.scm diff --git a/golden/arith/exec b/golden/exec/arith/exec similarity index 100% rename from golden/arith/exec rename to golden/exec/arith/exec diff --git a/golden/arith/source.scm b/golden/exec/arith/source.scm similarity index 100% rename from golden/arith/source.scm rename to golden/exec/arith/source.scm diff --git a/golden/callcc-constant/exec b/golden/exec/callcc-constant/exec similarity index 100% rename from golden/callcc-constant/exec rename to golden/exec/callcc-constant/exec diff --git a/golden/callcc-constant/source.scm b/golden/exec/callcc-constant/source.scm similarity index 100% rename from golden/callcc-constant/source.scm rename to golden/exec/callcc-constant/source.scm diff --git a/golden/callcc-discard/exec b/golden/exec/callcc-discard/exec similarity index 100% rename from golden/callcc-discard/exec rename to golden/exec/callcc-discard/exec diff --git a/golden/callcc-discard/source.scm b/golden/exec/callcc-discard/source.scm similarity index 100% rename from golden/callcc-discard/source.scm rename to golden/exec/callcc-discard/source.scm diff --git a/golden/callcc-nested1/exec b/golden/exec/callcc-nested1/exec similarity index 100% rename from golden/callcc-nested1/exec rename to golden/exec/callcc-nested1/exec diff --git a/golden/callcc-nested1/source.scm b/golden/exec/callcc-nested1/source.scm similarity index 100% rename from golden/callcc-nested1/source.scm rename to golden/exec/callcc-nested1/source.scm diff --git a/golden/callcc-nested2/exec b/golden/exec/callcc-nested2/exec similarity index 100% rename from golden/callcc-nested2/exec rename to golden/exec/callcc-nested2/exec diff --git a/golden/callcc-nested2/source.scm b/golden/exec/callcc-nested2/source.scm similarity index 100% rename from golden/callcc-nested2/source.scm rename to golden/exec/callcc-nested2/source.scm diff --git a/golden/factorial/exec b/golden/exec/factorial/exec similarity index 100% rename from golden/factorial/exec rename to golden/exec/factorial/exec diff --git a/golden/factorial/source.scm b/golden/exec/factorial/source.scm similarity index 100% rename from golden/factorial/source.scm rename to golden/exec/factorial/source.scm diff --git a/golden/false/exec b/golden/exec/false/exec similarity index 100% rename from golden/false/exec rename to golden/exec/false/exec diff --git a/golden/false/source.scm b/golden/exec/false/source.scm similarity index 100% rename from golden/false/source.scm rename to golden/exec/false/source.scm diff --git a/golden/fn-of-fn/exec b/golden/exec/fn-of-fn/exec similarity index 100% rename from golden/fn-of-fn/exec rename to golden/exec/fn-of-fn/exec diff --git a/golden/fn-of-fn/source.scm b/golden/exec/fn-of-fn/source.scm similarity index 100% rename from golden/fn-of-fn/source.scm rename to golden/exec/fn-of-fn/source.scm diff --git a/golden/if-false/exec b/golden/exec/if-false/exec similarity index 100% rename from golden/if-false/exec rename to golden/exec/if-false/exec diff --git a/golden/if-false/source.scm b/golden/exec/if-false/source.scm similarity index 100% rename from golden/if-false/source.scm rename to golden/exec/if-false/source.scm diff --git a/golden/if-number/exec b/golden/exec/if-number/exec similarity index 100% rename from golden/if-number/exec rename to golden/exec/if-number/exec diff --git a/golden/if-number/source.scm b/golden/exec/if-number/source.scm similarity index 100% rename from golden/if-number/source.scm rename to golden/exec/if-number/source.scm diff --git a/golden/if-true/exec b/golden/exec/if-true/exec similarity index 100% rename from golden/if-true/exec rename to golden/exec/if-true/exec diff --git a/golden/if-true/source.scm b/golden/exec/if-true/source.scm similarity index 100% rename from golden/if-true/source.scm rename to golden/exec/if-true/source.scm diff --git a/golden/lambda/exec b/golden/exec/lambda/exec similarity index 100% rename from golden/lambda/exec rename to golden/exec/lambda/exec diff --git a/golden/lambda/source.scm b/golden/exec/lambda/source.scm similarity index 100% rename from golden/lambda/source.scm rename to golden/exec/lambda/source.scm diff --git a/golden/let-fn/exec b/golden/exec/let-fn/exec similarity index 100% rename from golden/let-fn/exec rename to golden/exec/let-fn/exec diff --git a/golden/let-fn/source.scm b/golden/exec/let-fn/source.scm similarity index 100% rename from golden/let-fn/source.scm rename to golden/exec/let-fn/source.scm diff --git a/golden/letrec-fn/exec b/golden/exec/letrec-fn/exec similarity index 100% rename from golden/letrec-fn/exec rename to golden/exec/letrec-fn/exec diff --git a/golden/letrec-fn/source.scm b/golden/exec/letrec-fn/source.scm similarity index 100% rename from golden/letrec-fn/source.scm rename to golden/exec/letrec-fn/source.scm diff --git a/golden/square/exec b/golden/exec/square/exec similarity index 100% rename from golden/square/exec rename to golden/exec/square/exec diff --git a/golden/square/source.scm b/golden/exec/square/source.scm similarity index 100% rename from golden/square/source.scm rename to golden/exec/square/source.scm diff --git a/golden/true/exec b/golden/exec/true/exec similarity index 100% rename from golden/true/exec rename to golden/exec/true/exec diff --git a/golden/true/source.scm b/golden/exec/true/source.scm similarity index 100% rename from golden/true/source.scm rename to golden/exec/true/source.scm diff --git a/golden/print/begin-nonempty-thin b/golden/print/begin-nonempty-thin new file mode 100644 index 0000000..17862c2 --- /dev/null +++ b/golden/print/begin-nonempty-thin @@ -0,0 +1,4 @@ +(begin + 책을 + 더 + 먹으세요~!) \ No newline at end of file diff --git a/golden/print/begin-nonempty-wide b/golden/print/begin-nonempty-wide new file mode 100644 index 0000000..17862c2 --- /dev/null +++ b/golden/print/begin-nonempty-wide @@ -0,0 +1,4 @@ +(begin + 책을 + 더 + 먹으세요~!) \ No newline at end of file diff --git a/golden/print/lambda-thin b/golden/print/lambda-thin new file mode 100644 index 0000000..78cb74c --- /dev/null +++ b/golden/print/lambda-thin @@ -0,0 +1,5 @@ +(lambda + (어간 + 어미) + (display + 꾸깃)) \ No newline at end of file diff --git a/golden/print/lambda-wide b/golden/print/lambda-wide new file mode 100644 index 0000000..b989bcc --- /dev/null +++ b/golden/print/lambda-wide @@ -0,0 +1,2 @@ +(lambda (어간 어미) + (display 꾸깃)) \ No newline at end of file diff --git a/golden/print/null b/golden/print/null new file mode 100644 index 0000000..8af028e --- /dev/null +++ b/golden/print/null @@ -0,0 +1 @@ +() \ No newline at end of file diff --git a/golden/print/rainbow b/golden/print/rainbow new file mode 100644 index 0000000..9ba5d84 --- /dev/null +++ b/golden/print/rainbow @@ -0,0 +1 @@ +((((())))) \ No newline at end of file diff --git a/golden/print/simple-list-thin b/golden/print/simple-list-thin new file mode 100644 index 0000000..b9fa7cd --- /dev/null +++ b/golden/print/simple-list-thin @@ -0,0 +1,4 @@ +(가 + 나 + 다 + 라) \ No newline at end of file diff --git a/golden/print/simple-list-wide b/golden/print/simple-list-wide new file mode 100644 index 0000000..c955446 --- /dev/null +++ b/golden/print/simple-list-wide @@ -0,0 +1 @@ +(가 나 다 라) \ No newline at end of file diff --git a/golden/read/bool/read b/golden/read/bool/read new file mode 100644 index 0000000..c9bd1ea --- /dev/null +++ b/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 ) +] \ No newline at end of file diff --git a/golden/read/bool/source.scm b/golden/read/bool/source.scm new file mode 100644 index 0000000..84af926 --- /dev/null +++ b/golden/read/bool/source.scm @@ -0,0 +1 @@ +#t #true #f #false diff --git a/golden/read/datum-comment/source.scm b/golden/read/datum-comment/source.scm new file mode 100644 index 0000000..a870e40 --- /dev/null +++ b/golden/read/datum-comment/source.scm @@ -0,0 +1,4 @@ +#;(a datum comment can +span multiple lines) + +(but it ends here) diff --git a/golden/read/decimal/read b/golden/read/decimal/read new file mode 100644 index 0000000..4b23079 --- /dev/null +++ b/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 ) + ) +] \ No newline at end of file diff --git a/golden/read/decimal/source.scm b/golden/read/decimal/source.scm new file mode 100644 index 0000000..58684bc --- /dev/null +++ b/golden/read/decimal/source.scm @@ -0,0 +1 @@ +45 +5667 -123 diff --git a/golden/read/delimited-identifier/read b/golden/read/delimited-identifier/read new file mode 100644 index 0000000..b84aa6a --- /dev/null +++ b/golden/read/delimited-identifier/read @@ -0,0 +1,5 @@ +[ Fix + ( SimpleF + ( Symbol "aaaa bc" ) + ) +] \ No newline at end of file diff --git a/golden/read/delimited-identifier/source.scm b/golden/read/delimited-identifier/source.scm new file mode 100644 index 0000000..e067c11 --- /dev/null +++ b/golden/read/delimited-identifier/source.scm @@ -0,0 +1 @@ +|aaaa bc| diff --git a/golden/read/empty/read b/golden/read/empty/read new file mode 100644 index 0000000..0637a08 --- /dev/null +++ b/golden/read/empty/read @@ -0,0 +1 @@ +[] \ No newline at end of file diff --git a/golden/read/empty/source.scm b/golden/read/empty/source.scm new file mode 100644 index 0000000..e69de29 diff --git a/golden/read/list-dot-flat/read b/golden/read/list-dot-flat/read new file mode 100644 index 0000000..c2f77de --- /dev/null +++ b/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 "라" ) + ) + ) +] \ No newline at end of file diff --git a/golden/read/list-dot-flat/source.scm b/golden/read/list-dot-flat/source.scm new file mode 100644 index 0000000..13788b9 --- /dev/null +++ b/golden/read/list-dot-flat/source.scm @@ -0,0 +1 @@ +(가 나 다 . 라) diff --git a/golden/read/list-flat/read b/golden/read/list-flat/read new file mode 100644 index 0000000..c1b1a96 --- /dev/null +++ b/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 ) + ] + ) +] \ No newline at end of file diff --git a/golden/read/list-flat/source.scm b/golden/read/list-flat/source.scm new file mode 100644 index 0000000..d72527e --- /dev/null +++ b/golden/read/list-flat/source.scm @@ -0,0 +1 @@ +(가 나 다 라 1 2 3) diff --git a/golden/read/list/read b/golden/read/list/read new file mode 100644 index 0000000..6629342 --- /dev/null +++ b/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 "라" ) + ] + ) + ) + ) +] \ No newline at end of file diff --git a/golden/read/list/source.scm b/golden/read/list/source.scm new file mode 100644 index 0000000..7b19db2 --- /dev/null +++ b/golden/read/list/source.scm @@ -0,0 +1 @@ +(a b (c d) . (가 (나 . 다) 라)) diff --git a/golden/read/meta-expression/read b/golden/read/meta-expression/read new file mode 100644 index 0000000..685b9d2 --- /dev/null +++ b/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" +] \ No newline at end of file diff --git a/golden/read/meta-expression/source.scm b/golden/read/meta-expression/source.scm new file mode 100644 index 0000000..e34be63 --- /dev/null +++ b/golden/read/meta-expression/source.scm @@ -0,0 +1 @@ +#{aHaskellVariable + abc * 2} diff --git a/golden/read/meta-splice-expression-interior-brace/source.scm b/golden/read/meta-splice-expression-interior-brace/source.scm new file mode 100644 index 0000000..757da8a --- /dev/null +++ b/golden/read/meta-splice-expression-interior-brace/source.scm @@ -0,0 +1,2 @@ +##{case 123 of { 123 -> blah + ; xyz -> flah }} diff --git a/golden/read/meta-splice-expression/read b/golden/read/meta-splice-expression/read new file mode 100644 index 0000000..e5de84d --- /dev/null +++ b/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" +] \ No newline at end of file diff --git a/golden/read/meta-splice-expression/source.scm b/golden/read/meta-splice-expression/source.scm new file mode 100644 index 0000000..da3ab87 --- /dev/null +++ b/golden/read/meta-splice-expression/source.scm @@ -0,0 +1 @@ +##{takeWhile (\x -> even x) aHaskellList} diff --git a/golden/read/meta-splice-variable/read b/golden/read/meta-splice-variable/read new file mode 100644 index 0000000..d8428ec --- /dev/null +++ b/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" +] \ No newline at end of file diff --git a/golden/read/meta-splice-variable/source.scm b/golden/read/meta-splice-variable/source.scm new file mode 100644 index 0000000..ba63f2a --- /dev/null +++ b/golden/read/meta-splice-variable/source.scm @@ -0,0 +1 @@ +##{aHaskellList} diff --git a/golden/read/meta-variable/read b/golden/read/meta-variable/read new file mode 100644 index 0000000..4ec3604 --- /dev/null +++ b/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" +] \ No newline at end of file diff --git a/golden/read/meta-variable/source.scm b/golden/read/meta-variable/source.scm new file mode 100644 index 0000000..429bae8 --- /dev/null +++ b/golden/read/meta-variable/source.scm @@ -0,0 +1 @@ +#{aHaskellVariable} diff --git a/golden/read/peculiar-identifier-dot/read b/golden/read/peculiar-identifier-dot/read new file mode 100644 index 0000000..b907b33 --- /dev/null +++ b/golden/read/peculiar-identifier-dot/read @@ -0,0 +1,7 @@ +[ SynNone :< SimpleF + ( SimpleSymbol ".." ) +, SynNone :< SimpleF + ( SimpleSymbol ".abc" ) +, SynNone :< SimpleF + ( SimpleSymbol "....abcc" ) +] \ No newline at end of file diff --git a/golden/read/peculiar-identifier-dot/source.scm b/golden/read/peculiar-identifier-dot/source.scm new file mode 100644 index 0000000..01fdb9d --- /dev/null +++ b/golden/read/peculiar-identifier-dot/source.scm @@ -0,0 +1 @@ +.. .abc ....abcc diff --git a/golden/read/peculiar-identifier-sign/read b/golden/read/peculiar-identifier-sign/read new file mode 100644 index 0000000..0321ef5 --- /dev/null +++ b/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 "-" ) +] \ No newline at end of file diff --git a/golden/read/peculiar-identifier-sign/source.scm b/golden/read/peculiar-identifier-sign/source.scm new file mode 100644 index 0000000..c52cc3a --- /dev/null +++ b/golden/read/peculiar-identifier-sign/source.scm @@ -0,0 +1 @@ ++ - diff --git a/golden/read/string-line-continuation/read b/golden/read/string-line-continuation/read new file mode 100644 index 0000000..3795d82 --- /dev/null +++ b/golden/read/string-line-continuation/read @@ -0,0 +1,5 @@ +[ Fix + ( SimpleF + ( String "가나다라마바" ) + ) +] \ No newline at end of file diff --git a/golden/read/string-line-continuation/source.scm b/golden/read/string-line-continuation/source.scm new file mode 100644 index 0000000..0c26be9 --- /dev/null +++ b/golden/read/string-line-continuation/source.scm @@ -0,0 +1,2 @@ +"가나다\ + 라마바" diff --git a/golden/read/string/read b/golden/read/string/read new file mode 100644 index 0000000..aed8eb0 --- /dev/null +++ b/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 "가나다라" ) +] \ No newline at end of file diff --git a/golden/read/string/source.scm b/golden/read/string/source.scm new file mode 100644 index 0000000..9351d56 --- /dev/null +++ b/golden/read/string/source.scm @@ -0,0 +1 @@ +"가나다라" diff --git a/golden/read/typical-identifier-token/read b/golden/read/typical-identifier-token/read new file mode 100644 index 0000000..744edef --- /dev/null +++ b/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 "數學" ) + ] + ) +] \ No newline at end of file diff --git a/golden/read/typical-identifier-token/source.scm b/golden/read/typical-identifier-token/source.scm new file mode 100644 index 0000000..a662f23 --- /dev/null +++ b/golden/read/typical-identifier-token/source.scm @@ -0,0 +1,2 @@ +abc"xyz" +수학(數學) diff --git a/golden/read/typical-identifier/read b/golden/read/typical-identifier/read new file mode 100644 index 0000000..2ee59d6 --- /dev/null +++ b/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 "三個女人一臺戲。" ) +] \ No newline at end of file diff --git a/golden/read/typical-identifier/source.scm b/golden/read/typical-identifier/source.scm new file mode 100644 index 0000000..95d49bc --- /dev/null +++ b/golden/read/typical-identifier/source.scm @@ -0,0 +1,5 @@ +abc bala-hwa$ x!!! z z123 나는너무졸리다 學 + +車室. + +三個女人一臺戲。 diff --git a/gyehoek.cabal b/gyehoek.cabal index 2af765d..0bab908 100644 --- a/gyehoek.cabal +++ b/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 diff --git a/src/Gyehoek/CPS/Lower.hs b/src/Gyehoek/CPS/Lower.hs index 78a7894..a9c7a91 100644 --- a/src/Gyehoek/CPS/Lower.hs +++ b/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 n = SL.Symbol [i|$arg#{n}|] +getArgRegister :: Natural -> S.Datum +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 - Left _ -> show e - Right x -> T.unpack x +lower' g e = error . S.encodeOrShow' S.datumIso $ e 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'}) |] diff --git a/src/Gyehoek/CPS/Syntax.hs b/src/Gyehoek/CPS/Syntax.hs index 400e657..d2bc692 100644 --- a/src/Gyehoek/CPS/Syntax.hs +++ b/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.Sexp qualified -import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primSexpIso, Lit(..), pattern Void) -import Language.SexpGrammar.Generic +import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primDatumIso, Lit(..)) +import Gyehoek.Sexp qualified as S import Control.Category import Prelude hiding ((.), id) -import Language.Haskell.TH.Quote (QuasiQuoter) -import Language.Sexp.Located (Sexp) -import qualified Data.InvertibleGrammar.Base as IG -import Data.InvertibleGrammar.Base (type (:-)((:-))) import qualified Data.HashSet as HS import Data.Monoid (Endo) import Data.Functor.Foldable.TH -import qualified Gyehoek.Sexp as GS -import qualified Language.Sexp.Located as SL import Data.Data.Lens (uniplate) import Gyehoek.Prelude hiding (op) +import Gyehoek.Sexp (Datum) +import Gyehoek.Sexp (G, (:-)(..)) +import qualified Data.InvertibleGrammar.Base as IG -- 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 - plate = uniplate - -- plate k = \case - -- ExpPrim p kap -> ExpPrim p <$> body k kap - -- ExpLetRec bs e -> ExpLetRec <$> (each . _2 . body) k bs <*> k e - -- ExpContinue c xs -> pure $ ExpContinue c xs - -- ExpIf c t f -> ExpIf c <$> k t <*> k f - -- ExpApply f xs ktail -> pure $ ExpApply f xs ktail +instance Plated Exp where plate = uniplate --- SexpIso instances +-- DatumIso instances -instance S.SexpIso Val where - sexpIso = match - $ With (\imm -> imm . S.sexpIso) - $ With (\var -> var . S.sexpIso) - $ End +instance S.DatumIso Val where + datumIso = S.match + $ S.With (\imm -> imm . S.datumIso) + $ S.With (\var -> var . S.datumIso) + $ S.End -instance S.SexpIso Obj where - sexpIso = match - $ With (\imm -> imm . S.sexpIso) - $ With (\hob -> hob . S.sexpIso) - $ End +instance S.DatumIso Obj where + datumIso = S.match + $ S.With (\imm -> imm . S.datumIso) + $ S.With (\hob -> hob . S.datumIso) + $ S.End -instance S.SexpIso Imm where - sexpIso = match - $ With (. S.int) - $ With (. GS.schemeBool) - $ With (. labelName) - $ End +instance S.DatumIso Imm where + datumIso = S.match + $ S.With (. S.int) + $ S.With (. S.datumIso) + $ S.With (. labelName) + $ 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 - sexpIso = match - $ With (. closure) - $ End +instance S.DatumIso Hob where + datumIso = S.match + $ S.With (. closure) + $ 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|( #{code} ##{env})|] :- t) (const . Left $ mempty) -instance S.SexpIso Lambda where - sexpIso = match - $ With (. lambda) - $ End +instance S.DatumIso Lambda where + datumIso = S.match + $ S.With (. lambda) + $ S.End where lambda = S.list $ - S.el Gyehoek.Sexp.lambdaKeyword + S.el S.lambdaKeyword >>> S.el binders - >>> S.el S.sexpIso - binders :: forall t. - IG.Grammar S.Position (Sexp :- t) (Name :- List Name :- t) + >>> S.el S.datumIso + binders :: forall t. G (Datum :- 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 - sexpIso = match - $ With (. kappa) - $ End +instance S.DatumIso Kappa where + datumIso = S.match + $ S.With (. kappa) + $ S.End where kappa = S.list $ - S.el Gyehoek.Sexp.kappaKeyword - >>> S.el (S.list $ S.rest S.sexpIso) - >>> S.el S.sexpIso + S.el S.kappaKeyword + >>> S.el (S.list $ S.rest S.datumIso) + >>> S.el S.datumIso -instance S.SexpIso Abs where - sexpIso = match - $ With (\lambda -> lambda . S.sexpIso) - $ With (\kappa -> kappa . S.sexpIso) - $ End +instance S.DatumIso Abs where + datumIso = S.match + $ S.With (\lambda -> lambda . S.datumIso) + $ S.With (\kappa -> kappa . S.datumIso) + $ S.End -instance S.SexpIso Exp where - sexpIso = match - $ With (. prim) - $ With (. letrec) - $ With (. continue) - $ With (. if_) - $ With (. app) - $ End +instance S.DatumIso Exp where + datumIso = S.match + $ S.With (. prim) + $ S.With (. letrec) + $ S.With (. continue) + $ S.With (. if_) + $ S.With (. app) + $ S.End where continue = S.list $ S.el (S.sym "continue") - >>> S.el S.sexpIso - >>> S.rest S.sexpIso - letrec = Gyehoek.Sexp.let_ "letrec" S.sexpIso S.sexpIso S.sexpIso - if_ = S.list $ S.el (S.sym "if") - >>> S.el S.sexpIso >>> S.el S.sexpIso >>> S.el S.sexpIso + >>> S.el S.datumIso + >>> S.rest S.datumIso + letrec = S.letLike "letrec" S.datumIso S.datumIso S.datumIso + if_ = S.ifLike "if" + S.datumIso S.datumIso S.datumIso app :: forall t. - IG.Grammar S.Position (Sexp :- t) (Name :- ([Val] :- (Val :- t))) - app = S.list $ S.el (S.sexpIso @Val) - -- >>> S.flipped Gyehoek.Sexp.nonEmptyGrammar - >>> S.rest (S.sexpIso @Val) + G (Datum :- t) (Name :- ([Val] :- (Val :- t))) + app = S.list $ S.el (S.datumIso @Val) + -- >>> S.flipped Gyehoek.Datum.nonEmptyGrammar + >>> 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 S.sexpIso + >>> S.el (primDatumIso id (S.datumIso @Val)) + >>> S.el S.datumIso -instance S.SexpIso Program where - sexpIso = with \prog -> S.sexpIso @Exp >>> prog +instance S.DatumIso Program where + 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 Val where toCPS = Gyehoek.Sexp.fromSexp -instance CPS Kappa where toCPS = Gyehoek.Sexp.fromSexp -instance CPS Lambda where toCPS = Gyehoek.Sexp.fromSexp -instance CPS Abs where toCPS = Gyehoek.Sexp.fromSexp -instance CPS Program where toCPS = Gyehoek.Sexp.fromSexp +instance CPS Exp where toCPS = S.fromDatumUnsafe S.datumIso +instance CPS Val where toCPS = S.fromDatumUnsafe S.datumIso +instance CPS Kappa where toCPS = S.fromDatumUnsafe S.datumIso +instance CPS Lambda where toCPS = S.fromDatumUnsafe S.datumIso +instance CPS Abs where toCPS = S.fromDatumUnsafe S.datumIso +instance CPS Program where toCPS = S.fromDatumUnsafe S.datumIso -cps :: QuasiQuoter -cps = Gyehoek.Sexp.makeSx' [| toCPS |] +cps :: S.QuasiQuoter +cps = S.makeSx' [| toCPS |] diff --git a/src/Gyehoek/Driver.hs b/src/Gyehoek/Driver.hs index bb2e8a3..33b98a0 100644 --- a/src/Gyehoek/Driver.hs +++ b/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 "-" = "" fileName e = e -readScm :: FileSystem :> es => FilePath -> Eff es Scm.Program +readScm + :: forall es. (Jalmot :> es, FileSystem :> es) + => FilePath -> Eff es Scm.Program readScm f = withFile f FS.ReadMode $ \h -> - Sexp.parseSexps @Scm.CommandOrDef (fileName f) <$> hGetContents h - >>= either error (pure . Scm.MkProgram) + S.decodeDataWith @es S.dataIso =<< hGetContents h inspectWasm :: IOE :> es => Text -> Eff es () inspectWasm wat = do @@ -107,7 +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,22 +118,22 @@ 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) - (eval >>> fmap writeObj - >>> T.unwords + (hPutStrLn FS.stdout <=< S.encodeDataWith S.dataIso) + (eval >>> fmap writeObj + >>> T.unwords >>> hPutStrLn FS.stdout) when (rt_is #CPS) do closedCps & CPS.evalProgram - & fmap writeObj - & T.unwords + & fmap writeObj + & T.unwords & hPutStrLn FS.stdout dumpOrRun opts.inspectWasm (rt_is #Wasm) (lowerProgram cps) @@ -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 diff --git a/src/Gyehoek/Jalmot.hs b/src/Gyehoek/Jalmot.hs new file mode 100644 index 0000000..fe946d6 --- /dev/null +++ b/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" diff --git a/src/Gyehoek/Lift1.hs b/src/Gyehoek/Lift1.hs new file mode 100644 index 0000000..8b42a72 --- /dev/null +++ b/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)|] diff --git a/src/Gyehoek/Options.hs b/src/Gyehoek/Options.hs index 064ef15..b074753 100644 --- a/src/Gyehoek/Options.hs +++ b/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" diff --git a/src/Gyehoek/Prelude.hs b/src/Gyehoek/Prelude.hs index 9c863e6..9355d2f 100644 --- a/src/Gyehoek/Prelude.hs +++ b/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 diff --git a/src/Gyehoek/Scheme/Syntax.hs b/src/Gyehoek/Scheme/Syntax.hs index 8981c54..8b85e8d 100644 --- a/src/Gyehoek/Scheme/Syntax.hs +++ b/src/Gyehoek/Scheme/Syntax.hs @@ -17,29 +17,20 @@ module Gyehoek.Scheme.Syntax , Def(..) , Exp(..) , ExpF(..) - , Sexp(..) , Program(..) , CommandOrDef(..) - , primSexpIso - , pattern Void + , primDatumIso , free , subst , getName , scm - , readExp - , readProgram , free' , freeWithBound' , freeO - , encodeProgram ) where import Data.List (intersperse) -import Language.SexpGrammar - ( SexpIso(..), list, el, rest, sym, symbol ) -import Language.SexpGrammar qualified as Sexp -import Language.SexpGrammar.Generic import Effectful import Prelude hiding ((.), id) import Control.Category @@ -58,6 +49,9 @@ import qualified Effectful.FileSystem.IO as FS import qualified Data.Text.Encoding as T import qualified Effectful.FileSystem.IO.ByteString as FB import qualified Data.Set.Ordered as O +import Gyehoek.Sexp.Grammar qualified as Sexp +import Gyehoek.Sexp.Grammar qualified as S +import Gyehoek.Sexp.Grammar (DatumIso, 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 - sexpIso = symbol >>> Sexp.partialOsi f g +instance DatumIso Name where + 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 - g (MkName s) = s + idn = S.el . S.sym . namefn + 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) -primSexpIso namefn a = match - $ With (. ht2 "+") - $ With (. ht2 "-") - $ With (. ht2 "*") - $ With (. ht2 "/") - $ With (. ht2 "cons") - $ With (. ht1 "car") - $ With (. ht1 "cdr") - $ With (. ht1 "immediate?") - $ With (. ht1 "cons?") - $ With (. ht1 "integer?") - $ With (. ht1 "write") - $ With (. ht1 "zero?") - $ With (. nullop "newline") - $ With (. ht1' "make-closure") - $ With (. GS.headTagged2 (namefn "env-ref") a Sexp.int) - $ With (. ht1 "env-code") - $ With (. ht1 "call/cc") - $ End +instance DatumIso a => DatumIso (Prim a) where + -- datumIso = primDatumIso ("prim:"<>) datumIso + datumIso = primDatumIso id S.datumIso + +instance DatumIso Lit where + datumIso = S.match + $ S.With (. S.int) + $ S.With (. S.boolean) + $ S.With (. S.string) + $ S.End + +instance DatumIso Def where + datumIso = S.match + $ S.With (. defconst) + $ S.With (. defun) + $ S.End where - idn s = el (sym (namefn s)) - nullop s = list $ idn s - ht1 s = GS.headTagged1 (namefn s) a - ht2 s = GS.headTagged2 (namefn s) a a - ht1' s = GS.headTagged1' (namefn s) a a - -instance SexpIso a => SexpIso (Prim a) where - -- sexpIso = primSexpIso ("prim:"<>) sexpIso - sexpIso = primSexpIso id sexpIso - -instance SexpIso Lit where - sexpIso = match - $ With (. sexpIso) - $ With (. sym "nil") - $ With (. GS.schemeBool) - $ With (. sexpIso) - $ With (. GS.prefixSugar "quote" Sexp.Quote sexpIso) - $ End - -instance SexpIso Sexp where - sexpIso = match - $ With (\conss -> conss . GS.todo) - $ With (\s -> s . symbol) - $ With (\lit -> lit . sexpIso) - $ End - -instance SexpIso Def where - sexpIso = match - $ With (. defconst) - $ With (. defun) - $ End - where - defconst = list $ el (sym "define") >>> el sexpIso >>> el sexpIso - defun = list $ el (sym "define") >>> el args >>> rest sexpIso - args = list $ el sexpIso >>> rest sexpIso + defconst = S.list $ S.el (S.sym "define") + >>> S.el S.datumIso >>> S.el S.datumIso + defun = S.list $ S.el (S.sym "define") + >>> S.el args >>> S.rest S.datumIso + args = S.list $ S.el S.datumIso >>> S.rest S.datumIso -instance SexpIso Exp where - sexpIso = match - $ With (. GS.let_ "let" sexpIso sexpIso sexpIso) - $ With (. GS.let_ "letrec" sexpIso sexpIso sexpIso) - $ With (. sexpIso) - $ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso)) - $ With (. if_) - $ With (. sexpIso) - $ With (. lam) - $ With (. sexpIso) - $ With (\app -> app . list (el sexpIso >>> rest sexpIso)) - $ End +instance DatumIso Exp where + datumIso = S.match + $ S.With (. S.letLike "let" S.datumIso S.datumIso S.datumIso) + $ S.With (. S.letLike "letrec" S.datumIso S.datumIso S.datumIso) + $ S.With (. S.datumIso) + $ S.With (. S.beginLike "begin" S.datumIso) + $ S.With (. S.ifLike "if" S.datumIso S.datumIso S.datumIso) + $ S.With (. S.datumIso) + $ S.With (. lam) + $ S.With (. S.datumIso) + $ S.With (\app -> app . S.list (S.el S.datumIso >>> S.rest S.datumIso)) + $ S.End where - if_ = list $ el (sym "if") >>> el sexpIso >>> el sexpIso >>> el sexpIso - lam = list - ( el GS.lambdaKeyword - >>> el (sexpIso @(List Name)) - >>> el sexpIso ) + lam = S.lambdaLike S.lambdaKeyword S.datumIso (S.el S.datumIso) -instance SexpIso CommandOrDef where - sexpIso = match - $ With (\_Command -> _Command . sexpIso) - $ With (\_Definition -> _Definition . sexpIso) - $ With (\_Begin -> _Begin . bgn) - $ End - where - bgn = list $ el (sym "begin") >>> rest sexpIso +instance DatumIso CommandOrDef where + datumIso = S.match + $ S.With (\_Command -> _Command . S.datumIso) + $ S.With (\_Definition -> _Definition . S.datumIso) + $ S.With (\_Begin -> _Begin . S.beginLike "begin" S.datumIso) + $ S.End + +instance DataIso Program where + dataIso = S.dataIso @(List CommandOrDef) >>> S.iso coerce coerce -- utilities scm :: QuasiQuoter -scm = GS.makeSx [|| GS.fromSexp @Exp ||] +scm = GS.makeSx [|| S.fromDatumUnsafe @Exp S.datumIso ||] freeWithBound' :: Foldable f => f Name -> Exp -> List Name freeWithBound' bound = filter (`elem` bound) . free' @@ -309,27 +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 "-" = "" -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 diff --git a/src/Gyehoek/Sexp.hs b/src/Gyehoek/Sexp.hs index 7b04e83..7428d90 100644 --- a/src/Gyehoek/Sexp.hs +++ b/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_ - , sexp - , nonempty - , 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 + ( module Gyehoek.Sexp.QQ + , module Gyehoek.Sexp.Syntax + , module Gyehoek.Sexp.Grammar ) where -import Data.Text (Text) -import Language.SexpGrammar as Sexp hiding (toSexp, List, encode, decode, encodeWith, decodeWith, iso, encodePrettyWith, encodePretty, fromSexp) -import Language.SexpGrammar qualified as Sexp -import Language.Sexp qualified as S -import Data.InvertibleGrammar.Base qualified as IGB -import Data.InvertibleGrammar qualified as IG -import Data.InvertibleGrammar.Base ((:-)((:-))) -import Data.List.NonEmpty (NonEmpty ((:|))) -import Data.List (List, groupBy) -import Data.Text.Encoding -import GHC.Generics (Generic) -import Control.Lens hiding (para) -import Control.Monad (join) -import qualified Language.Sexp.Located as SL -import Data.Void (absurd) -import Language.Haskell.TH.Quote -import Language.Haskell.TH (Quote, location, Loc (..), ExpQ, varE, mkName, listE, Exp, appE, Q, Code, unTypeCode) -import qualified Data.Text as T -import qualified Control.Category -import Data.Data (Data (..), Typeable, cast) -import Language.Haskell.TH.Syntax (lift, Lift, liftData) -import Data.Functor.Foldable (cata) -import Data.Vector (Vector) -import Numeric.Natural (Natural) -import qualified Data.Vector.Strict -import Data.Function (on) -import Data.String (IsString (fromString)) -import Effectful -import qualified Effectful.FileSystem.IO as FS -import qualified Effectful.FileSystem.IO.ByteString as FB -import qualified Data.Text.Encoding as T +import Gyehoek.Sexp.QQ +import Gyehoek.Sexp.Syntax +import Gyehoek.Sexp.Grammar - -sexp :: SexpIso a => Iso' a Text -sexp = iso - (either error id . encode) - (either error id . decode) - -format :: Sexp -> Text -format = decodeUtf8 . view strict . SL.format - -encode :: SexpIso a => a -> Either String Text -encode = encodeWith sexpIso - -decode :: SexpIso a => Text -> Either String a -decode = decodeWith sexpIso - -encodeWith :: SexpGrammar a -> a -> Either String Text -encodeWith g = (_Right %~ decodeUtf8 . view strict) . Sexp.encodeWith g - -encodePretty :: SexpIso a => a -> Either String Text -encodePretty = encodePrettyWith sexpIso - -decodeWith :: SexpGrammar a -> Text -> Either String a -decodeWith g = Sexp.decodeWith g "FILE" . view lazy . encodeUtf8 - -encodePrettyWith :: SexpGrammar a -> a -> Either String Text -encodePrettyWith g = - (_Right %~ decodeUtf8 . view strict) . Sexp.encodePrettyWith g - -parseSexps :: SexpIso a => FilePath -> Text -> Either String (List a) -parseSexps f = marshal . SL.parseSexps f . view lazy . encodeUtf8 - where marshal = join . traverseOf (_Right . each) (Sexp.fromSexp sexpIso) - -parseSexpsWith :: SexpGrammar a -> FilePath -> Text -> Either String (List a) -parseSexpsWith g f = marshal . SL.parseSexps f . view lazy . encodeUtf8 - where marshal = join . traverseOf (_Right . each) (Sexp.fromSexp g) - -parseSexp :: SexpIso a => FilePath -> Text -> Either String a -parseSexp f = marshal . SL.parseSexp f . view lazy . encodeUtf8 - where marshal = join . traverseOf _Right (Sexp.fromSexp sexpIso) - -readSexpWithPos :: Position -> Text -> Either String Sexp -readSexpWithPos pos = SL.parseSexpWithPos pos . view lazy . encodeUtf8 - -readSexpsWithPos :: Position -> Text -> Either String (List Sexp) -readSexpsWithPos pos = SL.parseSexpsWithPos pos . view lazy . encodeUtf8 - -parseSexpsWithPos :: SexpGrammar a -> Position -> Text -> Either String (List a) -parseSexpsWithPos g pos = - marshal . SL.parseSexpsWithPos pos . view lazy . encodeUtf8 - where marshal = join . traverseOf (_Right . each) (Sexp.fromSexp g) - -parseSexpWithPos :: SexpGrammar a -> Position -> Text -> Either String a -parseSexpWithPos g pos = - marshal . SL.parseSexpWithPos pos . view lazy . encodeUtf8 - where marshal = join . traverseOf _Right (Sexp.fromSexp g) - -fileName :: FilePath -> FilePath -fileName "-" = "" -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||] diff --git a/src/Gyehoek/Sexp/Grammar.hs b/src/Gyehoek/Sexp/Grammar.hs new file mode 100644 index 0000000..0188a30 --- /dev/null +++ b/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 diff --git a/src/Gyehoek/Sexp/Grammar/Base.hs b/src/Gyehoek/Sexp/Grammar/Base.hs new file mode 100644 index 0000000..8224108 --- /dev/null +++ b/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: +-- :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) diff --git a/src/Gyehoek/Sexp/Print.hs b/src/Gyehoek/Sexp/Print.hs new file mode 100644 index 0000000..467e40c --- /dev/null +++ b/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] diff --git a/src/Gyehoek/Sexp/QQ.hs b/src/Gyehoek/Sexp/QQ.hs new file mode 100644 index 0000000..7a4d93b --- /dev/null +++ b/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 ||] diff --git a/src/Gyehoek/Sexp/Read.hs b/src/Gyehoek/Sexp/Read.hs new file mode 100644 index 0000000..1d6ffb0 --- /dev/null +++ b/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 "" s of + Right x -> pure x + Left eb -> throwError . ReaderError $ eb + +readString1 :: Jalmot :> es => Text -> Eff es Datum +readString1 s = + case runParser file1 "" 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 diff --git a/src/Gyehoek/Sexp/Syntax.hs b/src/Gyehoek/Sexp/Syntax.hs new file mode 100644 index 0000000..31517e6 --- /dev/null +++ b/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 "" 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)|] diff --git a/src/Gyehoek/Stack/Syntax.hs b/src/Gyehoek/Stack/Syntax.hs index 1c5dddd..2141d31 100644 --- a/src/Gyehoek/Stack/Syntax.hs +++ b/src/Gyehoek/Stack/Syntax.hs @@ -14,14 +14,10 @@ module Gyehoek.Stack.Syntax , Prim(..) , Name , pattern ValLabel - , encodeProgram ) where import Control.Lens -import Language.SexpGrammar (SexpIso, (>>>)) -import Language.SexpGrammar qualified as S -import Language.SexpGrammar.Generic -import qualified Gyehoek.Sexp +import qualified Gyehoek.Sexp as S import Gyehoek.Scheme.Syntax (Name(..), Lit(..), Prim(..)) import GHC.Exts (IsList(..)) import Data.List (intersperse) @@ -77,43 +73,40 @@ pattern ValLabel x = ValImm (ImmLabel x) pure [] -instance SexpIso Instr where - sexpIso = match - $ With (Gyehoek.Sexp.headTagged1 "pop!" regName >>>) - $ With (Gyehoek.Sexp.headTagged1 "push!" S.sexpIso >>>) - $ With (Gyehoek.Sexp.headTagged1 "pop-cont!" regName >>>) - $ With (Gyehoek.Sexp.headTagged1 "push-cont!" S.sexpIso >>>) - $ With (Gyehoek.Sexp.headTagged2 "prim" regName S.sexpIso >>>) - $ With (Gyehoek.Sexp.headTagged1' "call" S.sexpIso S.sexpIso >>>) - $ With (if_ >>>) - $ End +instance S.DatumIso Instr where + datumIso = S.match + $ S.With (S.headTagged1 "pop!" regName >>>) + $ S.With (S.headTagged1 "push!" S.datumIso >>>) + $ S.With (S.headTagged1 "pop-cont!" regName >>>) + $ S.With (S.headTagged1 "push-cont!" S.datumIso >>>) + $ S.With (S.headTagged2 "prim" regName S.datumIso >>>) + $ S.With (S.headTagged1' "call" S.datumIso S.datumIso >>>) + $ S.With (if_ >>>) + $ S.End where if_ = S.list $ S.el (S.sym "if") - >>> S.el (S.sexpIso @Val) - >>> S.el (S.list $ S.el (S.sym "then") >>> S.rest (S.sexpIso @Instr)) - >>> S.el (S.list $ S.el (S.sym "else") >>> S.rest (S.sexpIso @Instr)) + >>> S.el (S.datumIso @Val) + >>> S.el (S.list $ S.el (S.sym "then") >>> S.rest (S.datumIso @Instr)) + >>> S.el (S.list $ S.el (S.sym "else") >>> S.rest (S.datumIso @Instr)) -instance SexpIso Val where - sexpIso = match - $ With (regName >>>) - $ With (S.sexpIso >>>) - $ End +instance S.DatumIso Val where + datumIso = S.match + $ S.With (regName >>>) + $ S.With (S.datumIso >>>) + $ S.End -instance SexpIso Block where - sexpIso = with (block >>>) +instance S.DatumIso Block where + datumIso = S.with (block >>>) where block = S.list $ S.el (S.sym "define") >>> S.el (S.list $ S.el labelName >>> S.rest regName) - >>> S.rest (S.sexpIso @Instr) + >>> S.rest (S.datumIso @Instr) -encodeProgram :: Program -> Text -encodeProgram p = p.blocks - & fmap ((^?! _Right) . Gyehoek.Sexp.encodePretty) - & intersperse "\n\n" - & mconcat - -regName :: S.SexpGrammar Name -regName = S.sexpIso @Name >>> Gyehoek.Sexp.prismIso +regName :: S.DatumGrammar Name +regName = S.datumIso @Name >>> S.prismIso (S.expected "register") (prefixed @Name "%") + +instance S.DataIso Program where + dataIso = S.dataIso @(List Block) >>> S.iso coerce coerce diff --git a/src/Gyehoek/Wasm.hs b/src/Gyehoek/Wasm.hs index d3b1c64..2c65802 100644 --- a/src/Gyehoek/Wasm.hs +++ b/src/Gyehoek/Wasm.hs @@ -10,8 +10,8 @@ module Gyehoek.Wasm , Expr -- ** quasiquoters , expr - , Gyehoek.Sexp.sx - , Gyehoek.Sexp.sxs + , S.sx + , S.sxs -- * GenMod effect , GenMod , runGenMod @@ -29,10 +29,6 @@ module Gyehoek.Wasm ) where -import Language.SexpGrammar - ( SexpIso(..), (>>>) ) -import Language.SexpGrammar qualified as Sexp -import Language.SexpGrammar.Generic import Data.List (List) import GHC.Generics (Generic) import Data.Text (Text) @@ -43,16 +39,16 @@ import Effectful.State.Dynamic import Control.Lens import Data.Vector.Strict (Vector) import qualified Data.Vector.Strict as V -import Language.Sexp.Located -import qualified Gyehoek.Sexp import GHC.IsList (IsList(..)) import Language.Haskell.TH.Quote (QuasiQuoter) import Data.Data (Data) -import Gyehoek.Sexp (sx) +import Gyehoek.Sexp qualified as S +import Gyehoek.Sexp (Datum, sx, (>>>)) import Data.Foldable (traverse_) +import Data.Coerce (coerce) -newtype Module = MkModule { inner :: Vector Sexp } +newtype Module = MkModule { inner :: Vector Datum } deriving (Show, Generic) deriving newtype (Semigroup, Monoid) @@ -65,7 +61,7 @@ instance IsList Expr where fromList = MkExpr . V.fromList toList = V.toList . view #inner -newtype Instr = MkInstr { inner :: Sexp } +newtype Instr = MkInstr { inner :: Datum } deriving (Show, Generic, Data, Eq) newtype Idx = MkIdx { inner :: Natural } @@ -102,38 +98,38 @@ instance Monoid GenModState where } data GenMod :: Effect where - DefineFunction :: Sexp -> GenMod m Idx - DefineType :: Sexp -> GenMod m Idx - DefineGlobal :: Sexp -> GenMod m Idx - Emit :: Sexp -> GenMod m () + DefineFunction :: Datum -> GenMod m Idx + DefineType :: Datum -> GenMod m Idx + DefineGlobal :: Datum -> GenMod m Idx + Emit :: Datum -> GenMod m () type instance DispatchOf GenMod = Dynamic -defineFunction :: GenMod :> es => Sexp -> Eff es Idx +defineFunction :: GenMod :> es => Datum -> Eff es Idx defineFunction = send . DefineFunction -defineFunctions :: GenMod :> es => List Sexp -> Eff es (List Idx) +defineFunctions :: GenMod :> es => List Datum -> Eff es (List Idx) defineFunctions = traverse (send . DefineFunction) -defineType :: GenMod :> es => Sexp -> Eff es Idx +defineType :: GenMod :> es => Datum -> Eff es Idx defineType = send . DefineType -defineTypes :: GenMod :> es => List Sexp -> Eff es (List Idx) +defineTypes :: GenMod :> es => List Datum -> Eff es (List Idx) defineTypes = traverse (send . DefineType) -defineGlobal :: GenMod :> es => Sexp -> Eff es Idx +defineGlobal :: GenMod :> es => Datum -> Eff es Idx defineGlobal = send . DefineGlobal -defineGlobals :: GenMod :> es => List Sexp -> Eff es (List Idx) +defineGlobals :: GenMod :> es => List Datum -> Eff es (List Idx) defineGlobals = traverse (send . DefineGlobal) -emit :: GenMod :> es => List Sexp -> Eff es () +emit :: GenMod :> es => List Datum -> Eff es () emit = traverse_ (send . Emit) appendAndIncrement :: State GenModState :> es => LensLike' ((,) Natural) GenModState Natural - -> Sexp + -> Datum -> Eff es Idx appendAndIncrement l s = state \st -> st @@ -154,39 +150,38 @@ execGenMod :: Eff (GenMod : es) a -> Eff es Module execGenMod = fmap snd . runGenMod renderModule :: Module -> Text -renderModule (MkModule ss) = Gyehoek.Sexp.format [sx| +renderModule (MkModule ss) = S.encodeWith' S.datumIso [sx| (module ##{ss}) |] --- SexpIso instances +-- DatumIso instances -instance SexpIso Idx where - sexpIso = with \idx -> - Sexp.integer >>> Sexp.partialOsi f g +instance S.DatumIso Idx where + datumIso = S.with \idx -> + S.integer >>> S.partialOsi f g >>> idx where - f n | n < 0 = Left $ Sexp.unexpected "negative" - <> Sexp.expected "natural" + f n | n < 0 = Left $ S.unexpected "negative" + <> S.expected "natural" | otherwise = Right $ fromIntegral n g = fromIntegral -instance SexpIso Instr where - sexpIso = with id +instance S.DatumIso Instr where + datumIso = S.with S.id -instance Gyehoek.Sexp.SpliceSexp Expr where - spliceSexp = toListOf $ #inner . each . #inner +instance S.DataIso Expr where + dataIso = S.dataIso @(Vector Instr) >>> S.iso coerce coerce -- quasiquoters expr :: QuasiQuoter -expr = Gyehoek.Sexp.makeSxs - [||MkExpr . V.fromList . (each . #inner %~ Gyehoek.Sexp.stripLocation) - . fmap (Gyehoek.Sexp.fromSexp @Instr) ||] +expr = S.makeSxs + [|| MkExpr . V.fromList . fmap (S.fromDatumUnsafe $ S.datumIso @Instr) ||] wat :: QuasiQuoter -wat = Gyehoek.Sexp.makeSx [|| id ||] +wat = S.makeSx [|| id ||] wats :: QuasiQuoter -wats = Gyehoek.Sexp.makeSxs [|| id ||] +wats = S.makeSxs [|| id ||] diff --git a/test/Gyehoek/Test/CPS/Eval.hs b/test/Gyehoek/Test/CPS/Eval.hs index 8f28740..2b0c40f 100644 --- a/test/Gyehoek/Test/CPS/Eval.hs +++ b/test/Gyehoek/Test/CPS/Eval.hs @@ -2,7 +2,6 @@ module Gyehoek.Test.CPS.Eval where import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit -import Language.SexpGrammar () import Gyehoek.CPS.Syntax (cps, Obj(..), Hob(..), Imm(..)) import Gyehoek.CPS.Eval qualified as Sut import Data.List (List) diff --git a/test/Gyehoek/Test/CPS/Syntax.hs b/test/Gyehoek/Test/CPS/Syntax.hs index f32a04d..5ecd917 100644 --- a/test/Gyehoek/Test/CPS/Syntax.hs +++ b/test/Gyehoek/Test/CPS/Syntax.hs @@ -3,7 +3,6 @@ module Gyehoek.Test.CPS.Syntax where import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit -import Language.SexpGrammar () import Gyehoek.CPS.Syntax (cps) import Gyehoek.CPS.Syntax qualified as Sut diff --git a/test/Gyehoek/Test/Golden.hs b/test/Gyehoek/Test/Golden.hs index bd83f50..04bd34c 100644 --- a/test/Gyehoek/Test/Golden.hs +++ b/test/Gyehoek/Test/Golden.hs @@ -16,6 +16,10 @@ import Data.Text qualified as T import System.Exit (ExitCode(..)) import Test.Tasty.ExpectedFailure (expectFail, ignoreTestBecause) import Control.DeepSeq (($!!)) +import Text.Pretty.Simple (pShow, pShowNoColor) +import Control.Lens (strict, view) +import Gyehoek.Sexp.Read qualified as Read +import Effectful brokenWasmTests :: List String @@ -33,10 +37,10 @@ brokenStackifyTests = test_root :: IO TestTree test_root = do - all_cases <- listDirectory "golden" + all_cases <- listDirectory "golden/exec" let tests = all_cases - & fmap ("golden") - testGroup "golden" <$> sequenceA + & fmap ("golden/exec") + testGroup "execution" <$> sequenceA [ ignoreTestBecause "wasm codegen is on the backburner" <$> wasmTests tests , stackifyTests tests @@ -48,7 +52,7 @@ wasmTests :: List FilePath -> IO TestTree wasmTests files = do cmd <- getEnvDefault "GYEHOEK_RUNTIME" "runtime/target/debug/gyehoek-runtime" - pure $ testGroup "wasm execution" $ files <&> \test -> + pure $ testGroup "wasm" $ files <&> \test -> let testname = takeFileName test scmfile = test "source.scm" resultfile = test "exec" @@ -64,7 +68,7 @@ wasmTests files = do stackifyTests :: List FilePath -> IO TestTree stackifyTests files = do - pure $ testGroup "stackified execution" $ files <&> \test -> + pure $ testGroup "stackified" $ files <&> \test -> let testname = takeFileName test scmfile = test "source.scm" resultfile = test "exec" diff --git a/test/Gyehoek/Test/Scheme/Syntax.hs b/test/Gyehoek/Test/Scheme/Syntax.hs index 50f9442..2f3c1e9 100644 --- a/test/Gyehoek/Test/Scheme/Syntax.hs +++ b/test/Gyehoek/Test/Scheme/Syntax.hs @@ -2,7 +2,6 @@ module Gyehoek.Test.Scheme.Syntax where import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit -import Language.SexpGrammar () import Gyehoek.Scheme.Syntax (scm) import Gyehoek.Scheme.Syntax qualified as Sut diff --git a/test/Gyehoek/Test/Sexp/Print.hs b/test/Gyehoek/Test/Sexp/Print.hs new file mode 100644 index 0000000..0cbfc57 --- /dev/null +++ b/test/Gyehoek/Test/Sexp/Print.hs @@ -0,0 +1,49 @@ +module Gyehoek.Test.Sexp.Print where + +import Test.Tasty (TestTree, testGroup, TestName) +import Test.Tasty.HUnit +import Gyehoek.Prelude +import Gyehoek.Sexp.Syntax qualified as S +import Gyehoek.Sexp.Print qualified as Sut +import System.FilePath (()) +import Test.Tasty.Silver + + +tcase = tcaseW 80 + +tcaseW :: Int -> TestName -> S.Datum -> TestTree +tcaseW width name ast = + goldenVsAction + name + ("golden/print" name) + (pure $ Sut.printDatumW width ast) + id + +thinWide name x = testGroup name + [ tcase (name <> "-wide") x + , tcaseW 4 (name <> "-thin") x + ] + +datumBegin xs = S.indentWith (S.NSpecial 0) . S.List $ + (S.adorn S.SynBuiltin . S.Symbol $ "begin") : xs + +datumLambda formals body = + S.indentWith (S.NSpecial 1) . S.List $ + (S.adorn S.SynBuiltin . S.Symbol $ "lambda") : formals : body + +test_print = testGroup "sexp pretty printer" $ + [ tcase "null" $ S.List [] + , thinWide "simple-list" $ + S.List [ S.Symbol s | s <- ["가","나","다","라"] ] + , thinWide "begin-nonempty" $ + S.indentWith (S.NSpecial 0) $ + datumBegin [ S.Symbol "책을" + , S.Symbol "더" + , S.Symbol "먹으세요~!" + ] + , thinWide "lambda" $ + datumLambda (S.List [S.Symbol "어간", S.Symbol "어미"]) + [ S.List [S.Symbol "display", S.Symbol "꾸깃"] ] + , tcase "rainbow" $ + S.List [S.List [S.List [S.List [S.List []]]]] + ] diff --git a/test/Gyehoek/Test/Sexp.hs b/test/Gyehoek/Test/Sexp/QQ.hs similarity index 50% rename from test/Gyehoek/Test/Sexp.hs rename to test/Gyehoek/Test/Sexp/QQ.hs index 3f8f950..d1acea1 100644 --- a/test/Gyehoek/Test/Sexp.hs +++ b/test/Gyehoek/Test/Sexp/QQ.hs @@ -1,35 +1,32 @@ -module Gyehoek.Test.Sexp where +module Gyehoek.Test.Sexp.QQ where import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit -import Language.Sexp.Located qualified as SL -import Language.SexpGrammar () -import Gyehoek.Sexp (sx, equivalent) +import Gyehoek.Sexp.QQ (sx) import Data.Function (on) +import Gyehoek.Sexp.Syntax +import Data.Coerce (coerce) -test_root = testGroup "sexp" $ - [ sxTree - ] - -newtype EquivSexp = MkEquiv SL.Sexp +newtype EquivDatum = MkEquiv Datum deriving newtype (Show) -instance Eq EquivSexp where - MkEquiv x == MkEquiv y = equivalent x y +instance Eq EquivDatum where + (==) = (==) `on` (stripAnn . coerce) assertEquiv :: HasCallStack - => String -> SL.Sexp -> SL.Sexp -> Assertion + => String -> Datum -> Datum -> Assertion assertEquiv prefix = assertEqual prefix `on` MkEquiv +equivto :: HasCallStack => Datum -> Datum -> Assertion equivto = assertEquiv "" -sxTree :: TestTree -sxTree = testGroup "sx" +test_qq :: TestTree +test_qq = testGroup "sexp quasiquoter" [ testCase "quotation" do - equivto (SL.Symbol "abc") [sx|abc|] - equivto (SL.ParenList [SL.Symbol "a", SL.Symbol "b"]) [sx|(a b)|] + equivto (Symbol "abc") [sx|abc|] + equivto (List [Symbol "a", Symbol "b"]) [sx|(a b)|] , testCase "antiquotation" do equivto [sx|123|] let meta = 123 :: Int @@ -37,13 +34,14 @@ sxTree = testGroup "sx" equivto [sx|(blah (blah blah) blah)|] let meta = [sx|blah|] in [sx|(#{meta} (#{meta} #{meta}) #{meta})|] - , testCase "splicing" do + , testCase "splicing simple" do equivto [sx|(a b c d e f g)|] - let metas = SL.Symbol <$> ["c","d","e"] + let metas = Symbol <$> ["c","d","e"] in [sx|(a b ##{metas} f g)|] + , testCase "splicing multiple" do equivto [sx|(a (b c d) e f g)|] let - e1 = SL.Symbol "c" - e2 = SL.Symbol <$> ["e","f"] + e1 = Symbol "c" + e2 = Symbol <$> ["e","f"] in [sx|(a (b #{e1} d) ##{e2} g)|] ] diff --git a/test/Gyehoek/Test/Sexp/Read.hs b/test/Gyehoek/Test/Sexp/Read.hs new file mode 100644 index 0000000..d85d53e --- /dev/null +++ b/test/Gyehoek/Test/Sexp/Read.hs @@ -0,0 +1,60 @@ +module Gyehoek.Test.Sexp.Read where + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Silver +import System.FilePath +import Data.List (List) +import System.Directory +import Gyehoek.Prelude +import qualified Gyehoek.Sexp.Read as Read +import Gyehoek.TestUtil +import Gyehoek.Jalmot (runJalmotIO) +import Text.Pretty.Simple (pShowNoColor) +import Gyehoek.Sexp.Syntax +import Test.Tasty.HUnit +import Control.Exception (tryWithContext, ExceptionWithContext (..), rethrowIO) +import Gyehoek.Jalmot + + +brokenReaderTests :: List String +brokenReaderTests = + [ "delimited-identifier" + , "string-line-continuation" + , "peculiar-identifier-dot" + , "meta-splice-expression-interior-brace" + , "datum-comment" + ] + +test_golden :: IO TestTree +test_golden = do + all_cases <- listDirectory "golden/read" + let tests = all_cases + & fmap ("golden/read") + pure . testGroup "reader" $ tests <&> \test -> + let testname = takeFileName test + scmfile = test "source.scm" + resultfile = test "read" + action = runJalmotIO $ Read.readFile scmfile + in markIfBroken testname brokenReaderTests $ goldenVsAction + testname + resultfile + action + (view strict . pShowNoColor) + +readString1 = runJalmotIO . Read.readString1 + +test_invalidIdentifiers :: TestTree +test_invalidIdentifiers = testGroup "invalid identifiers" + [ testCase "dot" $ notIdentifier (readString1 ".") + , testCase "comma" $ notIdentifier (readString1 ",") + , testCase "pound" $ notIdentifier (readString1 "#") + , testCase "pound anything" $ notIdentifier (readString1 "#abc") + ] + where + notIdentifier m = tryWithContext m >>= \case + -- the reader is allowed to fail; we're just don't want it to + -- return a symbol. + Left (ExceptionWithContext _ (MkAJalmotCS _ (ReaderError _))) -> pure () + Left e -> rethrowIO e + Right (Symbol s) -> assertFailure [i|got symbol #{s}|] + Right _ -> pure () diff --git a/test/Gyehoek/TestUtil.hs b/test/Gyehoek/TestUtil.hs new file mode 100644 index 0000000..55e4861 --- /dev/null +++ b/test/Gyehoek/TestUtil.hs @@ -0,0 +1,11 @@ +module Gyehoek.TestUtil + ( markIfBroken + ) where + +import Test.Tasty.ExpectedFailure (expectFail) +import Data.Function +import Test.Tasty (TestTree) + + +markIfBroken :: Foldable f => String -> f String -> TestTree -> TestTree +markIfBroken name brokenTests = applyWhen (name `elem` brokenTests) expectFail diff --git a/test/Main.hs b/test/Main.hs index d4deb30..c023cf9 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,14 +1,6 @@ module Main (main) where --- import Test.Tasty (TestTree, testGroup) import Test.Tasty.Silver.Interactive (defaultMain) --- import qualified Gyehoek.Test.Golden --- import qualified Gyehoek.Test.Sexp --- import qualified Gyehoek.Test.CPS.Syntax --- import qualified Gyehoek.Test.Scheme.Syntax --- import qualified Gyehoek.Test.Stack.VM --- import qualified Gyehoek.Test.CPS.Stackify --- import qualified Gyehoek.Test.CPS.Eval import qualified Root diff --git a/test/doctest.hs b/test/doctest.hs new file mode 100644 index 0000000..85fa358 --- /dev/null +++ b/test/doctest.hs @@ -0,0 +1,7 @@ +module Main where + +import Test.DocTest (mainFromCabal) +import System.Environment (getArgs) + +main :: IO () +main = mainFromCabal "gyehoek" =<< getArgs