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