From a921b1b2f093ac6fe7cfa4e92994cb4b41687c8c Mon Sep 17 00:00:00 2001 From: Dmitrii Kovanikov Date: Tue, 15 Nov 2022 21:03:38 +0000 Subject: [PATCH 1/2] [#31] Refactor and simplify CLI Resolves #31 --- .gitattributes | 1 + README.md | 4 +- cabal.project | 6 - dr-cabal.cabal | 3 +- src/DrCabal.hs | 6 +- src/DrCabal/Cli.hs | 97 +++++++-------- src/DrCabal/Interactive.hs | 88 ------------- src/DrCabal/Json.hs | 39 ++++++ src/DrCabal/Model.hs | 21 ++++ src/DrCabal/Profile.hs | 71 ++++++----- src/DrCabal/Profile/Stacked.hs | 6 +- src/DrCabal/Terminal.hs | 47 +++++++ src/DrCabal/Watch.hs | 218 ++++++++++++++++++--------------- 13 files changed, 322 insertions(+), 285 deletions(-) create mode 100644 .gitattributes delete mode 100644 cabal.project delete mode 100644 src/DrCabal/Interactive.hs create mode 100644 src/DrCabal/Json.hs create mode 100644 src/DrCabal/Terminal.hs diff --git a/.gitattributes b/.gitattributes new file mode 100644 index 0000000..9703ea0 --- /dev/null +++ b/.gitattributes @@ -0,0 +1 @@ +dr-cabal-debug.json linguist-generated=true diff --git a/README.md b/README.md index 7de9e1c..49f1ad3 100644 --- a/README.md +++ b/README.md @@ -99,8 +99,8 @@ follow these steps: > rm -rf ~/.cabal > ``` > -> A less invasive approach is to point Cabal to a fresh store folder, -> but in this case you won't see the `Downloading` phase in the profiling +> A less invasive approach is to point Cabal to a fresh store folder, +> but in this case you won't see the `Downloading` phase in the profiling > output: > > ```shell diff --git a/cabal.project b/cabal.project deleted file mode 100644 index 78a19aa..0000000 --- a/cabal.project +++ /dev/null @@ -1,6 +0,0 @@ -packages: . - -source-repository-package - type: git - location: https://github.com/uhbif19/colourista.git - tag: 8148a0446bf61814f79d6a0c497007fde72b31eb \ No newline at end of file diff --git a/dr-cabal.cabal b/dr-cabal.cabal index 7ee6b2a..94d2c02 100644 --- a/dr-cabal.cabal +++ b/dr-cabal.cabal @@ -81,11 +81,12 @@ library exposed-modules: DrCabal DrCabal.Cli - DrCabal.Interactive + DrCabal.Json DrCabal.Model DrCabal.Profile DrCabal.Profile.Format DrCabal.Profile.Stacked + DrCabal.Terminal DrCabal.Watch build-depends: diff --git a/src/DrCabal.hs b/src/DrCabal.hs index a1c465d..49faeed 100644 --- a/src/DrCabal.hs +++ b/src/DrCabal.hs @@ -14,9 +14,7 @@ module DrCabal ) where import DrCabal.Cli (Command (..), readCommand) -import DrCabal.Interactive (runInteractive) import DrCabal.Profile (runProfile) -import DrCabal.Watch (runWatch) main :: IO () @@ -24,6 +22,4 @@ main = readCommand >>= runDrCabal runDrCabal :: Command -> IO () runDrCabal = \case - Watch args -> runWatch args - Profile args -> runProfile args - Interactive args -> runInteractive args + Profile args -> runProfile args diff --git a/src/DrCabal/Cli.hs b/src/DrCabal/Cli.hs index 90d7021..a3b52fd 100644 --- a/src/DrCabal/Cli.hs +++ b/src/DrCabal/Cli.hs @@ -15,9 +15,8 @@ module DrCabal.Cli ( Command (..) , readCommand - , WatchArgs (..) , ProfileArgs (..) - , InteractiveArgs (..) + , FileMode (..) ) where import DrCabal.Model (Style (..)) @@ -25,22 +24,22 @@ import DrCabal.Model (Style (..)) import qualified Options.Applicative as Opt data Command - = Watch WatchArgs - | Profile ProfileArgs - | Interactive InteractiveArgs - -newtype WatchArgs = WatchArgs - { watchArgsOutput :: FilePath - } + = Profile ProfileArgs data ProfileArgs = ProfileArgs - { profileArgsInput :: FilePath - , profileArgsStyle :: Style + { profileArgsStyle :: Style + , profileArgsFileMode :: FileMode } -newtype InteractiveArgs = InteractiveArgs - { interactiveArgsStyle :: Style - } +data FileMode + -- | Don't read from the file and don't store the results in the file + = None + + -- | Store current results in the file + | Output FilePath + + -- | Read previously saved results from the file + | Input FilePath readCommand :: IO Command readCommand = Opt.execParser opts @@ -53,48 +52,44 @@ readCommand = Opt.execParser opts -- | All possible commands. commandP :: Opt.Parser Command -commandP = Opt.subparser (mconcat - [ Opt.command "watch" - $ Opt.info (Opt.helper <*> watchP) - $ Opt.progDesc "Watch cabal output and save it" - , Opt.command "profile" - $ Opt.info (Opt.helper <*> profileP) - $ Opt.progDesc "Output pretty cabal profile results" - ]) <|> interactiveP - -watchP :: Opt.Parser Command -watchP = do - watchArgsOutput <- Opt.strOption $ mconcat - [ Opt.long "output" - , Opt.short 'o' - , Opt.metavar "FILE_PATH" - , Opt.help "Save cabal output to a file in a JSON format" - ] - - pure $ Watch WatchArgs{..} +commandP = Opt.subparser $ mconcat + [ Opt.command "profile" + $ Opt.info (Opt.helper <*> profileP) + $ Opt.progDesc "Build profiling report" + ] profileP :: Opt.Parser Command profileP = do - profileArgsInput <- Opt.strOption $ mconcat - [ Opt.long "input" - , Opt.short 'i' - , Opt.metavar "FILE_PATH" - , Opt.help "Read profile input from a JSON file, created by 'dr-cabal watch'" - ] - - profileArgsStyle <- stackedP <|> pure Stacked + profileArgsStyle <- styleP + profileArgsFileMode <- fileModeP pure $ Profile ProfileArgs{..} -interactiveP :: Opt.Parser Command -interactiveP = do - interactiveArgsStyle <- stackedP <|> pure Stacked +styleP :: Opt.Parser Style +styleP = stackedP <|> pure Stacked + where + stackedP :: Opt.Parser Style + stackedP = Opt.flag' Stacked $ mconcat + [ Opt.long "stacked" + , Opt.short 's' + , Opt.help "Format as stacked" + ] - pure $ Interactive InteractiveArgs{..} +fileModeP :: Opt.Parser FileMode +fileModeP = inputP <|> outputP <|> pure None + where + inputP :: Opt.Parser FileMode + inputP = fmap Input $ Opt.strOption $ mconcat + [ Opt.long "input" + , Opt.short 'i' + , Opt.metavar "FILE_PATH" + , Opt.help "Read profile input from a JSON file, created by 'dr-cabal profile --output='" + ] -stackedP :: Opt.Parser Style -stackedP = Opt.flag' Stacked $ mconcat - [ Opt.long "stacked" - , Opt.short 's' - , Opt.help "Format as stacked" - ] + outputP :: Opt.Parser FileMode + outputP = fmap Output $ Opt.strOption $ mconcat + [ Opt.long "output" + , Opt.short 'o' + , Opt.metavar "FILE_PATH" + , Opt.help "Save cabal output to a file in a JSON format" + ] diff --git a/src/DrCabal/Interactive.hs b/src/DrCabal/Interactive.hs deleted file mode 100644 index 734689e..0000000 --- a/src/DrCabal/Interactive.hs +++ /dev/null @@ -1,88 +0,0 @@ -{-# LANGUAGE NumericUnderscores #-} - -{- | -Module : DrCabal.Interactive -Copyright : (c) 2022 Dmitrii Kovanikov - (c) 2022 Andrew Lelechenko -SPDX-License-Identifier : MPL-2.0 -Maintainer : Dmitrii Kovanikov -Stability : Experimental -Portability : Portable - -Implementation of the @dr-cabal@ interactive command. --} - -module DrCabal.Interactive - ( runInteractive - ) where - -import Control.Concurrent (threadDelay) -import Control.Concurrent.Async (concurrently_) -import GHC.Clock (getMonotonicTimeNSec) -import System.Console.ANSI (clearFromCursorToScreenEnd, cursorUpLine) -import System.IO (isEOF) - -import DrCabal.Cli (InteractiveArgs (..)) -import DrCabal.Model (Entry (..), Line (..), Style) -import DrCabal.Profile (getTerminalWidth, createChart) -import DrCabal.Watch (parseLine) - -import qualified Data.ByteString as ByteString - - -runInteractive :: InteractiveArgs -> IO () -runInteractive InteractiveArgs{..} = do - hSetBuffering stdout (BlockBuffering Nothing) - terminalWidth <- getTerminalWidth - - stateRef <- newIORef (InteractiveState [] False) - - concurrently_ - (watchWorker interactiveArgsStyle terminalWidth 0 stateRef) - (readFromStdin stateRef) - -data InteractiveState = InteractiveState - { istEntries :: [Entry] - , istDone :: Bool - } - -readFromStdin :: IORef InteractiveState -> IO () -readFromStdin stateRef = go - where - go :: IO () - go = do - isEndOfInput <- isEOF - if isEndOfInput - then atomicModifyIORef' stateRef $ \st -> (st { istDone = True }, ()) - else do - time <- getMonotonicTimeNSec - line <- ByteString.getLine - case parseLine (Line time line) of - Nothing -> pure () - Just entry -> atomicModifyIORef' stateRef $ - \st -> (st { istEntries = istEntries st ++ [entry] }, ()) - go - -watchWorker :: Style -> Int -> Int -> IORef InteractiveState -> IO () -watchWorker style terminalWidth chartHeight stateRef = do - InteractiveState entries done <- readIORef stateRef - - clearScreen chartHeight - - let chart = case entries of - [] -> "" - _ -> createChart style terminalWidth entries - putText chart - hFlush stdout - - unless done $ do - threadDelay 80_000 -- wait 80 ms to update - let newChartHeight = length (lines chart) - watchWorker style terminalWidth newChartHeight stateRef - -clearScreen :: Int -> IO () -clearScreen chartHeight = do - -- https://github.com/UnkindPartition/ansi-terminal/issues/141 - when (chartHeight > 0) $ - cursorUpLine chartHeight - clearFromCursorToScreenEnd diff --git a/src/DrCabal/Json.hs b/src/DrCabal/Json.hs new file mode 100644 index 0000000..6d268eb --- /dev/null +++ b/src/DrCabal/Json.hs @@ -0,0 +1,39 @@ +{- | +Module : DrCabal.Json +Copyright : (c) 2022 Dmitrii Kovanikov +SPDX-License-Identifier : MPL-2.0 +Maintainer : Dmitrii Kovanikov +Stability : Experimental +Portability : Portable + +This module contains functions to process JSON entries recognised by @dr-cabal@. +-} + +module DrCabal.Json + ( readEntries + , writeEntries + ) where + +import Data.Aeson (eitherDecodeFileStrict') +import Data.Aeson.Encode.Pretty (encodePretty) + +import DrCabal.Model (Entry) + +import qualified Colourista + + +{- | Read a list of entries from a JSON file. + +Exits process with an error message on decoding failure. +-} +readEntries :: FilePath -> IO [Entry] +readEntries file = eitherDecodeFileStrict' file >>= \case + Right entries -> pure entries + Left err -> do + Colourista.errorMessage $ "Error parsing file: " <> toText file + Colourista.redMessage $ " " <> toText err + exitFailure + +-- | Write entries as a pretty JSON to the output file. +writeEntries :: FilePath -> [Entry] -> IO () +writeEntries outputPath = writeFileLBS outputPath . encodePretty diff --git a/src/DrCabal/Model.hs b/src/DrCabal/Model.hs index 09e057c..c05b8e7 100644 --- a/src/DrCabal/Model.hs +++ b/src/DrCabal/Model.hs @@ -14,10 +14,14 @@ module DrCabal.Model , Line (..) , Status (..) , Entry (..) + , parseLine ) where import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, withText, (.:), (.=)) +import qualified Data.Text as Text + + data Style = Stacked data Line = Line @@ -62,3 +66,20 @@ instance FromJSON Entry where entryStart <- o .: "startTime" entryLibrary <- o .: "library" pure Entry{..} + +parseLine :: Line -> Maybe Entry +parseLine Line{..} = do + let txtLine = decodeUtf8 lineLine + txtStatus : library : _ <- Just $ words txtLine + + -- parse status string to the 'Status' type + status <- readMaybe $ toString txtStatus + + -- check if this line is a library: '-' separates library name and its version + guard $ Text.elem '-' library + + pure $ Entry + { entryStatus = status + , entryStart = lineTime + , entryLibrary = library + } diff --git a/src/DrCabal/Profile.hs b/src/DrCabal/Profile.hs index cb6fac3..fed5157 100644 --- a/src/DrCabal/Profile.hs +++ b/src/DrCabal/Profile.hs @@ -11,50 +11,55 @@ Portability : Portable module DrCabal.Profile ( runProfile - , getTerminalWidth - , createChart ) where -import Colourista.Short (u) -import Data.Aeson (eitherDecodeFileStrict') -import System.Console.Terminal.Size (Window(..), size) -import DrCabal.Cli (ProfileArgs (..)) -import DrCabal.Model (Entry (..), Style (Stacked)) +import DrCabal.Cli (FileMode (..), ProfileArgs (..)) +import DrCabal.Json (readEntries, writeEntries) +import DrCabal.Model (Entry (..), Style (..)) import DrCabal.Profile.Stacked (createStackedChart) +import DrCabal.Terminal (getTerminalWidth) +import DrCabal.Watch (watchBuild) -import qualified Colourista - -getTerminalWidth :: IO Int -getTerminalWidth = size >>= \case - Just (Window _height width) -> pure width - Nothing -> do - putText $ unlines - [ "Error getting the terminal width. If you see this error, open an issue" - , "in the 'dr-cabal' issue tracker and provide as many details as possible" - , "" - , " * " <> u "https://github.com/chshersh/dr-cabal/issues/new" - ] - exitFailure runProfile :: ProfileArgs -> IO () -runProfile ProfileArgs{..} = do - terminalWidth <- getTerminalWidth +runProfile ProfileArgs{..} = case profileArgsFileMode of + None -> + profileInteractive profileArgsStyle + Output outputFile -> + profileWithOutput profileArgsStyle outputFile + Input inputFile -> + profileFromInput profileArgsStyle inputFile - entries <- readFromFile profileArgsInput +profileInteractive :: Style -> IO () +profileInteractive chartStyle = do + hSetBuffering stdout (BlockBuffering Nothing) + terminalWidth <- getTerminalWidth + let drawChart = createChart chartStyle terminalWidth + void $ watchBuild drawChart - let chart = createChart profileArgsStyle terminalWidth entries +profileWithOutput :: Style -> FilePath -> IO () +profileWithOutput chartStyle outputFile = do + hSetBuffering stdout (BlockBuffering Nothing) + terminalWidth <- getTerminalWidth + let drawChart = createChart chartStyle terminalWidth + entries <- watchBuild drawChart + writeEntries outputFile entries +profileFromInput :: Style -> FilePath -> IO () +profileFromInput chartStyle inputFile = do + terminalWidth <- getTerminalWidth + entries <- readEntries inputFile + let chart = createChart chartStyle terminalWidth entries putTextLn chart -createChart :: Style -> Int -> [Entry] -> Text +createChart + :: Style + -- ^ Chart type + -> Int + -- ^ Terminal width + -> [Entry] + -- ^ Time entries + -> Text createChart = \case Stacked -> createStackedChart - -readFromFile :: FilePath -> IO [Entry] -readFromFile file = eitherDecodeFileStrict' file >>= \case - Left err -> do - Colourista.errorMessage $ "Error parsing file: " <> toText file - Colourista.redMessage $ " " <> toText err - exitFailure - Right entries -> pure entries diff --git a/src/DrCabal/Profile/Stacked.hs b/src/DrCabal/Profile/Stacked.hs index 2872d59..f5e2455 100644 --- a/src/DrCabal/Profile/Stacked.hs +++ b/src/DrCabal/Profile/Stacked.hs @@ -6,7 +6,7 @@ Maintainer : Dmitrii Kovanikov Stability : Experimental Portability : Portable -Stacked profiling output mode. +Stacked profiling output mode for the @dr-cabal profile --stacked@ command. -} module DrCabal.Profile.Stacked @@ -117,7 +117,7 @@ The algorithm works this way: -} computeCriticalPath :: Map Text [(Status, Word64)] -> [Text] computeCriticalPath libs = case Map.maxView finishTimeToLibs of - Nothing -> [] -- oh well, seems the log was empty + Nothing -> [] -- oh well, seems the log was empty Just (lastLib, _) -> lastLib : unfoldr go lastLib where -- Inner lists are generated by 'groupEntries', so must be nonempty. @@ -252,7 +252,7 @@ createStackedChart :: Int -> [Entry] -> Text createStackedChart width l = case l of [] -> unlines [ "No cabal build entries found. Have you already built dependency?" - , "Try removing global cabal store cache and rerunning 'dr-cabal watch' again." + , "Try removing global cabal store cache and rerunning 'dr-cabal watch' again." -- TODO: update message ] entries -> let start = List.minimum $ map entryStart entries in diff --git a/src/DrCabal/Terminal.hs b/src/DrCabal/Terminal.hs new file mode 100644 index 0000000..042a734 --- /dev/null +++ b/src/DrCabal/Terminal.hs @@ -0,0 +1,47 @@ +{- | +Module : DrCabal.Terminal +Copyright : (c) 2022 Dmitrii Kovanikov +SPDX-License-Identifier : MPL-2.0 +Maintainer : Dmitrii Kovanikov +Stability : Experimental +Portability : Portable + +Utility functions to work with the terminal output. +-} + +module DrCabal.Terminal + ( getTerminalWidth + , clearScreen + ) where + +import Colourista.Short (u) +import System.Console.ANSI (clearFromCursorToScreenEnd, cursorUpLine) +import qualified System.Console.Terminal.Size as Terminal + + +{- | Get the width of the current terminal. + +This function exits the process with the message if it can't get the +width of the current terminal. +-} +getTerminalWidth :: IO Int +getTerminalWidth = Terminal.size >>= \case + Just (Terminal.Window _height width) -> pure width + Nothing -> do + putText $ unlines + [ "Error getting the terminal width. If you see this error, open an issue" + , "in the 'dr-cabal' issue tracker and provide as many details as possible" + , "" + , " * " <> u "https://github.com/chshersh/dr-cabal/issues/new" + ] + exitFailure + +{- | Clears the the @screenHeight@ number of lines in the screen. Pass +the number of lines in the output to clear the entire screen. +-} +clearScreen :: Int -> IO () +clearScreen screenHeight = do + -- https://github.com/UnkindPartition/ansi-terminal/issues/141 + when (screenHeight > 0) $ + cursorUpLine screenHeight + clearFromCursorToScreenEnd diff --git a/src/DrCabal/Watch.hs b/src/DrCabal/Watch.hs index 1088d71..915b90f 100644 --- a/src/DrCabal/Watch.hs +++ b/src/DrCabal/Watch.hs @@ -9,94 +9,119 @@ Maintainer : Dmitrii Kovanikov Stability : Experimental Portability : Portable -Implementation of the @dr-cabal watch@ command. +Watch the output of the @cabal build@ command and update the profile +chart interactively. -} module DrCabal.Watch - ( runWatch - , parseLine + ( watchBuild ) where import Colourista.Short (b) import Control.Concurrent (threadDelay) -import Control.Concurrent.Async (concurrently_) -import Data.Aeson.Encode.Pretty (encodePretty) +import Control.Concurrent.Async (concurrently) import GHC.Clock (getMonotonicTimeNSec) -import System.Console.ANSI (clearLine, setCursorColumn) import System.IO (isEOF) -import DrCabal.Cli (WatchArgs (..)) -import DrCabal.Model (Entry (..), Line (..)) +import DrCabal.Model (Entry (..), Line (..), parseLine) +import DrCabal.Terminal (clearScreen) import qualified Colourista import qualified Data.ByteString as ByteString -import qualified Data.Text as Text -runWatch :: WatchArgs -> IO () -runWatch WatchArgs{..} = do - watchRef <- newIORef [Start] - - concurrently_ - (watchWorker watchRef) - (readFromStdin watchRef watchArgsOutput) - -readFromStdin :: IORef [WatchAction] -> FilePath -> IO () -readFromStdin watchRef outputPath = go [] +{- | 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 :: [Line] -> IO () - go cabalOutput = do + go :: IO () + go = do isEndOfInput <- isEOF if isEndOfInput then do - pushAction watchRef $ End outputPath cabalOutput + 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 watchRef $ Consume line - - go $ Line time line : cabalOutput + pushAction inputActionRef $ Consume ln -linesToEntries :: [Line] -> [Entry] -linesToEntries = mapMaybe parseLine . reverse + go -parseLine :: Line -> Maybe Entry -parseLine Line{..} = do - let txtLine = decodeUtf8 lineLine - txtStatus : library : _ <- Just $ words txtLine +-- | Action returned by the @stdinReaderWorker@. +data InputAction + -- | Produce the initial message + = Start - -- parse status string to the 'Status' type - status <- readMaybe $ toString txtStatus + -- | Line content read from @stdin@ with timestamp + | Consume Line - -- check if this line is a library: '-' separates library name and its version - guard $ Text.elem '-' library + -- | EOF reached for @stdin@ + | End - pure $ Entry - { entryStatus = status - , entryStart = lineTime - , entryLibrary = library - } +-- | 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 WatchAction - = Start - | Consume ByteString - | End FilePath [Line] +data InteractiveCommand + -- | Initial message + = Greeting --- | Add 'WatchAction' to end of the list -pushAction :: IORef [WatchAction] -> WatchAction -> IO () -pushAction watchRef action = - atomicModifyIORef' watchRef $ \actions -> (actions ++ [action], ()) + -- | New line received from the @stdinReaderWorker@. Update the chart. + | UpdateChart Line -data WorkerCommand - = Greeting - | WriteLine ByteString + -- | No new lines from @stdin@. Simply wait and update the spinner. | Wait - | Finish FilePath [Line] -watchWorker :: IORef [WatchAction] -> IO () -watchWorker watchRef = go "Watching build output" (cycle spinnerFrames) + -- | 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 = @@ -112,52 +137,53 @@ watchWorker watchRef = go "Watching build output" (cycle spinnerFrames) , "⠏" ] - go :: Text -> [Text] -> IO () + go :: Output -> [Text] -> IO [Entry] go _ [] = do Colourista.errorMessage $ "Panic! At the 'dr-cabal'! Impossible happened: list of frames is empty" exitFailure - go prevLine (frame : frames) = do - command <- atomicModifyIORef' watchRef popAction + go prevOutput (frame : frames) = do + command <- nextCommand inputActionRef + case command of Greeting -> do - Colourista.formattedMessage - [Colourista.blue, Colourista.bold] - "Watching cabal output..." - - go prevLine (frame : frames) - WriteLine line -> do - resetLine - let l = decodeUtf8 line - putText $ frame <> " " <> l - hFlush stdout - threadDelay 80_000 -- wait 80 ms to update spinner - go l frames + 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 - resetLine - putText $ frame <> " " <> prevLine - hFlush stdout - threadDelay 80_000 -- wait 80 ms to update spinner - go prevLine frames - Finish outputPath lns -> do - writeFileLBS outputPath $ encodePretty $ linesToEntries lns - resetLine - putTextLn $ unlines - [ b "Build finished successfully!" - , "" - , "To see the profiling output, run the following command:" - , "" - , " dr-cabal profile --input=" <> toText outputPath - ] - - popAction :: [WatchAction] -> ([WatchAction], WorkerCommand) - popAction [] = ([], Wait) - popAction (x : xs) = case x of - Start -> (xs, Greeting) - Consume l -> (xs, WriteLine l) - End path lns -> ([], Finish path lns) - - resetLine :: IO () - resetLine = do - clearLine - setCursorColumn 0 + 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{..} = + frame <> " " <> outputCabalLog <> "\n" <> case outputEntries of + [] -> "" + _ -> drawChart outputEntries From d7be718ace2759d3072cc4bbc1d699e1a0b3d628 Mon Sep 17 00:00:00 2001 From: Dmitrii Kovanikov Date: Sun, 20 Nov 2022 17:18:32 +0000 Subject: [PATCH 2/2] Output dr-cabal interactive profiler in the alternate terminal screen buffer --- src/DrCabal/Profile.hs | 50 ++++++++++++++++++++++++++++++++--------- src/DrCabal/Terminal.hs | 24 ++++++++++++++++++++ src/DrCabal/Watch.hs | 8 ++++++- 3 files changed, 71 insertions(+), 11 deletions(-) diff --git a/src/DrCabal/Profile.hs b/src/DrCabal/Profile.hs index fed5157..5dc4688 100644 --- a/src/DrCabal/Profile.hs +++ b/src/DrCabal/Profile.hs @@ -13,12 +13,11 @@ module DrCabal.Profile ( runProfile ) where - import DrCabal.Cli (FileMode (..), ProfileArgs (..)) import DrCabal.Json (readEntries, writeEntries) import DrCabal.Model (Entry (..), Style (..)) import DrCabal.Profile.Stacked (createStackedChart) -import DrCabal.Terminal (getTerminalWidth) +import DrCabal.Terminal (getTerminalWidth, withAlternateBuffer) import DrCabal.Watch (watchBuild) @@ -33,19 +32,35 @@ runProfile ProfileArgs{..} = case profileArgsFileMode of profileInteractive :: Style -> IO () profileInteractive chartStyle = do - hSetBuffering stdout (BlockBuffering Nothing) - terminalWidth <- getTerminalWidth - let drawChart = createChart chartStyle terminalWidth - void $ watchBuild drawChart + -- draw profiling chart interactively and get all the entries after that + entries <- withInteractiveProfiling chartStyle + + -- draw the chart in the normal terminal screen buffer now + drawChart <- getChartDrawer chartStyle + putTextLn $ drawChart entries + + putText $ unlines + [ "✨ Done!" + , "🆙 Scroll up to view full profiling chart." + , "💾 To save the results in a file (to view later without recompilation), run:" + , "" + , " cabal build ... | dr-cabal profile --output=my_file.json" + ] profileWithOutput :: Style -> FilePath -> IO () profileWithOutput chartStyle outputFile = do - hSetBuffering stdout (BlockBuffering Nothing) - terminalWidth <- getTerminalWidth - let drawChart = createChart chartStyle terminalWidth - entries <- watchBuild drawChart + -- draw profiling chart interactively and get all the entries after that + entries <- withInteractiveProfiling chartStyle writeEntries outputFile entries + putText $ unlines + [ "✨ Done!" + , "💾 Profiling entries are saved in the file: " <> toText outputFile + , "👀 To view the results from the saved file, run:" + , "" + , " dr-cabal profile --input=" <> toText outputFile + ] + profileFromInput :: Style -> FilePath -> IO () profileFromInput chartStyle inputFile = do terminalWidth <- getTerminalWidth @@ -53,6 +68,21 @@ profileFromInput chartStyle inputFile = do let chart = createChart chartStyle terminalWidth entries putTextLn chart +------------- +-- HELPERS -- +------------- + +withInteractiveProfiling :: Style -> IO [Entry] +withInteractiveProfiling chartStyle = withAlternateBuffer $ do + hSetBuffering stdout (BlockBuffering Nothing) + drawChart <- getChartDrawer chartStyle + watchBuild drawChart + +getChartDrawer :: Style -> IO ([Entry] -> Text) +getChartDrawer chartStyle = do + terminalWidth <- getTerminalWidth + pure $ createChart chartStyle terminalWidth + createChart :: Style -- ^ Chart type diff --git a/src/DrCabal/Terminal.hs b/src/DrCabal/Terminal.hs index 042a734..28ddb93 100644 --- a/src/DrCabal/Terminal.hs +++ b/src/DrCabal/Terminal.hs @@ -12,10 +12,13 @@ Utility functions to work with the terminal output. module DrCabal.Terminal ( getTerminalWidth , clearScreen + , withAlternateBuffer ) where import Colourista.Short (u) +import Control.Exception (bracket) import System.Console.ANSI (clearFromCursorToScreenEnd, cursorUpLine) + import qualified System.Console.Terminal.Size as Terminal @@ -45,3 +48,24 @@ clearScreen screenHeight = do when (screenHeight > 0) $ cursorUpLine screenHeight clearFromCursorToScreenEnd + +{- | Run action in the alternate buffer and return to the normal +screen after exception or SIGINT. + +__NOTE:__ This function always returns to the normal screen after the +action. If you want to print something to the normal screen use the +result of the given action afterwards. +-} +withAlternateBuffer :: IO a -> IO a +withAlternateBuffer action = bracket + useAlternateScreenBuffer + (\_ -> useNormalScreenBuffer) + (\_ -> action) + +-- TODO: use functions from 'ansi-terminal' +useAlternateScreenBuffer :: IO () +useAlternateScreenBuffer = putStrLn "\ESC[?1049h\ESC[H" + +-- TODO: use functions from 'ansi-terminal' +useNormalScreenBuffer :: IO () +useNormalScreenBuffer = putStrLn "\ESC[?1049l" diff --git a/src/DrCabal/Watch.hs b/src/DrCabal/Watch.hs index 915b90f..8abf6ee 100644 --- a/src/DrCabal/Watch.hs +++ b/src/DrCabal/Watch.hs @@ -184,6 +184,12 @@ interactiveWorker inputActionRef drawChart = fmtOutput :: Text -> Output -> Text fmtOutput frame Output{..} = - frame <> " " <> outputCabalLog <> "\n" <> case outputEntries of + chart <> log + where + chart :: Text + chart = case outputEntries of [] -> "" _ -> drawChart outputEntries + + log :: Text + log = frame <> " " <> outputCabalLog