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