diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,22 +1,80 @@ # Changelog -`dr-cabal` uses [PVP Versioning][1]. -The changelog is available [on GitHub][2]. +All notable changes to this project will be documented in this file. -## 0.1.0.0 — August 6, 2022 📚 +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to [PVP Versioning][1]. The changelog is also +available [on GitHub][2]. +[1]: https://pvp.haskell.org +[2]: https://github.com/chshersh/dr-cabal/releases + +## [Unreleased] + +## [0.2.0.0] — 2022-11-20 ✨ + +### Added + +* [#28](https://github.com/chshersh/dr-cabal/issues/28): + Implement interactive mode + (by [@Bodigrim][Bodigrim]) +* [#24](https://github.com/chshersh/dr-cabal/issues/24): + Compute the critical path + (by [@Bodigrim][Bodigrim]) +* [#26](https://github.com/chshersh/dr-cabal/issues/26), + [#30](https://github.com/chshersh/dr-cabal/issues/30): + Multiple documentation improvements: suggest `--store-dir`, + `--dependencies-only`, `mktemp`, interactive mode by default + (by [@Bodigrim][Bodigrim], [@chshersh][chshersh]) + +### Removed + +* Remove `watch` command. Now `dr-cabal profile` can watch and build + the profiling output at the same time. + +### Changed + +* [#31](https://github.com/chshersh/dr-cabal/issues/31): + Refactor CLI significantly: + + + Remove `watch` command + + Use interactive mode by default (via alternate terminal screen) + + (by [@chshersh][chshersh]) + +## [0.1.0.0] — 2022-08-06 📚 + +### Added + * [#10](https://github.com/chshersh/dr-cabal/issues/10): Support `Haddock` phase in `cabal build` output - (by [@diasbruno](https://github.com/diasbruno)) + (by [@diasbruno][diasbruno]) * [#14](https://github.com/chshersh/dr-cabal/issues/14): Enrich _Summary_ with more info: parallelism level, total dependencies summary - (by [@bradrn](https://github.com/bradrn)) + (by [@bradrn][bradrn]) * Module structure refactoring to add new profiling modes easier - (by [@diasbruno](https://github.com/diasbruno)) + (by [@diasbruno][diasbruno]) -## 0.0.0.0 — July 31, 2022 🌇 +### Fixed -* Initially created. +* Fixed type in the profile example + (by [@tonyday567][tonyday567]) -[1]: https://pvp.haskell.org -[2]: https://github.com/chshersh/dr-cabal/releases +## [0.0.0.0] — 2022-07-31 🌇 + +Initial release prepared by [@chshersh][chshersh]. + + + +[Bodigrim]: https://github.com/Bodigrim +[bradrn]: https://github.com/bradrn +[chshersh]: https://github.com/chshersh +[diasbruno]: https://github.com/diasbruno +[tonyday567]: https://github.com/tonyday567 + + + +[Unreleased]: https://github.com/chshersh/dr-cabal/compare/v0.2.0.0...HEAD +[0.2.0.0]: https://github.com/chshersh/dr-cabal/compare/v0.1.0.0...v0.2.0.0 +[0.1.0.0]: https://github.com/chshersh/dr-cabal/compare/v0.0.0.0...v0.1.0.0 +[0.0.0.0]: https://github.com/chshersh/dr-cabal/releases/tag/v0.0.0.0 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -6,7 +6,7 @@ `dr-cabal` is a CLI tool for profiling Haskell dependencies build times. -![dr-cabal example](https://raw.githubusercontent.com/chshersh/dr-cabal/main/images/dr-cabal-example.png) +![dr-cabal demo](https://raw.githubusercontent.com/chshersh/dr-cabal/main/images/dr-cabal-demo.gif) > ℹī¸ **DISCLAIMER:** This project is developed and maintained in > free time by volunteers. The development may continue for decades or @@ -16,8 +16,8 @@ ## Install -`dr-cabal` is a Haskell CLI tool and can be installed either from -Hackage or from this repository. +`dr-cabal` is a CLI tool written in Haskell and can be installed +either from Hackage or from this repository. ### Prerequisites @@ -41,13 +41,12 @@ ``` 2. Build `dr-cabal` from Hackage and copy the resulting executable - into the desired location: + into the desired location (e.g. `$HOME/.local/bin`): ```shell cabal install dr-cabal \ --install-method=copy \ --overwrite-policy=always \ - --with-compiler=ghc-9.0.2 \ --installdir=$HOME/.local/bin ``` @@ -81,55 +80,59 @@ > ℹī¸ **NOTE:** Make sure the `~/.local/bin` directory or the > directory of your choice is listed in `$PATH`. -## How to use? +## Quick start guide -`dr-cabal` usages comprises two steps: +Run the following command to view interactive profiling report: -1. 👀 Watching `cabal build` output and recording data into a JSON file. -2. 🌈 Producing pretty profiling results. +```shell +cabal --store-dir=$(mktemp -d) build --dependencies-only all | dr-cabal profile +``` -### Watch +### Explanation -> ⚠ī¸ **WARNING:** To get meaningful results, the `dr-cabal watch` -> command needs to be run when none of the dependencies are build. If -> you've already build you project, including dependencies, you can -> purge global Cabal cache using the following command: +This section explains the above command: + +1. `dr-cabal` watches the output of the `cabal build` command to + produce the profiling report. Step into the directory of the + Haskell project you want to profile and pipe the output of + `cabal build` to `dr-cabal profile`. +2. Currently, `dr-cabal` can profile only dependencies. So you can + pass the `--dependencies-only` to avoid extra wait. +3. `cabal` caches built dependencies. You can specify a custom + directory for storing build artifacts using the `--store-dir` flag + to build the dependencies anew. +4. The `$(mktemp -d)` command generates a temporary directory so you + can run the build time profiler in an isolated location. + +> ⚠ī¸ **WARNING:** To get meaningful results, including downloading +> of packages, the `dr-cabal watch` command needs to be run when +> none of the dependencies are build (i.e. with cold cabal +> cache). If you've already build you project, including +> dependencies, you can purge global Cabal cache using the +> following command: > > ```shell > rm -rf ~/.cabal > ``` -> -> You may prefer a less invasive approach if you have custom global -> Cabal configurations: -> -> ```shell -> rm -rf ~/.cabal/store -> ``` -> -> However, with the latter solution you won't see the `Downloading` -> phase in the profiling output. -Run the following command inside the project directory, for which you -want to build the profile chart: - -```shell -cabal build all | dr-cabal watch --output=dr-cabal-debug.json -``` +## Usage -This command watches the `cabal build` output and records all the -relevant steps in the `dr-cabal-debug.json` file. +> ℹī¸ In this section, a more verbose `cabal-install` command from +> "Quick start guide" is replaced with shorter `cabal build`. -If everything is good, you should see output similar to the below one: +`dr-cabal` supports profiling of documentation as well, you only need +to pass relevant flags to `cabal build`: -![dr-cabal watch example](https://raw.githubusercontent.com/chshersh/dr-cabal/main/images/dr-cabal-watch.gif) +```shell +cabal build --enable-documentation --haddock-all | dr-cabal profile +``` -> It's also possible to see the time spent on Haddock. You can run with: -> -> ```shell -> cabal build all --enable-documentation --haddock-all | dr-cabal watch --output=dr-cabal-debug.json -> ``` +To cache the profiling results in JSON (and avoid building the project +again), use the `--output` flag: -### Profile +```shell +cabal build | dr-cabal profile --output=my_file.json +``` Once you successfully produced a JSON file with all the recorded steps, run the following command to pretty-print the profiling output: @@ -137,7 +140,7 @@ > ⚠ī¸ **WARNING:** For better results, make your terminal full-screen. ```shell -dr-cabal profile --input=dr-cabal-debug.json +dr-cabal profile --input=my_file.json ``` You'll see the output like on the image below: diff --git a/dr-cabal.cabal b/dr-cabal.cabal --- a/dr-cabal.cabal +++ b/dr-cabal.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: dr-cabal -version: 0.1.0.0 +version: 0.2.0.0 synopsis: See README for more info description: CLI tool for profiling Haskell dependencies build times. @@ -81,10 +81,12 @@ exposed-modules: DrCabal DrCabal.Cli + DrCabal.Json DrCabal.Model DrCabal.Profile DrCabal.Profile.Format DrCabal.Profile.Stacked + DrCabal.Terminal DrCabal.Watch build-depends: @@ -95,6 +97,7 @@ , bytestring ^>= 0.11 , colourista ^>= 0.1 , optparse-applicative ^>= 0.17 + , terminal-size ^>= 0.3.3 executable dr-cabal import: common-options diff --git a/src/DrCabal.hs b/src/DrCabal.hs --- a/src/DrCabal.hs +++ b/src/DrCabal.hs @@ -15,7 +15,6 @@ import DrCabal.Cli (Command (..), readCommand) import DrCabal.Profile (runProfile) -import DrCabal.Watch (runWatch) main :: IO () @@ -23,5 +22,4 @@ runDrCabal :: Command -> IO () runDrCabal = \case - Watch args -> runWatch args Profile args -> runProfile args diff --git a/src/DrCabal/Cli.hs b/src/DrCabal/Cli.hs --- a/src/DrCabal/Cli.hs +++ b/src/DrCabal/Cli.hs @@ -15,8 +15,8 @@ ( Command (..) , readCommand - , WatchArgs (..) , ProfileArgs (..) + , FileMode (..) ) where import DrCabal.Model (Style (..)) @@ -24,18 +24,23 @@ import qualified Options.Applicative as Opt data Command - = Watch WatchArgs - | Profile ProfileArgs - -newtype WatchArgs = WatchArgs - { watchArgsOutput :: FilePath - } + = Profile ProfileArgs data ProfileArgs = ProfileArgs - { profileArgsInput :: FilePath - , profileArgsStyle :: Style + { profileArgsStyle :: Style + , profileArgsFileMode :: FileMode } +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 where @@ -48,41 +53,43 @@ -- | 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" + [ Opt.command "profile" + $ Opt.info (Opt.helper <*> profileP) + $ Opt.progDesc "Build profiling report" ] -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{..} - profileP :: Opt.Parser Command profileP = do - profileArgsInput <- Opt.strOption $ mconcat + profileArgsStyle <- styleP + profileArgsFileMode <- fileModeP + + pure $ Profile ProfileArgs{..} + +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" + ] + +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 watch'" + , Opt.help "Read profile input from a JSON file, created by 'dr-cabal profile --output='" ] - profileArgsStyle <- stackedP <|> pure Stacked - - pure $ Profile ProfileArgs{..} - -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/Json.hs b/src/DrCabal/Json.hs new file mode 100644 --- /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 --- a/src/DrCabal/Model.hs +++ b/src/DrCabal/Model.hs @@ -14,10 +14,14 @@ , 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 @@ 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 --- a/src/DrCabal/Profile.hs +++ b/src/DrCabal/Profile.hs @@ -13,40 +13,83 @@ ( runProfile ) where -import Colourista.Short (u) -import Data.Aeson (eitherDecodeFileStrict') -import System.Console.ANSI (getTerminalSize) - -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, withAlternateBuffer) +import DrCabal.Watch (watchBuild) -import qualified Colourista runProfile :: ProfileArgs -> IO () -runProfile ProfileArgs{..} = do - terminalWidth <- getTerminalSize >>= \case - Just (_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{..} = 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 + -- draw profiling chart interactively and get all the entries after that + entries <- withInteractiveProfiling chartStyle - let chart = case profileArgsStyle of - Stacked -> createStackedChart terminalWidth entries + -- 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 + -- 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 + entries <- readEntries inputFile + let chart = createChart chartStyle terminalWidth entries putTextLn chart -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 +------------- +-- 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 + -> Int + -- ^ Terminal width + -> [Entry] + -- ^ Time entries + -> Text +createChart = \case + Stacked -> createStackedChart diff --git a/src/DrCabal/Profile/Stacked.hs b/src/DrCabal/Profile/Stacked.hs --- a/src/DrCabal/Profile/Stacked.hs +++ b/src/DrCabal/Profile/Stacked.hs @@ -6,7 +6,7 @@ Stability : Experimental Portability : Portable -Stacked profiling output mode. +Stacked profiling output mode for the @dr-cabal profile --stacked@ command. -} module DrCabal.Profile.Stacked @@ -104,8 +104,43 @@ Nothing -> ct `minusw` start Just it -> ct `minusw` it -formatChart :: Word64 -> Word64 -> Int -> Map Text Phase -> Text -formatChart start end width libs = unlines $ concat +{- | Take a log of Cabal events and derive a critical path, which is the longest +stretch of dependent packages such that the sum of their build times determines +the total wall clock time. + +The algorithm works this way: +1. Find the very last event in the log and a corresponding library L. +2. Find when L first emerges in the log (which is when its build started). +3. If this is the very first entry of the log, exit. +4. Find which build just finished before L's build started and a corresponding library L'. +5. Set L := L' and return to Step 2. +-} +computeCriticalPath :: Map Text [(Status, Word64)] -> [Text] +computeCriticalPath libs = case Map.maxView finishTimeToLibs of + 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. + libsList :: [(Text, [Word64])] + libsList = map (fmap (map snd)) $ Map.assocs libs + + libsByStartTime :: Map Text Word64 + libsByStartTime = Map.fromList $ map (fmap List.minimum) libsList + + -- Given that timestamps are in nanoseconds, we do not really + -- expect any entries to have the same finish time. + finishTimeToLibs :: Map Word64 Text + finishTimeToLibs = Map.fromList $ map (swap . fmap List.maximum) libsList + + go :: Text -> Maybe (Text, Text) + go lib = do + phase <- Map.lookup lib libsByStartTime + let (finishedBefore, _) = Map.split phase finishTimeToLibs + prevLib <- fst <$> Map.maxView finishedBefore + pure (prevLib, prevLib) + +formatChart :: Word64 -> Word64 -> Int -> [Text] -> Map Text Phase -> Text +formatChart start end width critPath libs = unlines $ concat [ legend , summary , profile @@ -122,17 +157,18 @@ , " " <> fmt [red] block <> " Building" , " " <> fmt [magenta] block <> " Haddock" , " " <> fmt [yellow] block <> " Installing" + , " " <> b "*" <> " Critical path" , "" ] summary :: [Text] summary = [ b "Summary" - , i " Wall time " <> " : " <> fmtNanos (end - start) - , i " Dependency sum time " <> " : " <> fmtNanos totalAllPhases - , i " Total dependencies " <> " : " <> show (Map.size libs) - , i " Parallelism level " <> " : " <> fmtDecimalPlaces 2 parallelism - , i " Single block resolution" <> " : " <> fmtNanos blockMeasure + , i " Wall time (sum along critpath)" <> " : " <> fmtNanos (end - start) + , i " Dependency sum time " <> " : " <> fmtNanos totalAllPhases + , i " Total dependencies " <> " : " <> show (Map.size libs) + , i " Parallelism level " <> " : " <> fmtDecimalPlaces 2 parallelism + , i " Single block resolution " <> " : " <> fmtNanos blockMeasure , "" ] @@ -176,14 +212,24 @@ fmtPrefix :: Text -> Phase -> Text fmtPrefix libName phase = mconcat - [ Text.justifyRight libSize ' ' libName + [ fmtCritPath , " [" , Text.justifyLeft phaseSize ' ' $ fmtPhase phase , "] " , "│" , " " ] + where + isOnCritPath :: Bool + isOnCritPath = libName `elem` critPath + fmtCritPath :: Text + fmtCritPath + | isOnCritPath = b $ paddedLibName <> "*" + | otherwise = paddedLibName <> " " + where + paddedLibName = Text.justifyRight libSize ' ' libName + -- How many nanoseconds each block represents? -- blocks take: -- width minus prefix size @@ -206,9 +252,11 @@ 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 - let end = List.maximum $ map entryStart entries in - formatChart start end width $ calculatePhases start $ groupEntries entries + let start = List.minimum $ map entryStart entries in + let end = List.maximum $ map entryStart entries in + let grouped = groupEntries entries in + let critPath = computeCriticalPath grouped in + formatChart start end width critPath $ calculatePhases start grouped diff --git a/src/DrCabal/Terminal.hs b/src/DrCabal/Terminal.hs new file mode 100644 --- /dev/null +++ b/src/DrCabal/Terminal.hs @@ -0,0 +1,71 @@ +{- | +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 + , withAlternateBuffer + ) where + +import Colourista.Short (u) +import Control.Exception (bracket) +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 + +{- | 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 --- a/src/DrCabal/Watch.hs +++ b/src/DrCabal/Watch.hs @@ -9,94 +9,120 @@ 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 + ( 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] +{- | 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] - concurrently_ - (watchWorker watchRef) - (readFromStdin watchRef watchArgsOutput) + (entries, _) <- concurrently + (interactiveWorker inputActionRef drawChart) + (stdinReaderWorker inputActionRef) -readFromStdin :: IORef [WatchAction] -> FilePath -> IO () -readFromStdin watchRef outputPath = go [] + 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 = [ "⠋" @@ -111,52 +137,59 @@ , "⠏" ] - 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 - ] + printOutput frame prevOutput prevOutput + go prevOutput frames - 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) + Finish -> do + putTextLn $ b "Build finished successfully!" + pure $ outputEntries prevOutput - resetLine :: IO () - resetLine = do - clearLine - setCursorColumn 0 + 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