diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Output.hs | 5 | ||||
| -rw-r--r-- | src/Parser/Statement.hs | 13 | ||||
| -rw-r--r-- | src/Process.hs | 7 | ||||
| -rw-r--r-- | src/Run.hs | 20 | ||||
| -rw-r--r-- | src/Script/Expr.hs | 21 | ||||
| -rw-r--r-- | src/Test.hs | 2 |
6 files changed, 48 insertions, 20 deletions
diff --git a/src/Output.hs b/src/Output.hs index b91bbdd..01c0b4b 100644 --- a/src/Output.hs +++ b/src/Output.hs @@ -53,6 +53,7 @@ data OutputType = OutputChildStdout | OutputChildStderr | OutputChildStdin + | OutputChildExec | OutputChildInfo | OutputChildFail | OutputMatch @@ -83,6 +84,7 @@ outColor :: OutputType -> Text outColor OutputChildStdout = T.pack "0" outColor OutputChildStderr = T.pack "31" outColor OutputChildStdin = T.pack "0" +outColor OutputChildExec = T.pack "33" outColor OutputChildInfo = T.pack "0" outColor OutputChildFail = T.pack "31" outColor OutputMatch = T.pack "32" @@ -95,6 +97,7 @@ outSign :: OutputType -> Text outSign OutputChildStdout = " " outSign OutputChildStderr = T.pack "!" outSign OutputChildStdin = T.empty +outSign OutputChildExec = "*" outSign OutputChildInfo = T.pack "." outSign OutputChildFail = T.pack "!!" outSign OutputMatch = T.pack "+" @@ -112,6 +115,7 @@ outTestLabel = \case OutputChildStdout -> "child-stdout" OutputChildStderr -> "child-stderr" OutputChildStdin -> "child-stdin" + OutputChildExec -> "child-exec" OutputChildInfo -> "child-info" OutputChildFail -> "child-fail" OutputMatch -> "match" @@ -189,6 +193,7 @@ testOutputLines otype@(OutputMatchFail (CallStack stack)) _ msg = concat [ [ T.concat [ outTestLabel otype, " ", msg ] ] , concat $ flip map stack $ \( sline, vars ) -> T.concat [ outTestLabel otype, "-line ", textSourceLine sline ] : showVars vars + , [ T.concat [ outTestLabel otype, "-done" ] ] ] where showVars = diff --git a/src/Parser/Statement.hs b/src/Parser/Statement.hs index 9b02770..0e6314b 100644 --- a/src/Parser/Statement.hs +++ b/src/Parser/Statement.hs @@ -169,6 +169,12 @@ instance ParamType SourceLine where parseParam _ = mzero showParamType _ = "<source line>" +instance ParamType CallStack where + type ParamRep CallStack = Expr CallStack + parseParam _ = mzero + showParamType _ = "<call stack>" + paramExpr = id + instance ExprType a => ParamType (TypedVarName a) where parseParam _ = newVarName showParamType _ = "<variable>" @@ -269,6 +275,9 @@ paramOrContext name = fromParamOrContext <$> param name cmdLine :: CommandDef SourceLine cmdLine = param "" +callStack :: CommandDef CallStack +callStack = param "" + newtype InnerBlock a = InnerBlock { fromInnerBlock :: [ a ] -> TestBlock () } instance ExprType a => ParamType (InnerBlock a) where @@ -320,6 +329,7 @@ command name (CommandDef types ctor) = do iparams <- forM params $ \case (_, SomeParam (p :: Proxy p) Nothing) | Just (Refl :: p :~: SourceLine) <- eqT -> return $ SomeParam p $ Identity line + | Just (Refl :: p :~: CallStack) <- eqT -> return $ SomeParam p $ Identity $ Variable line callStackFqVarName | SomeNewVariables (vars :: [ TypedVarName a ]) <- definedVariables , Just (Refl :: p :~: InnerBlock a) <- eqT @@ -424,7 +434,8 @@ testSpawn = command "spawn" $ Spawn testExpect :: TestParser (Expr (TestBlock ())) testExpect = command "expect" $ Expect - <$> cmdLine + <$> callStack + <*> cmdLine <*> (fromExprParam <$> paramOrContext "from") <*> param "" <*> (maybe 1 fromExprParam <$> param "timeout") diff --git a/src/Process.hs b/src/Process.hs index 1389987..a575e76 100644 --- a/src/Process.hs +++ b/src/Process.hs @@ -3,7 +3,7 @@ module Process ( ProcName(..), textProcName, unpackProcName, send, - outProc, + outProc, outProcName, lineReadingLoop, startProcessIOLoops, spawnOn, @@ -88,7 +88,10 @@ send p line = liftIO $ do hFlush (procStdin p) outProc :: MonadOutput m => OutputType -> Process -> Text -> m () -outProc otype p line = outLine otype (Just $ textProcName $ procName p) line +outProc otype p line = outProcName otype (procName p) line + +outProcName :: MonadOutput m => OutputType -> ProcName -> Text -> m () +outProcName otype pname line = outLine otype (Just $ textProcName pname) line lineReadingLoop :: MonadOutput m => Process -> Handle -> (Text -> m ()) -> m () lineReadingLoop process h act = @@ -79,7 +79,7 @@ runTest out opts gdefs test = do } tstate = TestState { tsGlobals = gdefs - , tsLocals = [] + , tsLocals = [ ( callStackVarName, someConstValue (CallStack []) ) ] , tsNodePacketLoss = M.empty , tsDisconnectedUp = S.empty , tsDisconnectedBridge = S.empty @@ -188,9 +188,10 @@ runStep = \case opts <- asks $ teOptions . fst let pname = ProcName tname tool = fromMaybe (optDefaultTool opts) (lookup pname $ optProcTools opts) - cmd = unwords $ tool : map (T.unpack . escape) args + cmd = T.unwords $ T.pack tool : map escape args escape = ("'" <>) . (<> "'") . T.replace "'" "'\\''" - withProcess (Right node) pname Nothing cmd $ runStep . inner + outProcName OutputChildExec pname cmd + withProcess (Right node) pname Nothing (T.unpack cmd) $ runStep . inner SpawnShell mbname node script inner -> do let tname | Just (TypedVarName (VarName name)) <- mbname = name @@ -202,8 +203,8 @@ runStep = \case outProc OutputChildStdin p line send p line - Expect line p expr timeout captures inner -> do - expect line p expr timeout captures $ runStep . inner + Expect stack line p expr timeout captures inner -> do + expect stack line p expr timeout captures $ runStep . inner Flush p regex -> do atomicallyTest $ flushProcessOutput p regex @@ -318,8 +319,9 @@ exprFailed desc stack pname = do outLine (OutputMatchFail stack) (Just prompt) $ desc <> " failed" throwError Failed -expect :: SourceLine -> Process -> Traced Regex -> Scientific -> [TypedVarName Text] -> ([ Text ] -> TestRun ()) -> TestRun () -expect sline p (Traced trace re) etimeout tvars inner = do +expect :: CallStack -> SourceLine -> Process -> Traced Regex -> Scientific -> [ TypedVarName Text ] -> ([ Text ] -> TestRun ()) -> TestRun () +expect (CallStack cs) sline p (Traced trace re) etimeout tvars inner = do + let stack = CallStack (( sline, trace ) : cs) timeout <- (etimeout *) <$> getCurrentTimeout delay <- liftIO $ registerDelay $ ceiling $ 1000000 * timeout mbmatch <- atomicallyTest $ (Nothing <$ (check =<< readTVar delay)) <|> do @@ -334,13 +336,13 @@ expect sline p (Traced trace re) etimeout tvars inner = do let vars = map (\(TypedVarName n) -> n) tvars when (length vars /= length capture) $ do - outProc (OutputMatchFail (CallStack [ ( sline, [] ) ])) p $ T.pack "mismatched number of capture variables on " `T.append` textSourceLine sline + outProc (OutputMatchFail stack) p $ T.pack "mismatched number of capture variables" throwError Failed outProc OutputMatch p line inner capture - Nothing -> exprFailed (T.pack "expect") (CallStack [ ( sline, trace ) ]) (Just $ procName p) + Nothing -> exprFailed (T.pack "expect") stack (Just $ procName p) testStepGuard :: CallStack -> Bool -> TestRun () testStepGuard stack x = do diff --git a/src/Script/Expr.hs b/src/Script/Expr.hs index 7a446c5..1a0f458 100644 --- a/src/Script/Expr.hs +++ b/src/Script/Expr.hs @@ -20,6 +20,7 @@ module Script.Expr ( Traced(..), EvalTrace, CallStack(..), VarNameSelectors, gatherVars, AppAnnotation(..), + callStackVarName, callStackFqVarName, module Script.Var, @@ -28,6 +29,7 @@ module Script.Expr ( ) where import Control.Monad +import Control.Monad.Except import Control.Monad.Reader import Data.Char @@ -132,14 +134,17 @@ withTypedVar :: (MonadEval m, ExprType e) => TypedVarName e -> e -> m a -> m a withTypedVar (TypedVarName name) = withVar name -newtype SimpleEval a = SimpleEval (Reader ( GlobalDefs, VariableDictionary ) a) - deriving (Functor, Applicative, Monad) +newtype SimpleEval a = SimpleEval (ReaderT ( GlobalDefs, VariableDictionary ) (Except String) a) + deriving (Functor, Applicative, Monad, MonadError String) runSimpleEval :: SimpleEval a -> GlobalDefs -> VariableDictionary -> a -runSimpleEval (SimpleEval x) = curry $ runReader x +runSimpleEval (SimpleEval x) gdefs dict = either error id $ runExcept $ runReaderT x ( gdefs, dict ) + +trySimpleEval :: SimpleEval a -> GlobalDefs -> VariableDictionary -> Maybe a +trySimpleEval (SimpleEval x) gdefs dict = either (const Nothing) Just $ runExcept $ runReaderT x ( gdefs, dict ) instance MonadFail SimpleEval where - fail = error . ("eval failed: " <>) + fail = throwError . ("eval failed: " <>) instance MonadEval SimpleEval where askGlobalDefs = SimpleEval (asks fst) @@ -175,7 +180,7 @@ eval = \case gdefs <- askGlobalDefs dict <- askDictionary return $ FunctionType $ \stack _ -> - runSimpleEval (eval expr) gdefs (( callStackVarName, someConstValue stack ) : dict) + runSimpleEval (eval expr) gdefs (( callStackVarName, someConstValue stack ) : filter ((callStackVarName /=) . fst) dict) FunctionEval sline efun -> do vars <- gatherVars efun CallStack cs <- maybe (return $ CallStack []) (fromSomeVarValue (CallStack []) callStackFqVarName) =<< tryLookupVar callStackFqVarName @@ -415,8 +420,10 @@ gatherVars = fmap (uniqOn fst . sortOn fst) . helper e@(App (AnnRecord sel) _ x) | Just (var, sels) <- gatherSelectors x -> do - val <- SomeVarValue . VarValue [] mempty . const . const <$> eval e - return [ (( var, sels ++ [ sel ] ), val ) ] + gdefs <- askGlobalDefs + dict <- askDictionary + let mbVal = SomeVarValue . VarValue [] mempty . const . const <$> trySimpleEval (eval e) gdefs dict + return $ catMaybes [ (( var, sels ++ [ sel ] ), ) <$> mbVal ] | otherwise -> do helper x App _ f x -> (++) <$> helper f <*> helper x diff --git a/src/Test.hs b/src/Test.hs index 5530081..2320d23 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -48,7 +48,7 @@ data TestStep a where Spawn :: TypedVarName Process -> Either Network Node -> [ Text ] -> (Process -> TestStep a) -> TestStep a SpawnShell :: Maybe (TypedVarName Process) -> Node -> ShellScript -> (Process -> TestStep a) -> TestStep a Send :: Process -> Text -> TestStep () - Expect :: SourceLine -> Process -> Traced Regex -> Scientific -> [ TypedVarName Text ] -> ([ Text ] -> TestStep a) -> TestStep a + Expect :: CallStack -> SourceLine -> Process -> Traced Regex -> Scientific -> [ TypedVarName Text ] -> ([ Text ] -> TestStep a) -> TestStep a Flush :: Process -> Maybe Regex -> TestStep () Guard :: CallStack -> Bool -> TestStep () DisconnectNode :: Node -> TestStep a -> TestStep a |