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] 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