Call stack type and tests

5 files changed, 84 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
diff --git a/test/asset/run/callstack.et b/test/asset/run/callstack.et
new file mode 100644
index 0000000..954b9ad
--- /dev/null
+++ b/test/asset/run/callstack.et
@@ -0,0 +1,3 @@
+test A:
+    let x = 1
+    guard (x == 0)
diff --git a/test/script/run.et b/test/script/run.et
index c3c698e..dc2b812 100644
--- a/test/script/run.et
+++ b/test/script/run.et
@@ -103,3 +103,18 @@ test GetSysInfo:
         expect /load-config-done/
         send "run SysInfo"
         expect /run-done/
+
+
+test CallStack:
+    spawn as p
+    with p:
+        send "load ${scripts.path}/callstack.et"
+        expect /load-done/
+
+        send "run A"
+        expect /match-fail guard failed/
+        expect /match-fail-line .*\/callstack.et:3:5: .*/
+        expect /match-fail-var x 1/
+        local:
+            expect /(run-.*)/ capture done
+            guard (done == "run-failed")