{- |
Module                  : DrCabal.Profile
Copyright               : (c) 2022 Dmitrii Kovanikov
SPDX-License-Identifier : MPL-2.0
Maintainer              : Dmitrii Kovanikov <kovanikov@gmail.com>
Stability               : Experimental
Portability             : Portable

@dr-cabal profile@ command.
-}

module DrCabal.Profile
    ( runProfile
    ) where

import Colourista.Pure (blue, cyan, formatWith, red, yellow)
import Colourista.Short (b, i, u)
import Data.Aeson (eitherDecodeFileStrict')
import System.Console.ANSI (getTerminalSize)

import DrCabal.Cli (ProfileArgs (..))
import DrCabal.Model (Entry (..), Status (..))

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 -> IO ()
runProfile ProfileArgs{FilePath
profileArgsInput :: ProfileArgs -> FilePath
profileArgsInput :: FilePath
..} = do
    Int
terminalWidth <- IO (Maybe (Int, Int))
getTerminalSize forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just (Int
_height, Int
width) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
width
        Maybe (Int, Int)
Nothing -> do
            forall (m :: * -> *). MonadIO m => Text -> m ()
putText forall a b. (a -> b) -> a -> b
$ forall t. IsText t "unlines" => [t] -> t
unlines
                [ Text
"Error getting the terminal width. If you see this error, open an issue"
                , Text
"in the 'dr-cabal' issue tracker and provide as many details as possible"
                , Text
""
                , Text
"  * " forall a. Semigroup a => a -> a -> a
<> forall str. (IsString str, Semigroup str) => str -> str
u Text
"https://github.com/chshersh/dr-cabal/issues/new"
                ]
            forall (m :: * -> *) a. MonadIO m => m a
exitFailure

    [Entry]
entries <- FilePath -> IO [Entry]
readFromFile FilePath
profileArgsInput
    let chart :: Text
chart = Int -> [Entry] -> Text
createProfileChart Int
terminalWidth [Entry]
entries
    forall (m :: * -> *). MonadIO m => Text -> m ()
putTextLn Text
chart

readFromFile :: FilePath -> IO [Entry]
readFromFile :: FilePath -> IO [Entry]
readFromFile FilePath
file = forall a. FromJSON a => FilePath -> IO (Either FilePath a)
eitherDecodeFileStrict' FilePath
file forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left FilePath
err -> do
        Text -> IO ()
Colourista.errorMessage forall a b. (a -> b) -> a -> b
$ Text
"Error parsing file: " forall a. Semigroup a => a -> a -> a
<> forall a. ToText a => a -> Text
toText FilePath
file
        Text -> IO ()
Colourista.redMessage   forall a b. (a -> b) -> a -> b
$ Text
"      " forall a. Semigroup a => a -> a -> a
<> forall a. ToText a => a -> Text
toText FilePath
err
        forall (m :: * -> *) a. MonadIO m => m a
exitFailure
    Right [Entry]
entries -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [Entry]
entries

createProfileChart :: Int -> [Entry] -> Text
createProfileChart :: Int -> [Entry] -> Text
createProfileChart Int
width [Entry]
l = case [Entry]
l of
    [] -> forall t. IsText t "unlines" => [t] -> t
unlines
        [ Text
"No cabal build entries found. Have you already built dependency?"
        , Text
"Try removing global cabal store cache and rerunning 'dr-cabal watch' again."
        ]
    [Entry]
entries ->
        let start :: Word64
start = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
List.minimum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Entry -> Word64
entryStart [Entry]
entries in
        let end :: Word64
end   = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
List.maximum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Entry -> Word64
entryStart [Entry]
entries in
        Word64 -> Word64 -> Int -> Map Text Phase -> Text
formatChart Word64
start Word64
end Int
width forall a b. (a -> b) -> a -> b
$ Word64 -> Map Text [(Status, Word64)] -> Map Text Phase
calculatePhases Word64
start forall a b. (a -> b) -> a -> b
$ [Entry] -> Map Text [(Status, Word64)]
groupEntries [Entry]
entries

groupEntries :: [Entry] -> Map Text [(Status, Word64)]
groupEntries :: [Entry] -> Map Text [(Status, Word64)]
groupEntries = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map Text [(Status, Word64)] -> Entry -> Map Text [(Status, Word64)]
insert forall a. Monoid a => a
mempty
  where
    insert :: Map Text [(Status, Word64)] -> Entry -> Map Text [(Status, Word64)]
    insert :: Map Text [(Status, Word64)] -> Entry -> Map Text [(Status, Word64)]
insert Map Text [(Status, Word64)]
m Entry{Word64
Text
Status
entryLibrary :: Entry -> Text
entryStatus :: Entry -> Status
entryLibrary :: Text
entryStart :: Word64
entryStatus :: Status
entryStart :: Entry -> Word64
..} = forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe [a] -> [a]
toVal (Status
entryStatus, Word64
entryStart)) Text
entryLibrary Map Text [(Status, Word64)]
m
      where
        toVal :: a -> Maybe [a] -> [a]
        toVal :: forall a. a -> Maybe [a] -> [a]
toVal a
x Maybe [a]
Nothing   = [a
x]
        toVal a
x (Just [a]
xs) = a
x forall a. a -> [a] -> [a]
: [a]
xs

data Phase = Phase
    { Phase -> Word64
phaseDownloading :: Word64
    , Phase -> Word64
phaseStarting    :: Word64
    , Phase -> Word64
phaseBuilding    :: Word64
    , Phase -> Word64
phaseInstalling  :: Word64
    }

phaseTotal :: Phase -> Word64
phaseTotal :: Phase -> Word64
phaseTotal (Phase Word64
p1 Word64
p2 Word64
p3 Word64
p4) = Word64
p1 forall a. Num a => a -> a -> a
+ Word64
p2 forall a. Num a => a -> a -> a
+ Word64
p3 forall a. Num a => a -> a -> a
+ Word64
p4

calculatePhases :: Word64 -> Map Text [(Status, Word64)] -> Map Text Phase
calculatePhases :: Word64 -> Map Text [(Status, Word64)] -> Map Text Phase
calculatePhases Word64
start = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Word64 -> [(Status, Word64)] -> Phase
entriesToPhase Word64
start)

entriesToPhase :: Word64 -> [(Status, Word64)] -> Phase
entriesToPhase :: Word64 -> [(Status, Word64)] -> Phase
entriesToPhase Word64
start [(Status, Word64)]
times = Phase
    { phaseDownloading :: Word64
phaseDownloading = Word64
calcDownloading
    , phaseStarting :: Word64
phaseStarting    = Word64
calcStarting
    , phaseBuilding :: Word64
phaseBuilding    = Word64
calcBuilding
    , phaseInstalling :: Word64
phaseInstalling  = Word64
calcInstalling
    }
  where
    downloading, downloaded, starting, building, installing, completed :: Maybe Word64
    downloading :: Maybe Word64
downloading = forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup Status
Downloading [(Status, Word64)]
times
    downloaded :: Maybe Word64
downloaded  = forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup Status
Downloaded  [(Status, Word64)]
times
    starting :: Maybe Word64
starting    = forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup Status
Starting    [(Status, Word64)]
times
    building :: Maybe Word64
building    = forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup Status
Building    [(Status, Word64)]
times
    installing :: Maybe Word64
installing  = forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup Status
Installing  [(Status, Word64)]
times
    completed :: Maybe Word64
completed   = forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup Status
Completed   [(Status, Word64)]
times

    minusw :: Word64 -> Word64 -> Word64
    Word64
x minusw :: Word64 -> Word64 -> Word64
`minusw` Word64
y
        | Word64
x forall a. Ord a => a -> a -> Bool
<= Word64
y    = Word64
0
        | Bool
otherwise = Word64
x forall a. Num a => a -> a -> a
- Word64
y

    calcDownloading :: Word64
    calcDownloading :: Word64
calcDownloading = case (Maybe Word64
downloading, Maybe Word64
downloaded) of
        (Just Word64
dStart, Just Word64
dEnd) -> Word64
dEnd Word64 -> Word64 -> Word64
`minusw` Word64
dStart
        (Maybe Word64, Maybe Word64)
_                        -> Word64
0

    calcStarting :: Word64
    calcStarting :: Word64
calcStarting = case Maybe Word64
building of
        Maybe Word64
Nothing -> Word64
0
        Just Word64
bt -> case Maybe Word64
starting of
            Just Word64
st -> Word64
bt Word64 -> Word64 -> Word64
`minusw` Word64
st
            Maybe Word64
Nothing -> Word64
bt Word64 -> Word64 -> Word64
`minusw` Word64
start

    calcBuilding :: Word64
    calcBuilding :: Word64
calcBuilding = case Maybe Word64
installing of
        Maybe Word64
Nothing -> Word64
0
        Just Word64
it -> case Maybe Word64
building of
            Maybe Word64
Nothing -> Word64
it Word64 -> Word64 -> Word64
`minusw` Word64
start
            Just Word64
bt -> Word64
it Word64 -> Word64 -> Word64
`minusw` Word64
bt

    calcInstalling :: Word64
    calcInstalling :: Word64
calcInstalling = case Maybe Word64
completed of
        Maybe Word64
Nothing -> Word64
0
        Just Word64
ct -> case Maybe Word64
installing of
            Maybe Word64
Nothing -> Word64
ct Word64 -> Word64 -> Word64
`minusw` Word64
start
            Just Word64
it -> Word64
ct Word64 -> Word64 -> Word64
`minusw` Word64
it

formatChart :: Word64 -> Word64 -> Int -> Map Text Phase -> Text
formatChart :: Word64 -> Word64 -> Int -> Map Text Phase -> Text
formatChart Word64
start Word64
end Int
width Map Text Phase
libs = forall t. IsText t "unlines" => [t] -> t
unlines forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$
    [ [Text]
legend
    , [Text]
summary
    , [Text]
profile
    ]
  where
    block :: Text
    block :: Text
block = Text
"▇"

    legend :: [Text]
    legend :: [Text]
legend =
        [ forall str. (IsString str, Semigroup str) => str -> str
b Text
"Legend"
        , Text
"  " forall a. Semigroup a => a -> a -> a
<> [Text] -> Text -> Text
fmt [forall str. IsString str => str
cyan]   Text
block forall a. Semigroup a => a -> a -> a
<> Text
"  Downloading"
        , Text
"  " forall a. Semigroup a => a -> a -> a
<> [Text] -> Text -> Text
fmt [forall str. IsString str => str
blue]   Text
block forall a. Semigroup a => a -> a -> a
<> Text
"  Starting"
        , Text
"  " forall a. Semigroup a => a -> a -> a
<> [Text] -> Text -> Text
fmt [forall str. IsString str => str
red]    Text
block forall a. Semigroup a => a -> a -> a
<> Text
"  Building"
        , Text
"  " forall a. Semigroup a => a -> a -> a
<> [Text] -> Text -> Text
fmt [forall str. IsString str => str
yellow] Text
block forall a. Semigroup a => a -> a -> a
<> Text
"  Installing"
        , Text
""
        ]

    summary :: [Text]
    summary :: [Text]
summary =
        [ forall str. (IsString str, Semigroup str) => str -> str
b Text
"Summary"
        , forall str. (IsString str, Semigroup str) => str -> str
i Text
"  Total dependency build time" forall a. Semigroup a => a -> a -> a
<> Text
" : " forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
fmtNanos (Word64
end forall a. Num a => a -> a -> a
- Word64
start)
        , forall str. (IsString str, Semigroup str) => str -> str
i Text
"  Single block resolution    " forall a. Semigroup a => a -> a -> a
<> Text
" : " forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
fmtNanos Word64
blockMeasure
        , Text
""
        ]

    profile :: [Text]
    profile :: [Text]
profile =
        [ forall str. (IsString str, Semigroup str) => str -> str
b Text
"Profile"
        ] forall a. [a] -> [a] -> [a]
++
        [Text]
formattedEntries

    formattedEntries :: [Text]
    formattedEntries :: [Text]
formattedEntries
        = forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Phase -> Text
formatRow)
        forall a b. (a -> b) -> a -> b
$ forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (forall a. a -> Down a
Down forall b c a. (b -> c) -> (a -> b) -> a -> c
. Phase -> Word64
phaseTotal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Text, Phase)]
entries

    formatRow :: Text -> Phase -> Text
    formatRow :: Text -> Phase -> Text
formatRow Text
libName phase :: Phase
phase@Phase{Word64
phaseInstalling :: Word64
phaseBuilding :: Word64
phaseStarting :: Word64
phaseDownloading :: Word64
phaseInstalling :: Phase -> Word64
phaseBuilding :: Phase -> Word64
phaseStarting :: Phase -> Word64
phaseDownloading :: Phase -> Word64
..} = forall a. Monoid a => [a] -> a
mconcat
        [ Text -> Phase -> Text
fmtPrefix Text
libName Phase
phase
        , Text -> Word64 -> Text
formatSinglePhase forall str. IsString str => str
cyan   Word64
phaseDownloading
        , Text -> Word64 -> Text
formatSinglePhase forall str. IsString str => str
blue   Word64
phaseStarting
        , Text -> Word64 -> Text
formatSinglePhase forall str. IsString str => str
red    Word64
phaseBuilding
        , Text -> Word64 -> Text
formatSinglePhase forall str. IsString str => str
yellow Word64
phaseInstalling
        ]

    entries :: [(Text, Phase)]
    entries :: [(Text, Phase)]
entries = forall k a. Map k a -> [(k, a)]
Map.toList Map Text Phase
libs

    libSize, phaseSize, prefixSize :: Int
    libSize :: Int
libSize    = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
List.maximum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Text -> Int
Text.length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Text, Phase)]
entries
    phaseSize :: Int
phaseSize  = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
List.maximum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Text -> Int
Text.length forall b c a. (b -> c) -> (a -> b) -> a -> c
. Phase -> Text
fmtPhase forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Text, Phase)]
entries
    prefixSize :: Int
prefixSize = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
List.maximum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Text -> Int
Text.length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Phase -> Text
fmtPrefix) [(Text, Phase)]
entries

    longestPhase :: Word64
    longestPhase :: Word64
longestPhase = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
List.maximum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Phase -> Word64
phaseTotal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Text, Phase)]
entries

    fmtPhase :: Phase -> Text
    fmtPhase :: Phase -> Text
fmtPhase = Word64 -> Text
fmtNanos forall b c a. (b -> c) -> (a -> b) -> a -> c
. Phase -> Word64
phaseTotal

    fmtPrefix :: Text -> Phase -> Text
    fmtPrefix :: Text -> Phase -> Text
fmtPrefix Text
libName Phase
phase = forall a. Monoid a => [a] -> a
mconcat
        [ Int -> Char -> Text -> Text
Text.justifyRight Int
libSize Char
' ' Text
libName
        , Text
" ["
        , Int -> Char -> Text -> Text
Text.justifyLeft Int
phaseSize Char
' ' forall a b. (a -> b) -> a -> b
$ Phase -> Text
fmtPhase Phase
phase
        , Text
"] "
        , Text
"│"
        , Text
" "
        ]

    -- How many nanoseconds each block represents?
    -- blocks take:
    -- width minus prefix size
    --       minus 4 for remainders of each phase
    blockMeasure :: Word64
    blockMeasure :: Word64
blockMeasure = Word64
longestPhase forall a. Integral a => a -> a -> a
`div` forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
width forall a. Num a => a -> a -> a
- Int
prefixSize forall a. Num a => a -> a -> a
- Int
4)

    formatSinglePhase :: Text -> Word64 -> Text
    formatSinglePhase :: Text -> Word64 -> Text
formatSinglePhase Text
colour Word64
phase
        | Word64
phase forall a. Eq a => a -> a -> Bool
== Word64
0 = Text
""
        | Bool
otherwise  = [Text] -> Text -> Text
fmt [Text
colour] forall a b. (a -> b) -> a -> b
$ forall a b. (Semigroup a, Integral b) => b -> a -> a
stimes Word64
blockCount Text
block
      where
        blockCount :: Word64
        blockCount :: Word64
blockCount = Word64
blockRemainder forall a. Num a => a -> a -> a
+ forall a. Integral a => a -> a -> a
div Word64
phase Word64
blockMeasure

        blockRemainder :: Word64
        blockRemainder :: Word64
blockRemainder = if Word64
phase forall a. Integral a => a -> a -> a
`mod` Word64
blockMeasure forall a. Ord a => a -> a -> Bool
> Word64
0 then Word64
1 else Word64
0

fmt :: [Text] -> Text -> Text
fmt :: [Text] -> Text -> Text
fmt = forall str. (IsString str, Semigroup str) => [str] -> str -> str
formatWith


fmtNanos :: Word64 -> Text
fmtNanos :: Word64 -> Text
fmtNanos Word64
time
    | Word64
time forall a. Ord a => a -> a -> Bool
< Word64
ns  = Text
"0ns"
    | Word64
time forall a. Ord a => a -> a -> Bool
< Word64
mcs = forall b a. (Show a, IsString b) => a -> b
show Word64
nanos   forall a. Semigroup a => a -> a -> a
<> Text
"ns"
    | Word64
time forall a. Ord a => a -> a -> Bool
< Word64
ms  = forall b a. (Show a, IsString b) => a -> b
show Word64
micros  forall a. Semigroup a => a -> a -> a
<> Text
"mcs"
    | Word64
time forall a. Ord a => a -> a -> Bool
< Word64
s   = forall b a. (Show a, IsString b) => a -> b
show Word64
millis  forall a. Semigroup a => a -> a -> a
<> Text
"ms"
    | Word64
time forall a. Ord a => a -> a -> Bool
< Word64
m   = forall b a. (Show a, IsString b) => a -> b
show Word64
seconds forall a. Semigroup a => a -> a -> a
<> Text
"s" forall a. Semigroup a => a -> a -> a
<> Word64 -> Text -> Text
emptyIfZero Word64
millis Text
"ms"
    | Bool
otherwise  = forall b a. (Show a, IsString b) => a -> b
show Word64
minutes forall a. Semigroup a => a -> a -> a
<> Text
"m" forall a. Semigroup a => a -> a -> a
<> Word64 -> Text -> Text
emptyIfZero Word64
seconds Text
"s"
  where
    ns, mcs, ms, s, m :: Word64
    ns :: Word64
ns  = Word64
1
    mcs :: Word64
mcs = Word64
1000 forall a. Num a => a -> a -> a
* Word64
ns
    ms :: Word64
ms  = Word64
1000 forall a. Num a => a -> a -> a
* Word64
mcs
    s :: Word64
s   = Word64
1000 forall a. Num a => a -> a -> a
* Word64
ms
    m :: Word64
m   = Word64
60 forall a. Num a => a -> a -> a
* Word64
s

    nanos :: Word64
    nanos :: Word64
nanos   = Word64
time forall a. Integral a => a -> a -> a
`mod` Word64
mcs
    micros :: Word64
micros  = (Word64
time forall a. Integral a => a -> a -> a
`div` Word64
mcs) forall a. Integral a => a -> a -> a
`mod` Word64
1000
    millis :: Word64
millis  = (Word64
time forall a. Integral a => a -> a -> a
`div` Word64
ms)  forall a. Integral a => a -> a -> a
`mod` Word64
1000
    seconds :: Word64
seconds = (Word64
time forall a. Integral a => a -> a -> a
`div` Word64
s)   forall a. Integral a => a -> a -> a
`mod` Word64
60
    minutes :: Word64
minutes = Word64
time forall a. Integral a => a -> a -> a
`div` Word64
m

    emptyIfZero :: Word64 -> Text -> Text
    emptyIfZero :: Word64 -> Text -> Text
emptyIfZero Word64
0 Text
_    = Text
""
    emptyIfZero Word64
t Text
unit = forall b a. (Show a, IsString b) => a -> b
show Word64
t forall a. Semigroup a => a -> a -> a
<> Text
unit