dr-cabal 0.0.0.0 → 0.1.0.0

raw patch · 9 files changed

+319/−220 lines, 9 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +11/−0
• README.md +8/−2
• dr-cabal.cabal +4/−2
• src/DrCabal/Cli.hs +13/−1
• src/DrCabal/Model.hs +4/−1
• src/DrCabal/Profile.hs +7/−210
• src/DrCabal/Profile/Format.hs +54/−0
• src/DrCabal/Profile/Stacked.hs +214/−0
• src/DrCabal/Watch.hs +4/−4

@@ -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.

@@ -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:

@@ -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:

@@ -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"+    ]

@@ -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)

@@ -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

@@ -0,0 +1,54 @@+{- |+Module                  : DrCabal.Profile.Format+Copyright               : (c) 2022 Dmitrii Kovanikov+SPDX-License-Identifier : MPL-2.0+Maintainer              : Dmitrii Kovanikov <kovanikov@gmail.com>+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 ""

@@ -0,0 +1,214 @@+{- |+Module                  : DrCabal.Profile.Stacked+Copyright               : (c) 2022 Dmitrii Kovanikov+SPDX-License-Identifier : MPL-2.0+Maintainer              : Dmitrii Kovanikov <kovanikov@gmail.com>+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

@@ -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 []