summaryrefslogtreecommitdiff
path: root/src/Parser.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Parser.hs')
-rw-r--r--src/Parser.hs22
1 files changed, 13 insertions, 9 deletions
diff --git a/src/Parser.hs b/src/Parser.hs
index 903ad54..f8c5b0e 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -29,7 +29,7 @@ import qualified Text.Megaparsec.Char.Lexer as L
import System.Exit
-import Network (Node)
+import Network (Network, Node)
import Process (Process, ProcName(..))
import Test
import Util
@@ -40,7 +40,7 @@ type TestStream = TL.Text
data TestParserState = TestParserState
{ testVars :: [(VarName, SomeExprType)]
- , testContext :: Maybe SomeExpr
+ , testContext :: SomeExpr
}
data SomeExprType = forall a. ExprType a => SomeExprType (Proxy a)
@@ -53,6 +53,7 @@ textSomeExprType (SomeExprType p) = textExprType p
instance MonadEval TestParser where
lookupVar name = maybe (fail $ "variable not in scope: '" ++ unpackVarName name ++ "'") (return . someEmptyVar) =<< gets (lookup name . testVars)
+ rootNetwork = return emptyVarValue
skipLineComment :: TestParser ()
skipLineComment = L.skipLineComment $ TL.pack "#"
@@ -386,13 +387,13 @@ instance ParamType a => ParamType [a] where
parseParam _ = listOf (parseParam @a Proxy)
showParamType _ = showParamType @a Proxy ++ " [, " ++ showParamType @a Proxy ++ " ...]"
paramDefault _ = return []
- paramFromSomeExpr _ (SomeExpr e) = cast e <|> ((:[]) <$> cast e)
+ paramFromSomeExpr _ se@(SomeExpr e) = cast e <|> ((:[]) <$> paramFromSomeExpr @a Proxy se)
instance (ParamType a, ParamType b) => ParamType (Either a b) where
type ParamRep (Either a b) = Either (ParamRep a) (ParamRep b)
parseParam _ = try (Left <$> parseParam @a Proxy) <|> (Right <$> parseParam @b Proxy)
showParamType _ = showParamType @a Proxy ++ " or " ++ showParamType @b Proxy
- paramFromSomeExpr _ (SomeExpr e) = (Left <$> cast e) <|> (Right <$> cast e)
+ paramFromSomeExpr _ se = (Left <$> paramFromSomeExpr @a Proxy se) <|> (Right <$> paramFromSomeExpr @b Proxy se)
data SomeParam f = forall a. ParamType a => SomeParam (Proxy a) (f (ParamRep a))
@@ -418,8 +419,9 @@ instance ParamType a => ParamType (ParamOrContext a) where
parseParam _ = parseParam @a Proxy
showParamType _ = showParamType @a Proxy
paramDefault _ = gets testContext >>= \case
- Just se | Just e <- paramFromSomeExpr @a Proxy se -> return e
- _ -> fail $ showParamType @a Proxy <> " not available from context"
+ se@(SomeExpr ctx)
+ | Just e <- paramFromSomeExpr @a Proxy se -> return e
+ | otherwise -> fail $ showParamType @a Proxy <> " not available from context type '" <> T.unpack (textExprType ctx) <> "'"
paramOrContext :: forall a. ParamType a => String -> CommandDef a
paramOrContext name = CommandDef [(name, SomeParam (Proxy @(ParamOrContext a)) Proxy)] (\[SomeParam Proxy (Identity x)] -> fromJust $ cast x)
@@ -515,7 +517,8 @@ testWith = do
off <- stateOffset <$> getParserState
ctx@(SomeExpr (_ :: Expr ctxe)) <- someExpr
let expected =
- [ SomeExprType @Node Proxy
+ [ SomeExprType @Network Proxy
+ , SomeExprType @Node Proxy
, SomeExprType @Process Proxy
]
notAllowed <- flip allM expected $ \case
@@ -529,12 +532,13 @@ testWith = do
indent <- L.indentGuard scn GT ref
localState $ do
- modify $ \s -> s { testContext = Just ctx }
+ modify $ \s -> s { testContext = ctx }
testBlock indent
testNode :: TestParser [TestStep]
testNode = command "node" $ DeclNode
<$> param ""
+ <*> paramOrContext "on"
<*> innerBlock
testSpawn :: TestParser [TestStep]
@@ -617,7 +621,7 @@ parseTestFile path = do
content <- TL.readFile path
let initState = TestParserState
{ testVars = []
- , testContext = Nothing
+ , testContext = SomeExpr RootNetwork
}
case evalState (runParserT parseTestDefinitions path content) initState of
Left err -> putStr (errorBundlePretty err) >> exitFailure