module Output (
Output, OutputStyle(..), OutputType(..),
MonadOutput(..),
startOutput,
resetOutputTime,
getElapsedTime,
outLine,
outLineF,
outPromptGetLine,
outPromptGetLineCompletion,
collectOutput,
collectErrorOutput,
) where
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.Scientific
import Data.Text (Text)
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
import Script.Expr
import TextFormat
import TextFormat.Ansi
data Output = Output
{ outState :: MVar OutputState
, outConfig :: OutputConfig
, outStartedAt :: MVar TimeSpec
}
data OutputConfig = OutputConfig
{ outStyle :: OutputStyle
, outUseColor :: Bool
}
data OutputState = OutputState
{ outPrint :: TL.Text -> IO ()
, outHistory :: History
, outLines :: [ Text ]
, outErrLines :: [ Text ]
}
data OutputStyle
= OutputStyleQuiet
| OutputStyleVerbose
| OutputStyleTest
deriving (Eq)
data OutputType
= OutputGlobalInfo
| OutputGlobalError
| OutputGlobalSummary
| OutputChildStdout
| OutputChildStderr
| OutputChildStdin
| OutputChildExec
| OutputChildInfo
| OutputChildFail
| OutputMatch
| OutputMatchFail CallStack
| OutputIgnored
| OutputError
| OutputAlways
| OutputTestRaw
class MonadIO m => MonadOutput m where
getOutput :: m Output
instance MonadIO m => MonadOutput (ReaderT Output m) where
getOutput = ask
startOutput :: OutputStyle -> Bool -> IO Output
startOutput outStyle outUseColor = do
outState <- newMVar OutputState
{ outPrint = TL.putStrLn
, outHistory = emptyHistory
, outLines = []
, outErrLines = []
}
outConfig <- pure OutputConfig {..}
outStartedAt <- newMVar =<< getTime Monotonic
hSetBuffering stdout LineBuffering
return Output {..}
resetOutputTime :: Output -> IO ()
resetOutputTime Output {..} = do
modifyMVar_ outStartedAt . const $ getTime Monotonic
getElapsedTime :: Output -> IO Scientific
getElapsedTime Output {..} = do
stime <- readMVar outStartedAt
(/ 1000000000) . fromIntegral . toNanoSecs . (`diffTimeSpec` stime) <$> getTime Monotonic
outColor :: OutputType -> Text
outColor = \case
OutputGlobalInfo -> "0"
OutputGlobalError -> "31"
OutputGlobalSummary -> "0"
OutputChildStdout -> "0"
OutputChildStderr -> "31"
OutputChildStdin -> "0"
OutputChildExec -> "33"
OutputChildInfo -> "0"
OutputChildFail -> "31"
OutputMatch -> "32"
OutputMatchFail {} -> "31"
OutputIgnored -> "90"
OutputError -> "31"
OutputAlways -> "0"
OutputTestRaw -> "0"
outSign :: OutputType -> Text
outSign = \case
OutputGlobalInfo -> ""
OutputGlobalError -> ""
OutputGlobalSummary -> ""
OutputChildStdout -> " "
OutputChildStderr -> "!"
OutputChildStdin -> T.empty
OutputChildExec -> "*"
OutputChildInfo -> "."
OutputChildFail -> "!!"
OutputMatch -> "+"
OutputMatchFail {} -> "/"
OutputIgnored -> "-"
OutputError -> "!!"
OutputAlways -> T.empty
OutputTestRaw -> T.empty
outArr :: OutputType -> Text
outArr = \case
OutputGlobalInfo -> ""
OutputGlobalError -> ""
OutputGlobalSummary -> ""
OutputChildStdin -> "<"
_ -> ">"
outTestLabel :: OutputType -> Text
outTestLabel = \case
OutputGlobalInfo -> "global-info"
OutputGlobalError -> "global-error"
OutputGlobalSummary -> "global-summary"
OutputChildStdout -> "child-stdout"
OutputChildStderr -> "child-stderr"
OutputChildStdin -> "child-stdin"
OutputChildExec -> "child-exec"
OutputChildInfo -> "child-info"
OutputChildFail -> "child-fail"
OutputMatch -> "match"
OutputMatchFail {} -> "match-fail"
OutputIgnored -> "ignored"
OutputError -> "error"
OutputAlways -> "other"
OutputTestRaw -> ""
printWhenQuiet :: OutputType -> Bool
printWhenQuiet = \case
OutputGlobalSummary -> True
OutputAlways -> True
t -> printIsError t
printIsError :: OutputType -> Bool
printIsError = \case
OutputGlobalError -> True
OutputChildStderr -> True
OutputChildFail -> True
OutputMatchFail {} -> True
OutputError -> True
_ -> False
includeTestTime :: OutputType -> Bool
includeTestTime = \case
OutputGlobalInfo -> False
OutputGlobalError -> False
OutputGlobalSummary -> False
_ -> True
ioWithOutput :: MonadOutput m => (Output -> IO a) -> m a
ioWithOutput act = liftIO . act =<< getOutput
outLine :: MonadOutput m => OutputType -> Maybe Text -> Text -> m ()
outLine otype prompt line = outLineF otype prompt (plainText line)
outLineF :: MonadOutput m => OutputType -> Maybe Text -> FormattedText -> m ()
outLineF otype prompt line = ioWithOutput $ \out ->
case outStyle (outConfig out) of
OutputStyleQuiet -> normalOutput (printWhenQuiet otype) out
OutputStyleVerbose -> normalOutput True out
OutputStyleTest -> testOutput out
where
normalOutput normal out = do
secs <- getElapsedTime out
let formatLine color line' = T.concat $ concat
[ if includeTestTime otype
then [ T.pack $ printf "[% 2d.%03d] " (floor secs :: Integer) (floor (secs * 1000) `rem` 1000 :: Integer) ]
else []
, if color
then [ T.pack "\ESC[", outColor otype, T.pack "m" ]
else []
, [ maybe "" (<> outSign otype <> outArr otype <> " ") prompt ]
, [ line' ]
, if color
then [ T.pack "\ESC[0m" ]
else []
]
modifyMVar_ (outState out) $ \ost -> do
(\f -> foldM f ost (normalOutputLines otype $ renderLine out line)) $ \st line' -> do
when normal $ do
outPrint st $ TL.fromStrict $ formatLine (outUseColor (outConfig out)) line'
return st
{ outLines = formatLine False line' : outLines st
, outErrLines = (if printIsError otype
then (formatLine False line' :)
else id) $ outErrLines st
}
renderLine out
| outUseColor (outConfig out) = fromAnsiText . renderAnsiText
| otherwise = renderPlainText
testOutput out = do
let pline = renderPlainText line
withMVar (outState out) $ \st -> do
case otype of
OutputTestRaw -> outPrint st $ TL.fromStrict pline
_ -> forM_ (testOutputLines otype (maybe "-" id prompt) pline) $ outPrint st . TL.fromStrict
normalOutputLines :: OutputType -> Text -> [ Text ]
normalOutputLines (OutputMatchFail (CallStack stack)) msg = concat
[ msg <> " on " <> textSourceLine stackTopLine : showVars stackTopVars
, concat $ flip map stackRest $ \( sline, vars ) ->
" called from " <> textSourceLine sline : showVars vars
]
where
showVars =
map $ \(( name, sel ), value ) -> T.concat
[ " ", textFqVarName name, T.concat (map ("."<>) sel)
, " = ", textSomeVarValue 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 vars
, [ T.concat [ outTestLabel otype, "-done" ] ]
]
where
showVars =
map $ \(( name, sel ), value ) -> T.concat
[ outTestLabel otype, "-var ", textFqVarName name, T.concat (map ("."<>) sel)
, " ", textSomeVarValue value
]
testOutputLines otype prompt msg = [ T.concat [ outTestLabel otype, " ", prompt, " ", msg ] ]
outPromptGetLine :: MonadOutput m => Text -> m (Maybe Text)
outPromptGetLine = outPromptGetLineCompletion noCompletion
outPromptGetLineCompletion :: MonadOutput m => CompletionFunc IO -> Text -> m (Maybe Text)
outPromptGetLineCompletion compl prompt = ioWithOutput $ \out -> do
st <- takeMVar (outState out)
(x, st') <- runInputT (setComplete compl defaultSettings) $ do
p <- getExternalPrint
putHistory $ outHistory st
liftIO $ putMVar (outState out) st { outPrint = p . TL.unpack . (<>"\n") }
x <- getInputLine $ T.unpack prompt
st' <- liftIO $ takeMVar (outState out)
hist' <- getHistory
return (x, st' { outPrint = outPrint st, outHistory = hist' })
putMVar (outState out) st'
return $ fmap T.pack x
collectOutput :: Output -> IO Text
collectOutput Output {..} = do
modifyMVar outState $ \st -> do
return ( st { outLines = [] }, T.unlines $ reverse $ outLines st )
collectErrorOutput :: Output -> IO Text
collectErrorOutput Output {..} = do
modifyMVar outState $ \st -> do
return ( st { outErrLines = [] }, T.unlines $ reverse $ outErrLines st )