Watch.hs

{-# 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 drawChart = do
    inputActionRef <- newIORef [Start]

    (entries, _) <- concurrently
        (interactiveWorker inputActionRef drawChart)
        (stdinReaderWorker inputActionRef)

    pure entries

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

            -- output line to the watch worker for output redirection
            pushAction inputActionRef $ Consume ln

            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 inputActionRef action =
    atomicModifyIORef' inputActionRef $ \actions -> (actions ++ [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 inputActionRef = atomicModifyIORef' inputActionRef popAction
  where
    popAction :: [InputAction] -> ([InputAction], InteractiveCommand)
    popAction [] = ([], Wait)
    popAction (x : xs) = case x of
        Start     -> (xs, Greeting)
        Consume l -> (xs, UpdateChart l)
        End       -> ([], Finish)

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

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

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

        case command of
            Greeting -> do
                printOutput frame prevOutput prevOutput
                go prevOutput (frame : frames)
            UpdateChart line@Line{..} -> case parseLine line of
                Nothing -> do
                    let newOutput = prevOutput { outputCabalLog = decodeUtf8 lineLine }
                    printOutput frame prevOutput newOutput
                    go newOutput frames
                Just entry -> do
                    let newOutput = Output
                            { outputCabalLog = decodeUtf8 lineLine
                            , outputEntries  = outputEntries prevOutput ++ [entry]
                            }
                    printOutput frame prevOutput newOutput
                    go newOutput frames
            Wait -> do
                printOutput frame prevOutput prevOutput
                go prevOutput frames

            Finish -> do
                putTextLn $ b "Build finished successfully!"
                pure $ outputEntries prevOutput

    printOutput :: Text -> Output -> Output -> IO ()
    printOutput frame oldOutput newOutput = do
        clearPreviousOutput oldOutput
        putText $ fmtOutput frame newOutput
        hFlush stdout
        threadDelay 80_000  -- wait 80 ms to update spinner

    clearPreviousOutput :: Output -> IO ()
    clearPreviousOutput output = do
        let fakeFrame = ""
        let screenHeight = length $ lines $ fmtOutput fakeFrame output
        clearScreen screenHeight

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

        log :: Text
        log = frame <> " " <> outputCabalLog