diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,6 +3,17 @@ `dr-cabal` uses [PVP Versioning][1]. The changelog is available [on GitHub][2]. +## 0.1.0.0 — August 6, 2022 📚 + +* [#10](https://github.com/chshersh/dr-cabal/issues/10): + Support `Haddock` phase in `cabal build` output + (by [@diasbruno](https://github.com/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)) +* Module structure refactoring to add new profiling modes easier + (by [@diasbruno](https://github.com/diasbruno)) + ## 0.0.0.0 — July 31, 2022 🌇 * Initially created. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -47,7 +47,7 @@ cabal install dr-cabal \ --install-method=copy \ --overwrite-policy=always \ - --with-compiler=ghc-9.0.2 + --with-compiler=ghc-9.0.2 \ --installdir=$HOME/.local/bin ``` @@ -123,6 +123,12 @@ ![dr-cabal watch example](https://raw.githubusercontent.com/chshersh/dr-cabal/main/images/dr-cabal-watch.gif) +> 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 +> ``` + ### Profile Once you successfully produced a JSON file with all the recorded @@ -131,7 +137,7 @@ > ⚠️ **WARNING:** For better results, make your terminal full-screen. ```shell -cabal profile --input=dr-cabal-debug.json +dr-cabal profile --input=dr-cabal-debug.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.0.0.0 +version: 0.1.0.0 synopsis: See README for more info description: CLI tool for profiling Haskell dependencies build times. @@ -16,7 +16,7 @@ build-type: Simple extra-doc-files: README.md CHANGELOG.md -tested-with: GHC == 9.2.3 +tested-with: GHC == 9.2.4 GHC == 9.0.2 source-repository head @@ -83,6 +83,8 @@ DrCabal.Cli DrCabal.Model DrCabal.Profile + DrCabal.Profile.Format + DrCabal.Profile.Stacked DrCabal.Watch build-depends: diff --git a/src/DrCabal/Cli.hs b/src/DrCabal/Cli.hs --- a/src/DrCabal/Cli.hs +++ b/src/DrCabal/Cli.hs @@ -19,6 +19,8 @@ , ProfileArgs (..) ) where +import DrCabal.Model (Style (..)) + import qualified Options.Applicative as Opt data Command @@ -29,8 +31,9 @@ { watchArgsOutput :: FilePath } -newtype ProfileArgs = ProfileArgs +data ProfileArgs = ProfileArgs { profileArgsInput :: FilePath + , profileArgsStyle :: Style } readCommand :: IO Command @@ -73,4 +76,13 @@ , Opt.help "Read profile input from a JSON file, created by 'dr-cabal watch'" ] + 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" + ] diff --git a/src/DrCabal/Model.hs b/src/DrCabal/Model.hs --- a/src/DrCabal/Model.hs +++ b/src/DrCabal/Model.hs @@ -10,13 +10,15 @@ -} module DrCabal.Model - ( Line (..) + ( Style (..) + , Line (..) , Status (..) , Entry (..) ) where import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, withText, (.:), (.=)) +data Style = Stacked data Line = Line { lineTime :: Word64 @@ -28,6 +30,7 @@ | Downloaded | Starting | Building + | Haddock | Installing | Completed deriving stock (Show, Read, Eq, Ord, Enum, Bounded) diff --git a/src/DrCabal/Profile.hs b/src/DrCabal/Profile.hs --- a/src/DrCabal/Profile.hs +++ b/src/DrCabal/Profile.hs @@ -13,20 +13,16 @@ ( runProfile ) where -import Colourista.Pure (blue, cyan, formatWith, red, yellow) -import Colourista.Short (b, i, u) +import Colourista.Short (u) import Data.Aeson (eitherDecodeFileStrict') import System.Console.ANSI (getTerminalSize) import DrCabal.Cli (ProfileArgs (..)) -import DrCabal.Model (Entry (..), Status (..)) +import DrCabal.Model (Entry (..), Style (Stacked)) +import DrCabal.Profile.Stacked (createStackedChart) import qualified Colourista -import qualified Data.List as List -import qualified Data.Map.Strict as Map -import qualified Data.Text as Text - runProfile :: ProfileArgs -> IO () runProfile ProfileArgs{..} = do terminalWidth <- getTerminalSize >>= \case @@ -41,7 +37,10 @@ exitFailure entries <- readFromFile profileArgsInput - let chart = createProfileChart terminalWidth entries + + let chart = case profileArgsStyle of + Stacked -> createStackedChart terminalWidth entries + putTextLn chart readFromFile :: FilePath -> IO [Entry] @@ -51,205 +50,3 @@ Colourista.redMessage $ " " <> toText err exitFailure Right entries -> pure entries - -createProfileChart :: Int -> [Entry] -> Text -createProfileChart 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." - ] - 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 - -groupEntries :: [Entry] -> Map Text [(Status, Word64)] -groupEntries = foldl' insert mempty - where - insert :: Map Text [(Status, Word64)] -> Entry -> Map Text [(Status, Word64)] - insert m Entry{..} = Map.alter (Just . toVal (entryStatus, entryStart)) entryLibrary m - where - toVal :: a -> Maybe [a] -> [a] - toVal x Nothing = [x] - toVal x (Just xs) = x : xs - -data Phase = Phase - { phaseDownloading :: Word64 - , phaseStarting :: Word64 - , phaseBuilding :: Word64 - , phaseInstalling :: Word64 - } - -phaseTotal :: Phase -> Word64 -phaseTotal (Phase p1 p2 p3 p4) = p1 + p2 + p3 + p4 - -calculatePhases :: Word64 -> Map Text [(Status, Word64)] -> Map Text Phase -calculatePhases start = fmap (entriesToPhase start) - -entriesToPhase :: Word64 -> [(Status, Word64)] -> Phase -entriesToPhase start times = Phase - { phaseDownloading = calcDownloading - , phaseStarting = calcStarting - , phaseBuilding = calcBuilding - , phaseInstalling = calcInstalling - } - where - downloading, downloaded, starting, building, installing, completed :: Maybe Word64 - downloading = List.lookup Downloading times - downloaded = List.lookup Downloaded times - starting = List.lookup Starting times - building = List.lookup Building times - installing = List.lookup Installing times - completed = List.lookup Completed times - - minusw :: Word64 -> Word64 -> Word64 - x `minusw` y - | x <= y = 0 - | otherwise = x - y - - calcDownloading :: Word64 - calcDownloading = case (downloading, downloaded) of - (Just dStart, Just dEnd) -> dEnd `minusw` dStart - _ -> 0 - - calcStarting :: Word64 - calcStarting = case building of - Nothing -> 0 - Just bt -> case starting of - Just st -> bt `minusw` st - Nothing -> bt `minusw` start - - calcBuilding :: Word64 - calcBuilding = case installing of - Nothing -> 0 - Just it -> case building of - Nothing -> it `minusw` start - Just bt -> it `minusw` bt - - calcInstalling :: Word64 - calcInstalling = case completed of - Nothing -> 0 - Just ct -> case installing of - Nothing -> ct `minusw` start - Just it -> ct `minusw` it - -formatChart :: Word64 -> Word64 -> Int -> Map Text Phase -> Text -formatChart start end width libs = unlines $ concat $ - [ legend - , summary - , profile - ] - where - block :: Text - block = "▇" - - legend :: [Text] - legend = - [ b "Legend" - , " " <> fmt [cyan] block <> " Downloading" - , " " <> fmt [blue] block <> " Starting" - , " " <> fmt [red] block <> " Building" - , " " <> fmt [yellow] block <> " Installing" - , "" - ] - - summary :: [Text] - summary = - [ b "Summary" - , i " Total dependency build time" <> " : " <> fmtNanos (end - start) - , i " Single block resolution " <> " : " <> fmtNanos blockMeasure - , "" - ] - - profile :: [Text] - profile = - [ b "Profile" - ] ++ - formattedEntries - - formattedEntries :: [Text] - formattedEntries - = map (uncurry formatRow) - $ sortOn (Down . phaseTotal . snd) entries - - formatRow :: Text -> Phase -> Text - formatRow libName phase@Phase{..} = mconcat - [ fmtPrefix libName phase - , formatSinglePhase cyan phaseDownloading - , formatSinglePhase blue phaseStarting - , formatSinglePhase red phaseBuilding - , formatSinglePhase yellow phaseInstalling - ] - - entries :: [(Text, Phase)] - entries = Map.toList libs - - libSize, phaseSize, prefixSize :: Int - libSize = List.maximum $ map (Text.length . fst) entries - phaseSize = List.maximum $ map (Text.length . fmtPhase . snd) entries - prefixSize = List.maximum $ map (Text.length . uncurry fmtPrefix) entries - - longestPhase :: Word64 - longestPhase = List.maximum $ map (phaseTotal . snd) entries - - fmtPhase :: Phase -> Text - fmtPhase = fmtNanos . phaseTotal - - fmtPrefix :: Text -> Phase -> Text - fmtPrefix libName phase = mconcat - [ Text.justifyRight libSize ' ' libName - , " [" - , Text.justifyLeft phaseSize ' ' $ fmtPhase phase - , "] " - , "│" - , " " - ] - - -- How many nanoseconds each block represents? - -- blocks take: - -- width minus prefix size - -- minus 4 for remainders of each phase - blockMeasure :: Word64 - blockMeasure = longestPhase `div` fromIntegral (width - prefixSize - 4) - - formatSinglePhase :: Text -> Word64 -> Text - formatSinglePhase colour phase - | phase == 0 = "" - | otherwise = fmt [colour] $ stimes blockCount block - where - blockCount :: Word64 - blockCount = blockRemainder + div phase blockMeasure - - blockRemainder :: Word64 - blockRemainder = if phase `mod` blockMeasure > 0 then 1 else 0 - -fmt :: [Text] -> Text -> Text -fmt = formatWith - - -fmtNanos :: Word64 -> Text -fmtNanos time - | time < ns = "0ns" - | time < mcs = show nanos <> "ns" - | time < ms = show micros <> "mcs" - | time < s = show millis <> "ms" - | time < m = show seconds <> "s" <> emptyIfZero millis "ms" - | otherwise = show minutes <> "m" <> emptyIfZero seconds "s" - where - ns, mcs, ms, s, m :: Word64 - ns = 1 - mcs = 1000 * ns - ms = 1000 * mcs - s = 1000 * ms - m = 60 * s - - nanos :: Word64 - nanos = time `mod` mcs - micros = (time `div` mcs) `mod` 1000 - millis = (time `div` ms) `mod` 1000 - seconds = (time `div` s) `mod` 60 - minutes = time `div` m - - emptyIfZero :: Word64 -> Text -> Text - emptyIfZero 0 _ = "" - emptyIfZero t unit = show t <> unit diff --git a/src/DrCabal/Profile/Format.hs b/src/DrCabal/Profile/Format.hs new file mode 100644 --- /dev/null +++ b/src/DrCabal/Profile/Format.hs @@ -0,0 +1,54 @@ +{- | +Module : DrCabal.Profile.Format +Copyright : (c) 2022 Dmitrii Kovanikov +SPDX-License-Identifier : MPL-2.0 +Maintainer : Dmitrii Kovanikov +Stability : Experimental +Portability : Portable + +Formatting functions for the @profile@ command. +-} + +module DrCabal.Profile.Format + ( fmt + , fmtNanos + , fmtDecimalPlaces + ) where + +import Colourista.Pure (formatWith) +import Data.Text (pack) +import Numeric (showFFloat) + + +fmt :: [Text] -> Text -> Text +fmt = formatWith + +fmtNanos :: Word64 -> Text +fmtNanos time + | time < ns = "0ns" + | time < mcs = show nanos <> "ns" + | time < ms = show micros <> "mcs" + | time < s = show millis <> "ms" + | time < m = show seconds <> "s" <> emptyIfZero millis "ms" + | otherwise = show minutes <> "m" <> emptyIfZero seconds "s" + where + ns, mcs, ms, s, m :: Word64 + ns = 1 + mcs = 1000 * ns + ms = 1000 * mcs + s = 1000 * ms + m = 60 * s + + nanos :: Word64 + nanos = time `mod` mcs + micros = (time `div` mcs) `mod` 1000 + millis = (time `div` ms) `mod` 1000 + seconds = (time `div` s) `mod` 60 + minutes = time `div` m + + emptyIfZero :: Word64 -> Text -> Text + emptyIfZero 0 _ = "" + emptyIfZero t unit = show t <> unit + +fmtDecimalPlaces :: Int -> Float -> Text +fmtDecimalPlaces dp f = pack $ showFFloat (Just dp) f "" diff --git a/src/DrCabal/Profile/Stacked.hs b/src/DrCabal/Profile/Stacked.hs new file mode 100644 --- /dev/null +++ b/src/DrCabal/Profile/Stacked.hs @@ -0,0 +1,214 @@ +{- | +Module : DrCabal.Profile.Stacked +Copyright : (c) 2022 Dmitrii Kovanikov +SPDX-License-Identifier : MPL-2.0 +Maintainer : Dmitrii Kovanikov +Stability : Experimental +Portability : Portable + +Stacked profiling output mode. +-} + +module DrCabal.Profile.Stacked + ( createStackedChart + ) where + +import Colourista.Pure (blue, cyan, magenta, red, yellow) +import Colourista.Short (b, i) + +import DrCabal.Model (Entry (..), Status (..)) +import DrCabal.Profile.Format (fmt, fmtDecimalPlaces, fmtNanos) + +import qualified Data.List as List +import qualified Data.Map.Strict as Map +import qualified Data.Text as Text + + +data Phase = Phase + { phaseDownloading :: Word64 + , phaseStarting :: Word64 + , phaseBuilding :: Word64 + , phaseHaddock :: Word64 + , phaseInstalling :: Word64 + } + +phaseTotal :: Phase -> Word64 +phaseTotal (Phase p1 p2 p3 p4 p5) = p1 + p2 + p3 + p4 + p5 + +groupEntries :: [Entry] -> Map Text [(Status, Word64)] +groupEntries = foldl' insert mempty + where + insert :: Map Text [(Status, Word64)] -> Entry -> Map Text [(Status, Word64)] + insert m Entry{..} = Map.alter (Just . toVal (entryStatus, entryStart)) entryLibrary m + where + toVal :: a -> Maybe [a] -> [a] + toVal x Nothing = [x] + toVal x (Just xs) = x : xs + +calculatePhases :: Word64 -> Map Text [(Status, Word64)] -> Map Text Phase +calculatePhases start = fmap (entriesToPhase start) + +entriesToPhase :: Word64 -> [(Status, Word64)] -> Phase +entriesToPhase start times = Phase + { phaseDownloading = calcDownloading + , phaseStarting = calcStarting + , phaseBuilding = calcBuilding + , phaseHaddock = calcHaddock + , phaseInstalling = calcInstalling + } + where + downloading, downloaded, starting, building, haddock, installing, completed :: Maybe Word64 + downloading = List.lookup Downloading times + downloaded = List.lookup Downloaded times + starting = List.lookup Starting times + building = List.lookup Building times + haddock = List.lookup Haddock times + installing = List.lookup Installing times + completed = List.lookup Completed times + + minusw :: Word64 -> Word64 -> Word64 + x `minusw` y + | x <= y = 0 + | otherwise = x - y + + calcDownloading :: Word64 + calcDownloading = case (downloading, downloaded) of + (Just dStart, Just dEnd) -> dEnd `minusw` dStart + _ -> 0 + + calcStarting :: Word64 + calcStarting = case building of + Nothing -> 0 + Just bt -> case starting of + Just st -> bt `minusw` st + Nothing -> bt `minusw` start + + calcBuilding :: Word64 + calcBuilding = case haddock <|> installing of + Nothing -> 0 + Just ba -> case building of + Nothing -> ba `minusw` start + Just bt -> ba `minusw` bt + + calcHaddock :: Word64 + calcHaddock = case haddock of + Nothing -> 0 + Just hd -> case installing of + Nothing -> hd `minusw` start + Just it -> it `minusw` hd + + calcInstalling :: Word64 + calcInstalling = case completed of + Nothing -> 0 + Just ct -> case installing of + Nothing -> ct `minusw` start + Just it -> ct `minusw` it + +formatChart :: Word64 -> Word64 -> Int -> Map Text Phase -> Text +formatChart start end width libs = unlines $ concat + [ legend + , summary + , profile + ] + where + block :: Text + block = "▇" + + legend :: [Text] + legend = + [ b "Legend" + , " " <> fmt [cyan] block <> " Downloading" + , " " <> fmt [blue] block <> " Starting" + , " " <> fmt [red] block <> " Building" + , " " <> fmt [magenta] block <> " Haddock" + , " " <> fmt [yellow] block <> " Installing" + , "" + ] + + 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 + , "" + ] + + profile :: [Text] + profile = b "Profile" : formattedEntries + + formattedEntries :: [Text] + formattedEntries + = map (uncurry formatRow) + $ sortOn (Down . phaseTotal . snd) entries + + formatRow :: Text -> Phase -> Text + formatRow libName phase@Phase{..} = mconcat + [ fmtPrefix libName phase + , formatSinglePhase cyan phaseDownloading + , formatSinglePhase blue phaseStarting + , formatSinglePhase red phaseBuilding + , formatSinglePhase magenta phaseHaddock + , formatSinglePhase yellow phaseInstalling + ] + + entries :: [(Text, Phase)] + entries = Map.toList libs + + libSize, phaseSize, prefixSize :: Int + libSize = List.maximum $ map (Text.length . fst) entries + phaseSize = List.maximum $ map (Text.length . fmtPhase . snd) entries + prefixSize = List.maximum $ map (Text.length . uncurry fmtPrefix) entries + + longestPhase :: Word64 + longestPhase = List.maximum $ map (phaseTotal . snd) entries + + totalAllPhases :: Word64 + totalAllPhases = sum $ map (phaseTotal . snd) entries + + parallelism :: Float + parallelism = fromIntegral totalAllPhases / fromIntegral (end - start) + + fmtPhase :: Phase -> Text + fmtPhase = fmtNanos . phaseTotal + + fmtPrefix :: Text -> Phase -> Text + fmtPrefix libName phase = mconcat + [ Text.justifyRight libSize ' ' libName + , " [" + , Text.justifyLeft phaseSize ' ' $ fmtPhase phase + , "] " + , "│" + , " " + ] + + -- How many nanoseconds each block represents? + -- blocks take: + -- width minus prefix size + -- minus 4 for remainders of each phase + blockMeasure :: Word64 + blockMeasure = longestPhase `div` fromIntegral (width - prefixSize - 4) + + formatSinglePhase :: Text -> Word64 -> Text + formatSinglePhase colour phase + | phase == 0 = "" + | otherwise = fmt [colour] $ stimes blockCount block + where + blockCount :: Word64 + blockCount = blockRemainder + div phase blockMeasure + + blockRemainder :: Word64 + blockRemainder = if phase `mod` blockMeasure > 0 then 1 else 0 + +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." + ] + 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 diff --git a/src/DrCabal/Watch.hs b/src/DrCabal/Watch.hs --- a/src/DrCabal/Watch.hs +++ b/src/DrCabal/Watch.hs @@ -18,7 +18,7 @@ import Colourista.Short (b) import Control.Concurrent (threadDelay) -import Control.Concurrent.Async (wait, withAsync) +import Control.Concurrent.Async (concurrently_) import Data.Aeson.Encode.Pretty (encodePretty) import GHC.Clock (getMonotonicTimeNSec) import System.Console.ANSI (clearLine, setCursorColumn) @@ -36,9 +36,9 @@ runWatch WatchArgs{..} = do watchRef <- newIORef [Start] - withAsync (watchWorker watchRef) $ \workerAsync -> do - readFromStdin watchRef watchArgsOutput - wait workerAsync + concurrently_ + (watchWorker watchRef) + (readFromStdin watchRef watchArgsOutput) readFromStdin :: IORef [WatchAction] -> FilePath -> IO () readFromStdin watchRef outputPath = go []