{-# LANGUAGE NumericUnderscores #-}

{- |
Module                  : DrCabal.Watch
Copyright               : (c) 2019 Alexander Gugel
                          (c) 2022 Dmitrii Kovanikov
SPDX-License-Identifier : MPL-2.0
Maintainer              : Dmitrii Kovanikov <kovanikov@gmail.com>
Stability               : Experimental
Portability             : Portable

Watch the output of the @cabal build@ command and update the profile
chart interactively.
-}

module DrCabal.Watch
    ( watchBuild
    ) where

import Colourista.Short (b)
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (concurrently)
import GHC.Clock (getMonotonicTimeNSec)
import System.IO (isEOF)

import DrCabal.Model (Entry (..), Line (..), parseLine)
import DrCabal.Terminal (clearScreen)

import qualified Colourista
import qualified Data.ByteString as ByteString


{- | Watch build entries from @stdin@ and interactively update the
chart and current status.
-}
watchBuild
    :: ([Entry] -> Text)
    -- ^ A function to draw chart
    -> IO [Entry]
    -- ^ Returns the final list of entries
watchBuild :: ([Entry] -> Text) -> IO [Entry]
watchBuild [Entry] -> Text
drawChart = do
    IORef [InputAction]
inputActionRef <- forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef [InputAction
Start]

    ([Entry]
entries, ()
_) <- forall a b. IO a -> IO b -> IO (a, b)
concurrently
        (IORef [InputAction] -> ([Entry] -> Text) -> IO [Entry]
interactiveWorker IORef [InputAction]
inputActionRef [Entry] -> Text
drawChart)
        (IORef [InputAction] -> IO ()
stdinReaderWorker IORef [InputAction]
inputActionRef)

    forall (f :: * -> *) a. Applicative f => a -> f a
pure [Entry]
entries

stdinReaderWorker :: IORef [InputAction] -> IO ()
stdinReaderWorker :: IORef [InputAction] -> IO ()
stdinReaderWorker IORef [InputAction]
inputActionRef = IO ()
go
  where
    go :: IO ()
    go :: IO ()
go = do
        Bool
isEndOfInput <- IO Bool
isEOF
        if Bool
isEndOfInput
        then do
            IORef [InputAction] -> InputAction -> IO ()
pushAction IORef [InputAction]
inputActionRef InputAction
End
        else do
            Word64
time <- IO Word64
getMonotonicTimeNSec
            ByteString
line <- IO ByteString
ByteString.getLine
            let ln :: Line
ln = Word64 -> ByteString -> Line
Line Word64
time ByteString
line

            -- output line to the watch worker for output redirection
            IORef [InputAction] -> InputAction -> IO ()
pushAction IORef [InputAction]
inputActionRef forall a b. (a -> b) -> a -> b
$ Line -> InputAction
Consume Line
ln

            IO ()
go

-- | Action returned by the @stdinReaderWorker@.
data InputAction
    -- | Produce the initial message
    = Start

    -- | Line content read from @stdin@ with timestamp
    | Consume Line

    -- | EOF reached for @stdin@
    | End

-- | Add 'InputAction' to end of the queue in the given 'IORef'.
pushAction :: IORef [InputAction] -> InputAction -> IO ()
pushAction :: IORef [InputAction] -> InputAction -> IO ()
pushAction IORef [InputAction]
inputActionRef InputAction
action =
    forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef [InputAction]
inputActionRef forall a b. (a -> b) -> a -> b
$ \[InputAction]
actions -> ([InputAction]
actions forall a. [a] -> [a] -> [a]
++ [InputAction
action], ())

data InteractiveCommand
    -- | Initial message
    = Greeting

    -- | New line received from the @stdinReaderWorker@. Update the chart.
    | UpdateChart Line

    -- | No new lines from @stdin@. Simply wait and update the spinner.
    | Wait

    -- | Finished reading lines from @stdin@
    | Finish

{- | Produce the next 'InteractiveCommand' by reading the current
'InputAction' and removing it from the queue.
-}
nextCommand :: IORef [InputAction] -> IO InteractiveCommand
nextCommand :: IORef [InputAction] -> IO InteractiveCommand
nextCommand IORef [InputAction]
inputActionRef = forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef [InputAction]
inputActionRef [InputAction] -> ([InputAction], InteractiveCommand)
popAction
  where
    popAction :: [InputAction] -> ([InputAction], InteractiveCommand)
    popAction :: [InputAction] -> ([InputAction], InteractiveCommand)
popAction [] = ([], InteractiveCommand
Wait)
    popAction (InputAction
x : [InputAction]
xs) = case InputAction
x of
        InputAction
Start     -> ([InputAction]
xs, InteractiveCommand
Greeting)
        Consume Line
l -> ([InputAction]
xs, Line -> InteractiveCommand
UpdateChart Line
l)
        InputAction
End       -> ([], InteractiveCommand
Finish)

-- | A data type
data Output = Output
    { Output -> Text
outputCabalLog :: Text
    , Output -> [Entry]
outputEntries  :: [Entry]
    }

interactiveWorker
    :: IORef [InputAction]
    -- ^ Mutable reference to the queue of input actions
    -> ([Entry] -> Text)
    -- ^ A function to draw the chart
    -> IO [Entry]
interactiveWorker :: IORef [InputAction] -> ([Entry] -> Text) -> IO [Entry]
interactiveWorker IORef [InputAction]
inputActionRef [Entry] -> Text
drawChart =
    Output -> [Text] -> IO [Entry]
go (Text -> [Entry] -> Output
Output Text
"Profiling 'cabal build' interactively..." []) (forall a. [a] -> [a]
cycle [Text]
spinnerFrames)
  where
    spinnerFrames :: [Text]
    spinnerFrames :: [Text]
spinnerFrames =
        [ Text
"⠋"
        , Text
"⠙"
        , Text
"⠹"
        , Text
"⠸"
        , Text
"⠼"
        , Text
"⠴"
        , Text
"⠦"
        , Text
"⠧"
        , Text
"⠇"
        , Text
"⠏"
        ]

    go :: Output -> [Text] -> IO [Entry]
    go :: Output -> [Text] -> IO [Entry]
go Output
_ [] = do
        Text -> IO ()
Colourista.errorMessage forall a b. (a -> b) -> a -> b
$
            Text
"Panic! At the 'dr-cabal'! Impossible happened: list of frames is empty"
        forall (m :: * -> *) a. MonadIO m => m a
exitFailure
    go Output
prevOutput (Text
frame : [Text]
frames) = do
        InteractiveCommand
command <- IORef [InputAction] -> IO InteractiveCommand
nextCommand IORef [InputAction]
inputActionRef

        case InteractiveCommand
command of
            InteractiveCommand
Greeting -> do
                Text -> Output -> Output -> IO ()
printOutput Text
frame Output
prevOutput Output
prevOutput
                Output -> [Text] -> IO [Entry]
go Output
prevOutput (Text
frame forall a. a -> [a] -> [a]
: [Text]
frames)
            UpdateChart line :: Line
line@Line{Word64
ByteString
lineLine :: Line -> ByteString
lineTime :: Line -> Word64
lineLine :: ByteString
lineTime :: Word64
..} -> case Line -> Maybe Entry
parseLine Line
line of
                Maybe Entry
Nothing -> do
                    let newOutput :: Output
newOutput = Output
prevOutput { outputCabalLog :: Text
outputCabalLog = forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 ByteString
lineLine }
                    Text -> Output -> Output -> IO ()
printOutput Text
frame Output
prevOutput Output
newOutput
                    Output -> [Text] -> IO [Entry]
go Output
newOutput [Text]
frames
                Just Entry
entry -> do
                    let newOutput :: Output
newOutput = Output
                            { outputCabalLog :: Text
outputCabalLog = forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 ByteString
lineLine
                            , outputEntries :: [Entry]
outputEntries  = Output -> [Entry]
outputEntries Output
prevOutput forall a. [a] -> [a] -> [a]
++ [Entry
entry]
                            }
                    Text -> Output -> Output -> IO ()
printOutput Text
frame Output
prevOutput Output
newOutput
                    Output -> [Text] -> IO [Entry]
go Output
newOutput [Text]
frames
            InteractiveCommand
Wait -> do
                Text -> Output -> Output -> IO ()
printOutput Text
frame Output
prevOutput Output
prevOutput
                Output -> [Text] -> IO [Entry]
go Output
prevOutput [Text]
frames

            InteractiveCommand
Finish -> do
                forall (m :: * -> *). MonadIO m => Text -> m ()
putTextLn forall a b. (a -> b) -> a -> b
$ forall str. (IsString str, Semigroup str) => str -> str
b Text
"Build finished successfully!"
                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Output -> [Entry]
outputEntries Output
prevOutput

    printOutput :: Text -> Output -> Output -> IO ()
    printOutput :: Text -> Output -> Output -> IO ()
printOutput Text
frame Output
oldOutput Output
newOutput = do
        Output -> IO ()
clearPreviousOutput Output
oldOutput
        forall (m :: * -> *). MonadIO m => Text -> m ()
putText forall a b. (a -> b) -> a -> b
$ Text -> Output -> Text
fmtOutput Text
frame Output
newOutput
        forall (m :: * -> *). MonadIO m => Handle -> m ()
hFlush Handle
stdout
        Int -> IO ()
threadDelay Int
80_000  -- wait 80 ms to update spinner

    clearPreviousOutput :: Output -> IO ()
    clearPreviousOutput :: Output -> IO ()
clearPreviousOutput Output
output = do
        let fakeFrame :: Text
fakeFrame = Text
""
        let screenHeight :: Int
screenHeight = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall t. IsText t "lines" => t -> [t]
lines forall a b. (a -> b) -> a -> b
$ Text -> Output -> Text
fmtOutput Text
fakeFrame Output
output
        Int -> IO ()
clearScreen Int
screenHeight

    fmtOutput :: Text -> Output -> Text
    fmtOutput :: Text -> Output -> Text
fmtOutput Text
frame Output{[Entry]
Text
outputEntries :: [Entry]
outputCabalLog :: Text
outputEntries :: Output -> [Entry]
outputCabalLog :: Output -> Text
..} =
        Text
chart forall a. Semigroup a => a -> a -> a
<> Text
log
      where
        chart :: Text
        chart :: Text
chart = case [Entry]
outputEntries of
            [] -> Text
""
            [Entry]
_  -> [Entry] -> Text
drawChart [Entry]
outputEntries

        log :: Text
        log :: Text
log = Text
frame forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
outputCabalLog