diff options
author | Roman Smrž <roman.smrz@seznam.cz> | 2024-09-23 19:44:17 +0200 |
---|---|---|
committer | Roman Smrž <roman.smrz@seznam.cz> | 2024-09-25 20:25:22 +0200 |
commit | 213e3523aead4c18b65ac85886203d2508b9b27e (patch) | |
tree | 6f207174a09ee312a366d0c22c08a31a056aaf3d /src/Parser | |
parent | 274554243235d3013430a48973fd0f25244ac392 (diff) |
Implement "guard" as a builtin
Diffstat (limited to 'src/Parser')
-rw-r--r-- | src/Parser/Core.hs | 24 | ||||
-rw-r--r-- | src/Parser/Expr.hs | 10 | ||||
-rw-r--r-- | src/Parser/Statement.hs | 19 |
3 files changed, 24 insertions, 29 deletions
diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs index dd2df12..ab6079a 100644 --- a/src/Parser/Core.hs +++ b/src/Parser/Core.hs @@ -55,12 +55,12 @@ lookupVarType off name = do gets (fromMaybe t . M.lookup tvar . testTypeUnif) Just x -> return x -lookupVarExpr :: Int -> VarName -> TestParser SomeExpr -lookupVarExpr off name = do +lookupVarExpr :: Int -> SourceLine -> VarName -> TestParser SomeExpr +lookupVarExpr off sline name = do lookupVarType off name >>= \case - ExprTypePrim (Proxy :: Proxy a) -> return $ SomeExpr $ (Variable name :: Expr a) - ExprTypeVar tvar -> return $ SomeExpr $ DynVariable tvar name - ExprTypeFunction args (_ :: Proxy a) -> return $ SomeExpr $ (FunVariable args name :: Expr (FunctionType a)) + ExprTypePrim (Proxy :: Proxy a) -> return $ SomeExpr $ (Variable sline name :: Expr a) + ExprTypeVar tvar -> return $ SomeExpr $ DynVariable tvar sline name + ExprTypeFunction args (_ :: Proxy a) -> return $ SomeExpr $ (FunVariable args sline name :: Expr (FunctionType a)) unify :: Int -> SomeExprType -> SomeExprType -> TestParser SomeExprType unify _ (ExprTypeVar aname) (ExprTypeVar bname) | aname == bname = do @@ -127,10 +127,10 @@ unifyExpr off pa expr = if | Just (Refl :: a :~: b) <- eqT -> return expr - | DynVariable tvar name <- expr + | DynVariable tvar sline name <- expr -> do _ <- unify off (ExprTypePrim (Proxy :: Proxy a)) (ExprTypeVar tvar) - return $ Variable name + return $ Variable sline name | Just (Refl :: FunctionType a :~: b) <- eqT -> do @@ -198,3 +198,13 @@ listOf :: TestParser a -> TestParser [a] listOf item = do x <- item (x:) <$> choice [ symbol "," >> listOf item, return [] ] + + +getSourceLine :: TestParser SourceLine +getSourceLine = do + pstate <- statePosState <$> getParserState + return $ SourceLine $ T.concat + [ T.pack $ sourcePosPretty $ pstateSourcePos pstate + , T.pack ": " + , TL.toStrict $ TL.takeWhile (/='\n') $ pstateInput pstate + ] diff --git a/src/Parser/Expr.hs b/src/Parser/Expr.hs index 04035c1..8ae0f77 100644 --- a/src/Parser/Expr.hs +++ b/src/Parser/Expr.hs @@ -66,8 +66,9 @@ someExpansion = do void $ char '$' choice [do off <- stateOffset <$> getParserState + sline <- getSourceLine name <- VarName . TL.toStrict <$> takeWhile1P Nothing (\x -> isAlphaNum x || x == '_') - lookupVarExpr off name + lookupVarExpr off sline name , between (char '{') (char '}') someExpr ] @@ -348,9 +349,10 @@ literal = label "literal" $ choice variable :: TestParser SomeExpr variable = label "variable" $ do off <- stateOffset <$> getParserState + sline <- getSourceLine name <- varName - lookupVarExpr off name >>= \case - SomeExpr e'@(FunVariable (FunctionArguments argTypes) _) -> do + lookupVarExpr off sline name >>= \case + SomeExpr e'@(FunVariable (FunctionArguments argTypes) _ _) -> do let check poff kw expr = do case M.lookup kw argTypes of Just expected -> do @@ -364,7 +366,7 @@ variable = label "variable" $ do Nothing -> "unexpected parameter" return expr - args <- functionArguments check someExpr literal (\poff -> lookupVarExpr poff . VarName) + args <- functionArguments check someExpr literal (\poff -> lookupVarExpr poff sline . VarName) return $ SomeExpr $ ArgsApp args e' e -> do return e diff --git a/src/Parser/Statement.hs b/src/Parser/Statement.hs index 94a5583..6434a53 100644 --- a/src/Parser/Statement.hs +++ b/src/Parser/Statement.hs @@ -8,9 +8,8 @@ import Control.Monad.State import Data.Kind import Data.Maybe -import qualified Data.Set as S +import Data.Set qualified as S import Data.Text qualified as T -import qualified Data.Text.Lazy as TL import Data.Typeable import Text.Megaparsec hiding (State) @@ -24,16 +23,6 @@ import Process (Process) import Test import Util -getSourceLine :: TestParser SourceLine -getSourceLine = do - pstate <- statePosState <$> getParserState - return $ SourceLine $ T.concat - [ T.pack $ sourcePosPretty $ pstateSourcePos pstate - , T.pack ": " - , TL.toStrict $ TL.takeWhile (/='\n') $ pstateInput pstate - ] - - letStatement :: TestParser [TestStep] letStatement = do line <- getSourceLine @@ -313,11 +302,6 @@ testFlush = command "flush" $ Flush <$> paramOrContext "from" <*> param "" -testGuard :: TestParser [TestStep] -testGuard = command "guard" $ Guard - <$> cmdLine - <*> param "" - testDisconnectNode :: TestParser [TestStep] testDisconnectNode = command "disconnect_node" $ DisconnectNode <$> paramOrContext "" @@ -364,7 +348,6 @@ testStep = choice , testSend , testExpect , testFlush - , testGuard , testDisconnectNode , testDisconnectNodes , testDisconnectUpstream |