From f9ed1274d9c1b2610321e8f278f84ea5a04dbef5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Thu, 20 Aug 2026 21:52:55 -0600 Subject: [PATCH 01/13] r7rs datum ast --- gyehoek.cabal | 6 ++++ src/Gyehoek/Language.hs | 25 ++++++++++++++++ src/Gyehoek/Options.hs | 35 ++++++++++++++++++++-- src/Gyehoek/Prelude.hs | 4 +++ src/Gyehoek/Sexp.hs | 1 + src/Gyehoek/Sexp/Grammar.hs | 4 +++ src/Gyehoek/Sexp/Print.hs | 4 +++ src/Gyehoek/Sexp/Read.hs | 4 +++ src/Gyehoek/Sexp/Syntax.hs | 58 +++++++++++++++++++++++++++++++++++++ 9 files changed, 138 insertions(+), 3 deletions(-) create mode 100644 src/Gyehoek/Language.hs create mode 100644 src/Gyehoek/Sexp/Grammar.hs create mode 100644 src/Gyehoek/Sexp/Print.hs create mode 100644 src/Gyehoek/Sexp/Read.hs create mode 100644 src/Gyehoek/Sexp/Syntax.hs diff --git a/gyehoek.cabal b/gyehoek.cabal index 2af765d..e1ec645 100644 --- a/gyehoek.cabal +++ b/gyehoek.cabal @@ -60,10 +60,15 @@ library Gyehoek.CPS.Syntax Gyehoek.Driver Gyehoek.GenSym + Gyehoek.Language Gyehoek.Options Gyehoek.Prelude Gyehoek.Scheme.Syntax Gyehoek.Sexp + Gyehoek.Sexp.Grammar + Gyehoek.Sexp.Print + Gyehoek.Sexp.Read + Gyehoek.Sexp.Syntax Gyehoek.Stack.Syntax Gyehoek.Stack.VM Gyehoek.Wasm @@ -90,6 +95,7 @@ library , prettyprinter , process , recursion-schemes + , scientific , sexp-grammar , string-interpolate , template-haskell diff --git a/src/Gyehoek/Language.hs b/src/Gyehoek/Language.hs new file mode 100644 index 0000000..f3bdd84 --- /dev/null +++ b/src/Gyehoek/Language.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +module Gyehoek.Language + ( Language(..) + ) where + +import Data.Kind (Type) +import Gyehoek.Prelude +import Language.SexpGrammar (Position, Grammar, (:-), Sexp) + + +class Language l where + type Program l :: Type + languageName :: Text + programGrammar :: forall t. Grammar Position (List Sexp :- t) (Program l :- t) + +readProgramFile + :: forall l es. Language l + => FilePath -> Eff es (Program l) +readProgramFile fp = _ + +readProgramStringPos + :: forall l. Language l + => Position -> Text -> Either Text (Program l) +readProgramStringPos pos s = _ 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..10e66a8 100644 --- a/src/Gyehoek/Prelude.hs +++ b/src/Gyehoek/Prelude.hs @@ -14,6 +14,8 @@ module Gyehoek.Prelude , IsList(fromList) , HasCallStack , Hashable + , NonEmpty((:|)) + , Natural ) where import Control.Lens @@ -31,4 +33,6 @@ 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) diff --git a/src/Gyehoek/Sexp.hs b/src/Gyehoek/Sexp.hs index 7b04e83..dcf2590 100644 --- a/src/Gyehoek/Sexp.hs +++ b/src/Gyehoek/Sexp.hs @@ -26,6 +26,7 @@ module Gyehoek.Sexp , encodePrettyWith , encodePretty , SpliceSexp(..) + , Position(..) , parseSexpsWithPos , parseSexpWithPos , parseSexp diff --git a/src/Gyehoek/Sexp/Grammar.hs b/src/Gyehoek/Sexp/Grammar.hs new file mode 100644 index 0000000..1d908f3 --- /dev/null +++ b/src/Gyehoek/Sexp/Grammar.hs @@ -0,0 +1,4 @@ +module Gyehoek.Sexp.Grammar + ( + ) where + diff --git a/src/Gyehoek/Sexp/Print.hs b/src/Gyehoek/Sexp/Print.hs new file mode 100644 index 0000000..66064c7 --- /dev/null +++ b/src/Gyehoek/Sexp/Print.hs @@ -0,0 +1,4 @@ +module Gyehoek.Sexp.Print + ( + ) where + diff --git a/src/Gyehoek/Sexp/Read.hs b/src/Gyehoek/Sexp/Read.hs new file mode 100644 index 0000000..12a0530 --- /dev/null +++ b/src/Gyehoek/Sexp/Read.hs @@ -0,0 +1,4 @@ +module Gyehoek.Sexp.Read + ( + ) where + diff --git a/src/Gyehoek/Sexp/Syntax.hs b/src/Gyehoek/Sexp/Syntax.hs new file mode 100644 index 0000000..8afba00 --- /dev/null +++ b/src/Gyehoek/Sexp/Syntax.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE DeriveAnyClass #-} +module Gyehoek.Sexp.Syntax + ( DatumF(..) + , Simple(..) + , CompoundF(..) + , Prefix(..) + , Delimiter(..) + , Label(..) + ) where + +import Language.Haskell.TH.Syntax (Lift) +import Data.Scientific (Scientific) +import Data.ByteString (ByteString) +import Gyehoek.Prelude hiding (Simple) + + +data DatumF a + = SimpleF Simple + | CompoundF (CompoundF a) + | LabeledF Label a + | LabelRefF Label + deriving stock (Show, Eq, Data, Generic, Lift) + deriving anyclass (NFData) + +data Simple + = SimpleBool Bool + | SimpleNumber Scientific + | SimpleChar Char + | SimpleString Text + | SimpleSymbol Text + | SimpleBytevector ByteString + deriving stock (Show, Eq, Data, Generic, Lift) + deriving anyclass (NFData) + +data CompoundF a + = ListF (List a) + | DotListF (NonEmpty a) a + | VectorF (List a) + | AbbrevF Prefix a + deriving stock (Show, Eq, Data, Generic, Lift) + 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) -- 2.54.0 From 52009329445a937c47c5ad3f402628e3e7c9148e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Thu, 20 Aug 2026 23:26:45 -0600 Subject: [PATCH 02/13] wip: reader --- golden/{ => exec}/adder/exec | 0 golden/{ => exec}/adder/source.scm | 0 golden/{ => exec}/apply-twice/exec | 0 golden/{ => exec}/apply-twice/source.scm | 0 golden/{ => exec}/apply2/exec | 0 golden/{ => exec}/apply2/source.scm | 0 golden/{ => exec}/arith/exec | 0 golden/{ => exec}/arith/source.scm | 0 golden/{ => exec}/callcc-constant/exec | 0 golden/{ => exec}/callcc-constant/source.scm | 0 golden/{ => exec}/callcc-discard/exec | 0 golden/{ => exec}/callcc-discard/source.scm | 0 golden/{ => exec}/callcc-nested1/exec | 0 golden/{ => exec}/callcc-nested1/source.scm | 0 golden/{ => exec}/callcc-nested2/exec | 0 golden/{ => exec}/callcc-nested2/source.scm | 0 golden/{ => exec}/factorial/exec | 0 golden/{ => exec}/factorial/source.scm | 0 golden/{ => exec}/false/exec | 0 golden/{ => exec}/false/source.scm | 0 golden/{ => exec}/fn-of-fn/exec | 0 golden/{ => exec}/fn-of-fn/source.scm | 0 golden/{ => exec}/if-false/exec | 0 golden/{ => exec}/if-false/source.scm | 0 golden/{ => exec}/if-number/exec | 0 golden/{ => exec}/if-number/source.scm | 0 golden/{ => exec}/if-true/exec | 0 golden/{ => exec}/if-true/source.scm | 0 golden/{ => exec}/lambda/exec | 0 golden/{ => exec}/lambda/source.scm | 0 golden/{ => exec}/let-fn/exec | 0 golden/{ => exec}/let-fn/source.scm | 0 golden/{ => exec}/letrec-fn/exec | 0 golden/{ => exec}/letrec-fn/source.scm | 0 golden/{ => exec}/square/exec | 0 golden/{ => exec}/square/source.scm | 0 golden/{ => exec}/true/exec | 0 golden/{ => exec}/true/source.scm | 0 golden/reader/bool/read | 9 ++ golden/reader/bool/source.scm | 1 + golden/reader/decimal/read | 15 ++ golden/reader/decimal/source.scm | 1 + golden/reader/delimited-identifier/read | 5 + golden/reader/delimited-identifier/source.scm | 1 + golden/reader/empty/read | 1 + golden/reader/empty/source.scm | 0 golden/reader/peculiar-identifier/read | 9 ++ golden/reader/peculiar-identifier/source.scm | 1 + golden/reader/string-line-continuation/read | 5 + .../string-line-continuation/source.scm | 2 + golden/reader/string/read | 5 + golden/reader/string/source.scm | 1 + golden/reader/typical-identifier/read | 29 ++++ golden/reader/typical-identifier/source.scm | 1 + gyehoek.cabal | 7 + src/Gyehoek/Prelude.hs | 2 +- src/Gyehoek/Sexp/Read.hs | 131 +++++++++++++++++- src/Gyehoek/Sexp/Syntax.hs | 36 +++-- test/Gyehoek/Test/Golden.hs | 38 ++++- 59 files changed, 284 insertions(+), 16 deletions(-) rename golden/{ => exec}/adder/exec (100%) rename golden/{ => exec}/adder/source.scm (100%) rename golden/{ => exec}/apply-twice/exec (100%) rename golden/{ => exec}/apply-twice/source.scm (100%) rename golden/{ => exec}/apply2/exec (100%) rename golden/{ => exec}/apply2/source.scm (100%) rename golden/{ => exec}/arith/exec (100%) rename golden/{ => exec}/arith/source.scm (100%) rename golden/{ => exec}/callcc-constant/exec (100%) rename golden/{ => exec}/callcc-constant/source.scm (100%) rename golden/{ => exec}/callcc-discard/exec (100%) rename golden/{ => exec}/callcc-discard/source.scm (100%) rename golden/{ => exec}/callcc-nested1/exec (100%) rename golden/{ => exec}/callcc-nested1/source.scm (100%) rename golden/{ => exec}/callcc-nested2/exec (100%) rename golden/{ => exec}/callcc-nested2/source.scm (100%) rename golden/{ => exec}/factorial/exec (100%) rename golden/{ => exec}/factorial/source.scm (100%) rename golden/{ => exec}/false/exec (100%) rename golden/{ => exec}/false/source.scm (100%) rename golden/{ => exec}/fn-of-fn/exec (100%) rename golden/{ => exec}/fn-of-fn/source.scm (100%) rename golden/{ => exec}/if-false/exec (100%) rename golden/{ => exec}/if-false/source.scm (100%) rename golden/{ => exec}/if-number/exec (100%) rename golden/{ => exec}/if-number/source.scm (100%) rename golden/{ => exec}/if-true/exec (100%) rename golden/{ => exec}/if-true/source.scm (100%) rename golden/{ => exec}/lambda/exec (100%) rename golden/{ => exec}/lambda/source.scm (100%) rename golden/{ => exec}/let-fn/exec (100%) rename golden/{ => exec}/let-fn/source.scm (100%) rename golden/{ => exec}/letrec-fn/exec (100%) rename golden/{ => exec}/letrec-fn/source.scm (100%) rename golden/{ => exec}/square/exec (100%) rename golden/{ => exec}/square/source.scm (100%) rename golden/{ => exec}/true/exec (100%) rename golden/{ => exec}/true/source.scm (100%) create mode 100644 golden/reader/bool/read create mode 100644 golden/reader/bool/source.scm create mode 100644 golden/reader/decimal/read create mode 100644 golden/reader/decimal/source.scm create mode 100644 golden/reader/delimited-identifier/read create mode 100644 golden/reader/delimited-identifier/source.scm create mode 100644 golden/reader/empty/read create mode 100644 golden/reader/empty/source.scm create mode 100644 golden/reader/peculiar-identifier/read create mode 100644 golden/reader/peculiar-identifier/source.scm create mode 100644 golden/reader/string-line-continuation/read create mode 100644 golden/reader/string-line-continuation/source.scm create mode 100644 golden/reader/string/read create mode 100644 golden/reader/string/source.scm create mode 100644 golden/reader/typical-identifier/read create mode 100644 golden/reader/typical-identifier/source.scm 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/reader/bool/read b/golden/reader/bool/read new file mode 100644 index 0000000..310c858 --- /dev/null +++ b/golden/reader/bool/read @@ -0,0 +1,9 @@ +[ Fix + ( SimpleF ( Boolean True ) ) +, Fix + ( SimpleF ( Boolean True ) ) +, Fix + ( SimpleF ( Boolean False ) ) +, Fix + ( SimpleF ( Boolean False ) ) +] \ No newline at end of file diff --git a/golden/reader/bool/source.scm b/golden/reader/bool/source.scm new file mode 100644 index 0000000..84af926 --- /dev/null +++ b/golden/reader/bool/source.scm @@ -0,0 +1 @@ +#t #true #f #false diff --git a/golden/reader/decimal/read b/golden/reader/decimal/read new file mode 100644 index 0000000..1b3cade --- /dev/null +++ b/golden/reader/decimal/read @@ -0,0 +1,15 @@ +[ Fix + ( SimpleF + ( Number 45.0 ) + ) +, Fix + ( SimpleF + ( Number 5667.0 ) + ) +, Fix + ( SimpleF + ( Number + ( -123.0 ) + ) + ) +] \ No newline at end of file diff --git a/golden/reader/decimal/source.scm b/golden/reader/decimal/source.scm new file mode 100644 index 0000000..58684bc --- /dev/null +++ b/golden/reader/decimal/source.scm @@ -0,0 +1 @@ +45 +5667 -123 diff --git a/golden/reader/delimited-identifier/read b/golden/reader/delimited-identifier/read new file mode 100644 index 0000000..b84aa6a --- /dev/null +++ b/golden/reader/delimited-identifier/read @@ -0,0 +1,5 @@ +[ Fix + ( SimpleF + ( Symbol "aaaa bc" ) + ) +] \ No newline at end of file diff --git a/golden/reader/delimited-identifier/source.scm b/golden/reader/delimited-identifier/source.scm new file mode 100644 index 0000000..e067c11 --- /dev/null +++ b/golden/reader/delimited-identifier/source.scm @@ -0,0 +1 @@ +|aaaa bc| diff --git a/golden/reader/empty/read b/golden/reader/empty/read new file mode 100644 index 0000000..0637a08 --- /dev/null +++ b/golden/reader/empty/read @@ -0,0 +1 @@ +[] \ No newline at end of file diff --git a/golden/reader/empty/source.scm b/golden/reader/empty/source.scm new file mode 100644 index 0000000..e69de29 diff --git a/golden/reader/peculiar-identifier/read b/golden/reader/peculiar-identifier/read new file mode 100644 index 0000000..ef7025d --- /dev/null +++ b/golden/reader/peculiar-identifier/read @@ -0,0 +1,9 @@ +[ Fix + ( SimpleF + ( Symbol "+" ) + ) +, Fix + ( SimpleF + ( Symbol "-" ) + ) +] \ No newline at end of file diff --git a/golden/reader/peculiar-identifier/source.scm b/golden/reader/peculiar-identifier/source.scm new file mode 100644 index 0000000..c52cc3a --- /dev/null +++ b/golden/reader/peculiar-identifier/source.scm @@ -0,0 +1 @@ ++ - diff --git a/golden/reader/string-line-continuation/read b/golden/reader/string-line-continuation/read new file mode 100644 index 0000000..3795d82 --- /dev/null +++ b/golden/reader/string-line-continuation/read @@ -0,0 +1,5 @@ +[ Fix + ( SimpleF + ( String "가나다라마바" ) + ) +] \ No newline at end of file diff --git a/golden/reader/string-line-continuation/source.scm b/golden/reader/string-line-continuation/source.scm new file mode 100644 index 0000000..0c26be9 --- /dev/null +++ b/golden/reader/string-line-continuation/source.scm @@ -0,0 +1,2 @@ +"가나다\ + 라마바" diff --git a/golden/reader/string/read b/golden/reader/string/read new file mode 100644 index 0000000..71ddf65 --- /dev/null +++ b/golden/reader/string/read @@ -0,0 +1,5 @@ +[ Fix + ( SimpleF + ( String "가나다라" ) + ) +] \ No newline at end of file diff --git a/golden/reader/string/source.scm b/golden/reader/string/source.scm new file mode 100644 index 0000000..9351d56 --- /dev/null +++ b/golden/reader/string/source.scm @@ -0,0 +1 @@ +"가나다라" diff --git a/golden/reader/typical-identifier/read b/golden/reader/typical-identifier/read new file mode 100644 index 0000000..31a3925 --- /dev/null +++ b/golden/reader/typical-identifier/read @@ -0,0 +1,29 @@ +[ Fix + ( SimpleF + ( Symbol "abc" ) + ) +, Fix + ( SimpleF + ( Symbol "balahwa$" ) + ) +, Fix + ( SimpleF + ( Symbol "x!!!" ) + ) +, Fix + ( SimpleF + ( Symbol "z" ) + ) +, Fix + ( SimpleF + ( Symbol "z123" ) + ) +, Fix + ( SimpleF + ( Symbol "나는너무졸리다" ) + ) +, Fix + ( SimpleF + ( Symbol "學" ) + ) +] \ No newline at end of file diff --git a/golden/reader/typical-identifier/source.scm b/golden/reader/typical-identifier/source.scm new file mode 100644 index 0000000..bfcfcf8 --- /dev/null +++ b/golden/reader/typical-identifier/source.scm @@ -0,0 +1 @@ +abc balahwa$ x!!! z z123 나는너무졸리다 學 diff --git a/gyehoek.cabal b/gyehoek.cabal index e1ec645..04b9560 100644 --- a/gyehoek.cabal +++ b/gyehoek.cabal @@ -77,12 +77,16 @@ library , 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 @@ -114,6 +118,8 @@ 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 @@ -133,6 +139,7 @@ test-suite test , generic-lens , gyehoek , lens + , pretty-simple , process-extras , sexp-grammar , tasty diff --git a/src/Gyehoek/Prelude.hs b/src/Gyehoek/Prelude.hs index 10e66a8..d9a6022 100644 --- a/src/Gyehoek/Prelude.hs +++ b/src/Gyehoek/Prelude.hs @@ -21,7 +21,7 @@ module Gyehoek.Prelude import Control.Lens 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) diff --git a/src/Gyehoek/Sexp/Read.hs b/src/Gyehoek/Sexp/Read.hs index 12a0530..0eb5e4d 100644 --- a/src/Gyehoek/Sexp/Read.hs +++ b/src/Gyehoek/Sexp/Read.hs @@ -1,4 +1,133 @@ module Gyehoek.Sexp.Read - ( + ( readFile ) 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 System.IO (stderr, hPutStrLn) +import Prelude hiding (readFile) +import Data.Functor (($>)) +import qualified Data.Text as T +import Data.Char (GeneralCategory(..), generalCategory) +import Control.Exception hiding (try) +import Data.Scientific (Scientific) + + +-- i'm lazy +newtype ReaderError = MkReaderError String + deriving (Show) + +instance Exception ReaderError where + displayException (MkReaderError x) = x + +readFile :: 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 e -> do + -- liftIO . hPutStrLn stderr . errorBundlePretty $ e + liftIO . throw . MkReaderError . errorBundlePretty $ e + +type P = Parsec Void Text + + +--- lexer helpers + +-- TODO: check R⁷RS +sc :: P () +sc = L.space space1 + (L.skipLineComment ";") + (L.skipBlockCommentNested "#|" "|#") + +lexeme :: P a -> P a +lexeme = L.lexeme sc + +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 identChar + initial = satisfy \c -> + identChar c && not (c `hasCategory` + [DecimalNumber,SpacingCombiningMark,EnclosingMark]) + delimited = _ + peculiar = _ + + hasCategory c xs = generalCategory c `elem` xs + identChar c = c `hasCategory` + [ UppercaseLetter, LowercaseLetter, TitlecaseLetter, ModifierLetter + , OtherLetter, SpacingCombiningMark, EnclosingMark, DecimalNumber + , LetterNumber, OtherNumber, DashPunctuation, ConnectorPunctuation + , OpenPunctuation, CurrencySymbol, OtherPunctuation, MathSymbol + , ModifierSymbol, OtherSymbol, PrivateUse ] + || c == '\x200c' || c == '\x200d' + +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 ')' + +string :: P Text +string = label "string" . lexeme $ + char '"' *> (T.pack <$> many element) <* char '"' + where + element = choice + [ satisfy (\c -> c /= '"' && c /= '\\') + , "\\\"" $> '"' + , "\\\\" $> '\\' + ] + + + +file :: P (List Datum) +file = many datum <* eof + +datum :: P Datum +datum = choice + [ Fix . SimpleF <$> simpleDatum + -- , Fix . CompoundF <$> compoundDatum + -- , labeled + -- , labelRef + ] + +simpleDatum :: P Simple +simpleDatum = choice + [ Boolean <$> boolean + , Number <$> try number + -- , Character <$> character + , String <$> string + , Symbol <$> symbol + -- , Bytevector <$> bytevector + ] diff --git a/src/Gyehoek/Sexp/Syntax.hs b/src/Gyehoek/Sexp/Syntax.hs index 8afba00..e63420c 100644 --- a/src/Gyehoek/Sexp/Syntax.hs +++ b/src/Gyehoek/Sexp/Syntax.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE TemplateHaskell #-} module Gyehoek.Sexp.Syntax ( DatumF(..) , Simple(..) @@ -6,12 +7,22 @@ module Gyehoek.Sexp.Syntax , Prefix(..) , Delimiter(..) , Label(..) + , SourcePos(..) + , Datum + , Cofree((:<)) + , Fix(..) ) where import Language.Haskell.TH.Syntax (Lift) import Data.Scientific (Scientific) import Data.ByteString (ByteString) -import Gyehoek.Prelude hiding (Simple) +import Gyehoek.Prelude hiding ((:<), Simple) +import Text.Megaparsec.Pos (SourcePos(..)) +import Control.Comonad.Cofree (Cofree((:<))) +import Data.Fix (Fix (..)) +import Data.Functor.Foldable +import Text.Show.Deriving (deriveShow1) +import qualified Control.Comonad.Trans.Cofree as F data DatumF a @@ -19,16 +30,16 @@ data DatumF a | CompoundF (CompoundF a) | LabeledF Label a | LabelRefF Label - deriving stock (Show, Eq, Data, Generic, Lift) + deriving stock (Show, Eq, Data, Generic, Lift, Functor, Foldable, Traversable) deriving anyclass (NFData) data Simple - = SimpleBool Bool - | SimpleNumber Scientific - | SimpleChar Char - | SimpleString Text - | SimpleSymbol Text - | SimpleBytevector ByteString + = Boolean Bool + | Number Scientific + | Character Char + | String Text + | Symbol Text + | Bytevector ByteString deriving stock (Show, Eq, Data, Generic, Lift) deriving anyclass (NFData) @@ -37,7 +48,7 @@ data CompoundF a | DotListF (NonEmpty a) a | VectorF (List a) | AbbrevF Prefix a - deriving stock (Show, Eq, Data, Generic, Lift) + deriving stock (Show, Eq, Data, Generic, Lift, Functor, Foldable, Traversable) deriving anyclass (NFData) data Prefix @@ -56,3 +67,10 @@ newtype Label = MkLabel Natural deriving stock (Data, Generic, Lift) deriving newtype (Eq, Ord, Show) deriving anyclass (NFData) + +deriveShow1 ''CompoundF +deriveShow1 ''DatumF + + + +type Datum = Fix DatumF diff --git a/test/Gyehoek/Test/Golden.hs b/test/Gyehoek/Test/Golden.hs index bd83f50..5085890 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 @@ -31,12 +35,17 @@ brokenStackifyTests = -- , "callcc-nested1" -- requires closure-conversion -- ] +brokenReaderTests = + [ "delimited-identifier" + , "string-line-continuation" + ] + 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 +57,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 +73,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" @@ -81,3 +90,22 @@ stackifyTests files = do resultfile action printProcResult + +test_reader :: IO TestTree +test_reader = do + all_cases <- listDirectory "golden/reader" + let tests = all_cases + & fmap ("golden/reader") + pure . testGroup "reader" $ tests <&> \test -> + let testname = takeFileName test + scmfile = test "source.scm" + resultfile = test "read" + action = runEff $ Read.readFile scmfile + in maybeBroken testname brokenReaderTests $ goldenVsAction + testname + resultfile + action + (view strict . pShowNoColor) + +-- readTests files = pure . testGroup "reader" $ files <&> \test -> +-- let -- 2.54.0 From 6ff01a8607298a773d4f3b3aaf7daa407e98bb0d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Fri, 21 Aug 2026 02:03:28 -0600 Subject: [PATCH 03/13] parse lists --- golden/reader/list-dot-flat/read | 25 +++++++++ golden/reader/list-dot-flat/source.scm | 1 + golden/reader/list-flat/read | 35 ++++++++++++ golden/reader/list-flat/source.scm | 1 + golden/reader/list/read | 60 +++++++++++++++++++++ golden/reader/list/source.scm | 1 + golden/reader/typical-identifier/read | 10 +++- golden/reader/typical-identifier/source.scm | 6 ++- src/Gyehoek/Sexp/Read.hs | 54 ++++++++++++++----- src/Gyehoek/Sexp/Syntax.hs | 2 + 10 files changed, 181 insertions(+), 14 deletions(-) create mode 100644 golden/reader/list-dot-flat/read create mode 100644 golden/reader/list-dot-flat/source.scm create mode 100644 golden/reader/list-flat/read create mode 100644 golden/reader/list-flat/source.scm create mode 100644 golden/reader/list/read create mode 100644 golden/reader/list/source.scm diff --git a/golden/reader/list-dot-flat/read b/golden/reader/list-dot-flat/read new file mode 100644 index 0000000..1276fe6 --- /dev/null +++ b/golden/reader/list-dot-flat/read @@ -0,0 +1,25 @@ +[ Fix + ( CompoundF + ( DotListF + ( Fix + ( SimpleF + ( Symbol "가" ) + ) :| + [ Fix + ( SimpleF + ( Symbol "나" ) + ) + , Fix + ( SimpleF + ( Symbol "다" ) + ) + ] + ) + ( Fix + ( SimpleF + ( Symbol "라" ) + ) + ) + ) + ) +] \ No newline at end of file diff --git a/golden/reader/list-dot-flat/source.scm b/golden/reader/list-dot-flat/source.scm new file mode 100644 index 0000000..13788b9 --- /dev/null +++ b/golden/reader/list-dot-flat/source.scm @@ -0,0 +1 @@ +(가 나 다 . 라) diff --git a/golden/reader/list-flat/read b/golden/reader/list-flat/read new file mode 100644 index 0000000..3bd5792 --- /dev/null +++ b/golden/reader/list-flat/read @@ -0,0 +1,35 @@ +[ Fix + ( CompoundF + ( ListF + [ Fix + ( SimpleF + ( Symbol "가" ) + ) + , Fix + ( SimpleF + ( Symbol "나" ) + ) + , Fix + ( SimpleF + ( Symbol "다" ) + ) + , Fix + ( SimpleF + ( Symbol "라" ) + ) + , Fix + ( SimpleF + ( Number 1.0 ) + ) + , Fix + ( SimpleF + ( Number 2.0 ) + ) + , Fix + ( SimpleF + ( Number 3.0 ) + ) + ] + ) + ) +] \ No newline at end of file diff --git a/golden/reader/list-flat/source.scm b/golden/reader/list-flat/source.scm new file mode 100644 index 0000000..d72527e --- /dev/null +++ b/golden/reader/list-flat/source.scm @@ -0,0 +1 @@ +(가 나 다 라 1 2 3) diff --git a/golden/reader/list/read b/golden/reader/list/read new file mode 100644 index 0000000..4db4f9a --- /dev/null +++ b/golden/reader/list/read @@ -0,0 +1,60 @@ +[ Fix + ( CompoundF + ( DotListF + ( Fix + ( SimpleF + ( Symbol "a" ) + ) :| + [ Fix + ( SimpleF + ( Symbol "b" ) + ) + , Fix + ( CompoundF + ( ListF + [ Fix + ( SimpleF + ( Symbol "c" ) + ) + , Fix + ( SimpleF + ( Symbol "d" ) + ) + ] + ) + ) + ] + ) + ( Fix + ( CompoundF + ( ListF + [ Fix + ( SimpleF + ( Symbol "가" ) + ) + , Fix + ( CompoundF + ( DotListF + ( Fix + ( SimpleF + ( Symbol "나" ) + ) :| [] + ) + ( Fix + ( SimpleF + ( Symbol "다" ) + ) + ) + ) + ) + , Fix + ( SimpleF + ( Symbol "라" ) + ) + ] + ) + ) + ) + ) + ) +] \ No newline at end of file diff --git a/golden/reader/list/source.scm b/golden/reader/list/source.scm new file mode 100644 index 0000000..7b19db2 --- /dev/null +++ b/golden/reader/list/source.scm @@ -0,0 +1 @@ +(a b (c d) . (가 (나 . 다) 라)) diff --git a/golden/reader/typical-identifier/read b/golden/reader/typical-identifier/read index 31a3925..1a8cb2e 100644 --- a/golden/reader/typical-identifier/read +++ b/golden/reader/typical-identifier/read @@ -4,7 +4,7 @@ ) , Fix ( SimpleF - ( Symbol "balahwa$" ) + ( Symbol "bala-hwa$" ) ) , Fix ( SimpleF @@ -26,4 +26,12 @@ ( SimpleF ( Symbol "學" ) ) +, Fix + ( SimpleF + ( Symbol "車室." ) + ) +, Fix + ( SimpleF + ( Symbol "三個女人一臺戲。" ) + ) ] \ No newline at end of file diff --git a/golden/reader/typical-identifier/source.scm b/golden/reader/typical-identifier/source.scm index bfcfcf8..95d49bc 100644 --- a/golden/reader/typical-identifier/source.scm +++ b/golden/reader/typical-identifier/source.scm @@ -1 +1,5 @@ -abc balahwa$ x!!! z z123 나는너무졸리다 學 +abc bala-hwa$ x!!! z z123 나는너무졸리다 學 + +車室. + +三個女人一臺戲。 diff --git a/src/Gyehoek/Sexp/Read.hs b/src/Gyehoek/Sexp/Read.hs index 0eb5e4d..711c22a 100644 --- a/src/Gyehoek/Sexp/Read.hs +++ b/src/Gyehoek/Sexp/Read.hs @@ -11,7 +11,7 @@ import Gyehoek.Prelude hiding (Simple, (:<)) import qualified Data.Text.IO as T import System.IO (stderr, hPutStrLn) import Prelude hiding (readFile) -import Data.Functor (($>)) +import Data.Functor (($>), void) import qualified Data.Text as T import Data.Char (GeneralCategory(..), generalCategory) import Control.Exception hiding (try) @@ -57,25 +57,28 @@ verb = L.symbol sc identifier :: P Text identifier = label "identifier" . lexeme . choice $ [ typical-- , delimited, peculiar - ] + ] where typical = T.cons <$> initial <*> subsequent where - subsequent = takeWhileP Nothing identChar - initial = satisfy \c -> - identChar c && not (c `hasCategory` - [DecimalNumber,SpacingCombiningMark,EnclosingMark]) + 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 - identChar c = c `hasCategory` + isInitial c = (c `hasCategory` [ UppercaseLetter, LowercaseLetter, TitlecaseLetter, ModifierLetter - , OtherLetter, SpacingCombiningMark, EnclosingMark, DecimalNumber + , OtherLetter + -- , SpacingCombiningMark, EnclosingMark, DecimalNumber , LetterNumber, OtherNumber, DashPunctuation, ConnectorPunctuation - , OpenPunctuation, CurrencySymbol, OtherPunctuation, MathSymbol + , CurrencySymbol, OtherPunctuation, MathSymbol , ModifierSymbol, OtherSymbol, PrivateUse ] - || c == '\x200c' || c == '\x200d' + || c == '\x200c' || c == '\x200d') + && c /= ';' && c /= '|' && c /= '"' && c /= '.' boolean :: P Bool boolean = label "boolean" . lexeme $ choice @@ -98,6 +101,18 @@ number = label "number" . lexeme $ num 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 $ @@ -116,8 +131,8 @@ file = many datum <* eof datum :: P Datum datum = choice - [ Fix . SimpleF <$> simpleDatum - -- , Fix . CompoundF <$> compoundDatum + [ Fix . CompoundF <$> compoundDatum + , Fix . SimpleF <$> simpleDatum -- , labeled -- , labelRef ] @@ -131,3 +146,18 @@ simpleDatum = choice , Symbol <$> symbol -- , Bytevector <$> bytevector ] + +compoundDatum :: P Compound +compoundDatum = choice + [ list + ] + +list :: P Compound +list = label "list" . between lparen rparen $ do + optional datum >>= \case + Nothing -> pure $ ListF [] + Just x -> do + xs <- many datum + optional (dot *> datum) >>= \case + Nothing -> pure $ ListF (x:xs) + Just y -> pure $ DotListF (x:|xs) y diff --git a/src/Gyehoek/Sexp/Syntax.hs b/src/Gyehoek/Sexp/Syntax.hs index e63420c..ae10e19 100644 --- a/src/Gyehoek/Sexp/Syntax.hs +++ b/src/Gyehoek/Sexp/Syntax.hs @@ -11,6 +11,7 @@ module Gyehoek.Sexp.Syntax , Datum , Cofree((:<)) , Fix(..) + , Compound ) where import Language.Haskell.TH.Syntax (Lift) @@ -74,3 +75,4 @@ deriveShow1 ''DatumF type Datum = Fix DatumF +type Compound = CompoundF Datum -- 2.54.0 From b234a52d4bf289e71028d77698584dc7f6683732 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Fri, 21 Aug 2026 15:01:22 -0600 Subject: [PATCH 04/13] wip: printer --- golden/print/flat | 1 + golden/print/long | 4 + golden/print/null | 1 + golden/read/bool/read | 5 + golden/{reader => read}/bool/source.scm | 0 golden/read/decimal/read | 9 ++ golden/{reader => read}/decimal/source.scm | 0 .../delimited-identifier/read | 0 .../delimited-identifier/source.scm | 0 golden/{reader => read}/empty/read | 0 golden/{reader => read}/empty/source.scm | 0 golden/read/list-dot-flat/read | 17 ++++ .../{reader => read}/list-dot-flat/source.scm | 0 golden/read/list-flat/read | 19 ++++ golden/{reader => read}/list-flat/source.scm | 0 golden/read/list/read | 40 ++++++++ golden/{reader => read}/list/source.scm | 0 golden/read/peculiar-identifier/read | 5 + .../peculiar-identifier/source.scm | 0 .../string-line-continuation/read | 0 .../string-line-continuation/source.scm | 0 golden/read/string/read | 3 + golden/{reader => read}/string/source.scm | 0 golden/read/typical-identifier/read | 19 ++++ .../typical-identifier/source.scm | 0 golden/reader/bool/read | 9 -- golden/reader/decimal/read | 15 --- golden/reader/list-dot-flat/read | 25 ----- golden/reader/list-flat/read | 35 ------- golden/reader/list/read | 60 ----------- golden/reader/peculiar-identifier/read | 9 -- golden/reader/string/read | 5 - golden/reader/typical-identifier/read | 37 ------- gyehoek.cabal | 4 +- src/Gyehoek/Prelude.hs | 2 + src/Gyehoek/Sexp/Print.hs | 73 +++++++++++++- src/Gyehoek/Sexp/Read.hs | 33 ++++--- src/Gyehoek/Sexp/Syntax.hs | 99 ++++++++++++++++--- test/Gyehoek/Test/Golden.hs | 4 +- test/Gyehoek/Test/Sexp/Print.hs | 29 ++++++ 40 files changed, 341 insertions(+), 221 deletions(-) create mode 100644 golden/print/flat create mode 100644 golden/print/long create mode 100644 golden/print/null create mode 100644 golden/read/bool/read rename golden/{reader => read}/bool/source.scm (100%) create mode 100644 golden/read/decimal/read rename golden/{reader => read}/decimal/source.scm (100%) rename golden/{reader => read}/delimited-identifier/read (100%) rename golden/{reader => read}/delimited-identifier/source.scm (100%) rename golden/{reader => read}/empty/read (100%) rename golden/{reader => read}/empty/source.scm (100%) create mode 100644 golden/read/list-dot-flat/read rename golden/{reader => read}/list-dot-flat/source.scm (100%) create mode 100644 golden/read/list-flat/read rename golden/{reader => read}/list-flat/source.scm (100%) create mode 100644 golden/read/list/read rename golden/{reader => read}/list/source.scm (100%) create mode 100644 golden/read/peculiar-identifier/read rename golden/{reader => read}/peculiar-identifier/source.scm (100%) rename golden/{reader => read}/string-line-continuation/read (100%) rename golden/{reader => read}/string-line-continuation/source.scm (100%) create mode 100644 golden/read/string/read rename golden/{reader => read}/string/source.scm (100%) create mode 100644 golden/read/typical-identifier/read rename golden/{reader => read}/typical-identifier/source.scm (100%) delete mode 100644 golden/reader/bool/read delete mode 100644 golden/reader/decimal/read delete mode 100644 golden/reader/list-dot-flat/read delete mode 100644 golden/reader/list-flat/read delete mode 100644 golden/reader/list/read delete mode 100644 golden/reader/peculiar-identifier/read delete mode 100644 golden/reader/string/read delete mode 100644 golden/reader/typical-identifier/read create mode 100644 test/Gyehoek/Test/Sexp/Print.hs diff --git a/golden/print/flat b/golden/print/flat new file mode 100644 index 0000000..c955446 --- /dev/null +++ b/golden/print/flat @@ -0,0 +1 @@ +(가 나 다 라) \ No newline at end of file diff --git a/golden/print/long b/golden/print/long new file mode 100644 index 0000000..b9fa7cd --- /dev/null +++ b/golden/print/long @@ -0,0 +1,4 @@ +(가 + 나 + 다 + 라) \ 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/read/bool/read b/golden/read/bool/read new file mode 100644 index 0000000..c37392f --- /dev/null +++ b/golden/read/bool/read @@ -0,0 +1,5 @@ +[ SynNone :< SimpleF ( SimpleBoolean True ) +, SynNone :< SimpleF ( SimpleBoolean True ) +, SynNone :< SimpleF ( SimpleBoolean False ) +, SynNone :< SimpleF ( SimpleBoolean False ) +] \ No newline at end of file diff --git a/golden/reader/bool/source.scm b/golden/read/bool/source.scm similarity index 100% rename from golden/reader/bool/source.scm rename to golden/read/bool/source.scm diff --git a/golden/read/decimal/read b/golden/read/decimal/read new file mode 100644 index 0000000..36dd7be --- /dev/null +++ b/golden/read/decimal/read @@ -0,0 +1,9 @@ +[ SynNone :< SimpleF + ( SimpleNumber 45.0 ) +, SynNone :< SimpleF + ( SimpleNumber 5667.0 ) +, SynNone :< SimpleF + ( SimpleNumber + ( -123.0 ) + ) +] \ No newline at end of file diff --git a/golden/reader/decimal/source.scm b/golden/read/decimal/source.scm similarity index 100% rename from golden/reader/decimal/source.scm rename to golden/read/decimal/source.scm diff --git a/golden/reader/delimited-identifier/read b/golden/read/delimited-identifier/read similarity index 100% rename from golden/reader/delimited-identifier/read rename to golden/read/delimited-identifier/read diff --git a/golden/reader/delimited-identifier/source.scm b/golden/read/delimited-identifier/source.scm similarity index 100% rename from golden/reader/delimited-identifier/source.scm rename to golden/read/delimited-identifier/source.scm diff --git a/golden/reader/empty/read b/golden/read/empty/read similarity index 100% rename from golden/reader/empty/read rename to golden/read/empty/read diff --git a/golden/reader/empty/source.scm b/golden/read/empty/source.scm similarity index 100% rename from golden/reader/empty/source.scm rename to golden/read/empty/source.scm diff --git a/golden/read/list-dot-flat/read b/golden/read/list-dot-flat/read new file mode 100644 index 0000000..df2e6c9 --- /dev/null +++ b/golden/read/list-dot-flat/read @@ -0,0 +1,17 @@ +[ SynNone :< CompoundF + ( DotListF + ( + ( SynNone :< SimpleF + ( SimpleSymbol "가" ) + ) :| + [ SynNone :< SimpleF + ( SimpleSymbol "나" ) + , SynNone :< SimpleF + ( SimpleSymbol "다" ) + ] + ) + ( SynNone :< SimpleF + ( SimpleSymbol "라" ) + ) + ) +] \ No newline at end of file diff --git a/golden/reader/list-dot-flat/source.scm b/golden/read/list-dot-flat/source.scm similarity index 100% rename from golden/reader/list-dot-flat/source.scm rename to golden/read/list-dot-flat/source.scm diff --git a/golden/read/list-flat/read b/golden/read/list-flat/read new file mode 100644 index 0000000..e933982 --- /dev/null +++ b/golden/read/list-flat/read @@ -0,0 +1,19 @@ +[ SynNone :< CompoundF + ( ListF Ordinary + [ SynNone :< SimpleF + ( SimpleSymbol "가" ) + , SynNone :< SimpleF + ( SimpleSymbol "나" ) + , SynNone :< SimpleF + ( SimpleSymbol "다" ) + , SynNone :< SimpleF + ( SimpleSymbol "라" ) + , SynNone :< SimpleF + ( SimpleNumber 1.0 ) + , SynNone :< SimpleF + ( SimpleNumber 2.0 ) + , SynNone :< SimpleF + ( SimpleNumber 3.0 ) + ] + ) +] \ No newline at end of file diff --git a/golden/reader/list-flat/source.scm b/golden/read/list-flat/source.scm similarity index 100% rename from golden/reader/list-flat/source.scm rename to golden/read/list-flat/source.scm diff --git a/golden/read/list/read b/golden/read/list/read new file mode 100644 index 0000000..2043de1 --- /dev/null +++ b/golden/read/list/read @@ -0,0 +1,40 @@ +[ SynNone :< CompoundF + ( DotListF + ( + ( SynNone :< SimpleF + ( SimpleSymbol "a" ) + ) :| + [ SynNone :< SimpleF + ( SimpleSymbol "b" ) + , SynNone :< CompoundF + ( ListF Ordinary + [ SynNone :< SimpleF + ( SimpleSymbol "c" ) + , SynNone :< SimpleF + ( SimpleSymbol "d" ) + ] + ) + ] + ) + ( SynNone :< CompoundF + ( ListF Ordinary + [ SynNone :< SimpleF + ( SimpleSymbol "가" ) + , SynNone :< CompoundF + ( DotListF + ( + ( SynNone :< SimpleF + ( SimpleSymbol "나" ) + ) :| [] + ) + ( SynNone :< SimpleF + ( SimpleSymbol "다" ) + ) + ) + , SynNone :< SimpleF + ( SimpleSymbol "라" ) + ] + ) + ) + ) +] \ No newline at end of file diff --git a/golden/reader/list/source.scm b/golden/read/list/source.scm similarity index 100% rename from golden/reader/list/source.scm rename to golden/read/list/source.scm diff --git a/golden/read/peculiar-identifier/read b/golden/read/peculiar-identifier/read new file mode 100644 index 0000000..9f2cdd5 --- /dev/null +++ b/golden/read/peculiar-identifier/read @@ -0,0 +1,5 @@ +[ SynNone :< SimpleF + ( SimpleSymbol "+" ) +, SynNone :< SimpleF + ( SimpleSymbol "-" ) +] \ No newline at end of file diff --git a/golden/reader/peculiar-identifier/source.scm b/golden/read/peculiar-identifier/source.scm similarity index 100% rename from golden/reader/peculiar-identifier/source.scm rename to golden/read/peculiar-identifier/source.scm diff --git a/golden/reader/string-line-continuation/read b/golden/read/string-line-continuation/read similarity index 100% rename from golden/reader/string-line-continuation/read rename to golden/read/string-line-continuation/read diff --git a/golden/reader/string-line-continuation/source.scm b/golden/read/string-line-continuation/source.scm similarity index 100% rename from golden/reader/string-line-continuation/source.scm rename to golden/read/string-line-continuation/source.scm diff --git a/golden/read/string/read b/golden/read/string/read new file mode 100644 index 0000000..c1f307e --- /dev/null +++ b/golden/read/string/read @@ -0,0 +1,3 @@ +[ SynNone :< SimpleF + ( SimpleString "가나다라" ) +] \ No newline at end of file diff --git a/golden/reader/string/source.scm b/golden/read/string/source.scm similarity index 100% rename from golden/reader/string/source.scm rename to golden/read/string/source.scm diff --git a/golden/read/typical-identifier/read b/golden/read/typical-identifier/read new file mode 100644 index 0000000..676bce0 --- /dev/null +++ b/golden/read/typical-identifier/read @@ -0,0 +1,19 @@ +[ SynNone :< SimpleF + ( SimpleSymbol "abc" ) +, SynNone :< SimpleF + ( SimpleSymbol "bala-hwa$" ) +, SynNone :< SimpleF + ( SimpleSymbol "x!!!" ) +, SynNone :< SimpleF + ( SimpleSymbol "z" ) +, SynNone :< SimpleF + ( SimpleSymbol "z123" ) +, SynNone :< SimpleF + ( SimpleSymbol "나는너무졸리다" ) +, SynNone :< SimpleF + ( SimpleSymbol "學" ) +, SynNone :< SimpleF + ( SimpleSymbol "車室." ) +, SynNone :< SimpleF + ( SimpleSymbol "三個女人一臺戲。" ) +] \ No newline at end of file diff --git a/golden/reader/typical-identifier/source.scm b/golden/read/typical-identifier/source.scm similarity index 100% rename from golden/reader/typical-identifier/source.scm rename to golden/read/typical-identifier/source.scm diff --git a/golden/reader/bool/read b/golden/reader/bool/read deleted file mode 100644 index 310c858..0000000 --- a/golden/reader/bool/read +++ /dev/null @@ -1,9 +0,0 @@ -[ Fix - ( SimpleF ( Boolean True ) ) -, Fix - ( SimpleF ( Boolean True ) ) -, Fix - ( SimpleF ( Boolean False ) ) -, Fix - ( SimpleF ( Boolean False ) ) -] \ No newline at end of file diff --git a/golden/reader/decimal/read b/golden/reader/decimal/read deleted file mode 100644 index 1b3cade..0000000 --- a/golden/reader/decimal/read +++ /dev/null @@ -1,15 +0,0 @@ -[ Fix - ( SimpleF - ( Number 45.0 ) - ) -, Fix - ( SimpleF - ( Number 5667.0 ) - ) -, Fix - ( SimpleF - ( Number - ( -123.0 ) - ) - ) -] \ No newline at end of file diff --git a/golden/reader/list-dot-flat/read b/golden/reader/list-dot-flat/read deleted file mode 100644 index 1276fe6..0000000 --- a/golden/reader/list-dot-flat/read +++ /dev/null @@ -1,25 +0,0 @@ -[ Fix - ( CompoundF - ( DotListF - ( Fix - ( SimpleF - ( Symbol "가" ) - ) :| - [ Fix - ( SimpleF - ( Symbol "나" ) - ) - , Fix - ( SimpleF - ( Symbol "다" ) - ) - ] - ) - ( Fix - ( SimpleF - ( Symbol "라" ) - ) - ) - ) - ) -] \ No newline at end of file diff --git a/golden/reader/list-flat/read b/golden/reader/list-flat/read deleted file mode 100644 index 3bd5792..0000000 --- a/golden/reader/list-flat/read +++ /dev/null @@ -1,35 +0,0 @@ -[ Fix - ( CompoundF - ( ListF - [ Fix - ( SimpleF - ( Symbol "가" ) - ) - , Fix - ( SimpleF - ( Symbol "나" ) - ) - , Fix - ( SimpleF - ( Symbol "다" ) - ) - , Fix - ( SimpleF - ( Symbol "라" ) - ) - , Fix - ( SimpleF - ( Number 1.0 ) - ) - , Fix - ( SimpleF - ( Number 2.0 ) - ) - , Fix - ( SimpleF - ( Number 3.0 ) - ) - ] - ) - ) -] \ No newline at end of file diff --git a/golden/reader/list/read b/golden/reader/list/read deleted file mode 100644 index 4db4f9a..0000000 --- a/golden/reader/list/read +++ /dev/null @@ -1,60 +0,0 @@ -[ Fix - ( CompoundF - ( DotListF - ( Fix - ( SimpleF - ( Symbol "a" ) - ) :| - [ Fix - ( SimpleF - ( Symbol "b" ) - ) - , Fix - ( CompoundF - ( ListF - [ Fix - ( SimpleF - ( Symbol "c" ) - ) - , Fix - ( SimpleF - ( Symbol "d" ) - ) - ] - ) - ) - ] - ) - ( Fix - ( CompoundF - ( ListF - [ Fix - ( SimpleF - ( Symbol "가" ) - ) - , Fix - ( CompoundF - ( DotListF - ( Fix - ( SimpleF - ( Symbol "나" ) - ) :| [] - ) - ( Fix - ( SimpleF - ( Symbol "다" ) - ) - ) - ) - ) - , Fix - ( SimpleF - ( Symbol "라" ) - ) - ] - ) - ) - ) - ) - ) -] \ No newline at end of file diff --git a/golden/reader/peculiar-identifier/read b/golden/reader/peculiar-identifier/read deleted file mode 100644 index ef7025d..0000000 --- a/golden/reader/peculiar-identifier/read +++ /dev/null @@ -1,9 +0,0 @@ -[ Fix - ( SimpleF - ( Symbol "+" ) - ) -, Fix - ( SimpleF - ( Symbol "-" ) - ) -] \ No newline at end of file diff --git a/golden/reader/string/read b/golden/reader/string/read deleted file mode 100644 index 71ddf65..0000000 --- a/golden/reader/string/read +++ /dev/null @@ -1,5 +0,0 @@ -[ Fix - ( SimpleF - ( String "가나다라" ) - ) -] \ No newline at end of file diff --git a/golden/reader/typical-identifier/read b/golden/reader/typical-identifier/read deleted file mode 100644 index 1a8cb2e..0000000 --- a/golden/reader/typical-identifier/read +++ /dev/null @@ -1,37 +0,0 @@ -[ Fix - ( SimpleF - ( Symbol "abc" ) - ) -, Fix - ( SimpleF - ( Symbol "bala-hwa$" ) - ) -, Fix - ( SimpleF - ( Symbol "x!!!" ) - ) -, Fix - ( SimpleF - ( Symbol "z" ) - ) -, Fix - ( SimpleF - ( Symbol "z123" ) - ) -, Fix - ( SimpleF - ( Symbol "나는너무졸리다" ) - ) -, Fix - ( SimpleF - ( Symbol "學" ) - ) -, Fix - ( SimpleF - ( Symbol "車室." ) - ) -, Fix - ( SimpleF - ( Symbol "三個女人一臺戲。" ) - ) -] \ No newline at end of file diff --git a/gyehoek.cabal b/gyehoek.cabal index 04b9560..1edac77 100644 --- a/gyehoek.cabal +++ b/gyehoek.cabal @@ -74,7 +74,7 @@ library Gyehoek.Wasm build-depends: - , base ^>=4.21.2.0 + , base ^>=4.21.2.0 , binary , bytestring , comonad @@ -97,6 +97,7 @@ library , ordered-containers , pretty-simple , prettyprinter + , prettyprinter-ansi-terminal , process , recursion-schemes , scientific @@ -127,6 +128,7 @@ test-suite test Gyehoek.Test.Golden Gyehoek.Test.Scheme.Syntax Gyehoek.Test.Sexp + Gyehoek.Test.Sexp.Print Gyehoek.Test.Stack.VM Root diff --git a/src/Gyehoek/Prelude.hs b/src/Gyehoek/Prelude.hs index d9a6022..ff3314a 100644 --- a/src/Gyehoek/Prelude.hs +++ b/src/Gyehoek/Prelude.hs @@ -16,6 +16,7 @@ module Gyehoek.Prelude , Hashable , NonEmpty((:|)) , Natural + , (>>>) ) where import Control.Lens @@ -35,4 +36,5 @@ import GHC.Stack (HasCallStack) import Data.Hashable (Hashable) import Data.List.NonEmpty (NonEmpty((:|))) import Numeric.Natural (Natural) +import Control.Category ((>>>)) diff --git a/src/Gyehoek/Sexp/Print.hs b/src/Gyehoek/Sexp/Print.hs index 66064c7..9d721fa 100644 --- a/src/Gyehoek/Sexp/Print.hs +++ b/src/Gyehoek/Sexp/Print.hs @@ -1,4 +1,75 @@ module Gyehoek.Sexp.Print - ( + ( printDatum + , printDatumW ) 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 Gyehoek.Sexp.Read (rd) +import Data.Foldable (traverse_) +import qualified Prettyprinter.Render.Terminal as ANSI +import System.IO (stdout) +import Prettyprinter.Render.Terminal (Color(..), color, italicized, AnsiStyle) + + +printDatum :: Datum -> Text +printDatum = printDatumW 80 + +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 = \case + syn :< SimpleF s -> annotate syn $ prettySimple depth s + syn :< CompoundF compound -> case compound of + ListF indent xs -> + case indent of + NSpecial 1 | special:body <- xs + -> pparen depth $ + nest 2 $ prettyDatum (depth+1) special + <+> vsep (prettyDatum (depth+1) <$> body) + Ordinary; NSpecial _ -> pparen depth $ + group . align . vsep $ + prettyDatum (depth+1) <$> xs + +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 -> annotate SynConstant $ viaShow n + SimpleString s -> annotate SynString $ viaShow s + SimpleSymbol s -> pretty s + +rdpr n s = rd s >>= traverse_ \x -> do + putDocW n . prettyDatum 0 $ x + putStr "\n" + +putDoc :: Doc Syn -> IO () +putDoc = ANSI.renderIO stdout + . reAnnotateS highlight . layoutSmart defaultLayoutOptions . (<>"\n") + +highlight :: Syn -> AnsiStyle +highlight = \case + SynBuiltin -> color Magenta <> italicized + SynParen n -> color $ rainbow ^?! ix n + _ -> mempty + where + rainbow = cycle [Red,Yellow,Green,Blue,Magenta,Cyan] diff --git a/src/Gyehoek/Sexp/Read.hs b/src/Gyehoek/Sexp/Read.hs index 711c22a..ebccb9c 100644 --- a/src/Gyehoek/Sexp/Read.hs +++ b/src/Gyehoek/Sexp/Read.hs @@ -1,5 +1,7 @@ module Gyehoek.Sexp.Read ( readFile + , readString + , rd ) where import Text.Megaparsec @@ -25,13 +27,22 @@ newtype ReaderError = MkReaderError String instance Exception ReaderError where displayException (MkReaderError x) = x + -- temp +rd = runEff . readString + readFile :: 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 e -> do - -- liftIO . hPutStrLn stderr . errorBundlePretty $ e + liftIO . throw . MkReaderError . errorBundlePretty $ e + +readString :: IOE :> es => Text -> Eff es (List Datum) +readString s = + case runParser file "" s of + Right x -> pure x + Left e -> do liftIO . throw . MkReaderError . errorBundlePretty $ e type P = Parsec Void Text @@ -131,20 +142,20 @@ file = many datum <* eof datum :: P Datum datum = choice - [ Fix . CompoundF <$> compoundDatum - , Fix . SimpleF <$> simpleDatum + [ (SynNone :<) . CompoundF <$> compoundDatum + , (SynNone :<) . SimpleF <$> simpleDatum -- , labeled -- , labelRef ] simpleDatum :: P Simple simpleDatum = choice - [ Boolean <$> boolean - , Number <$> try number - -- , Character <$> character - , String <$> string - , Symbol <$> symbol - -- , Bytevector <$> bytevector + [ SimpleBoolean <$> boolean + , SimpleNumber <$> try number + -- , SimpleCharacter <$> character + , SimpleString <$> string + , SimpleSymbol <$> symbol + -- , SimpleBytevector <$> bytevector ] compoundDatum :: P Compound @@ -155,9 +166,9 @@ compoundDatum = choice list :: P Compound list = label "list" . between lparen rparen $ do optional datum >>= \case - Nothing -> pure $ ListF [] + Nothing -> pure $ ListF Ordinary [] Just x -> do xs <- many datum optional (dot *> datum) >>= \case - Nothing -> pure $ ListF (x:xs) + 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 index ae10e19..45be9ab 100644 --- a/src/Gyehoek/Sexp/Syntax.hs +++ b/src/Gyehoek/Sexp/Syntax.hs @@ -12,6 +12,23 @@ module Gyehoek.Sexp.Syntax , Cofree((:<)) , Fix(..) , Compound + , Indentation(..) + , Syn(..) + , pattern Simple + , pattern Compound + , pattern Labeled + , pattern LabelRef + , pattern Abbrev + , pattern Vector + , pattern DotList + , pattern Gyehoek.Sexp.Syntax.List + , adorn + , pattern Bytevector + , pattern Symbol + , pattern String + , pattern Character + , pattern Number + , pattern Boolean ) where import Language.Haskell.TH.Syntax (Lift) @@ -35,17 +52,17 @@ data DatumF a deriving anyclass (NFData) data Simple - = Boolean Bool - | Number Scientific - | Character Char - | String Text - | Symbol Text - | Bytevector ByteString + = 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 (List a) + = ListF Indentation (List a) | DotListF (NonEmpty a) a | VectorF (List a) | AbbrevF Prefix a @@ -69,10 +86,70 @@ newtype Label = MkLabel Natural deriving newtype (Eq, Ord, Show) deriving anyclass (NFData) -deriveShow1 ''CompoundF -deriveShow1 ''DatumF + + +type Datum = Cofree DatumF Syn +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) -type Datum = Fix DatumF -type Compound = CompoundF Datum +deriveShow1 ''CompoundF +deriveShow1 ''DatumF + +adorn :: Syn -> Datum -> Datum +adorn syn (_ :< d) = syn :< d + +pattern Simple :: Simple -> Datum +pattern Simple a <- _ :< SimpleF a + where Simple a = SynNone :< SimpleF a + +pattern Compound :: CompoundF Datum -> Datum +pattern Compound a <- _ :< CompoundF a + where Compound a = SynNone :< CompoundF a + +pattern Labeled :: Label -> Datum -> Datum +pattern Labeled l a <- _ :< LabeledF l a + where Labeled l a = SynNone :< LabeledF l a + +pattern LabelRef :: Label -> Datum +pattern LabelRef l <- _ :< LabelRefF l + where LabelRef l = SynNone :< LabelRefF l + +pattern List :: List Datum -> Datum +pattern List a <- _ :< CompoundF (ListF _ a) + where List a = SynNone :< CompoundF (ListF Ordinary a) + +pattern DotList :: NonEmpty Datum -> Datum -> Datum +pattern DotList xs x <- _ :< CompoundF (DotListF xs x) + where DotList xs x = SynNone :< CompoundF (DotListF xs x) + +pattern Vector :: [Datum] -> Datum +pattern Vector xs <- _ :< CompoundF (VectorF xs) + where Vector xs = SynNone :< CompoundF (VectorF xs) + +pattern Abbrev :: Prefix -> Datum -> Datum +pattern Abbrev p a <- _ :< CompoundF (AbbrevF p a) + where Abbrev p a = SynNone :< 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) diff --git a/test/Gyehoek/Test/Golden.hs b/test/Gyehoek/Test/Golden.hs index 5085890..bedca27 100644 --- a/test/Gyehoek/Test/Golden.hs +++ b/test/Gyehoek/Test/Golden.hs @@ -93,9 +93,9 @@ stackifyTests files = do test_reader :: IO TestTree test_reader = do - all_cases <- listDirectory "golden/reader" + all_cases <- listDirectory "golden/read" let tests = all_cases - & fmap ("golden/reader") + & fmap ("golden/read") pure . testGroup "reader" $ tests <&> \test -> let testname = takeFileName test scmfile = test "source.scm" diff --git a/test/Gyehoek/Test/Sexp/Print.hs b/test/Gyehoek/Test/Sexp/Print.hs new file mode 100644 index 0000000..4933e75 --- /dev/null +++ b/test/Gyehoek/Test/Sexp/Print.hs @@ -0,0 +1,29 @@ +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 + +test_print = testGroup "sexp pretty printer" $ + [ tcase "null" $ S.List [] + , let x = S.List [ S.Symbol s | s <- ["가","나","다","라"] ] + in testGroup "simple list" + [ tcase "flat" x + , tcaseW 4 "long" x + ] + ] -- 2.54.0 From 66386cda6493a51037989afd83420b2628050a4b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Fri, 21 Aug 2026 15:10:44 -0600 Subject: [PATCH 05/13] more tests }:) --- golden/read/peculiar-identifier-dot/read | 7 +++++++ golden/read/peculiar-identifier-dot/source.scm | 1 + .../read | 0 .../source.scm | 0 golden/read/typical-identifier-token/read | 13 +++++++++++++ golden/read/typical-identifier-token/source.scm | 2 ++ test/Gyehoek/Test/Golden.hs | 1 + 7 files changed, 24 insertions(+) create mode 100644 golden/read/peculiar-identifier-dot/read create mode 100644 golden/read/peculiar-identifier-dot/source.scm rename golden/read/{peculiar-identifier => peculiar-identifier-sign}/read (100%) rename golden/read/{peculiar-identifier => peculiar-identifier-sign}/source.scm (100%) create mode 100644 golden/read/typical-identifier-token/read create mode 100644 golden/read/typical-identifier-token/source.scm 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/read b/golden/read/peculiar-identifier-sign/read similarity index 100% rename from golden/read/peculiar-identifier/read rename to golden/read/peculiar-identifier-sign/read diff --git a/golden/read/peculiar-identifier/source.scm b/golden/read/peculiar-identifier-sign/source.scm similarity index 100% rename from golden/read/peculiar-identifier/source.scm rename to golden/read/peculiar-identifier-sign/source.scm diff --git a/golden/read/typical-identifier-token/read b/golden/read/typical-identifier-token/read new file mode 100644 index 0000000..3a65b71 --- /dev/null +++ b/golden/read/typical-identifier-token/read @@ -0,0 +1,13 @@ +[ SynNone :< SimpleF + ( SimpleSymbol "abc" ) +, SynNone :< SimpleF + ( SimpleString "xyz" ) +, SynNone :< SimpleF + ( SimpleSymbol "수학" ) +, SynNone :< CompoundF + ( ListF Ordinary + [ SynNone :< 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/test/Gyehoek/Test/Golden.hs b/test/Gyehoek/Test/Golden.hs index bedca27..3652cd8 100644 --- a/test/Gyehoek/Test/Golden.hs +++ b/test/Gyehoek/Test/Golden.hs @@ -38,6 +38,7 @@ brokenStackifyTests = brokenReaderTests = [ "delimited-identifier" , "string-line-continuation" + , "peculiar-identifier-dot" ] test_root :: IO TestTree -- 2.54.0 From c340ede84f3d3f3ee9c9b180e13f48eeaa483224 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Fri, 21 Aug 2026 15:37:58 -0600 Subject: [PATCH 06/13] print begin --- .dir-locals.el | 7 +++++- golden/print/begin-nonempty-thin | 4 ++++ golden/print/begin-nonempty-wide | 4 ++++ golden/print/lambda-thin | 5 +++++ golden/print/lambda-wide | 2 ++ golden/print/rainbow | 1 + golden/print/{long => simple-list-thin} | 0 golden/print/{flat => simple-list-wide} | 0 src/Gyehoek/Sexp/Print.hs | 18 ++++++++++----- src/Gyehoek/Sexp/Syntax.hs | 18 ++++++++++++++- test/Gyehoek/Test/Sexp/Print.hs | 30 ++++++++++++++++++++----- 11 files changed, 76 insertions(+), 13 deletions(-) create mode 100644 golden/print/begin-nonempty-thin create mode 100644 golden/print/begin-nonempty-wide create mode 100644 golden/print/lambda-thin create mode 100644 golden/print/lambda-wide create mode 100644 golden/print/rainbow rename golden/print/{long => simple-list-thin} (100%) rename golden/print/{flat => simple-list-wide} (100%) 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/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/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/long b/golden/print/simple-list-thin similarity index 100% rename from golden/print/long rename to golden/print/simple-list-thin diff --git a/golden/print/flat b/golden/print/simple-list-wide similarity index 100% rename from golden/print/flat rename to golden/print/simple-list-wide diff --git a/src/Gyehoek/Sexp/Print.hs b/src/Gyehoek/Sexp/Print.hs index 9d721fa..7d0421c 100644 --- a/src/Gyehoek/Sexp/Print.hs +++ b/src/Gyehoek/Sexp/Print.hs @@ -13,7 +13,7 @@ import Gyehoek.Sexp.Read (rd) import Data.Foldable (traverse_) import qualified Prettyprinter.Render.Terminal as ANSI import System.IO (stdout) -import Prettyprinter.Render.Terminal (Color(..), color, italicized, AnsiStyle) +import Prettyprinter.Render.Terminal (Color(..), color, italicized, AnsiStyle, bold) printDatum :: Datum -> Text @@ -36,10 +36,16 @@ prettyDatum depth = \case syn :< CompoundF compound -> case compound of ListF indent xs -> case indent of - NSpecial 1 | special:body <- xs - -> pparen depth $ - nest 2 $ prettyDatum (depth+1) special - <+> vsep (prettyDatum (depth+1) <$> body) + 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 @@ -68,7 +74,7 @@ putDoc = ANSI.renderIO stdout highlight :: Syn -> AnsiStyle highlight = \case - SynBuiltin -> color Magenta <> italicized + (SynBuiltin; SynMacro) -> color Magenta <> italicized <> bold SynParen n -> color $ rainbow ^?! ix n _ -> mempty where diff --git a/src/Gyehoek/Sexp/Syntax.hs b/src/Gyehoek/Sexp/Syntax.hs index 45be9ab..e8c2def 100644 --- a/src/Gyehoek/Sexp/Syntax.hs +++ b/src/Gyehoek/Sexp/Syntax.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ApplicativeDo #-} module Gyehoek.Sexp.Syntax ( DatumF(..) , Simple(..) @@ -22,7 +23,10 @@ module Gyehoek.Sexp.Syntax , pattern Vector , pattern DotList , pattern Gyehoek.Sexp.Syntax.List + , syntax + , indentation , adorn + , indentWith , pattern Bytevector , pattern Symbol , pattern String @@ -36,7 +40,7 @@ import Data.Scientific (Scientific) import Data.ByteString (ByteString) import Gyehoek.Prelude hiding ((:<), Simple) import Text.Megaparsec.Pos (SourcePos(..)) -import Control.Comonad.Cofree (Cofree((:<))) +import Control.Comonad.Cofree (Cofree((:<)), _extract) import Data.Fix (Fix (..)) import Data.Functor.Foldable import Text.Show.Deriving (deriveShow1) @@ -112,9 +116,21 @@ data Syn deriveShow1 ''CompoundF deriveShow1 ''DatumF +syntax :: Lens' Datum Syn +syntax = _extract + +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 syn (_ :< d) = syn :< d +indentWith :: Indentation -> Datum -> Datum +indentWith = set indentation + pattern Simple :: Simple -> Datum pattern Simple a <- _ :< SimpleF a where Simple a = SynNone :< SimpleF a diff --git a/test/Gyehoek/Test/Sexp/Print.hs b/test/Gyehoek/Test/Sexp/Print.hs index 4933e75..0cbfc57 100644 --- a/test/Gyehoek/Test/Sexp/Print.hs +++ b/test/Gyehoek/Test/Sexp/Print.hs @@ -19,11 +19,31 @@ tcaseW width name ast = (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 [] - , let x = S.List [ S.Symbol s | s <- ["가","나","다","라"] ] - in testGroup "simple list" - [ tcase "flat" x - , tcaseW 4 "long" x - ] + , 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 []]]]] ] -- 2.54.0 From 4beeb7c4cdea73f62234b90efbb72b1d509b8b64 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Fri, 21 Aug 2026 17:22:33 -0600 Subject: [PATCH 07/13] datum grammar --- cabal.project | 2 + gyehoek.cabal | 11 ++ src/Gyehoek/Jalmot.hs | 59 +++++++ src/Gyehoek/Prelude.hs | 5 +- src/Gyehoek/Scheme/Syntax.hs | 177 ++++++++----------- src/Gyehoek/Sexp/Grammar.hs | 97 +++++++++- src/Gyehoek/Sexp/Grammar/Base.hs | 293 +++++++++++++++++++++++++++++++ src/Gyehoek/Sexp/Print.hs | 61 ++++--- src/Gyehoek/Sexp/Read.hs | 36 ++-- src/Gyehoek/Sexp/Syntax.hs | 60 +++++-- test/Main.hs | 8 - test/doctest.hs | 7 + 12 files changed, 650 insertions(+), 166 deletions(-) create mode 100644 src/Gyehoek/Jalmot.hs create mode 100644 src/Gyehoek/Sexp/Grammar/Base.hs create mode 100644 test/doctest.hs diff --git a/cabal.project b/cabal.project index b50cb5f..610c695 100644 --- a/cabal.project +++ b/cabal.project @@ -1,5 +1,7 @@ packages: *.cabal tests: True +-- required for doctest-parallel +write-ghc-environment-files: always source-repository-package type: git diff --git a/gyehoek.cabal b/gyehoek.cabal index 1edac77..9259fd7 100644 --- a/gyehoek.cabal +++ b/gyehoek.cabal @@ -60,12 +60,14 @@ library Gyehoek.CPS.Syntax Gyehoek.Driver Gyehoek.GenSym + Gyehoek.Jalmot Gyehoek.Language Gyehoek.Options Gyehoek.Prelude Gyehoek.Scheme.Syntax Gyehoek.Sexp Gyehoek.Sexp.Grammar + Gyehoek.Sexp.Grammar.Base Gyehoek.Sexp.Print Gyehoek.Sexp.Read Gyehoek.Sexp.Syntax @@ -151,3 +153,12 @@ test-suite test , text default-language: GHC2024 + +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/Jalmot.hs b/src/Gyehoek/Jalmot.hs new file mode 100644 index 0000000..705a911 --- /dev/null +++ b/src/Gyehoek/Jalmot.hs @@ -0,0 +1,59 @@ +module Gyehoek.Jalmot + ( Jalmot + , Exception(..) + , AJalmot(..) + , module Effectful.Error.Static + , runJalmot + , runJalmotIO + , runJalmotIOE + ) + where + +import Gyehoek.Prelude +import Text.Megaparsec.Error (ParseErrorBundle, errorBundlePretty) +import Data.Void (Void) +import Control.Exception.Base (Exception(..), throwIO) +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) + + +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 AJalmotWithCallStack = MkAJalmotWithCallStack !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) -> liftIO . throwIO $ MkAJalmotWithCallStack cs jm + +runJalmotIO :: Eff '[Jalmot, IOE] a -> IO a +runJalmotIO = runEff . runJalmotIOE + +instance Exception AJalmot where + displayException = \case + ReaderError eb -> errorBundlePretty eb + GrammarError err -> + pretty err + & layoutPretty defaultLayoutOptions + & renderString + +instance Exception AJalmotWithCallStack where + backtraceDesired = const False + displayException (MkAJalmotWithCallStack cs jm) = + "\n" <> displayException jm <> "\n\n" <> prettyCallStack cs diff --git a/src/Gyehoek/Prelude.hs b/src/Gyehoek/Prelude.hs index ff3314a..5327396 100644 --- a/src/Gyehoek/Prelude.hs +++ b/src/Gyehoek/Prelude.hs @@ -17,9 +17,11 @@ module Gyehoek.Prelude , NonEmpty((:|)) , Natural , (>>>) + , (>=>) + , (<=<) ) where -import Control.Lens +import Control.Lens hiding (List) import Data.List (List) import Data.Text (Text) import Effectful @@ -37,4 +39,5 @@ 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..8f3da10 100644 --- a/src/Gyehoek/Scheme/Syntax.hs +++ b/src/Gyehoek/Scheme/Syntax.hs @@ -17,11 +17,9 @@ module Gyehoek.Scheme.Syntax , Def(..) , Exp(..) , ExpF(..) - , Sexp(..) , Program(..) , CommandOrDef(..) - , primSexpIso - , pattern Void + , primDatumIso , free , subst , getName @@ -36,10 +34,6 @@ module Gyehoek.Scheme.Syntax 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 +52,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) import Gyehoek.Prelude @@ -97,16 +94,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 +118,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 @@ -159,96 +144,82 @@ 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 -- utilities diff --git a/src/Gyehoek/Sexp/Grammar.hs b/src/Gyehoek/Sexp/Grammar.hs index 1d908f3..b321b5b 100644 --- a/src/Gyehoek/Sexp/Grammar.hs +++ b/src/Gyehoek/Sexp/Grammar.hs @@ -1,4 +1,97 @@ module Gyehoek.Sexp.Grammar - ( - ) where + ( module Gyehoek.Sexp.Grammar.Base + , module Data.InvertibleGrammar.Combinators + , (>>>) + , toDatum + , fromDatum + , toData + , fromData + , encodeWith + , encodeDataWith + , decodeWith + , encodeTest + , encodeTestColour + , decodeTest + , DataIso(..) + , DatumIso(..) + -- * generics + , with + , match + , Coproduct (..) + ) + where +import Gyehoek.Sexp.Grammar.Base +import Gyehoek.Prelude +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 + + +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 + +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 + +-- | 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) + +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 diff --git a/src/Gyehoek/Sexp/Grammar/Base.hs b/src/Gyehoek/Sexp/Grammar/Base.hs new file mode 100644 index 0000000..481280b --- /dev/null +++ b/src/Gyehoek/Sexp/Grammar/Base.hs @@ -0,0 +1,293 @@ +-- | cribbed from sexp-grammar:Language.SexpGrammar.Base +module Gyehoek.Sexp.Grammar.Base + ( module Gyehoek.Sexp.Syntax + -- * 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 + , beginLike + ) where + +import Data.InvertibleGrammar +import Data.InvertibleGrammar.Base +import Gyehoek.Prelude hiding (iso, cons, coerced, Iso, Simple, simple) +import Gyehoek.Sexp.Syntax hiding (position) +import Gyehoek.Sexp qualified as GS +import qualified Gyehoek.Sexp as GS +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 a + -- | alternative (else-branch) + -> DatumGrammar a + -> G (Datum :- t) (a :- a :- 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 "lambda", sym "λ" ] + +beginLike + :: Text + -> DatumGrammar a + -> G (Datum :- t) (List a :- t) +beginLike kw g = + listWithIndentation (NSpecial 0) $ + el (symBuiltin kw) >>> rest g diff --git a/src/Gyehoek/Sexp/Print.hs b/src/Gyehoek/Sexp/Print.hs index 7d0421c..aba1df2 100644 --- a/src/Gyehoek/Sexp/Print.hs +++ b/src/Gyehoek/Sexp/Print.hs @@ -1,6 +1,8 @@ module Gyehoek.Sexp.Print ( printDatum , printDatumW + , printDatum' + , printData ) where import Gyehoek.Sexp.Syntax @@ -9,16 +11,31 @@ import Data.Functor.Foldable import qualified Control.Comonad.Trans.Cofree as F import Prettyprinter.Util import Gyehoek.Prelude hiding (Simple, (:<)) -import Gyehoek.Sexp.Read (rd) 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 @@ -31,24 +48,23 @@ printDatumW w = } prettyDatum :: Int -> Datum -> Doc Syn -prettyDatum depth = \case - syn :< SimpleF s -> annotate syn $ prettySimple depth s - syn :< CompoundF compound -> case compound of - ListF 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 +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 ] - Ordinary; NSpecial _ -> pparen depth $ - group . align . vsep $ - prettyDatum (depth+1) <$> xs + , vsep $ prettyDatum (depth+1) <$> body + ] + Ordinary; NSpecial _ -> pparen depth $ + group . align . vsep $ + prettyDatum (depth+1) <$> xs pparen depth = enclose (delim depth "(") (delim depth ")") delim depth = annotate (SynParen depth) @@ -60,14 +76,13 @@ delimited depth open close = prettySimple :: Int -> Simple -> Doc Syn prettySimple depth = \case SimpleBoolean b -> annotate SynConstant $ if b then "#t" else "#f" - SimpleNumber n -> annotate SynConstant $ viaShow n + SimpleNumber n -> + Sci.floatingOrInteger n + & either viaShow viaShow + & annotate SynConstant SimpleString s -> annotate SynString $ viaShow s SimpleSymbol s -> pretty s -rdpr n s = rd s >>= traverse_ \x -> do - putDocW n . prettyDatum 0 $ x - putStr "\n" - putDoc :: Doc Syn -> IO () putDoc = ANSI.renderIO stdout . reAnnotateS highlight . layoutSmart defaultLayoutOptions . (<>"\n") diff --git a/src/Gyehoek/Sexp/Read.hs b/src/Gyehoek/Sexp/Read.hs index ebccb9c..11c3a72 100644 --- a/src/Gyehoek/Sexp/Read.hs +++ b/src/Gyehoek/Sexp/Read.hs @@ -1,7 +1,7 @@ module Gyehoek.Sexp.Read ( readFile , readString - , rd + , readString1 ) where import Text.Megaparsec @@ -18,6 +18,7 @@ import qualified Data.Text as T import Data.Char (GeneralCategory(..), generalCategory) import Control.Exception hiding (try) import Data.Scientific (Scientific) +import Gyehoek.Jalmot -- i'm lazy @@ -27,23 +28,24 @@ newtype ReaderError = MkReaderError String instance Exception ReaderError where displayException (MkReaderError x) = x - -- temp -rd = runEff . readString - -readFile :: IOE :> es => FilePath -> Eff es (List Datum) +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 e -> do - liftIO . throw . MkReaderError . errorBundlePretty $ e + Left eb -> throwError . ReaderError $ eb -readString :: IOE :> es => Text -> Eff es (List Datum) +readString :: Jalmot :> es => Text -> Eff es (List Datum) readString s = case runParser file "" s of Right x -> pure x - Left e -> do - liftIO . throw . MkReaderError . errorBundlePretty $ e + Left eb -> throwError . ReaderError $ eb + +readString1 :: Jalmot :> es => Text -> Eff es Datum +readString1 s = + case runParser (sc *> datum <* eof) "" s of + Right x -> pure x + Left eb -> throwError . ReaderError $ eb type P = Parsec Void Text @@ -141,12 +143,14 @@ file :: P (List Datum) file = many datum <* eof datum :: P Datum -datum = choice - [ (SynNone :<) . CompoundF <$> compoundDatum - , (SynNone :<) . SimpleF <$> simpleDatum - -- , labeled - -- , labelRef - ] +datum = do + pos <- getSourcePos + (position ?~ pos) <$> choice + [ Compound <$> compoundDatum + , Simple <$> simpleDatum + -- , labeled + -- , labelRef + ] simpleDatum :: P Simple simpleDatum = choice diff --git a/src/Gyehoek/Sexp/Syntax.hs b/src/Gyehoek/Sexp/Syntax.hs index e8c2def..63aac31 100644 --- a/src/Gyehoek/Sexp/Syntax.hs +++ b/src/Gyehoek/Sexp/Syntax.hs @@ -33,18 +33,24 @@ module Gyehoek.Sexp.Syntax , pattern Character , pattern Number , pattern Boolean + , Ann(..) + , noAnn + , ann + , pattern List' + , position ) where import Language.Haskell.TH.Syntax (Lift) import Data.Scientific (Scientific) import Data.ByteString (ByteString) import Gyehoek.Prelude hiding ((:<), Simple) -import Text.Megaparsec.Pos (SourcePos(..)) +import Text.Megaparsec.Pos (SourcePos(..), sourcePosPretty) import Control.Comonad.Cofree (Cofree((:<)), _extract) import Data.Fix (Fix (..)) import Data.Functor.Foldable import Text.Show.Deriving (deriveShow1) import qualified Control.Comonad.Trans.Cofree as F +import Prettyprinter (Pretty (pretty), viaShow) data DatumF a @@ -62,6 +68,8 @@ data Simple | SimpleString Text | SimpleSymbol Text | SimpleBytevector ByteString + | SimpleMeta Text + | SimpleMetaSplice Text deriving stock (Show, Eq, Data, Generic, Lift) deriving anyclass (NFData) @@ -92,7 +100,7 @@ newtype Label = MkLabel Natural -type Datum = Cofree DatumF Syn +type Datum = Cofree DatumF Ann type Compound = CompoundF Datum data Indentation @@ -109,15 +117,37 @@ data Syn | SynString | SynConstant | SynNone - deriving (Show, Read) + 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 deriveShow1 ''DatumF +ann :: Lens' Datum Ann +ann = _extract + syntax :: Lens' Datum Syn -syntax = _extract +syntax = ann . #syntax + +position :: Lens' Datum (Maybe SourcePos) +position = ann . #position indentation :: Traversal' Datum Indentation indentation k (syn :< CompoundF (ListF ind xs)) = do @@ -126,42 +156,46 @@ indentation k (syn :< CompoundF (ListF ind xs)) = do indentation k a = pure a adorn :: Syn -> Datum -> Datum -adorn syn (_ :< d) = syn :< d +adorn = set syntax indentWith :: Indentation -> Datum -> Datum indentWith = set indentation pattern Simple :: Simple -> Datum pattern Simple a <- _ :< SimpleF a - where Simple a = SynNone :< SimpleF a + where Simple a = noAnn :< SimpleF a pattern Compound :: CompoundF Datum -> Datum pattern Compound a <- _ :< CompoundF a - where Compound a = SynNone :< CompoundF a + where Compound a = noAnn :< CompoundF a pattern Labeled :: Label -> Datum -> Datum pattern Labeled l a <- _ :< LabeledF l a - where Labeled l a = SynNone :< LabeledF l a + where Labeled l a = noAnn :< LabeledF l a pattern LabelRef :: Label -> Datum pattern LabelRef l <- _ :< LabelRefF l - where LabelRef l = SynNone :< LabelRefF l + where LabelRef l = noAnn :< LabelRefF l pattern List :: List Datum -> Datum pattern List a <- _ :< CompoundF (ListF _ a) - where List a = SynNone :< CompoundF (ListF Ordinary 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 = SynNone :< 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 = SynNone :< 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 = SynNone :< 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) 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 -- 2.54.0 From 73063d2b2cb70be27d6f22360117e4498707744f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Sat, 22 Aug 2026 17:45:35 -0600 Subject: [PATCH 08/13] parse meta vars --- golden/read/meta-expression/read | 12 ++++ golden/read/meta-expression/source.scm | 1 + golden/read/meta-splice-expression/read | 12 ++++ golden/read/meta-splice-expression/source.scm | 1 + golden/read/meta-splice-variable/read | 12 ++++ golden/read/meta-splice-variable/source.scm | 1 + golden/read/meta-variable/read | 12 ++++ golden/read/meta-variable/source.scm | 1 + gyehoek.cabal | 2 + src/Gyehoek/CPS/Syntax.hs | 3 +- src/Gyehoek/Jalmot.hs | 11 ++-- src/Gyehoek/Sexp/Read.hs | 27 +++++---- test/Gyehoek/Test/Golden.hs | 25 -------- test/Gyehoek/Test/Sexp/Read.hs | 58 +++++++++++++++++++ test/Gyehoek/TestUtil.hs | 11 ++++ 15 files changed, 146 insertions(+), 43 deletions(-) create mode 100644 golden/read/meta-expression/read create mode 100644 golden/read/meta-expression/source.scm create mode 100644 golden/read/meta-splice-expression/read create mode 100644 golden/read/meta-splice-expression/source.scm create mode 100644 golden/read/meta-splice-variable/read create mode 100644 golden/read/meta-splice-variable/source.scm create mode 100644 golden/read/meta-variable/read create mode 100644 golden/read/meta-variable/source.scm create mode 100644 test/Gyehoek/Test/Sexp/Read.hs create mode 100644 test/Gyehoek/TestUtil.hs diff --git a/golden/read/meta-expression/read b/golden/read/meta-expression/read new file mode 100644 index 0000000..ba6dbf1 --- /dev/null +++ b/golden/read/meta-expression/read @@ -0,0 +1,12 @@ +[ MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/meta-expression/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 1 + } + ) + } :< SimpleF + ( SimpleMeta "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/read b/golden/read/meta-splice-expression/read new file mode 100644 index 0000000..a6cdbd6 --- /dev/null +++ b/golden/read/meta-splice-expression/read @@ -0,0 +1,12 @@ +[ MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/meta-splice-expression/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 1 + } + ) + } :< SimpleF + ( SimpleMetaSplice "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..d55be83 --- /dev/null +++ b/golden/read/meta-splice-variable/read @@ -0,0 +1,12 @@ +[ MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/meta-splice-variable/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 1 + } + ) + } :< SimpleF + ( SimpleMetaSplice "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..cee6314 --- /dev/null +++ b/golden/read/meta-variable/read @@ -0,0 +1,12 @@ +[ MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/meta-variable/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 1 + } + ) + } :< SimpleF + ( SimpleMeta "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/gyehoek.cabal b/gyehoek.cabal index 9259fd7..ddab5d9 100644 --- a/gyehoek.cabal +++ b/gyehoek.cabal @@ -131,7 +131,9 @@ test-suite test Gyehoek.Test.Scheme.Syntax Gyehoek.Test.Sexp Gyehoek.Test.Sexp.Print + Gyehoek.Test.Sexp.Read Gyehoek.Test.Stack.VM + Gyehoek.TestUtil Root build-depends: diff --git a/src/Gyehoek/CPS/Syntax.hs b/src/Gyehoek/CPS/Syntax.hs index 400e657..b5032c0 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 @@ -43,7 +42,7 @@ module Gyehoek.CPS.Syntax import Language.SexpGrammar qualified as S import Gyehoek.Sexp qualified -import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primSexpIso, Lit(..), pattern Void) +import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primDatumIso, Lit(..)) import Language.SexpGrammar.Generic import Control.Category import Prelude hiding ((.), id) diff --git a/src/Gyehoek/Jalmot.hs b/src/Gyehoek/Jalmot.hs index 705a911..2a7ef0d 100644 --- a/src/Gyehoek/Jalmot.hs +++ b/src/Gyehoek/Jalmot.hs @@ -2,6 +2,7 @@ module Gyehoek.Jalmot ( Jalmot , Exception(..) , AJalmot(..) + , AJalmotCS(..) , module Effectful.Error.Static , runJalmot , runJalmotIO @@ -12,7 +13,7 @@ module Gyehoek.Jalmot import Gyehoek.Prelude import Text.Megaparsec.Error (ParseErrorBundle, errorBundlePretty) import Data.Void (Void) -import Control.Exception.Base (Exception(..), throwIO) +import Effectful.Exception import Effectful.Error.Static import qualified Data.InvertibleGrammar as Grammar import Gyehoek.Sexp.Syntax (Ann) @@ -28,7 +29,7 @@ data AJalmot | GrammarError (Grammar.ErrorMessage Ann) deriving (Show, Generic, Data) -data AJalmotWithCallStack = MkAJalmotWithCallStack !CallStack !AJalmot +data AJalmotCS = MkAJalmotCS !CallStack !AJalmot deriving (Show) type Jalmot = Error AJalmot @@ -40,7 +41,7 @@ runJalmotIOE :: IOE :> es => Eff (Jalmot : es) a -> Eff es a runJalmotIOE eff = runJalmot eff >>= \case Right a -> pure a - Left (cs,jm) -> liftIO . throwIO $ MkAJalmotWithCallStack cs jm + Left (cs,jm) -> throwIO $ MkAJalmotCS cs jm runJalmotIO :: Eff '[Jalmot, IOE] a -> IO a runJalmotIO = runEff . runJalmotIOE @@ -53,7 +54,7 @@ instance Exception AJalmot where & layoutPretty defaultLayoutOptions & renderString -instance Exception AJalmotWithCallStack where +instance Exception AJalmotCS where backtraceDesired = const False - displayException (MkAJalmotWithCallStack cs jm) = + displayException (MkAJalmotCS cs jm) = "\n" <> displayException jm <> "\n\n" <> prettyCallStack cs diff --git a/src/Gyehoek/Sexp/Read.hs b/src/Gyehoek/Sexp/Read.hs index 11c3a72..7dc7a69 100644 --- a/src/Gyehoek/Sexp/Read.hs +++ b/src/Gyehoek/Sexp/Read.hs @@ -11,23 +11,14 @@ import Data.Void (Void) import Gyehoek.Sexp.Syntax import Gyehoek.Prelude hiding (Simple, (:<)) import qualified Data.Text.IO as T -import System.IO (stderr, hPutStrLn) import Prelude hiding (readFile) -import Data.Functor (($>), void) +import Data.Functor (($>)) import qualified Data.Text as T import Data.Char (GeneralCategory(..), generalCategory) -import Control.Exception hiding (try) import Data.Scientific (Scientific) import Gyehoek.Jalmot --- i'm lazy -newtype ReaderError = MkReaderError String - deriving (Show) - -instance Exception ReaderError where - displayException (MkReaderError x) = x - readFile :: (Jalmot :> es, IOE :> es) => FilePath -> Eff es (List Datum) readFile f = do s <- liftIO . T.readFile $ f @@ -52,7 +43,9 @@ type P = Parsec Void Text --- lexer helpers --- TODO: check R⁷RS +-- TODO: check R⁷RS's definition of ⟨atmosphere⟩. +-- TODO: datum comments. +-- | whitespace consumer. sc :: P () sc = L.space space1 (L.skipLineComment ";") @@ -61,6 +54,7 @@ sc = L.space space1 lexeme :: P a -> P a lexeme = L.lexeme sc +-- | verbatim text. verb :: Text -> P Text verb = L.symbol sc @@ -92,6 +86,7 @@ identifier = label "identifier" . lexeme . choice $ , ModifierSymbol, OtherSymbol, PrivateUse ] || c == '\x200c' || c == '\x200d') && c /= ';' && c /= '|' && c /= '"' && c /= '.' + && c /= ',' && c /= '#' boolean :: P Bool boolean = label "boolean" . lexeme $ choice @@ -137,6 +132,14 @@ string = label "string" . lexeme $ , "\\\\" $> '\\' ] +metaSplice :: P Text +metaSplice = label "splicing meta" . lexeme . between "##{" "}" $ + takeWhileP Nothing (/= '}') + +meta :: P Text +meta = label "meta" . lexeme . between "#{" "}" $ + takeWhileP Nothing (/= '}') + file :: P (List Datum) @@ -160,6 +163,8 @@ simpleDatum = choice , SimpleString <$> string , SimpleSymbol <$> symbol -- , SimpleBytevector <$> bytevector + , SimpleMetaSplice <$> metaSplice + , SimpleMeta <$> meta ] compoundDatum :: P Compound diff --git a/test/Gyehoek/Test/Golden.hs b/test/Gyehoek/Test/Golden.hs index 3652cd8..04bd34c 100644 --- a/test/Gyehoek/Test/Golden.hs +++ b/test/Gyehoek/Test/Golden.hs @@ -35,12 +35,6 @@ brokenStackifyTests = -- , "callcc-nested1" -- requires closure-conversion -- ] -brokenReaderTests = - [ "delimited-identifier" - , "string-line-continuation" - , "peculiar-identifier-dot" - ] - test_root :: IO TestTree test_root = do all_cases <- listDirectory "golden/exec" @@ -91,22 +85,3 @@ stackifyTests files = do resultfile action printProcResult - -test_reader :: IO TestTree -test_reader = 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 = runEff $ Read.readFile scmfile - in maybeBroken testname brokenReaderTests $ goldenVsAction - testname - resultfile - action - (view strict . pShowNoColor) - --- readTests files = pure . testGroup "reader" $ files <&> \test -> --- let diff --git a/test/Gyehoek/Test/Sexp/Read.hs b/test/Gyehoek/Test/Sexp/Read.hs new file mode 100644 index 0000000..21ae325 --- /dev/null +++ b/test/Gyehoek/Test/Sexp/Read.hs @@ -0,0 +1,58 @@ +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" + ] + +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 -- 2.54.0 From bbcc924b34daa3691b1386ffda2fd03bacac6cab Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Sat, 22 Aug 2026 18:07:39 -0600 Subject: [PATCH 09/13] fix all the reader tests lol --- golden/read/bool/read | 44 +++++- golden/read/datum-comment/source.scm | 4 + golden/read/decimal/read | 33 ++++- golden/read/list-dot-flat/read | 55 +++++++- golden/read/list-flat/read | 88 ++++++++++-- golden/read/list/read | 132 ++++++++++++++++-- .../source.scm | 2 + golden/read/peculiar-identifier-sign/read | 22 ++- golden/read/string/read | 11 +- golden/read/typical-identifier-token/read | 55 +++++++- golden/read/typical-identifier/read | 99 +++++++++++-- src/Gyehoek/Jalmot.hs | 2 +- test/Gyehoek/Test/Sexp/Read.hs | 2 + 13 files changed, 499 insertions(+), 50 deletions(-) create mode 100644 golden/read/datum-comment/source.scm create mode 100644 golden/read/meta-splice-expression-interior-brace/source.scm diff --git a/golden/read/bool/read b/golden/read/bool/read index c37392f..c9bd1ea 100644 --- a/golden/read/bool/read +++ b/golden/read/bool/read @@ -1,5 +1,41 @@ -[ SynNone :< SimpleF ( SimpleBoolean True ) -, SynNone :< SimpleF ( SimpleBoolean True ) -, SynNone :< SimpleF ( SimpleBoolean False ) -, SynNone :< SimpleF ( SimpleBoolean False ) +[ 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/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 index 36dd7be..4b23079 100644 --- a/golden/read/decimal/read +++ b/golden/read/decimal/read @@ -1,8 +1,35 @@ -[ SynNone :< SimpleF +[ MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/decimal/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 1 + } + ) + } :< SimpleF ( SimpleNumber 45.0 ) -, SynNone :< SimpleF +, MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/decimal/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 4 + } + ) + } :< SimpleF ( SimpleNumber 5667.0 ) -, SynNone :< SimpleF +, MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/decimal/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 10 + } + ) + } :< SimpleF ( SimpleNumber ( -123.0 ) ) diff --git a/golden/read/list-dot-flat/read b/golden/read/list-dot-flat/read index df2e6c9..c2f77de 100644 --- a/golden/read/list-dot-flat/read +++ b/golden/read/list-dot-flat/read @@ -1,16 +1,61 @@ -[ SynNone :< CompoundF +[ MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/list-dot-flat/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 1 + } + ) + } :< CompoundF ( DotListF ( - ( SynNone :< SimpleF + ( MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/list-dot-flat/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 2 + } + ) + } :< SimpleF ( SimpleSymbol "가" ) ) :| - [ SynNone :< SimpleF + [ MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/list-dot-flat/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 5 + } + ) + } :< SimpleF ( SimpleSymbol "나" ) - , SynNone :< SimpleF + , MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/list-dot-flat/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 8 + } + ) + } :< SimpleF ( SimpleSymbol "다" ) ] ) - ( SynNone :< SimpleF + ( MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/list-dot-flat/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 13 + } + ) + } :< SimpleF ( SimpleSymbol "라" ) ) ) diff --git a/golden/read/list-flat/read b/golden/read/list-flat/read index e933982..c1b1a96 100644 --- a/golden/read/list-flat/read +++ b/golden/read/list-flat/read @@ -1,18 +1,90 @@ -[ SynNone :< CompoundF +[ MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/list-flat/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 1 + } + ) + } :< CompoundF ( ListF Ordinary - [ SynNone :< SimpleF + [ MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/list-flat/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 2 + } + ) + } :< SimpleF ( SimpleSymbol "가" ) - , SynNone :< SimpleF + , MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/list-flat/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 5 + } + ) + } :< SimpleF ( SimpleSymbol "나" ) - , SynNone :< SimpleF + , MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/list-flat/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 8 + } + ) + } :< SimpleF ( SimpleSymbol "다" ) - , SynNone :< SimpleF + , MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/list-flat/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 11 + } + ) + } :< SimpleF ( SimpleSymbol "라" ) - , SynNone :< SimpleF + , MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/list-flat/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 14 + } + ) + } :< SimpleF ( SimpleNumber 1.0 ) - , SynNone :< SimpleF + , MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/list-flat/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 16 + } + ) + } :< SimpleF ( SimpleNumber 2.0 ) - , SynNone :< SimpleF + , MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/list-flat/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 18 + } + ) + } :< SimpleF ( SimpleNumber 3.0 ) ] ) diff --git a/golden/read/list/read b/golden/read/list/read index 2043de1..6629342 100644 --- a/golden/read/list/read +++ b/golden/read/list/read @@ -1,37 +1,145 @@ -[ SynNone :< CompoundF +[ MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/list/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 1 + } + ) + } :< CompoundF ( DotListF ( - ( SynNone :< SimpleF + ( MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/list/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 2 + } + ) + } :< SimpleF ( SimpleSymbol "a" ) ) :| - [ SynNone :< SimpleF + [ MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/list/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 4 + } + ) + } :< SimpleF ( SimpleSymbol "b" ) - , SynNone :< CompoundF + , MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/list/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 6 + } + ) + } :< CompoundF ( ListF Ordinary - [ SynNone :< SimpleF + [ MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/list/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 7 + } + ) + } :< SimpleF ( SimpleSymbol "c" ) - , SynNone :< SimpleF + , MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/list/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 9 + } + ) + } :< SimpleF ( SimpleSymbol "d" ) ] ) ] ) - ( SynNone :< CompoundF + ( MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/list/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 14 + } + ) + } :< CompoundF ( ListF Ordinary - [ SynNone :< SimpleF + [ MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/list/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 15 + } + ) + } :< SimpleF ( SimpleSymbol "가" ) - , SynNone :< CompoundF + , MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/list/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 18 + } + ) + } :< CompoundF ( DotListF ( - ( SynNone :< SimpleF + ( MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/list/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 19 + } + ) + } :< SimpleF ( SimpleSymbol "나" ) ) :| [] ) - ( SynNone :< SimpleF + ( MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/list/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 24 + } + ) + } :< SimpleF ( SimpleSymbol "다" ) ) ) - , SynNone :< SimpleF + , MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/list/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 28 + } + ) + } :< SimpleF ( SimpleSymbol "라" ) ] ) 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/peculiar-identifier-sign/read b/golden/read/peculiar-identifier-sign/read index 9f2cdd5..0321ef5 100644 --- a/golden/read/peculiar-identifier-sign/read +++ b/golden/read/peculiar-identifier-sign/read @@ -1,5 +1,23 @@ -[ SynNone :< SimpleF +[ MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/peculiar-identifier-sign/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 1 + } + ) + } :< SimpleF ( SimpleSymbol "+" ) -, SynNone :< SimpleF +, 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/string/read b/golden/read/string/read index c1f307e..aed8eb0 100644 --- a/golden/read/string/read +++ b/golden/read/string/read @@ -1,3 +1,12 @@ -[ SynNone :< SimpleF +[ 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/typical-identifier-token/read b/golden/read/typical-identifier-token/read index 3a65b71..744edef 100644 --- a/golden/read/typical-identifier-token/read +++ b/golden/read/typical-identifier-token/read @@ -1,12 +1,57 @@ -[ SynNone :< SimpleF +[ MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/typical-identifier-token/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 1 + } + ) + } :< SimpleF ( SimpleSymbol "abc" ) -, SynNone :< SimpleF +, MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/typical-identifier-token/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 4 + } + ) + } :< SimpleF ( SimpleString "xyz" ) -, SynNone :< SimpleF +, MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/typical-identifier-token/source.scm" + , sourceLine = Pos 2 + , sourceColumn = Pos 1 + } + ) + } :< SimpleF ( SimpleSymbol "수학" ) -, SynNone :< CompoundF +, MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/typical-identifier-token/source.scm" + , sourceLine = Pos 2 + , sourceColumn = Pos 5 + } + ) + } :< CompoundF ( ListF Ordinary - [ SynNone :< SimpleF + [ MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/typical-identifier-token/source.scm" + , sourceLine = Pos 2 + , sourceColumn = Pos 6 + } + ) + } :< SimpleF ( SimpleSymbol "數學" ) ] ) diff --git a/golden/read/typical-identifier/read b/golden/read/typical-identifier/read index 676bce0..2ee59d6 100644 --- a/golden/read/typical-identifier/read +++ b/golden/read/typical-identifier/read @@ -1,19 +1,100 @@ -[ SynNone :< SimpleF +[ MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/typical-identifier/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 1 + } + ) + } :< SimpleF ( SimpleSymbol "abc" ) -, SynNone :< SimpleF +, MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/typical-identifier/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 5 + } + ) + } :< SimpleF ( SimpleSymbol "bala-hwa$" ) -, SynNone :< SimpleF +, MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/typical-identifier/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 15 + } + ) + } :< SimpleF ( SimpleSymbol "x!!!" ) -, SynNone :< SimpleF +, MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/typical-identifier/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 20 + } + ) + } :< SimpleF ( SimpleSymbol "z" ) -, SynNone :< SimpleF +, MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/typical-identifier/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 22 + } + ) + } :< SimpleF ( SimpleSymbol "z123" ) -, SynNone :< SimpleF +, MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/typical-identifier/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 27 + } + ) + } :< SimpleF ( SimpleSymbol "나는너무졸리다" ) -, SynNone :< SimpleF +, MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/typical-identifier/source.scm" + , sourceLine = Pos 1 + , sourceColumn = Pos 42 + } + ) + } :< SimpleF ( SimpleSymbol "學" ) -, SynNone :< SimpleF +, MkAnn + { syntax = SynNone + , position = Just + ( SourcePos + { sourceName = "golden/read/typical-identifier/source.scm" + , sourceLine = Pos 3 + , sourceColumn = Pos 1 + } + ) + } :< SimpleF ( SimpleSymbol "車室." ) -, SynNone :< SimpleF +, 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/src/Gyehoek/Jalmot.hs b/src/Gyehoek/Jalmot.hs index 2a7ef0d..f6acb66 100644 --- a/src/Gyehoek/Jalmot.hs +++ b/src/Gyehoek/Jalmot.hs @@ -57,4 +57,4 @@ instance Exception AJalmot where instance Exception AJalmotCS where backtraceDesired = const False displayException (MkAJalmotCS cs jm) = - "\n" <> displayException jm <> "\n\n" <> prettyCallStack cs + "\n" <> displayException jm <> "\n\n" <> prettyCallStack cs <> "\n" diff --git a/test/Gyehoek/Test/Sexp/Read.hs b/test/Gyehoek/Test/Sexp/Read.hs index 21ae325..d85d53e 100644 --- a/test/Gyehoek/Test/Sexp/Read.hs +++ b/test/Gyehoek/Test/Sexp/Read.hs @@ -21,6 +21,8 @@ brokenReaderTests = [ "delimited-identifier" , "string-line-continuation" , "peculiar-identifier-dot" + , "meta-splice-expression-interior-brace" + , "datum-comment" ] test_golden :: IO TestTree -- 2.54.0 From bf5595f1854cf4eeabfa7a8d4b1d284139b53cf7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Sat, 22 Aug 2026 21:55:16 -0600 Subject: [PATCH 10/13] qq --- gyehoek.cabal | 3 + src/Gyehoek/Lift1.hs | 30 ++++++++ src/Gyehoek/Prelude.hs | 2 +- src/Gyehoek/Sexp/Grammar.hs | 8 ++- src/Gyehoek/Sexp/Print.hs | 1 + src/Gyehoek/Sexp/QQ.hs | 128 +++++++++++++++++++++++++++++++++++ src/Gyehoek/Sexp/Read.hs | 56 +++++++++++++-- src/Gyehoek/Sexp/Syntax.hs | 57 ++++++++++++++-- test/Gyehoek/Test/Sexp/QQ.hs | 47 +++++++++++++ 9 files changed, 318 insertions(+), 14 deletions(-) create mode 100644 src/Gyehoek/Lift1.hs create mode 100644 src/Gyehoek/Sexp/QQ.hs create mode 100644 test/Gyehoek/Test/Sexp/QQ.hs diff --git a/gyehoek.cabal b/gyehoek.cabal index ddab5d9..ccb2fa4 100644 --- a/gyehoek.cabal +++ b/gyehoek.cabal @@ -62,6 +62,7 @@ library Gyehoek.GenSym Gyehoek.Jalmot Gyehoek.Language + Gyehoek.Lift1 Gyehoek.Options Gyehoek.Prelude Gyehoek.Scheme.Syntax @@ -69,6 +70,7 @@ library Gyehoek.Sexp.Grammar Gyehoek.Sexp.Grammar.Base Gyehoek.Sexp.Print + Gyehoek.Sexp.QQ Gyehoek.Sexp.Read Gyehoek.Sexp.Syntax Gyehoek.Stack.Syntax @@ -131,6 +133,7 @@ test-suite test 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 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/Prelude.hs b/src/Gyehoek/Prelude.hs index 5327396..9355d2f 100644 --- a/src/Gyehoek/Prelude.hs +++ b/src/Gyehoek/Prelude.hs @@ -21,7 +21,7 @@ module Gyehoek.Prelude , (<=<) ) where -import Control.Lens hiding (List) +import Control.Lens hiding (List, (:<)) import Data.List (List) import Data.Text (Text) import Effectful diff --git a/src/Gyehoek/Sexp/Grammar.hs b/src/Gyehoek/Sexp/Grammar.hs index b321b5b..a75e1c8 100644 --- a/src/Gyehoek/Sexp/Grammar.hs +++ b/src/Gyehoek/Sexp/Grammar.hs @@ -22,7 +22,7 @@ module Gyehoek.Sexp.Grammar where import Gyehoek.Sexp.Grammar.Base -import Gyehoek.Prelude +import Gyehoek.Prelude hiding (traversed, iso) import Data.InvertibleGrammar (backward, sealed, forward, runGrammar) import Gyehoek.Sexp.Print (printDatum, printDatum', printData) import Gyehoek.Jalmot @@ -31,6 +31,7 @@ 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 toDatum :: Jalmot :> es => DatumGrammar a -> a -> Eff es Datum @@ -95,3 +96,8 @@ instance DatumIso a => DatumIso (List a) where 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 diff --git a/src/Gyehoek/Sexp/Print.hs b/src/Gyehoek/Sexp/Print.hs index aba1df2..467e40c 100644 --- a/src/Gyehoek/Sexp/Print.hs +++ b/src/Gyehoek/Sexp/Print.hs @@ -65,6 +65,7 @@ prettyDatum depth datum = case datum of 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) diff --git a/src/Gyehoek/Sexp/QQ.hs b/src/Gyehoek/Sexp/QQ.hs new file mode 100644 index 0000000..12834cd --- /dev/null +++ b/src/Gyehoek/Sexp/QQ.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE TemplateHaskell #-} +module Gyehoek.Sexp.QQ + ( makeSxs + , makeSx + , makeSx' + , sx + , sxs + ) 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 [|| id @(List Datum) ||] +sx = makeSx [|| id @Datum ||] diff --git a/src/Gyehoek/Sexp/Read.hs b/src/Gyehoek/Sexp/Read.hs index 7dc7a69..1d6ffb0 100644 --- a/src/Gyehoek/Sexp/Read.hs +++ b/src/Gyehoek/Sexp/Read.hs @@ -2,6 +2,9 @@ module Gyehoek.Sexp.Read ( readFile , readString , readString1 + , SourcePos(..) + , readStringWithPos + , readStringWithPos1 ) where import Text.Megaparsec @@ -34,10 +37,48 @@ readString s = readString1 :: Jalmot :> es => Text -> Eff es Datum readString1 s = - case runParser (sc *> datum <* eof) "" s of + 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 @@ -134,16 +175,19 @@ string = label "string" . lexeme $ metaSplice :: P Text metaSplice = label "splicing meta" . lexeme . between "##{" "}" $ - takeWhileP Nothing (/= '}') + takeWhile1P Nothing (/= '}') meta :: P Text meta = label "meta" . lexeme . between "#{" "}" $ - takeWhileP Nothing (/= '}') + takeWhile1P Nothing (/= '}') file :: P (List Datum) -file = many datum <* eof +file = sc *> many datum <* eof + +file1 :: P Datum +file1 = sc *> datum <* eof datum :: P Datum datum = do @@ -153,6 +197,8 @@ datum = do , Simple <$> simpleDatum -- , labeled -- , labelRef + , MetaSplice <$> metaSplice + , Meta <$> meta ] simpleDatum :: P Simple @@ -163,8 +209,6 @@ simpleDatum = choice , SimpleString <$> string , SimpleSymbol <$> symbol -- , SimpleBytevector <$> bytevector - , SimpleMetaSplice <$> metaSplice - , SimpleMeta <$> meta ] compoundDatum :: P Compound diff --git a/src/Gyehoek/Sexp/Syntax.hs b/src/Gyehoek/Sexp/Syntax.hs index 63aac31..31517e6 100644 --- a/src/Gyehoek/Sexp/Syntax.hs +++ b/src/Gyehoek/Sexp/Syntax.hs @@ -19,6 +19,8 @@ module Gyehoek.Sexp.Syntax , pattern Compound , pattern Labeled , pattern LabelRef + , pattern Meta + , pattern MetaSplice , pattern Abbrev , pattern Vector , pattern DotList @@ -38,19 +40,26 @@ module Gyehoek.Sexp.Syntax , ann , pattern List' , position + , stripAnn ) where -import Language.Haskell.TH.Syntax (Lift) +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) +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 @@ -58,6 +67,8 @@ data DatumF a | 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) @@ -68,8 +79,6 @@ data Simple | SimpleString Text | SimpleSymbol Text | SimpleBytevector ByteString - | SimpleMeta Text - | SimpleMetaSplice Text deriving stock (Show, Eq, Data, Generic, Lift) deriving anyclass (NFData) @@ -135,10 +144,13 @@ noAnn = MkAnn 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 @@ -161,6 +173,12 @@ 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 @@ -177,6 +195,14 @@ 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) @@ -203,3 +229,22 @@ 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/test/Gyehoek/Test/Sexp/QQ.hs b/test/Gyehoek/Test/Sexp/QQ.hs new file mode 100644 index 0000000..d1acea1 --- /dev/null +++ b/test/Gyehoek/Test/Sexp/QQ.hs @@ -0,0 +1,47 @@ +module Gyehoek.Test.Sexp.QQ where + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit +import Gyehoek.Sexp.QQ (sx) +import Data.Function (on) +import Gyehoek.Sexp.Syntax +import Data.Coerce (coerce) + + +newtype EquivDatum = MkEquiv Datum + deriving newtype (Show) + +instance Eq EquivDatum where + (==) = (==) `on` (stripAnn . coerce) + +assertEquiv + :: HasCallStack + => String -> Datum -> Datum -> Assertion +assertEquiv prefix = assertEqual prefix `on` MkEquiv + +equivto :: HasCallStack => Datum -> Datum -> Assertion +equivto = assertEquiv "" + +test_qq :: TestTree +test_qq = testGroup "sexp quasiquoter" + [ testCase "quotation" do + equivto (Symbol "abc") [sx|abc|] + equivto (List [Symbol "a", Symbol "b"]) [sx|(a b)|] + , testCase "antiquotation" do + equivto [sx|123|] + let meta = 123 :: Int + in [sx|#{meta}|] + equivto [sx|(blah (blah blah) blah)|] + let meta = [sx|blah|] + in [sx|(#{meta} (#{meta} #{meta}) #{meta})|] + , testCase "splicing simple" do + equivto [sx|(a b c d e f g)|] + 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 = Symbol "c" + e2 = Symbol <$> ["e","f"] + in [sx|(a (b #{e1} d) ##{e2} g)|] + ] -- 2.54.0 From 7c0642655f20e2a6b635598a675a0ad83b46457b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Sat, 22 Aug 2026 23:29:46 -0600 Subject: [PATCH 11/13] tests pass! --- golden/read/meta-expression/read | 3 +- golden/read/meta-splice-expression/read | 3 +- golden/read/meta-splice-variable/read | 3 +- golden/read/meta-variable/read | 3 +- gyehoek.cabal | 1 - src/Gyehoek/CPS/Lower.hs | 31 +- src/Gyehoek/CPS/Syntax.hs | 183 +++++----- src/Gyehoek/Driver.hs | 25 +- src/Gyehoek/Jalmot.hs | 7 + src/Gyehoek/Scheme/Syntax.hs | 36 +- src/Gyehoek/Sexp.hs | 454 +----------------------- src/Gyehoek/Sexp/Grammar.hs | 28 ++ src/Gyehoek/Sexp/Grammar/Base.hs | 27 +- src/Gyehoek/Sexp/QQ.hs | 5 +- src/Gyehoek/Wasm.hs | 73 ++-- test/Gyehoek/Test/Sexp.hs | 49 --- 16 files changed, 211 insertions(+), 720 deletions(-) delete mode 100644 test/Gyehoek/Test/Sexp.hs diff --git a/golden/read/meta-expression/read b/golden/read/meta-expression/read index ba6dbf1..685b9d2 100644 --- a/golden/read/meta-expression/read +++ b/golden/read/meta-expression/read @@ -7,6 +7,5 @@ , sourceColumn = Pos 1 } ) - } :< SimpleF - ( SimpleMeta "aHaskellVariable + abc * 2" ) + } :< MetaF "aHaskellVariable + abc * 2" ] \ No newline at end of file diff --git a/golden/read/meta-splice-expression/read b/golden/read/meta-splice-expression/read index a6cdbd6..e5de84d 100644 --- a/golden/read/meta-splice-expression/read +++ b/golden/read/meta-splice-expression/read @@ -7,6 +7,5 @@ , sourceColumn = Pos 1 } ) - } :< SimpleF - ( SimpleMetaSplice "takeWhile (\x -> even x) aHaskellList" ) + } :< MetaSpliceF "takeWhile (\x -> even x) aHaskellList" ] \ No newline at end of file diff --git a/golden/read/meta-splice-variable/read b/golden/read/meta-splice-variable/read index d55be83..d8428ec 100644 --- a/golden/read/meta-splice-variable/read +++ b/golden/read/meta-splice-variable/read @@ -7,6 +7,5 @@ , sourceColumn = Pos 1 } ) - } :< SimpleF - ( SimpleMetaSplice "aHaskellList" ) + } :< MetaSpliceF "aHaskellList" ] \ No newline at end of file diff --git a/golden/read/meta-variable/read b/golden/read/meta-variable/read index cee6314..4ec3604 100644 --- a/golden/read/meta-variable/read +++ b/golden/read/meta-variable/read @@ -7,6 +7,5 @@ , sourceColumn = Pos 1 } ) - } :< SimpleF - ( SimpleMeta "aHaskellVariable" ) + } :< MetaF "aHaskellVariable" ] \ No newline at end of file diff --git a/gyehoek.cabal b/gyehoek.cabal index ccb2fa4..133a4aa 100644 --- a/gyehoek.cabal +++ b/gyehoek.cabal @@ -131,7 +131,6 @@ test-suite test 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 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 b5032c0..d2bc692 100644 --- a/src/Gyehoek/CPS/Syntax.hs +++ b/src/Gyehoek/CPS/Syntax.hs @@ -40,23 +40,18 @@ module Gyehoek.CPS.Syntax ) where -import Language.SexpGrammar qualified as S -import Gyehoek.Sexp qualified import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primDatumIso, Lit(..)) -import Language.SexpGrammar.Generic +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 @@ -131,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 @@ -157,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 @@ -227,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) -> @@ -273,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..d9c3ebe 100644 --- a/src/Gyehoek/Driver.hs +++ b/src/Gyehoek/Driver.hs @@ -33,12 +33,14 @@ 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 @@ -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,10 +118,10 @@ 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) @@ -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 index f6acb66..fe946d6 100644 --- a/src/Gyehoek/Jalmot.hs +++ b/src/Gyehoek/Jalmot.hs @@ -7,6 +7,7 @@ module Gyehoek.Jalmot , runJalmot , runJalmotIO , runJalmotIOE + , runJalmotUnsafe ) where @@ -19,6 +20,7 @@ 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) @@ -46,6 +48,11 @@ runJalmotIOE eff = 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 diff --git a/src/Gyehoek/Scheme/Syntax.hs b/src/Gyehoek/Scheme/Syntax.hs index 8f3da10..f63ec5c 100644 --- a/src/Gyehoek/Scheme/Syntax.hs +++ b/src/Gyehoek/Scheme/Syntax.hs @@ -24,12 +24,9 @@ module Gyehoek.Scheme.Syntax , subst , getName , scm - , readExp - , readProgram , free' , freeWithBound' , freeO - , encodeProgram ) where @@ -54,7 +51,7 @@ 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) +import Gyehoek.Sexp.Grammar (DatumIso, DataIso) import Gyehoek.Prelude @@ -125,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) @@ -221,11 +218,14 @@ instance DatumIso CommandOrDef where $ 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 S.datumIso ||] freeWithBound' :: Foldable f => f Name -> Exp -> List Name freeWithBound' bound = filter (`elem` bound) . free' @@ -280,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 dcf2590..7428d90 100644 --- a/src/Gyehoek/Sexp.hs +++ b/src/Gyehoek/Sexp.hs @@ -1,453 +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(..) - , Position(..) - , 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 index a75e1c8..0188a30 100644 --- a/src/Gyehoek/Sexp/Grammar.hs +++ b/src/Gyehoek/Sexp/Grammar.hs @@ -7,6 +7,7 @@ module Gyehoek.Sexp.Grammar , toData , fromData , encodeWith + , encodeWith' , encodeDataWith , decodeWith , encodeTest @@ -18,6 +19,10 @@ module Gyehoek.Sexp.Grammar , with , match , Coproduct (..) + , fromDatumUnsafe + , Control.Category.id + , encodeOrShow' + , decodeDataWith ) where @@ -32,6 +37,9 @@ 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 @@ -52,6 +60,9 @@ fromDatum 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) @@ -70,6 +81,10 @@ 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) @@ -82,6 +97,12 @@ encodeTest g = TIO.putStrLn <=< (runJalmotIO . encodeWith' g) 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 @@ -101,3 +122,10 @@ 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 index 481280b..8224108 100644 --- a/src/Gyehoek/Sexp/Grammar/Base.hs +++ b/src/Gyehoek/Sexp/Grammar/Base.hs @@ -1,6 +1,8 @@ -- | 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 @@ -31,15 +33,17 @@ module Gyehoek.Sexp.Grammar.Base , 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 qualified as GS -import qualified Gyehoek.Sexp as GS import Gyehoek.Sexp.Print (printDatum') import Data.Scientific (Scientific) import qualified Data.Scientific as Sci @@ -249,10 +253,10 @@ ifLike -- | condition -> DatumGrammar a -- | consequent (then-branch) - -> DatumGrammar a + -> DatumGrammar b -- | alternative (else-branch) - -> DatumGrammar a - -> G (Datum :- t) (a :- a :- a :- t) + -> 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 @@ -282,7 +286,10 @@ lambdaLike kw formals body = listWithIndentation (NSpecial 1) $ >>> body lambdaKeyword :: G (Datum :- t) t -lambdaKeyword = coproduct [ sym "lambda", sym "λ" ] +lambdaKeyword = coproduct [ sym "λ", sym "lambda" ] + +kappaKeyword :: G (Datum :- t) t +kappaKeyword = coproduct [ sym "κ", sym "kappa" ] beginLike :: Text @@ -291,3 +298,11 @@ beginLike 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/QQ.hs b/src/Gyehoek/Sexp/QQ.hs index 12834cd..7a4d93b 100644 --- a/src/Gyehoek/Sexp/QQ.hs +++ b/src/Gyehoek/Sexp/QQ.hs @@ -5,6 +5,7 @@ module Gyehoek.Sexp.QQ , makeSx' , sx , sxs + , QuasiQuoter ) where import Data.Data (Typeable, cast) @@ -124,5 +125,5 @@ makeSx :: Data r => Code Q (Datum -> r) -> QuasiQuoter makeSx = makeSx' . unTypeCode sx, sxs :: QuasiQuoter -sxs = makeSxs [|| id @(List Datum) ||] -sx = makeSx [|| id @Datum ||] +sxs = makeSxs [|| Prelude.id @(List Datum) ||] +sx = makeSx [|| Prelude.id @Datum ||] 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/Sexp.hs b/test/Gyehoek/Test/Sexp.hs deleted file mode 100644 index 3f8f950..0000000 --- a/test/Gyehoek/Test/Sexp.hs +++ /dev/null @@ -1,49 +0,0 @@ -module Gyehoek.Test.Sexp 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 Data.Function (on) - - -test_root = testGroup "sexp" $ - [ sxTree - ] - -newtype EquivSexp = MkEquiv SL.Sexp - deriving newtype (Show) - -instance Eq EquivSexp where - MkEquiv x == MkEquiv y = equivalent x y - -assertEquiv - :: HasCallStack - => String -> SL.Sexp -> SL.Sexp -> Assertion -assertEquiv prefix = assertEqual prefix `on` MkEquiv - -equivto = assertEquiv "" - -sxTree :: TestTree -sxTree = testGroup "sx" - [ testCase "quotation" do - equivto (SL.Symbol "abc") [sx|abc|] - equivto (SL.ParenList [SL.Symbol "a", SL.Symbol "b"]) [sx|(a b)|] - , testCase "antiquotation" do - equivto [sx|123|] - let meta = 123 :: Int - in [sx|#{meta}|] - equivto [sx|(blah (blah blah) blah)|] - let meta = [sx|blah|] - in [sx|(#{meta} (#{meta} #{meta}) #{meta})|] - , testCase "splicing" do - equivto [sx|(a b c d e f g)|] - let metas = SL.Symbol <$> ["c","d","e"] - in [sx|(a b ##{metas} f g)|] - equivto [sx|(a (b c d) e f g)|] - let - e1 = SL.Symbol "c" - e2 = SL.Symbol <$> ["e","f"] - in [sx|(a (b #{e1} d) ##{e2} g)|] - ] -- 2.54.0 From 2ceefdb3df286fe721439e662855cd2357376e28 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Sun, 23 Aug 2026 00:46:57 -0600 Subject: [PATCH 12/13] remove sexp-grammar --- gyehoek.cabal | 3 -- src/Gyehoek/Driver.hs | 16 ++++---- src/Gyehoek/Language.hs | 25 ------------ src/Gyehoek/Scheme/Syntax.hs | 2 +- src/Gyehoek/Stack/Syntax.hs | 61 +++++++++++++----------------- test/Gyehoek/Test/CPS/Eval.hs | 1 - test/Gyehoek/Test/CPS/Syntax.hs | 1 - test/Gyehoek/Test/Scheme/Syntax.hs | 1 - 8 files changed, 36 insertions(+), 74 deletions(-) delete mode 100644 src/Gyehoek/Language.hs diff --git a/gyehoek.cabal b/gyehoek.cabal index 133a4aa..f48e9fc 100644 --- a/gyehoek.cabal +++ b/gyehoek.cabal @@ -61,7 +61,6 @@ library Gyehoek.Driver Gyehoek.GenSym Gyehoek.Jalmot - Gyehoek.Language Gyehoek.Lift1 Gyehoek.Options Gyehoek.Prelude @@ -105,7 +104,6 @@ library , process , recursion-schemes , scientific - , sexp-grammar , string-interpolate , template-haskell , text @@ -149,7 +147,6 @@ test-suite test , lens , pretty-simple , process-extras - , sexp-grammar , tasty , tasty-expected-failure , tasty-hunit diff --git a/src/Gyehoek/Driver.hs b/src/Gyehoek/Driver.hs index d9c3ebe..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 @@ -35,14 +35,14 @@ 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 runJalmotIO . runFileSystem . runGenSym . driver $ opts - + -- hPutStr :: FileSystem :> es => Handle -> Text -> Eff es () -- hPutStr h = FB.hPutStr h . T.encodeUtf8 @@ -125,15 +125,15 @@ driver opts = do 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) diff --git a/src/Gyehoek/Language.hs b/src/Gyehoek/Language.hs deleted file mode 100644 index f3bdd84..0000000 --- a/src/Gyehoek/Language.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -module Gyehoek.Language - ( Language(..) - ) where - -import Data.Kind (Type) -import Gyehoek.Prelude -import Language.SexpGrammar (Position, Grammar, (:-), Sexp) - - -class Language l where - type Program l :: Type - languageName :: Text - programGrammar :: forall t. Grammar Position (List Sexp :- t) (Program l :- t) - -readProgramFile - :: forall l es. Language l - => FilePath -> Eff es (Program l) -readProgramFile fp = _ - -readProgramStringPos - :: forall l. Language l - => Position -> Text -> Either Text (Program l) -readProgramStringPos pos s = _ diff --git a/src/Gyehoek/Scheme/Syntax.hs b/src/Gyehoek/Scheme/Syntax.hs index f63ec5c..8b85e8d 100644 --- a/src/Gyehoek/Scheme/Syntax.hs +++ b/src/Gyehoek/Scheme/Syntax.hs @@ -225,7 +225,7 @@ instance DataIso Program where -- utilities scm :: QuasiQuoter -scm = GS.makeSx [|| S.fromDatumUnsafe S.datumIso ||] +scm = GS.makeSx [|| S.fromDatumUnsafe @Exp S.datumIso ||] freeWithBound' :: Foldable f => f Name -> Exp -> List Name freeWithBound' bound = filter (`elem` bound) . free' 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/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/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 -- 2.54.0 From d4c1385225291462c70bbc62e3ae818538988ea8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Sun, 23 Aug 2026 01:13:14 -0600 Subject: [PATCH 13/13] remove doctest --- cabal.project | 3 +++ gyehoek.cabal | 18 ++++++++++-------- 2 files changed, 13 insertions(+), 8 deletions(-) diff --git a/cabal.project b/cabal.project index 610c695..44f12dd 100644 --- a/cabal.project +++ b/cabal.project @@ -3,6 +3,9 @@ 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 location: https://git.deertopia.net/msyds/qbe-hs.git diff --git a/gyehoek.cabal b/gyehoek.cabal index f48e9fc..0bab908 100644 --- a/gyehoek.cabal +++ b/gyehoek.cabal @@ -155,11 +155,13 @@ test-suite test default-language: GHC2024 -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 +-- 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 -- 2.54.0