dr-cabal-0.2.0.0: src/DrCabal/Profile/Stacked.hs
{- |
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 for the @dr-cabal profile --stacked@ command.
-}
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
{- | 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
]
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"
, " " <> b "*" <> " Critical path"
, ""
]
summary :: [Text]
summary =
[ b "Summary"
, 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
, ""
]
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
[ 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
-- 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." -- TODO: update message
]
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