Guard command

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