1 files changed, 73 insertions, 18 deletions

diff --git a/src/Output.hs b/src/Output.hs
index 135e6e0..7c4a8a5 100644
--- a/src/Output.hs
+++ b/src/Output.hs
@@ -1,14 +1,14 @@
 module Output (
-    Output, OutputType(..),
+    Output, OutputStyle(..), OutputType(..),
     MonadOutput(..),
     startOutput,
+    resetOutputTime,
     outLine,
     outPromptGetLine,
     outPromptGetLineCompletion,
 ) where
 
 import Control.Concurrent.MVar
-import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Reader
 
@@ -17,16 +17,21 @@ import Data.Text qualified as T
 import Data.Text.Lazy qualified as TL
 import Data.Text.Lazy.IO qualified as TL
 
+import System.Clock
 import System.Console.Haskeline
 import System.Console.Haskeline.History
+import System.IO
+
+import Text.Printf
 
 data Output = Output
     { outState :: MVar OutputState
     , outConfig :: OutputConfig
+    , outStartedAt :: MVar TimeSpec
     }
 
 data OutputConfig = OutputConfig
-    { outVerbose :: Bool
+    { outStyle :: OutputStyle
     , outUseColor :: Bool
     }
 
@@ -35,15 +40,23 @@ data OutputState = OutputState
     , outHistory :: History
     }
 
-data OutputType = OutputChildStdout
-                | OutputChildStderr
-                | OutputChildStdin
-                | OutputChildInfo
-                | OutputChildFail
-                | OutputMatch
-                | OutputMatchFail
-                | OutputError
-                | OutputAlways
+data OutputStyle
+    = OutputStyleQuiet
+    | OutputStyleVerbose
+    | OutputStyleTest
+    deriving (Eq)
+
+data OutputType
+    = OutputChildStdout
+    | OutputChildStderr
+    | OutputChildStdin
+    | OutputChildInfo
+    | OutputChildFail
+    | OutputMatch
+    | OutputMatchFail
+    | OutputError
+    | OutputAlways
+    | OutputTestRaw
 
 class MonadIO m => MonadOutput m where
     getOutput :: m Output
@@ -51,10 +64,17 @@ class MonadIO m => MonadOutput m where
 instance MonadIO m => MonadOutput (ReaderT Output m) where
     getOutput = ask
 
-startOutput :: Bool -> Bool -> IO Output
-startOutput outVerbose outUseColor = Output
-    <$> newMVar OutputState { outPrint = TL.putStrLn, outHistory = emptyHistory }
-    <*> pure OutputConfig { .. }
+startOutput :: OutputStyle -> Bool -> IO Output
+startOutput outStyle outUseColor = do
+    outState <- newMVar OutputState { outPrint = TL.putStrLn, outHistory = emptyHistory }
+    outConfig <- pure OutputConfig {..}
+    outStartedAt <- newMVar =<< getTime Monotonic
+    hSetBuffering stdout LineBuffering
+    return Output {..}
+
+resetOutputTime :: Output -> IO ()
+resetOutputTime Output {..} = do
+    modifyMVar_ outStartedAt . const $ getTime Monotonic
 
 outColor :: OutputType -> Text
 outColor OutputChildStdout = T.pack "0"
@@ -66,6 +86,7 @@ outColor OutputMatch = T.pack "32"
 outColor OutputMatchFail = T.pack "31"
 outColor OutputError = T.pack "31"
 outColor OutputAlways = "0"
+outColor OutputTestRaw = "0"
 
 outSign :: OutputType -> Text
 outSign OutputChildStdout = T.empty
@@ -77,11 +98,25 @@ outSign OutputMatch = T.pack "+"
 outSign OutputMatchFail = T.pack "/"
 outSign OutputError = T.pack "!!"
 outSign OutputAlways = T.empty
+outSign OutputTestRaw = T.empty
 
 outArr :: OutputType -> Text
 outArr OutputChildStdin = "<"
 outArr _ = ">"
 
+outTestLabel :: OutputType -> Text
+outTestLabel = \case
+    OutputChildStdout -> "child-stdout"
+    OutputChildStderr -> "child-stderr"
+    OutputChildStdin -> "child-stdin"
+    OutputChildInfo -> "child-info"
+    OutputChildFail -> "child-fail"
+    OutputMatch -> "match"
+    OutputMatchFail -> "match-fail"
+    OutputError -> "error"
+    OutputAlways -> "other"
+    OutputTestRaw -> ""
+
 printWhenQuiet :: OutputType -> Bool
 printWhenQuiet = \case
     OutputChildStderr -> True
@@ -96,10 +131,20 @@ ioWithOutput act = liftIO . act =<< getOutput
 
 outLine :: MonadOutput m => OutputType -> Maybe Text -> Text -> m ()
 outLine otype prompt line = ioWithOutput $ \out ->
-    when (outVerbose (outConfig out) || printWhenQuiet otype) $ do
+    case outStyle (outConfig out) of
+        OutputStyleQuiet
+            | printWhenQuiet otype -> normalOutput out
+            | otherwise -> return ()
+        OutputStyleVerbose -> normalOutput out
+        OutputStyleTest -> testOutput out
+  where
+    normalOutput out = do
+        stime <- readMVar (outStartedAt out)
+        nsecs <- toNanoSecs . (`diffTimeSpec` stime) <$> getTime Monotonic
         withMVar (outState out) $ \st -> do
             outPrint st $ TL.fromChunks $ concat
-                [ if outUseColor (outConfig out)
+                [ [ 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 ]
@@ -109,6 +154,16 @@ outLine otype prompt line = ioWithOutput $ \out ->
                     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
+                    ]
+
 outPromptGetLine :: MonadOutput m => Text -> m (Maybe Text)
 outPromptGetLine = outPromptGetLineCompletion noCompletion