diff options
author | Roman Smrž <roman.smrz@seznam.cz> | 2024-08-07 21:41:09 +0200 |
---|---|---|
committer | Roman Smrž <roman.smrz@seznam.cz> | 2024-08-07 21:51:10 +0200 |
commit | fed9f38d30f0d2a37042f9a88ec7f5248767ea58 (patch) | |
tree | c266d7e7c64c696569d213c57667129762b62f67 /src/Parser.hs | |
parent | dc2202f36f8ee220293cc6f230be604a19be8cbb (diff) |
Parser: collect toplevel definitions using Writer
Diffstat (limited to 'src/Parser.hs')
-rw-r--r-- | src/Parser.hs | 19 |
1 files changed, 14 insertions, 5 deletions
diff --git a/src/Parser.hs b/src/Parser.hs index 405622e..5c79390 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -5,7 +5,9 @@ module Parser ( ) where import Control.Monad.State +import Control.Monad.Writer +import Data.Maybe import Data.Set qualified as S import Data.Text qualified as T import Data.Text.Lazy qualified as TL @@ -24,8 +26,8 @@ import Parser.Statement import Test import Test.Builtins -parseTestDefinition :: TestParser Test -parseTestDefinition = label "test definition" $ toplevel $ do +parseTestDefinition :: TestParser () +parseTestDefinition = label "test definition" $ toplevel ToplevelTest $ do block (\name steps -> return $ Test name $ concat steps) header testStep where header = do wsymbol "test" @@ -47,7 +49,10 @@ parseTestModule absPath = do , do return $ [ T.pack $ takeBaseName absPath ] ] - moduleTests <- many parseTestDefinition + (_, toplevels) <- listen $ many $ choice + [ parseTestDefinition + ] + let moduleTests = catMaybes $ map (\case ToplevelTest x -> Just x; {- _ -> Nothing -}) toplevels eof return Module { .. } @@ -56,9 +61,13 @@ parseTestFile path = do content <- TL.readFile path absPath <- makeAbsolute path let initState = TestParserState - { testVars = map (fmap someVarValueType) builtins + { testVars = concat + [ map (fmap someVarValueType) builtins + ] , testContext = SomeExpr RootNetwork } - case evalState (runParserT (parseTestModule absPath) path content) initState of + (res, _) = flip evalState initState $ runWriterT $ runParserT (parseTestModule absPath) path content + + case res of Left err -> putStr (errorBundlePretty err) >> exitFailure Right testModule -> return testModule |