diff options
| -rw-r--r-- | erebos-tester.cabal | 1 | ||||
| -rw-r--r-- | src/Output.hs | 22 | ||||
| -rw-r--r-- | src/Run.hs | 1 |
3 files changed, 20 insertions, 4 deletions
diff --git a/erebos-tester.cabal b/erebos-tester.cabal index c944e83..77af52b 100644 --- a/erebos-tester.cabal +++ b/erebos-tester.cabal @@ -96,6 +96,7 @@ executable erebos-tester base ^>= { 4.15, 4.16, 4.17, 4.18, 4.19, 4.20 }, bytestring ^>= { 0.10, 0.11, 0.12 }, containers ^>= { 0.6.2.1, 0.7 }, + clock ^>= { 0.8.4 }, directory ^>=1.3.6.0, filepath ^>= { 1.4.2.1, 1.5.2 }, Glob >=0.10 && <0.11, diff --git a/src/Output.hs b/src/Output.hs index 135e6e0..1555e54 100644 --- a/src/Output.hs +++ b/src/Output.hs @@ -2,6 +2,7 @@ module Output ( Output, OutputType(..), MonadOutput(..), startOutput, + resetOutputTime, outLine, outPromptGetLine, outPromptGetLineCompletion, @@ -19,10 +20,14 @@ import Data.Text.Lazy.IO qualified as TL import System.Console.Haskeline import System.Console.Haskeline.History +import System.Clock + +import Text.Printf data Output = Output { outState :: MVar OutputState , outConfig :: OutputConfig + , outStartedAt :: MVar TimeSpec } data OutputConfig = OutputConfig @@ -52,9 +57,15 @@ 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 outVerbose outUseColor = do + outState <- newMVar OutputState { outPrint = TL.putStrLn, outHistory = emptyHistory } + outConfig <- pure OutputConfig {..} + outStartedAt <- newMVar =<< getTime Monotonic + return Output {..} + +resetOutputTime :: Output -> IO () +resetOutputTime Output {..} = do + modifyMVar_ outStartedAt . const $ getTime Monotonic outColor :: OutputType -> Text outColor OutputChildStdout = T.pack "0" @@ -97,9 +108,12 @@ 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 + 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 ] @@ -88,6 +88,7 @@ runTest out opts test variables = do withVarExprList rest act withVarExprList [] act = act + resetOutputTime out res <- runExceptT $ flip runReaderT (tenv, tstate) $ fromTestRun $ do withVarExprList variables $ do withInternet $ \_ -> do |