path: root/src/Output.hs

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 )