diff options
| -rw-r--r-- | src/Main.hs | 15 | ||||
| -rw-r--r-- | src/Parser.hs | 32 | ||||
| -rw-r--r-- | src/Test.hs | 5 |
3 files changed, 33 insertions, 19 deletions
diff --git a/src/Main.hs b/src/Main.hs index e062dee..5e1e7b2 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -267,8 +267,8 @@ tryMatch re (x:xs) | Right (Just (_, _, _, capture)) <- regexec re x = Just ((x, | otherwise = fmap (x:) <$> tryMatch re xs tryMatch _ [] = Nothing -expect :: Process -> Regex -> Text -> [VarName] -> TestRun () -expect p re pat vars = do +expect :: SourceLine -> Process -> Regex -> [VarName] -> TestRun () +expect (SourceLine sline) p re vars = do timeout <- asks $ optTimeout . teOptions delay <- liftIO $ registerDelay $ ceiling $ 1000000 * timeout mbmatch <- atomicallyTest $ (Nothing <$ (check =<< readTVar delay)) <|> do @@ -281,19 +281,19 @@ expect p re pat vars = do case mbmatch of Just (line, capture) -> do when (length vars /= length capture) $ do - outLine OutputMatchFail (Just $ procName p) $ T.pack "mismatched number of capture variables /" `T.append` pat `T.append` T.pack "/" + outLine OutputMatchFail (Just $ procName p) $ T.pack "mismatched number of capture variables on " `T.append` sline throwError () forM_ vars $ \name -> do cur <- gets (lookup name . tsVars) when (isJust cur) $ do - outLine OutputMatchFail (Just $ procName p) $ T.pack "variable already exists: '" `T.append` textVarName name `T.append` T.pack "'" + outLine OutputMatchFail (Just $ procName p) $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` sline throwError () modify $ \s -> s { tsVars = zip vars capture ++ tsVars s } outLine OutputMatch (Just $ procName p) line Nothing -> do - outLine OutputMatchFail (Just $ procName p) $ T.pack "expect failed /" `T.append` pat `T.append` T.pack "/" + outLine OutputMatchFail (Just $ procName p) $ T.pack "expect failed on " `T.append` sline throwError () allM :: Monad m => [a] -> (a -> m Bool) -> m Bool @@ -335,11 +335,10 @@ runTest out opts test = do line <- eval expr send p line - Expect pname expr@(Regex ps) captures -> do + Expect line pname expr captures -> do p <- getProcess net pname regex <- eval expr - pat <- eval (Concat ps) - expect p regex pat captures + expect line p regex captures Wait -> do outPrompt $ T.pack "Waiting..." diff --git a/src/Parser.hs b/src/Parser.hs index 6131a78..0608ccd 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -152,16 +152,28 @@ instance (GInit f, GInit h) => GInit (f :*: h) where ginit = ginit :*: ginit data Param a = forall b. Param String (Lens' a (Maybe b)) (TestParser b) -command :: (Generic b, GInit (Rep b)) => String -> [Param b] -> (b -> TestParser a) -> TestParser [a] +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 + ] + +command :: (Generic b, GInit (Rep b)) => String -> [Param b] -> (SourceLine -> b -> TestParser a) -> TestParser [a] command name params fin = do + origline <- getSourceLine wsymbol name - let blockHelper prev cur = L.indentBlock scn $ helper prev cur - helper prev cur = choice $ concat + let blockHelper line prev cur = L.indentBlock scn $ helper line prev cur + helper line prev cur = choice $ concat [[ do void $ eol - L.IndentNone . (:[]) <$> fin cur + L.IndentNone . (:[]) <$> fin line cur ] ,[ do void $ lexeme (char ':') - return $ L.IndentSome Nothing (return . concat) (blockHelper prev cur) + return $ L.IndentSome Nothing (return . concat) $ do + line' <- getSourceLine + blockHelper line' prev cur ] , flip map params $ \(Param sym l p) -> do x <- if null sym @@ -175,10 +187,10 @@ command name params fin = do when (any (== sym) prev) $ do fail $ "multiple '" ++ sym ++ "' parameters" p - helper (sym:prev) (l .~ Just x $ cur) + helper line (sym:prev) (l .~ Just x $ cur) ] - blockHelper [] (G.to ginit) + blockHelper origline [] (G.to ginit) data SpawnBuilder = SpawnBuilder @@ -193,7 +205,7 @@ testSpawn :: TestParser [TestStep] testSpawn = command "spawn" [ Param "on" spawnBuilderNode nodeName , Param "as" spawnBuilderProc procName - ] $ \b -> Spawn + ] $ \_ b -> Spawn <$> (maybe (fail "missing 'as' <proc>") return $ b ^. spawnBuilderProc) <*> (maybe (fail "missing 'on' <node>") return $ b ^. spawnBuilderNode) @@ -210,7 +222,7 @@ testSend :: TestParser [TestStep] testSend = command "send" [ Param "to" sendBuilderProc procName , Param "" sendBuilderLine quotedString - ] $ \b -> Send + ] $ \_ b -> Send <$> (maybe (fail "missing 'to' <proc>") return $ b ^. sendBuilderProc) <*> (maybe (fail "missing line to send") return $ b ^. sendBuilderLine) @@ -229,7 +241,7 @@ testExpect = command "expect" [ Param "from" expectBuilderProc procName , Param "" expectBuilderRegex regex , Param "capture" expectBuilderCaptures (listOf $ VarName . (:[]) <$> identifier) - ] $ \b -> Expect + ] $ \s b -> Expect s <$> (maybe (fail "missing 'from' <proc>") return $ b ^. expectBuilderProc) <*> (maybe (fail "missing regex to match") return $ b ^. expectBuilderRegex) <*> (maybe (return []) return $ b ^. expectBuilderCaptures) diff --git a/src/Test.hs b/src/Test.hs index ab97bc7..404d965 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -1,6 +1,7 @@ module Test ( Test(..), TestStep(..), + SourceLine(..), ProcName(..), textProcName, unpackProcName, NodeName(..), textNodeName, unpackNodeName, @@ -29,9 +30,11 @@ data Test = Test data TestStep = Spawn ProcName NodeName | Send ProcName (Expr Text) - | Expect ProcName (Expr Regex) [VarName] + | Expect SourceLine ProcName (Expr Regex) [VarName] | Wait +newtype SourceLine = SourceLine Text + newtype NodeName = NodeName Text deriving (Eq, Ord) |