content: {- |
  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
  