summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Output.hs81
-rw-r--r--src/Run.hs17
-rw-r--r--src/Script/Expr.hs3
3 files changed, 66 insertions, 35 deletions
diff --git a/src/Output.hs b/src/Output.hs
index 7c4a8a5..f8ce41d 100644
--- a/src/Output.hs
+++ b/src/Output.hs
@@ -9,6 +9,7 @@ module Output (
) where
import Control.Concurrent.MVar
+import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader
@@ -24,6 +25,8 @@ import System.IO
import Text.Printf
+import Script.Expr
+
data Output = Output
{ outState :: MVar OutputState
, outConfig :: OutputConfig
@@ -53,7 +56,7 @@ data OutputType
| OutputChildInfo
| OutputChildFail
| OutputMatch
- | OutputMatchFail
+ | OutputMatchFail CallStack
| OutputError
| OutputAlways
| OutputTestRaw
@@ -83,7 +86,7 @@ outColor OutputChildStdin = T.pack "0"
outColor OutputChildInfo = T.pack "0"
outColor OutputChildFail = T.pack "31"
outColor OutputMatch = T.pack "32"
-outColor OutputMatchFail = T.pack "31"
+outColor OutputMatchFail {} = T.pack "31"
outColor OutputError = T.pack "31"
outColor OutputAlways = "0"
outColor OutputTestRaw = "0"
@@ -95,7 +98,7 @@ outSign OutputChildStdin = T.empty
outSign OutputChildInfo = T.pack "."
outSign OutputChildFail = T.pack "!!"
outSign OutputMatch = T.pack "+"
-outSign OutputMatchFail = T.pack "/"
+outSign OutputMatchFail {} = T.pack "/"
outSign OutputError = T.pack "!!"
outSign OutputAlways = T.empty
outSign OutputTestRaw = T.empty
@@ -112,7 +115,7 @@ outTestLabel = \case
OutputChildInfo -> "child-info"
OutputChildFail -> "child-fail"
OutputMatch -> "match"
- OutputMatchFail -> "match-fail"
+ OutputMatchFail {} -> "match-fail"
OutputError -> "error"
OutputAlways -> "other"
OutputTestRaw -> ""
@@ -121,7 +124,7 @@ printWhenQuiet :: OutputType -> Bool
printWhenQuiet = \case
OutputChildStderr -> True
OutputChildFail -> True
- OutputMatchFail -> True
+ OutputMatchFail {} -> True
OutputError -> True
OutputAlways -> True
_ -> False
@@ -142,27 +145,59 @@ outLine otype prompt line = ioWithOutput $ \out ->
stime <- readMVar (outStartedAt out)
nsecs <- toNanoSecs . (`diffTimeSpec` stime) <$> getTime Monotonic
withMVar (outState out) $ \st -> do
- outPrint st $ TL.fromChunks $ concat
- [ [ T.pack $ printf "[% 2d.%03d] " (nsecs `quot` 1000000000) ((nsecs `quot` 1000000) `rem` 1000) ]
- , if outUseColor (outConfig out)
- then [ T.pack "\ESC[", outColor otype, T.pack "m" ]
- else []
- , [ maybe "" (<> outSign otype <> outArr otype <> " ") prompt ]
- , [ line ]
- , if outUseColor (outConfig out)
- then [ T.pack "\ESC[0m" ]
- else []
- ]
+ forM_ (normalOutputLines otype line) $ \line' -> do
+ outPrint st $ TL.fromChunks $ concat
+ [ [ T.pack $ printf "[% 2d.%03d] " (nsecs `quot` 1000000000) ((nsecs `quot` 1000000) `rem` 1000) ]
+ , if outUseColor (outConfig out)
+ then [ T.pack "\ESC[", outColor otype, T.pack "m" ]
+ else []
+ , [ maybe "" (<> outSign otype <> outArr otype <> " ") prompt ]
+ , [ line' ]
+ , if outUseColor (outConfig out)
+ then [ T.pack "\ESC[0m" ]
+ else []
+ ]
testOutput out = do
withMVar (outState out) $ \st -> do
- outPrint st $ case otype of
- OutputTestRaw -> TL.fromStrict line
- _ -> TL.fromChunks
- [ outTestLabel otype, " "
- , maybe "-" id prompt, " "
- , line
- ]
+ case otype of
+ OutputTestRaw -> outPrint st $ TL.fromStrict line
+ _ -> forM_ (testOutputLines otype (maybe "-" id prompt) line) $ outPrint st . TL.fromStrict
+
+
+normalOutputLines :: OutputType -> Text -> [ Text ]
+normalOutputLines (OutputMatchFail (CallStack stack)) msg = concat
+ [ msg <> " on " <> textSourceLine stackTopLine : showVars stackTopLine stackTopVars
+ , concat $ flip map stackRest $ \( sline, vars ) ->
+ " called from " <> textSourceLine sline : showVars sline vars
+ ]
+ where
+ showVars sline =
+ map $ \(( name, sel ), value ) -> T.concat
+ [ " ", textFqVarName name, T.concat (map ("."<>) sel)
+ , " = ", textSomeVarValue sline value
+ ]
+ (( stackTopLine, stackTopVars ), stackRest ) =
+ case stack of
+ (stop : srest) -> ( stop, srest )
+ [] -> (( SourceLine "unknown", [] ), [] )
+normalOutputLines _ msg = [ msg ]
+
+
+testOutputLines :: OutputType -> Text -> Text -> [ Text ]
+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 sline vars
+ ]
+ where
+ showVars sline =
+ map $ \(( name, sel ), value ) -> T.concat
+ [ outTestLabel otype, "-var ", textFqVarName name, T.concat (map ("."<>) sel)
+ , " ", textSomeVarValue sline value
+ ]
+testOutputLines otype prompt msg = [ T.concat [ outTestLabel otype, " ", prompt, " ", msg ] ]
+
outPromptGetLine :: MonadOutput m => Text -> m (Maybe Text)
outPromptGetLine = outPromptGetLineCompletion noCompletion
diff --git a/src/Run.hs b/src/Run.hs
index a09947b..3ecd7d4 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -313,15 +313,10 @@ tryMatch re (x:xs) | Right (Just (_, _, _, capture)) <- regexMatch re x = Just (
| otherwise = fmap (x:) <$> tryMatch re xs
tryMatch _ [] = Nothing
-exprFailed :: Text -> SourceLine -> Maybe ProcName -> EvalTrace -> TestRun ()
-exprFailed desc sline pname exprVars = do
+exprFailed :: Text -> CallStack -> Maybe ProcName -> TestRun ()
+exprFailed desc stack pname = do
let prompt = maybe T.empty textProcName pname
- outLine OutputMatchFail (Just prompt) $ T.concat [desc, T.pack " failed on ", textSourceLine sline]
- forM_ exprVars $ \((name, sel), value) ->
- outLine OutputMatchFail (Just prompt) $ T.concat
- [ " ", textFqVarName name, T.concat (map ("."<>) sel)
- , " = ", textSomeVarValue sline value
- ]
+ outLine (OutputMatchFail stack) (Just prompt) $ desc <> " failed"
throwError Failed
expect :: SourceLine -> Process -> Traced Regex -> [TypedVarName Text] -> ([ Text ] -> TestRun ()) -> TestRun ()
@@ -340,14 +335,14 @@ expect sline p (Traced trace re) tvars inner = do
let vars = map (\(TypedVarName n) -> n) tvars
when (length vars /= length capture) $ do
- outProc OutputMatchFail p $ T.pack "mismatched number of capture variables on " `T.append` textSourceLine sline
+ outProc (OutputMatchFail (CallStack [ ( sline, [] ) ])) p $ T.pack "mismatched number of capture variables on " `T.append` textSourceLine sline
throwError Failed
outProc OutputMatch p line
inner capture
- Nothing -> exprFailed (T.pack "expect") sline (Just $ procName p) trace
+ Nothing -> exprFailed (T.pack "expect") (CallStack [ ( sline, trace ) ]) (Just $ procName p)
testStepGuard :: SourceLine -> EvalTrace -> Bool -> TestRun ()
testStepGuard sline vars x = do
- when (not x) $ exprFailed (T.pack "guard") sline Nothing vars
+ when (not x) $ exprFailed (T.pack "guard") (CallStack [ ( sline, vars ) ]) Nothing
diff --git a/src/Script/Expr.hs b/src/Script/Expr.hs
index ced807c..022ec88 100644
--- a/src/Script/Expr.hs
+++ b/src/Script/Expr.hs
@@ -18,7 +18,7 @@ module Script.Expr (
anull, exprArgs,
SomeArgumentType(..), ArgumentType(..),
- Traced(..), EvalTrace, VarNameSelectors, gatherVars,
+ Traced(..), EvalTrace, CallStack(..), VarNameSelectors, gatherVars,
AppAnnotation(..),
module Script.Var,
@@ -377,6 +377,7 @@ data Traced a = Traced EvalTrace a
type VarNameSelectors = ( FqVarName, [ Text ] )
type EvalTrace = [ ( VarNameSelectors, SomeVarValue ) ]
+newtype CallStack = CallStack [ ( SourceLine, EvalTrace ) ]
gatherVars :: forall a m. MonadEval m => Expr a -> m EvalTrace
gatherVars = fmap (uniqOn fst . sortOn fst) . helper
generated by cgit v1.2.3 (git 2.25.1) at 2025-09-16 07:25:39 +0000