diff options
| -rw-r--r-- | src/Main.hs | 10 | ||||
| -rw-r--r-- | src/Parser.hs | 42 | ||||
| -rw-r--r-- | src/Test.hs | 3 |
3 files changed, 53 insertions, 2 deletions
diff --git a/src/Main.hs b/src/Main.hs index 5e1e7b2..efab611 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -296,6 +296,13 @@ expect (SourceLine sline) p re vars = do outLine OutputMatchFail (Just $ procName p) $ T.pack "expect failed on " `T.append` sline throwError () +testStepGuard :: SourceLine -> Expr Bool -> TestRun () +testStepGuard (SourceLine sline) expr = do + x <- eval expr + when (not x) $ do + outLine OutputMatchFail Nothing $ T.pack "guard failed on " `T.append` sline + throwError () + allM :: Monad m => [a] -> (a -> m Bool) -> m Bool allM (x:xs) p = p x >>= \case True -> allM xs p; False -> return False allM [] _ = return True @@ -340,6 +347,9 @@ runTest out opts test = do regex <- eval expr expect line p regex captures + Guard line expr -> do + testStepGuard line expr + Wait -> do outPrompt $ T.pack "Waiting..." void $ liftIO $ getLine diff --git a/src/Parser.hs b/src/Parser.hs index 0608ccd..fa85f8c 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -92,15 +92,20 @@ identifier :: TestParser Text identifier = do TL.toStrict <$> takeWhile1P Nothing (\x -> isAlphaNum x || x == '_') +varName :: TestParser VarName +varName = do + VarName . T.splitOn (T.singleton '.') . TL.toStrict <$> + takeWhile1P Nothing (\x -> isAlphaNum x || x == '_' || x == '.') + varExpansion :: TestParser VarName varExpansion = do void $ char '$' choice [ VarName . (:[]) <$> identifier ,do void $ char '{' - name <- takeWhile1P Nothing (/='}') + name <- varName void $ char '}' - return $ VarName $ T.splitOn (T.singleton '.') (TL.toStrict name) + return name ] quotedString :: TestParser (Expr Text) @@ -143,6 +148,24 @@ regex = label "regular expression" $ lexeme $ do _ <- eval expr -- test regex parsing with empty variables return expr +stringExpr :: TestParser (Expr Text) +stringExpr = choice + [ quotedString + , StringVar <$> varName + ] + +boolExpr :: TestParser (Expr Bool) +boolExpr = do + x <- stringExpr + sc + op <- choice + [ symbol "==" >> return (==) + , symbol "/=" >> return (/=) + ] + y <- stringExpr + sc + return $ BinOp op x y + class GInit f where ginit :: f x instance GInit U1 where ginit = U1 @@ -247,6 +270,20 @@ testExpect = command "expect" <*> (maybe (return []) return $ b ^. expectBuilderCaptures) +data GuardBuilder = GuardBuilder + { _guardBuilderExpr :: Maybe (Expr Bool) + } + deriving (Generic) + +makeLenses ''GuardBuilder + +testGuard :: TestParser [TestStep] +testGuard = command "guard" + [ Param "" guardBuilderExpr boolExpr + ] $ \s b -> Guard s + <$> (maybe (fail "missing guard expression") return $ b ^. guardBuilderExpr) + + testWait :: TestParser [TestStep] testWait = do wsymbol "wait" @@ -258,6 +295,7 @@ parseTestDefinition = label "test definition" $ toplevel $ do [ testSpawn , testSend , testExpect + , testGuard , testWait ] where header = do diff --git a/src/Test.hs b/src/Test.hs index 404d965..e21eaee 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -31,6 +31,7 @@ data Test = Test data TestStep = Spawn ProcName NodeName | Send ProcName (Expr Text) | Expect SourceLine ProcName (Expr Regex) [VarName] + | Guard SourceLine (Expr Bool) | Wait newtype SourceLine = SourceLine Text @@ -64,6 +65,7 @@ data Expr a where StringLit :: Text -> Expr Text Concat :: [Expr Text] -> Expr Text Regex :: [Expr Text] -> Expr Regex + BinOp :: (b -> c -> a) -> Expr b -> Expr c -> Expr a eval :: MonadEval m => Expr a -> m a eval (StringVar var) = lookupStringVar var @@ -76,3 +78,4 @@ eval (Regex xs) = do case compile defaultCompOpt defaultExecOpt $ T.concat $ concat [[T.singleton '^'], parts, [T.singleton '$']] of Left err -> fail err Right re -> return re +eval (BinOp f x y) = f <$> eval x <*> eval y |