-- | @futhark profile@
module Futhark.CLI.Profile (main) where

import Control.Arrow ((&&&), (>>>))
import Control.Exception (catch)
import Control.Monad (forM_)
import Control.Monad.Except (ExceptT, liftEither, runExcept, runExceptT)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Except (Except)
import Data.Bifunctor (first, second)
import Data.ByteString.Lazy.Char8 qualified as BS
import Data.Char (isAlphaNum, isAscii, ord)
import Data.Foldable (toList)
import Data.Function ((&))
import Data.List qualified as L
import Data.Map qualified as M
import Data.Maybe (catMaybes, isJust)
import Data.Monoid (Sum (..))
import Data.Sequence qualified as Seq
import Data.Set qualified as S
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Data.Text.IO qualified as T
import Data.Text.Lazy qualified as LT
import Data.Text.Lazy.IO qualified as LT
import Futhark.Bench
  ( BenchResult (BenchResult, benchResultProg),
    DataResult (DataResult),
    ProfilingEvent (ProfilingEvent),
    ProfilingReport (profilingEvents, profilingMemory),
    Result (report, stdErr),
    decodeBenchResults,
    decodeProfilingReport,
  )
import Futhark.Profile.Details (CostCentreDetails (CostCentreDetails), CostCentreName (CostCentreName), CostCentres, SourceRangeDetails (SourceRangeDetails), SourceRanges, containingCostCentres)
import Futhark.Profile.EventSummary qualified as ES
import Futhark.Profile.Html (generateCCOverviewHtml, generateHeatmapHtml, generateHtmlIndex, generateSourceIndex, securedHashPath)
import Futhark.Profile.SourceRange (SourceRange)
import Futhark.Profile.SourceRange qualified as SR
import Futhark.Util (showText)
import Futhark.Util.Html (cssFile)
import Futhark.Util.Options (mainWithOptions)
import System.Directory (createDirectoryIfMissing, removePathForcibly)
import System.Exit (ExitCode (ExitFailure), exitWith)
import System.FilePath
  ( dropExtension,
    makeRelative,
    splitPath,
    takeDirectory,
    takeFileName,
    (-<.>),
    (<.>),
    (</>),
  )
import System.IO (hPutStrLn, stderr)
import Text.Blaze.Html.Renderer.Text qualified as H
import Text.Blaze.Html5 qualified as H
import Text.Blaze.Html5.Attributes qualified as A
import Text.Printf (printf)

commonPrefix :: (Eq e) => [e] -> [e] -> [e]
commonPrefix :: forall e. Eq e => [e] -> [e] -> [e]
commonPrefix [e]
_ [] = []
commonPrefix [] [e]
_ = []
commonPrefix (e
x : [e]
xs) (e
y : [e]
ys)
  | e
x e -> e -> Bool
forall a. Eq a => a -> a -> Bool
== e
y = e
x e -> [e] -> [e]
forall a. a -> [a] -> [a]
: [e] -> [e] -> [e]
forall e. Eq e => [e] -> [e] -> [e]
commonPrefix [e]
xs [e]
ys
  | Bool
otherwise = []

longestCommonPrefix :: [FilePath] -> FilePath
longestCommonPrefix :: [FilePath] -> FilePath
longestCommonPrefix [] = FilePath
""
longestCommonPrefix (FilePath
x : [FilePath]
xs) = (FilePath -> FilePath -> FilePath)
-> FilePath -> [FilePath] -> FilePath
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr FilePath -> FilePath -> FilePath
forall e. Eq e => [e] -> [e] -> [e]
commonPrefix FilePath
x [FilePath]
xs

memoryReport :: M.Map T.Text Integer -> T.Text
memoryReport :: Map Text Integer -> Text
memoryReport = [Text] -> Text
T.unlines ([Text] -> Text)
-> (Map Text Integer -> [Text]) -> Map Text Integer -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"Peak memory usage in bytes" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:) ([Text] -> [Text])
-> (Map Text Integer -> [Text]) -> Map Text Integer -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Integer) -> Text) -> [(Text, Integer)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Integer) -> Text
forall {a}. Show a => (Text, a) -> Text
f ([(Text, Integer)] -> [Text])
-> (Map Text Integer -> [(Text, Integer)])
-> Map Text Integer
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text Integer -> [(Text, Integer)]
forall k a. Map k a -> [(k, a)]
M.toList
  where
    f :: (Text, a) -> Text
f (Text
space, a
bytes) = Text
space Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. Show a => a -> Text
showText a
bytes

padRight :: Int -> T.Text -> T.Text
padRight :: Int -> Text -> Text
padRight Int
k Text
s = Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.replicate (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
s) Text
" "

padLeft :: Int -> T.Text -> T.Text
padLeft :: Int -> Text -> Text
padLeft Int
k Text
s = Int -> Text -> Text
T.replicate (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
s) Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s

tabulateEvents :: M.Map (T.Text, T.Text) ES.EvSummary -> T.Text
tabulateEvents :: Map (Text, Text) EvSummary -> Text
tabulateEvents = [((Text, Text), EvSummary)] -> Text
mkRows ([((Text, Text), EvSummary)] -> Text)
-> (Map (Text, Text) EvSummary -> [((Text, Text), EvSummary)])
-> Map (Text, Text) EvSummary
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (Text, Text) EvSummary -> [((Text, Text), EvSummary)]
forall k a. Map k a -> [(k, a)]
M.toList
  where
    numpad :: Int
numpad = Int
15
    mkRows :: [((Text, Text), EvSummary)] -> Text
mkRows [((Text, Text), EvSummary)]
rows =
      let longest :: Int
longest = (Int -> Int -> Int) -> Int -> [Int] -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
numpad ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (((Text, Text), EvSummary) -> Int)
-> [((Text, Text), EvSummary)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Int
T.length (Text -> Int)
-> (((Text, Text), EvSummary) -> Text)
-> ((Text, Text), EvSummary)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Text) -> Text
forall a b. (a, b) -> a
fst ((Text, Text) -> Text)
-> (((Text, Text), EvSummary) -> (Text, Text))
-> ((Text, Text), EvSummary)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Text), EvSummary) -> (Text, Text)
forall a b. (a, b) -> a
fst) [((Text, Text), EvSummary)]
rows
          total :: Double
total = [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Double] -> Double) -> [Double] -> Double
forall a b. (a -> b) -> a -> b
$ (((Text, Text), EvSummary) -> Double)
-> [((Text, Text), EvSummary)] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (EvSummary -> Double
ES.evSum (EvSummary -> Double)
-> (((Text, Text), EvSummary) -> EvSummary)
-> ((Text, Text), EvSummary)
-> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Text), EvSummary) -> EvSummary
forall a b. (a, b) -> b
snd) [((Text, Text), EvSummary)]
rows
          header :: Text
header = Int -> Text
headerRow Int
longest
          splitter :: Text
splitter = (Char -> Char) -> Text -> Text
T.map (Char -> Char -> Char
forall a b. a -> b -> a
const Char
'-') Text
header
          eventSummary :: Text
eventSummary =
            [Text] -> Text
T.unwords
              [ Integer -> Text
forall a. Show a => a -> Text
showText ([Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((((Text, Text), EvSummary) -> Integer)
-> [((Text, Text), EvSummary)] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map (EvSummary -> Integer
ES.evCount (EvSummary -> Integer)
-> (((Text, Text), EvSummary) -> EvSummary)
-> ((Text, Text), EvSummary)
-> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Text), EvSummary) -> EvSummary
forall a b. (a, b) -> b
snd) [((Text, Text), EvSummary)]
rows)),
                Text
"events with a total runtime of",
                FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Double -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%.2fμs" Double
total
              ]
          costCentreSources :: [Text]
costCentreSources =
            let costCentreSourceBlocks :: [[Text]]
costCentreSourceBlocks =
                  (((Text, Text), EvSummary) -> [Text])
-> [((Text, Text), EvSummary)] -> [[Text]]
forall a b. (a -> b) -> [a] -> [b]
map ((Text, Text) -> [Text]
costCentreSourceLines ((Text, Text) -> [Text])
-> (((Text, Text), EvSummary) -> (Text, Text))
-> ((Text, Text), EvSummary)
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Text), EvSummary) -> (Text, Text)
forall a b. (a, b) -> a
fst)
                    ([((Text, Text), EvSummary)] -> [[Text]])
-> ([((Text, Text), EvSummary)] -> [((Text, Text), EvSummary)])
-> [((Text, Text), EvSummary)]
-> [[Text]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((Text, Text), EvSummary) -> Text)
-> [((Text, Text), EvSummary)] -> [((Text, Text), EvSummary)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
L.sortOn ((Text, Text) -> Text
forall a b. (a, b) -> a
fst ((Text, Text) -> Text)
-> (((Text, Text), EvSummary) -> (Text, Text))
-> ((Text, Text), EvSummary)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Text), EvSummary) -> (Text, Text)
forall a b. (a, b) -> a
fst)
                    ([((Text, Text), EvSummary)] -> [[Text]])
-> [((Text, Text), EvSummary)] -> [[Text]]
forall a b. (a -> b) -> a -> b
$ [((Text, Text), EvSummary)]
rows
                costCentreHeaderTitle :: Text
costCentreHeaderTitle = Text
" Cost Centre Source Locations "
                costCentreHeader :: Text
costCentreHeader = Int -> Char -> Text -> Text
T.center (Text -> Int
T.length Text
header) Char
'=' Text
costCentreHeaderTitle
             in [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Text]] -> [Text]) -> [[Text]] -> [Text]
forall a b. (a -> b) -> a -> b
$
                  [Text
costCentreHeader, Text
T.empty]
                    [Text] -> [[Text]] -> [[Text]]
forall a. a -> [a] -> [a]
: [Text] -> [[Text]] -> [[Text]]
forall a. a -> [a] -> [a]
L.intersperse [Text
T.empty] [[Text]]
costCentreSourceBlocks
          costCentreSourceLines :: (Text, Text) -> [Text]
costCentreSourceLines (Text
name, Text
provenance) =
            let sources :: [Text]
sources = HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"->" Text
provenance
                orderedSources :: [Text]
orderedSources = [Text] -> [Text]
forall a. Ord a => [a] -> [a]
L.sort [Text]
sources
             in Text
name
                  Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text
"- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) [Text]
orderedSources
       in [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
            Text
header
              Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text
splitter
              Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (((Text, Text), EvSummary) -> Text)
-> [((Text, Text), EvSummary)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Double -> (Text, EvSummary) -> Text
mkRow Int
longest Double
total ((Text, EvSummary) -> Text)
-> (((Text, Text), EvSummary) -> (Text, EvSummary))
-> ((Text, Text), EvSummary)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Text) -> Text)
-> ((Text, Text), EvSummary) -> (Text, EvSummary)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text, Text) -> Text
forall a b. (a, b) -> a
fst) [((Text, Text), EvSummary)]
rows
                [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
splitter, Text
eventSummary]
                [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> [Text]
forall a. Int -> a -> [a]
replicate Int
5 Text
T.empty
                [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
costCentreSources
    headerRow :: Int -> Text
headerRow Int
longest =
      [Text] -> Text
T.unwords
        [ Int -> Text -> Text
padLeft Int
longest Text
"Cost centre",
          Int -> Text -> Text
padLeft Int
numpad Text
"count",
          Int -> Text -> Text
padLeft Int
numpad Text
"sum",
          Int -> Text -> Text
padLeft Int
numpad Text
"avg",
          Int -> Text -> Text
padLeft Int
numpad Text
"min",
          Int -> Text -> Text
padLeft Int
numpad Text
"max",
          Int -> Text -> Text
padLeft Int
numpad Text
"fraction"
        ]
    mkRow :: Int -> Double -> (Text, EvSummary) -> Text
mkRow Int
longest Double
total (Text
name, EvSummary
ev) =
      [Text] -> Text
T.unwords
        [ Int -> Text -> Text
padRight Int
longest Text
name,
          Int -> Text -> Text
padLeft Int
numpad (Integer -> Text
forall a. Show a => a -> Text
showText (EvSummary -> Integer
ES.evCount EvSummary
ev)),
          Int -> Text -> Text
padLeft Int
numpad (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Double -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%.2fμs" (EvSummary -> Double
ES.evSum EvSummary
ev),
          Int -> Text -> Text
padLeft Int
numpad (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Double -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%.2fμs" (Double -> FilePath) -> Double -> FilePath
forall a b. (a -> b) -> a -> b
$ EvSummary -> Double
ES.evSum EvSummary
ev Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Integer -> Double
forall a. Num a => Integer -> a
fromInteger (EvSummary -> Integer
ES.evCount EvSummary
ev),
          Int -> Text -> Text
padLeft Int
numpad (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Double -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%.2fμs" (EvSummary -> Double
ES.evMin EvSummary
ev),
          Int -> Text -> Text
padLeft Int
numpad (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Double -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%.2fμs" (EvSummary -> Double
ES.evMax EvSummary
ev),
          Int -> Text -> Text
padLeft Int
numpad (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Double -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%.4f" (EvSummary -> Double
ES.evSum EvSummary
ev Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
total)
        ]

timeline :: [ProfilingEvent] -> T.Text
timeline :: [ProfilingEvent] -> Text
timeline = [Text] -> Text
T.unlines ([Text] -> Text)
-> ([ProfilingEvent] -> [Text]) -> [ProfilingEvent] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [[Text]] -> [Text]
forall a. [a] -> [[a]] -> [a]
L.intercalate [Text
""] ([[Text]] -> [Text])
-> ([ProfilingEvent] -> [[Text]]) -> [ProfilingEvent] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProfilingEvent -> [Text]) -> [ProfilingEvent] -> [[Text]]
forall a b. (a -> b) -> [a] -> [b]
map ProfilingEvent -> [Text]
onEvent
  where
    onEvent :: ProfilingEvent -> [Text]
onEvent (ProfilingEvent Text
name Double
duration Text
provenance Value
_details) =
      [ Text
name,
        Text
"Duration: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Double -> Text
forall a. Show a => a -> Text
showText Double
duration Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" μs",
        Text
"At: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
provenance
      ]

data TargetFiles = TargetFiles
  { TargetFiles -> FilePath
summaryFile :: FilePath,
    TargetFiles -> FilePath
timelineFile :: FilePath,
    TargetFiles -> FilePath
htmlIndexFile :: FilePath,
    TargetFiles -> FilePath
htmlDir :: FilePath
  }

-- | Write text and HTML reports, even if source analysis is unavailable.
writeAnalysis :: TargetFiles -> Maybe T.Text -> Maybe ProfilingReport -> IO ()
writeAnalysis :: TargetFiles -> Maybe Text -> Maybe ProfilingReport -> IO ()
writeAnalysis TargetFiles
tf Maybe Text
logText Maybe ProfilingReport
profilingReport = do
  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ TargetFiles -> FilePath
htmlDir TargetFiles
tf
  FilePath -> Text -> IO ()
T.writeFile (TargetFiles -> FilePath
htmlDir TargetFiles
tf FilePath -> FilePath -> FilePath
</> FilePath
"style.css") Text
cssFile

  let timelineText :: Maybe Text
timelineText = [ProfilingEvent] -> Text
timeline ([ProfilingEvent] -> Text)
-> (ProfilingReport -> [ProfilingEvent]) -> ProfilingReport -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProfilingReport -> [ProfilingEvent]
profilingEvents (ProfilingReport -> Text) -> Maybe ProfilingReport -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ProfilingReport
profilingReport
  sourceIndex <- case Maybe ProfilingReport
profilingReport of
    Maybe ProfilingReport
Nothing -> MarkupM () -> IO (MarkupM ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MarkupM () -> IO (MarkupM ())) -> MarkupM () -> IO (MarkupM ())
forall a b. (a -> b) -> a -> b
$ MarkupM () -> MarkupM ()
H.p MarkupM ()
"No profiling information recorded."
    Just ProfilingReport
r -> do
      let evSummaryMap :: Map (Text, Text) EvSummary
evSummaryMap = [ProfilingEvent] -> Map (Text, Text) EvSummary
ES.eventSummaries ([ProfilingEvent] -> Map (Text, Text) EvSummary)
-> [ProfilingEvent] -> Map (Text, Text) EvSummary
forall a b. (a -> b) -> a -> b
$ ProfilingReport -> [ProfilingEvent]
profilingEvents ProfilingReport
r
      FilePath -> Text -> IO ()
T.writeFile (TargetFiles -> FilePath
summaryFile TargetFiles
tf) (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
        Map Text Integer -> Text
memoryReport (ProfilingReport -> Map Text Integer
profilingMemory ProfilingReport
r)
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\n"
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Map (Text, Text) EvSummary -> Text
tabulateEvents Map (Text, Text) EvSummary
evSummaryMap
      Maybe Text -> (Text -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Text
timelineText ((Text -> IO ()) -> IO ()) -> (Text -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text -> IO ()
T.writeFile (TargetFiles -> FilePath
timelineFile TargetFiles
tf)

      sourceResult <- ExceptT Text IO (MarkupM ()) -> IO (Either Text (MarkupM ()))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text IO (MarkupM ()) -> IO (Either Text (MarkupM ())))
-> ExceptT Text IO (MarkupM ()) -> IO (Either Text (MarkupM ()))
forall a b. (a -> b) -> a -> b
$ TargetFiles
-> Map (Text, Text) EvSummary -> ExceptT Text IO (MarkupM ())
writeHtml TargetFiles
tf Map (Text, Text) EvSummary
evSummaryMap
      case sourceResult of
        Left Text
err -> do
          Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr Text
err
          MarkupM () -> IO (MarkupM ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MarkupM () -> IO (MarkupM ())) -> MarkupM () -> IO (MarkupM ())
forall a b. (a -> b) -> a -> b
$ do
            MarkupM () -> MarkupM ()
H.p MarkupM ()
"Source information unavailable."
            MarkupM () -> MarkupM ()
H.pre (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ Text -> MarkupM ()
H.text Text
err
        Right MarkupM ()
html -> MarkupM () -> IO (MarkupM ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MarkupM ()
html

  let relHtmlDirPath = [FilePath] -> FilePath
forall a. HasCallStack => [a] -> a
last ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath]
splitPath (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall a b. (a -> b) -> a -> b
$ TargetFiles -> FilePath
htmlDir TargetFiles
tf
  LT.writeFile (htmlIndexFile tf) $
    H.renderHtml $
      generateHtmlIndex relHtmlDirPath logText timelineText sourceIndex

toIOExcept :: Except T.Text a -> ExceptT T.Text IO a
toIOExcept :: forall a. Except Text a -> ExceptT Text IO a
toIOExcept = Either Text a -> ExceptT Text IO a
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either Text a -> ExceptT Text IO a)
-> (Except Text a -> Either Text a)
-> Except Text a
-> ExceptT Text IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Except Text a -> Either Text a
forall e a. Except e a -> Either e a
runExcept

writeHtml ::
  -- | Target paths
  TargetFiles ->
  -- | mapping keys are (name, provenance)
  M.Map (T.Text, T.Text) ES.EvSummary ->
  ExceptT T.Text IO H.Html
writeHtml :: TargetFiles
-> Map (Text, Text) EvSummary -> ExceptT Text IO (MarkupM ())
writeHtml TargetFiles
tf Map (Text, Text) EvSummary
evSummaryMap = do
  let htmlDirPath :: FilePath
htmlDirPath = TargetFiles -> FilePath
htmlDir TargetFiles
tf
  (sourceRanges, costCentres) <- Except Text (Map FilePath SourceRanges, CostCentres)
-> ExceptT Text IO (Map FilePath SourceRanges, CostCentres)
forall a. Except Text a -> ExceptT Text IO a
toIOExcept (Except Text (Map FilePath SourceRanges, CostCentres)
 -> ExceptT Text IO (Map FilePath SourceRanges, CostCentres))
-> Except Text (Map FilePath SourceRanges, CostCentres)
-> ExceptT Text IO (Map FilePath SourceRanges, CostCentres)
forall a b. (a -> b) -> a -> b
$ Map (Text, Text) EvSummary
-> Except Text (Map FilePath SourceRanges, CostCentres)
buildDetailStructures Map (Text, Text) EvSummary
evSummaryMap
  htmlFiles <- generateHtmlHeatmaps sourceRanges
  let costCentreOverview = CostCentres -> MarkupM ()
generateCCOverviewHtml CostCentres
costCentres

  liftIO $ do
    -- cost centre file
    LT.writeFile
      (htmlDirPath </> "cost-centres.html")
      (H.renderHtml costCentreOverview)

    -- write all the source-heatmap files
    forM_ (M.toList htmlFiles) $ \(FilePath
srcFilePath, MarkupM ()
html) -> do
      let absPath :: FilePath
absPath =
            FilePath
htmlDirPath FilePath -> FilePath -> FilePath
</> FilePath -> FilePath -> FilePath
makeRelative FilePath
"/" (FilePath
srcFilePath FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
".html")
      FilePath -> Text -> IO ()
writeLazyTextFile FilePath
absPath (MarkupM () -> Text
H.renderHtml MarkupM ()
html)

  let relHtmlDirPath = [FilePath] -> FilePath
forall a. HasCallStack => [a] -> a
last ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath]
splitPath FilePath
htmlDirPath
  pure $ generateSourceIndex relHtmlDirPath sourceRanges

writeLazyTextFile :: FilePath -> LT.Text -> IO ()
writeLazyTextFile :: FilePath -> Text -> IO ()
writeLazyTextFile FilePath
filepath Text
content = do
  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeDirectory FilePath
filepath
  FilePath -> Text -> IO ()
LT.writeFile FilePath
filepath Text
content

generateHtmlHeatmaps ::
  M.Map FilePath SourceRanges ->
  ExceptT T.Text IO (M.Map FilePath H.Html)
generateHtmlHeatmaps :: Map FilePath SourceRanges
-> ExceptT Text IO (Map FilePath (MarkupM ()))
generateHtmlHeatmaps Map FilePath SourceRanges
fileToRanges = do
  sourceFiles <- [FilePath] -> ExceptT Text IO (Map FilePath Text)
loadAllFiles (Map FilePath SourceRanges -> [FilePath]
forall k a. Map k a -> [k]
M.keys Map FilePath SourceRanges
fileToRanges)
  let disambiguatedSourceFiles =
        (FilePath -> (FilePath, FilePath))
-> Map FilePath Text -> Map (FilePath, FilePath) Text
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys (FilePath -> FilePath
securedHashPath (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> (FilePath, FilePath)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& FilePath -> FilePath
forall a. a -> a
id) Map FilePath Text
sourceFiles
  let renderSingle (FilePath
targetPath, FilePath
oldPath) Text
text =
        FilePath -> FilePath -> Text -> SourceRanges -> MarkupM ()
generateHeatmapHtml FilePath
targetPath FilePath
oldPath Text
text (Map FilePath SourceRanges
fileToRanges Map FilePath SourceRanges -> FilePath -> SourceRanges
forall k a. Ord k => Map k a -> k -> a
M.! FilePath
oldPath)
  pure $
    M.mapWithKey renderSingle disambiguatedSourceFiles
      & M.mapKeys fst

buildDetailStructures ::
  -- | mapping keys are: (name, provenance)
  M.Map (T.Text, T.Text) ES.EvSummary ->
  -- | mapping key is the filename
  Except T.Text (M.Map FilePath SourceRanges, CostCentres)
buildDetailStructures :: Map (Text, Text) EvSummary
-> Except Text (Map FilePath SourceRanges, CostCentres)
buildDetailStructures Map (Text, Text) EvSummary
evSummaries = do
  parsedEvSummaries <- Map (Text, Text) EvSummary
-> Except Text (Map (CostCentreName, Seq SourceRange) EvSummary)
parseEvSummaries Map (Text, Text) EvSummary
evSummaries
  pure $
    let ranges = Map (CostCentreName, Seq SourceRange) EvSummary
-> (CostCentreName -> CostCentreDetails)
-> Map FilePath SourceRanges
buildSourceRanges Map (CostCentreName, Seq SourceRange) EvSummary
parsedEvSummaries CostCentreName -> CostCentreDetails
lookupCC
        centres = Map (CostCentreName, Seq SourceRange) EvSummary
-> (CostCentreName -> SourceRanges) -> CostCentres
buildCostCentres Map (CostCentreName, Seq SourceRange) EvSummary
parsedEvSummaries CostCentreName -> SourceRanges
ccToRanges
        lookupCC = (CostCentres
centres CostCentres -> CostCentreName -> CostCentreDetails
forall k a. Ord k => Map k a -> k -> a
M.!)
        ccToRanges :: CostCentreName -> M.Map SourceRange SourceRangeDetails
        ccToRanges CostCentreName
ccName =
          Map FilePath SourceRanges -> SourceRanges
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
M.unions Map FilePath SourceRanges
ranges
            SourceRanges -> (SourceRanges -> SourceRanges) -> SourceRanges
forall a b. a -> (a -> b) -> b
& (SourceRangeDetails -> Bool) -> SourceRanges -> SourceRanges
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (CostCentreName -> CostCentres -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member CostCentreName
ccName (CostCentres -> Bool)
-> (SourceRangeDetails -> CostCentres)
-> SourceRangeDetails
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceRangeDetails -> CostCentres
containingCostCentres)
     in (ranges, centres)

buildCostCentres ::
  M.Map (CostCentreName, Seq.Seq SourceRange) ES.EvSummary ->
  (CostCentreName -> M.Map SourceRange SourceRangeDetails) ->
  CostCentres
buildCostCentres :: Map (CostCentreName, Seq SourceRange) EvSummary
-> (CostCentreName -> SourceRanges) -> CostCentres
buildCostCentres Map (CostCentreName, Seq SourceRange) EvSummary
summaries CostCentreName -> SourceRanges
rangesInCC =
  let totalTime :: Double
totalTime = Sum Double -> Double
forall a. Sum a -> a
getSum (Sum Double -> Double) -> Sum Double -> Double
forall a b. (a -> b) -> a -> b
$ (EvSummary -> Sum Double)
-> Map (CostCentreName, Seq SourceRange) EvSummary -> Sum Double
forall m a.
Monoid m =>
(a -> m) -> Map (CostCentreName, Seq SourceRange) a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Double -> Sum Double
forall a. a -> Sum a
Sum (Double -> Sum Double)
-> (EvSummary -> Double) -> EvSummary -> Sum Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvSummary -> Double
ES.evSum) Map (CostCentreName, Seq SourceRange) EvSummary
summaries
      makeDetails :: ((CostCentreName, b), EvSummary) -> CostCentreDetails
makeDetails ((CostCentreName
name, b
_), EvSummary
summary) =
        Double -> SourceRanges -> EvSummary -> CostCentreDetails
CostCentreDetails Double
fraction SourceRanges
ranges EvSummary
summary
        where
          fraction :: Double
fraction = EvSummary -> Double
ES.evSum EvSummary
summary Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
totalTime
          ranges :: SourceRanges
ranges = CostCentreName -> SourceRanges
rangesInCC CostCentreName
name
   in Map (CostCentreName, Seq SourceRange) EvSummary
-> [((CostCentreName, Seq SourceRange), EvSummary)]
forall k a. Map k a -> [(k, a)]
M.toList Map (CostCentreName, Seq SourceRange) EvSummary
summaries
        [((CostCentreName, Seq SourceRange), EvSummary)]
-> ([((CostCentreName, Seq SourceRange), EvSummary)]
    -> [(CostCentreName, CostCentreDetails)])
-> [(CostCentreName, CostCentreDetails)]
forall a b. a -> (a -> b) -> b
& (((CostCentreName, Seq SourceRange), EvSummary)
 -> (CostCentreName, CostCentreDetails))
-> [((CostCentreName, Seq SourceRange), EvSummary)]
-> [(CostCentreName, CostCentreDetails)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CostCentreName, Seq SourceRange) -> CostCentreName
forall a b. (a, b) -> a
fst ((CostCentreName, Seq SourceRange) -> CostCentreName)
-> (((CostCentreName, Seq SourceRange), EvSummary)
    -> (CostCentreName, Seq SourceRange))
-> ((CostCentreName, Seq SourceRange), EvSummary)
-> CostCentreName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((CostCentreName, Seq SourceRange), EvSummary)
-> (CostCentreName, Seq SourceRange)
forall a b. (a, b) -> a
fst (((CostCentreName, Seq SourceRange), EvSummary) -> CostCentreName)
-> (((CostCentreName, Seq SourceRange), EvSummary)
    -> CostCentreDetails)
-> ((CostCentreName, Seq SourceRange), EvSummary)
-> (CostCentreName, CostCentreDetails)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ((CostCentreName, Seq SourceRange), EvSummary) -> CostCentreDetails
forall {b}. ((CostCentreName, b), EvSummary) -> CostCentreDetails
makeDetails)
        [(CostCentreName, CostCentreDetails)]
-> ([(CostCentreName, CostCentreDetails)] -> CostCentres)
-> CostCentres
forall a b. a -> (a -> b) -> b
& [(CostCentreName, CostCentreDetails)] -> CostCentres
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList

buildSourceRanges ::
  M.Map (CostCentreName, Seq.Seq SourceRange) ES.EvSummary ->
  (CostCentreName -> CostCentreDetails) ->
  M.Map FilePath SourceRanges
buildSourceRanges :: Map (CostCentreName, Seq SourceRange) EvSummary
-> (CostCentreName -> CostCentreDetails)
-> Map FilePath SourceRanges
buildSourceRanges Map (CostCentreName, Seq SourceRange) EvSummary
summaries CostCentreName -> CostCentreDetails
lookupCC =
  let distributeRanges ::
        (CostCentreName, Seq.Seq SourceRange) ->
        S.Set (CostCentreName, SourceRange)
      distributeRanges :: (CostCentreName, Seq SourceRange)
-> Set (CostCentreName, SourceRange)
distributeRanges (CostCentreName
name, Seq SourceRange
ranges) =
        Seq SourceRange -> [SourceRange]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq SourceRange
ranges
          [SourceRange]
-> ([SourceRange] -> [(CostCentreName, SourceRange)])
-> [(CostCentreName, SourceRange)]
forall a b. a -> (a -> b) -> b
& (SourceRange -> (CostCentreName, SourceRange))
-> [SourceRange] -> [(CostCentreName, SourceRange)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CostCentreName
name,)
          [(CostCentreName, SourceRange)]
-> ([(CostCentreName, SourceRange)]
    -> Set (CostCentreName, SourceRange))
-> Set (CostCentreName, SourceRange)
forall a b. a -> (a -> b) -> b
& [(CostCentreName, SourceRange)]
-> Set (CostCentreName, SourceRange)
forall a. Ord a => [a] -> Set a
S.fromList

      distributedRanges :: Set (CostCentreName, SourceRange)
distributedRanges =
        Map (CostCentreName, Seq SourceRange) EvSummary
-> Set (CostCentreName, Seq SourceRange)
forall k a. Map k a -> Set k
M.keysSet Map (CostCentreName, Seq SourceRange) EvSummary
summaries
          Set (CostCentreName, Seq SourceRange)
-> (Set (CostCentreName, Seq SourceRange)
    -> Set (Set (CostCentreName, SourceRange)))
-> Set (Set (CostCentreName, SourceRange))
forall a b. a -> (a -> b) -> b
& ((CostCentreName, Seq SourceRange)
 -> Set (CostCentreName, SourceRange))
-> Set (CostCentreName, Seq SourceRange)
-> Set (Set (CostCentreName, SourceRange))
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (CostCentreName, Seq SourceRange)
-> Set (CostCentreName, SourceRange)
distributeRanges
          Set (Set (CostCentreName, SourceRange))
-> (Set (Set (CostCentreName, SourceRange))
    -> Set (CostCentreName, SourceRange))
-> Set (CostCentreName, SourceRange)
forall a b. a -> (a -> b) -> b
& Set (Set (CostCentreName, SourceRange))
-> Set (CostCentreName, SourceRange)
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions

      rangeToCCs :: Map SourceRange (Seq CostCentreName)
rangeToCCs = Set (CostCentreName, SourceRange)
-> Map SourceRange (Seq CostCentreName)
summarizeAndSplitRanges Set (CostCentreName, SourceRange)
distributedRanges
      fileToRangeToCCs :: Map FilePath (Map SourceRange (Seq CostCentreName))
fileToRangeToCCs =
        ((SourceRange, Seq CostCentreName)
 -> (FilePath, Map SourceRange (Seq CostCentreName)))
-> [(SourceRange, Seq CostCentreName)]
-> [(FilePath, Map SourceRange (Seq CostCentreName))]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SourceRange, Seq CostCentreName)
-> (FilePath, Map SourceRange (Seq CostCentreName))
forall {b}. (SourceRange, b) -> (FilePath, Map SourceRange b)
prepareElement (Map SourceRange (Seq CostCentreName)
-> [(SourceRange, Seq CostCentreName)]
forall k a. Map k a -> [(k, a)]
M.toList Map SourceRange (Seq CostCentreName)
rangeToCCs)
          [(FilePath, Map SourceRange (Seq CostCentreName))]
-> ([(FilePath, Map SourceRange (Seq CostCentreName))]
    -> Map FilePath (Map SourceRange (Seq CostCentreName)))
-> Map FilePath (Map SourceRange (Seq CostCentreName))
forall a b. a -> (a -> b) -> b
& (Map SourceRange (Seq CostCentreName)
 -> Map SourceRange (Seq CostCentreName)
 -> Map SourceRange (Seq CostCentreName))
-> [(FilePath, Map SourceRange (Seq CostCentreName))]
-> Map FilePath (Map SourceRange (Seq CostCentreName))
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith Map SourceRange (Seq CostCentreName)
-> Map SourceRange (Seq CostCentreName)
-> Map SourceRange (Seq CostCentreName)
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union
        where
          prepareElement :: (SourceRange, b) -> (FilePath, Map SourceRange b)
prepareElement =
            ((SourceRange, b) -> Map SourceRange b)
-> (FilePath, (SourceRange, b)) -> (FilePath, Map SourceRange b)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((SourceRange -> b -> Map SourceRange b)
-> (SourceRange, b) -> Map SourceRange b
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry SourceRange -> b -> Map SourceRange b
forall k a. k -> a -> Map k a
M.singleton)
              ((FilePath, (SourceRange, b)) -> (FilePath, Map SourceRange b))
-> ((SourceRange, b) -> (FilePath, (SourceRange, b)))
-> (SourceRange, b)
-> (FilePath, Map SourceRange b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(SourceRange
range, b
ccs) -> (SourceRange -> FilePath
SR.fileName SourceRange
range, (SourceRange
range, b
ccs)))

      ccsToDetails :: Seq CostCentreName -> SourceRangeDetails
ccsToDetails =
        Seq CostCentreName -> [CostCentreName]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
          (Seq CostCentreName -> [CostCentreName])
-> ([CostCentreName] -> SourceRangeDetails)
-> Seq CostCentreName
-> SourceRangeDetails
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (CostCentreName -> (CostCentreName, CostCentreDetails))
-> [CostCentreName] -> [(CostCentreName, CostCentreDetails)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CostCentreName -> CostCentreName
forall a. a -> a
id (CostCentreName -> CostCentreName)
-> (CostCentreName -> CostCentreDetails)
-> CostCentreName
-> (CostCentreName, CostCentreDetails)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& CostCentreName -> CostCentreDetails
lookupCC)
          ([CostCentreName] -> [(CostCentreName, CostCentreDetails)])
-> ([(CostCentreName, CostCentreDetails)] -> SourceRangeDetails)
-> [CostCentreName]
-> SourceRangeDetails
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> [(CostCentreName, CostCentreDetails)] -> CostCentres
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
          ([(CostCentreName, CostCentreDetails)] -> CostCentres)
-> (CostCentres -> SourceRangeDetails)
-> [(CostCentreName, CostCentreDetails)]
-> SourceRangeDetails
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> CostCentres -> SourceRangeDetails
SourceRangeDetails
   in (Map SourceRange (Seq CostCentreName) -> SourceRanges)
-> Map FilePath (Map SourceRange (Seq CostCentreName))
-> Map FilePath SourceRanges
forall a b. (a -> b) -> Map FilePath a -> Map FilePath b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Seq CostCentreName -> SourceRangeDetails)
-> Map SourceRange (Seq CostCentreName) -> SourceRanges
forall a b. (a -> b) -> Map SourceRange a -> Map SourceRange b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Seq CostCentreName -> SourceRangeDetails
ccsToDetails) Map FilePath (Map SourceRange (Seq CostCentreName))
fileToRangeToCCs

parseEvSummaries ::
  M.Map (T.Text, T.Text) ES.EvSummary ->
  Except T.Text (M.Map (CostCentreName, Seq.Seq SourceRange) ES.EvSummary)
parseEvSummaries :: Map (Text, Text) EvSummary
-> Except Text (Map (CostCentreName, Seq SourceRange) EvSummary)
parseEvSummaries Map (Text, Text) EvSummary
evSummaries =
  let parseKey :: (Text, Text)
-> b
-> ExceptT Text Identity ((CostCentreName, Seq SourceRange), b)
parseKey (Text
ccName, Text
sourceLocs) b
v =
        let ccName' :: CostCentreName
ccName' = Text -> CostCentreName
CostCentreName Text
ccName
         in do
              sourceRanges <- Text -> Except Text (Seq SourceRange)
splitParseSourceLocs Text
sourceLocs
              pure ((ccName', sourceRanges), v)
   in Map (Text, Text) EvSummary -> [((Text, Text), EvSummary)]
forall k a. Map k a -> [(k, a)]
M.toList Map (Text, Text) EvSummary
evSummaries
        [((Text, Text), EvSummary)]
-> ([((Text, Text), EvSummary)]
    -> ExceptT
         Text Identity [((CostCentreName, Seq SourceRange), EvSummary)])
-> ExceptT
     Text Identity [((CostCentreName, Seq SourceRange), EvSummary)]
forall a b. a -> (a -> b) -> b
& (((Text, Text), EvSummary)
 -> ExceptT
      Text Identity ((CostCentreName, Seq SourceRange), EvSummary))
-> [((Text, Text), EvSummary)]
-> ExceptT
     Text Identity [((CostCentreName, Seq SourceRange), EvSummary)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (((Text, Text)
 -> EvSummary
 -> ExceptT
      Text Identity ((CostCentreName, Seq SourceRange), EvSummary))
-> ((Text, Text), EvSummary)
-> ExceptT
     Text Identity ((CostCentreName, Seq SourceRange), EvSummary)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Text, Text)
-> EvSummary
-> ExceptT
     Text Identity ((CostCentreName, Seq SourceRange), EvSummary)
forall {b}.
(Text, Text)
-> b
-> ExceptT Text Identity ((CostCentreName, Seq SourceRange), b)
parseKey)
        ExceptT
  Text Identity [((CostCentreName, Seq SourceRange), EvSummary)]
-> (ExceptT
      Text Identity [((CostCentreName, Seq SourceRange), EvSummary)]
    -> Except Text (Map (CostCentreName, Seq SourceRange) EvSummary))
-> Except Text (Map (CostCentreName, Seq SourceRange) EvSummary)
forall a b. a -> (a -> b) -> b
& ([((CostCentreName, Seq SourceRange), EvSummary)]
 -> Map (CostCentreName, Seq SourceRange) EvSummary)
-> ExceptT
     Text Identity [((CostCentreName, Seq SourceRange), EvSummary)]
-> Except Text (Map (CostCentreName, Seq SourceRange) EvSummary)
forall a b.
(a -> b) -> ExceptT Text Identity a -> ExceptT Text Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [((CostCentreName, Seq SourceRange), EvSummary)]
-> Map (CostCentreName, Seq SourceRange) EvSummary
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList

splitParseSourceLocs :: T.Text -> Except T.Text (Seq.Seq SourceRange)
splitParseSourceLocs :: Text -> Except Text (Seq SourceRange)
splitParseSourceLocs Text
t =
  if Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"unknown"
    then Seq SourceRange -> Except Text (Seq SourceRange)
forall a. a -> ExceptT Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Seq SourceRange
forall a. Seq a
Seq.empty
    else ([SourceRange] -> Seq SourceRange)
-> ExceptT Text Identity [SourceRange]
-> Except Text (Seq SourceRange)
forall a b.
(a -> b) -> ExceptT Text Identity a -> ExceptT Text Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [SourceRange] -> Seq SourceRange
forall a. [a] -> Seq a
Seq.fromList (ExceptT Text Identity [SourceRange]
 -> Except Text (Seq SourceRange))
-> ExceptT Text Identity [SourceRange]
-> Except Text (Seq SourceRange)
forall a b. (a -> b) -> a -> b
$ (Text -> ExceptT Text Identity SourceRange)
-> [Text] -> ExceptT Text Identity [SourceRange]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Either Text SourceRange -> ExceptT Text Identity SourceRange
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either Text SourceRange -> ExceptT Text Identity SourceRange)
-> (Text -> Either Text SourceRange)
-> Text
-> ExceptT Text Identity SourceRange
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text SourceRange
SR.parse) ([Text] -> ExceptT Text Identity [SourceRange])
-> [Text] -> ExceptT Text Identity [SourceRange]
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"->" Text
t

summarizeAndSplitRanges ::
  -- | Mapping from (ccName, ccProvenance) to event summary
  S.Set (CostCentreName, SR.SourceRange) ->
  -- | Non-Overlapping Events with SourceRanges separated by file
  -- invariant: sourcerange.rangeStartPos.file is always equal to the map key
  M.Map SR.SourceRange (Seq.Seq CostCentreName)
summarizeAndSplitRanges :: Set (CostCentreName, SourceRange)
-> Map SourceRange (Seq CostCentreName)
summarizeAndSplitRanges Set (CostCentreName, SourceRange)
summaries =
  let separateSourceRanges ::
        -- \| All possibly overlapping SourceRanges
        Seq.Seq (SR.SourceRange, CostCentreName) ->
        -- \| Ordered non-overlapping sourceranges with merged attached informations
        M.Map SR.SourceRange (Seq.Seq CostCentreName)
      separateSourceRanges :: Seq (SourceRange, CostCentreName)
-> Map SourceRange (Seq CostCentreName)
separateSourceRanges = (Map SourceRange (Seq CostCentreName)
 -> (SourceRange, Seq CostCentreName)
 -> Map SourceRange (Seq CostCentreName))
-> Map SourceRange (Seq CostCentreName)
-> Seq (SourceRange, Seq CostCentreName)
-> Map SourceRange (Seq CostCentreName)
forall b a. (b -> a -> b) -> b -> Seq a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' Map SourceRange (Seq CostCentreName)
-> (SourceRange, Seq CostCentreName)
-> Map SourceRange (Seq CostCentreName)
accumulateRange Map SourceRange (Seq CostCentreName)
forall k a. Map k a
M.empty (Seq (SourceRange, Seq CostCentreName)
 -> Map SourceRange (Seq CostCentreName))
-> (Seq (SourceRange, CostCentreName)
    -> Seq (SourceRange, Seq CostCentreName))
-> Seq (SourceRange, CostCentreName)
-> Map SourceRange (Seq CostCentreName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((SourceRange, CostCentreName)
 -> (SourceRange, Seq CostCentreName))
-> Seq (SourceRange, CostCentreName)
-> Seq (SourceRange, Seq CostCentreName)
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CostCentreName -> Seq CostCentreName)
-> (SourceRange, CostCentreName)
-> (SourceRange, Seq CostCentreName)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second CostCentreName -> Seq CostCentreName
forall a. a -> Seq a
Seq.singleton)
        where
          accumulateRange ::
            -- \| Mapping of non-overlapping ranges, the T.Text is a ccName
            M.Map SR.SourceRange (Seq.Seq CostCentreName) ->
            -- \| New SourceRange that must be merged and inserted
            (SR.SourceRange, Seq.Seq CostCentreName) ->
            -- \| Mapping of non-overlapping ranges
            M.Map SR.SourceRange (Seq.Seq CostCentreName)
          accumulateRange :: Map SourceRange (Seq CostCentreName)
-> (SourceRange, Seq CostCentreName)
-> Map SourceRange (Seq CostCentreName)
accumulateRange Map SourceRange (Seq CostCentreName)
ranges (SourceRange
range, Seq CostCentreName
aux) = case SourceRange
-> Map SourceRange (Seq CostCentreName)
-> Maybe (SourceRange, Seq CostCentreName)
forall k v. Ord k => k -> Map k v -> Maybe (k, v)
M.lookupLE SourceRange
range Map SourceRange (Seq CostCentreName)
ranges of
            -- there is no lower range
            Maybe (SourceRange, Seq CostCentreName)
Nothing -> case SourceRange
-> Map SourceRange (Seq CostCentreName)
-> Maybe (SourceRange, Seq CostCentreName)
forall k v. Ord k => k -> Map k v -> Maybe (k, v)
M.lookupGE SourceRange
range Map SourceRange (Seq CostCentreName)
ranges of
              -- there is no higher range
              Maybe (SourceRange, Seq CostCentreName)
Nothing -> SourceRange
-> Seq CostCentreName
-> Map SourceRange (Seq CostCentreName)
-> Map SourceRange (Seq CostCentreName)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert SourceRange
range Seq CostCentreName
aux Map SourceRange (Seq CostCentreName)
ranges -- nothing to merge at all

              -- higher ranges was found
              Just higher :: (SourceRange, Seq CostCentreName)
higher@(SourceRange
higherRange, Seq CostCentreName
_) ->
                if SourceRange
range SourceRange -> SourceRange -> Bool
`SR.overlapsWith` SourceRange
higherRange
                  then
                    let mergedRanges :: OneTwoThree (SourceRange, Seq CostCentreName)
mergedRanges = (SourceRange, Seq CostCentreName)
-> (SourceRange, Seq CostCentreName)
-> OneTwoThree (SourceRange, Seq CostCentreName)
forall s.
Semigroup s =>
(SourceRange, s)
-> (SourceRange, s) -> OneTwoThree (SourceRange, s)
SR.mergeSemigroup (SourceRange
range, Seq CostCentreName
aux) (SourceRange, Seq CostCentreName)
higher
                        rangesWithoutHigher :: Map SourceRange (Seq CostCentreName)
rangesWithoutHigher = SourceRange
-> Map SourceRange (Seq CostCentreName)
-> Map SourceRange (Seq CostCentreName)
forall k a. Ord k => k -> Map k a -> Map k a
M.delete SourceRange
higherRange Map SourceRange (Seq CostCentreName)
ranges
                     in (Map SourceRange (Seq CostCentreName)
 -> (SourceRange, Seq CostCentreName)
 -> Map SourceRange (Seq CostCentreName))
-> Map SourceRange (Seq CostCentreName)
-> OneTwoThree (SourceRange, Seq CostCentreName)
-> Map SourceRange (Seq CostCentreName)
forall b a. (b -> a -> b) -> b -> OneTwoThree a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Map SourceRange (Seq CostCentreName)
-> (SourceRange, Seq CostCentreName)
-> Map SourceRange (Seq CostCentreName)
accumulateRange Map SourceRange (Seq CostCentreName)
rangesWithoutHigher OneTwoThree (SourceRange, Seq CostCentreName)
mergedRanges
                  -- ranges don't overlap, don't merge
                  else SourceRange
-> Seq CostCentreName
-> Map SourceRange (Seq CostCentreName)
-> Map SourceRange (Seq CostCentreName)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert SourceRange
range Seq CostCentreName
aux Map SourceRange (Seq CostCentreName)
ranges
            -- lower range was found
            Just lower :: (SourceRange, Seq CostCentreName)
lower@(SourceRange
lowerRange, Seq CostCentreName
_) ->
              if SourceRange
range SourceRange -> SourceRange -> Bool
`SR.overlapsWith` SourceRange
lowerRange
                then
                  let mergedRanges :: OneTwoThree (SourceRange, Seq CostCentreName)
mergedRanges = (SourceRange, Seq CostCentreName)
-> (SourceRange, Seq CostCentreName)
-> OneTwoThree (SourceRange, Seq CostCentreName)
forall s.
Semigroup s =>
(SourceRange, s)
-> (SourceRange, s) -> OneTwoThree (SourceRange, s)
SR.mergeSemigroup (SourceRange
range, Seq CostCentreName
aux) (SourceRange, Seq CostCentreName)
lower
                      rangesWithoutLower :: Map SourceRange (Seq CostCentreName)
rangesWithoutLower = SourceRange
-> Map SourceRange (Seq CostCentreName)
-> Map SourceRange (Seq CostCentreName)
forall k a. Ord k => k -> Map k a -> Map k a
M.delete SourceRange
lowerRange Map SourceRange (Seq CostCentreName)
ranges
                   in (Map SourceRange (Seq CostCentreName)
 -> (SourceRange, Seq CostCentreName)
 -> Map SourceRange (Seq CostCentreName))
-> Map SourceRange (Seq CostCentreName)
-> OneTwoThree (SourceRange, Seq CostCentreName)
-> Map SourceRange (Seq CostCentreName)
forall b a. (b -> a -> b) -> b -> OneTwoThree a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Map SourceRange (Seq CostCentreName)
-> (SourceRange, Seq CostCentreName)
-> Map SourceRange (Seq CostCentreName)
accumulateRange Map SourceRange (Seq CostCentreName)
rangesWithoutLower OneTwoThree (SourceRange, Seq CostCentreName)
mergedRanges
                -- lower range does not overlap
                else case SourceRange
-> Map SourceRange (Seq CostCentreName)
-> Maybe (SourceRange, Seq CostCentreName)
forall k v. Ord k => k -> Map k v -> Maybe (k, v)
M.lookupGE SourceRange
range Map SourceRange (Seq CostCentreName)
ranges of -- check the higher bound
                -- nothing to merge
                  Maybe (SourceRange, Seq CostCentreName)
Nothing -> SourceRange
-> Seq CostCentreName
-> Map SourceRange (Seq CostCentreName)
-> Map SourceRange (Seq CostCentreName)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert SourceRange
range Seq CostCentreName
aux Map SourceRange (Seq CostCentreName)
ranges
                  -- higher range was found
                  Just higher :: (SourceRange, Seq CostCentreName)
higher@(SourceRange
higherRange, Seq CostCentreName
_) ->
                    if SourceRange
range SourceRange -> SourceRange -> Bool
`SR.overlapsWith` SourceRange
higherRange
                      then
                        let mergedRanges :: OneTwoThree (SourceRange, Seq CostCentreName)
mergedRanges = (SourceRange, Seq CostCentreName)
-> (SourceRange, Seq CostCentreName)
-> OneTwoThree (SourceRange, Seq CostCentreName)
forall s.
Semigroup s =>
(SourceRange, s)
-> (SourceRange, s) -> OneTwoThree (SourceRange, s)
SR.mergeSemigroup (SourceRange
range, Seq CostCentreName
aux) (SourceRange, Seq CostCentreName)
higher
                            rangesWithoutHigher :: Map SourceRange (Seq CostCentreName)
rangesWithoutHigher = SourceRange
-> Map SourceRange (Seq CostCentreName)
-> Map SourceRange (Seq CostCentreName)
forall k a. Ord k => k -> Map k a -> Map k a
M.delete SourceRange
higherRange Map SourceRange (Seq CostCentreName)
ranges
                         in (Map SourceRange (Seq CostCentreName)
 -> (SourceRange, Seq CostCentreName)
 -> Map SourceRange (Seq CostCentreName))
-> Map SourceRange (Seq CostCentreName)
-> OneTwoThree (SourceRange, Seq CostCentreName)
-> Map SourceRange (Seq CostCentreName)
forall b a. (b -> a -> b) -> b -> OneTwoThree a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Map SourceRange (Seq CostCentreName)
-> (SourceRange, Seq CostCentreName)
-> Map SourceRange (Seq CostCentreName)
accumulateRange Map SourceRange (Seq CostCentreName)
rangesWithoutHigher OneTwoThree (SourceRange, Seq CostCentreName)
mergedRanges
                      -- just insert the range normally
                      else SourceRange
-> Seq CostCentreName
-> Map SourceRange (Seq CostCentreName)
-> Map SourceRange (Seq CostCentreName)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert SourceRange
range Seq CostCentreName
aux Map SourceRange (Seq CostCentreName)
ranges
   in Set (CostCentreName, SourceRange)
-> [(CostCentreName, SourceRange)]
forall a. Set a -> [a]
S.toList Set (CostCentreName, SourceRange)
summaries
        [(CostCentreName, SourceRange)]
-> ([(CostCentreName, SourceRange)]
    -> [(SourceRange, CostCentreName)])
-> [(SourceRange, CostCentreName)]
forall a b. a -> (a -> b) -> b
& ((CostCentreName, SourceRange) -> (SourceRange, CostCentreName))
-> [(CostCentreName, SourceRange)]
-> [(SourceRange, CostCentreName)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CostCentreName -> SourceRange -> (SourceRange, CostCentreName))
-> (CostCentreName, SourceRange) -> (SourceRange, CostCentreName)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((CostCentreName -> SourceRange -> (SourceRange, CostCentreName))
 -> (CostCentreName, SourceRange) -> (SourceRange, CostCentreName))
-> (CostCentreName -> SourceRange -> (SourceRange, CostCentreName))
-> (CostCentreName, SourceRange)
-> (SourceRange, CostCentreName)
forall a b. (a -> b) -> a -> b
$ (SourceRange -> CostCentreName -> (SourceRange, CostCentreName))
-> CostCentreName -> SourceRange -> (SourceRange, CostCentreName)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,))
        [(SourceRange, CostCentreName)]
-> ([(SourceRange, CostCentreName)]
    -> Seq (SourceRange, CostCentreName))
-> Seq (SourceRange, CostCentreName)
forall a b. a -> (a -> b) -> b
& [(SourceRange, CostCentreName)]
-> Seq (SourceRange, CostCentreName)
forall a. [a] -> Seq a
Seq.fromList
        Seq (SourceRange, CostCentreName)
-> (Seq (SourceRange, CostCentreName)
    -> Map SourceRange (Seq CostCentreName))
-> Map SourceRange (Seq CostCentreName)
forall a b. a -> (a -> b) -> b
& Seq (SourceRange, CostCentreName)
-> Map SourceRange (Seq CostCentreName)
separateSourceRanges

loadAllFiles :: [FilePath] -> ExceptT T.Text IO (M.Map FilePath T.Text)
loadAllFiles :: [FilePath] -> ExceptT Text IO (Map FilePath Text)
loadAllFiles [FilePath]
files =
  (FilePath -> ExceptT Text IO (FilePath, Text))
-> [FilePath] -> ExceptT Text IO [(FilePath, Text)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\FilePath
path -> (FilePath
path,) (Text -> (FilePath, Text))
-> ExceptT Text IO Text -> ExceptT Text IO (FilePath, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> ExceptT Text IO Text
forall {m :: * -> *}.
(MonadIO m, MonadError Text m) =>
FilePath -> m Text
tryLoadFile FilePath
path) [FilePath]
files
    ExceptT Text IO [(FilePath, Text)]
-> (ExceptT Text IO [(FilePath, Text)]
    -> ExceptT Text IO (Map FilePath Text))
-> ExceptT Text IO (Map FilePath Text)
forall a b. a -> (a -> b) -> b
& ([(FilePath, Text)] -> Map FilePath Text)
-> ExceptT Text IO [(FilePath, Text)]
-> ExceptT Text IO (Map FilePath Text)
forall a b. (a -> b) -> ExceptT Text IO a -> ExceptT Text IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(FilePath, Text)] -> Map FilePath Text
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
  where
    tryLoadFile :: FilePath -> m Text
tryLoadFile FilePath
filePath = do
      bytes <- IO (Either FilePath ByteString) -> m (Either FilePath ByteString)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either FilePath ByteString) -> m (Either FilePath ByteString))
-> IO (Either FilePath ByteString)
-> m (Either FilePath ByteString)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO (Either FilePath ByteString)
readFileSafely FilePath
filePath
      bytes' <- liftEither . first T.pack $ bytes
      liftEither . first showText $ T.decodeUtf8' (BS.toStrict bytes')

prepareDir :: FilePath -> IO FilePath
prepareDir :: FilePath -> IO FilePath
prepareDir FilePath
json_path = do
  let top_dir :: FilePath
top_dir = FilePath -> FilePath
takeFileName FilePath
json_path FilePath -> FilePath -> FilePath
-<.> FilePath
"prof"
  Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Writing results to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
top_dir Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/"
  FilePath -> IO ()
removePathForcibly FilePath
top_dir
  FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
top_dir

analyseProfilingReport :: FilePath -> ProfilingReport -> IO ()
analyseProfilingReport :: FilePath -> ProfilingReport -> IO ()
analyseProfilingReport FilePath
json_path ProfilingReport
r = do
  top_dir <- FilePath -> IO FilePath
prepareDir FilePath
json_path
  createDirectoryIfMissing True top_dir
  let tf =
        TargetFiles
          { summaryFile :: FilePath
summaryFile = FilePath
top_dir FilePath -> FilePath -> FilePath
</> FilePath
"summary",
            timelineFile :: FilePath
timelineFile = FilePath
top_dir FilePath -> FilePath -> FilePath
</> FilePath
"timeline",
            htmlIndexFile :: FilePath
htmlIndexFile = FilePath
top_dir FilePath -> FilePath -> FilePath
</> FilePath
"index.html",
            htmlDir :: FilePath
htmlDir = FilePath
top_dir FilePath -> FilePath -> FilePath
</> FilePath
"html/"
          }
  writeAnalysis tf Nothing $ Just r

analyseBenchResults :: FilePath -> [BenchResult] -> IO ()
analyseBenchResults :: FilePath -> [BenchResult] -> IO ()
analyseBenchResults FilePath
json_path [BenchResult]
bench_results = do
  top_dir <- FilePath -> IO FilePath
prepareDir FilePath
json_path
  T.hPutStrLn stderr $ "Stripping '" <> T.pack prefix <> "' from program paths."
  programs <- mapM (onBenchResult top_dir) bench_results
  writeNavigationIndex (top_dir </> "index.html") "Program Index" programs
  where
    programPaths :: [FilePath]
programPaths = (BenchResult -> FilePath) -> [BenchResult] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':') (FilePath -> FilePath)
-> (BenchResult -> FilePath) -> BenchResult -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BenchResult -> FilePath
benchResultProg) [BenchResult]
bench_results
    prefix :: FilePath
prefix = case Set FilePath -> [FilePath]
forall a. Set a -> [a]
S.toList (Set FilePath -> [FilePath]) -> Set FilePath -> [FilePath]
forall a b. (a -> b) -> a -> b
$ [FilePath] -> Set FilePath
forall a. Ord a => [a] -> Set a
S.fromList [FilePath]
programPaths of
      [FilePath
path] -> FilePath
path
      [FilePath]
paths -> FilePath -> FilePath
takeDirectory (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
longestCommonPrefix [FilePath]
paths

    -- Eliminate characters that are filesystem-meaningful.
    escape :: Char -> Char
escape Char
'/' = Char
'_'
    escape Char
c = Char
c

    problem :: Text -> Text -> Text -> IO ()
problem Text
prog_name Text
name Text
what =
      Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
prog_name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" dataset " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
what

    onBenchResult :: FilePath -> BenchResult -> IO (Text, FilePath)
onBenchResult FilePath
top_dir (BenchResult FilePath
prog_path [DataResult]
data_results) = do
      let (FilePath
prog_path', FilePath
entry) = (Char -> Bool) -> FilePath -> (FilePath, FilePath)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':') FilePath
prog_path
          prog_name :: FilePath
prog_name = FilePath -> FilePath -> FilePath
makeRelative FilePath
prefix FilePath
prog_path'
          relative_dir :: FilePath
relative_dir = FilePath -> FilePath
dropExtension FilePath
prog_name FilePath -> FilePath -> FilePath
</> Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop Int
1 FilePath
entry
          -- Preserve the established <entry>/<dataset>-index.html layout for
          -- one source file. A file without an entry point still needs its
          -- own directory so it does not collide with the top-level index.
          prog_dir :: FilePath
prog_dir =
            FilePath
top_dir
              FilePath -> FilePath -> FilePath
</> if FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
relative_dir Bool -> Bool -> Bool
|| FilePath
relative_dir FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"."
                then FilePath
"program"
                else FilePath
relative_dir
      Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
prog_dir
      datasets <-
        [Maybe (Text, FilePath)] -> [(Text, FilePath)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Text, FilePath)] -> [(Text, FilePath)])
-> IO [Maybe (Text, FilePath)] -> IO [(Text, FilePath)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DataResult -> IO (Maybe (Text, FilePath)))
-> [DataResult] -> IO [Maybe (Text, FilePath)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (FilePath -> Text -> DataResult -> IO (Maybe (Text, FilePath))
onDataResult FilePath
prog_dir (FilePath -> Text
T.pack FilePath
prog_name)) [DataResult]
data_results
      let index = FilePath
prog_dir FilePath -> FilePath -> FilePath
</> FilePath
"index.html"
      writeNavigationIndex index (T.pack prog_path) datasets
      pure (T.pack prog_path, makeRelative top_dir index)

    onDataResult :: FilePath -> Text -> DataResult -> IO (Maybe (Text, FilePath))
onDataResult FilePath
_ Text
prog_name (DataResult Text
name (Left Text
_)) = do
      Text -> Text -> Text -> IO ()
problem Text
prog_name Text
name Text
"execution failed"
      Maybe (Text, FilePath) -> IO (Maybe (Text, FilePath))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Text, FilePath)
forall a. Maybe a
Nothing
    onDataResult FilePath
prog_dir Text
prog_name (DataResult Text
name (Right Result
res)) = do
      let name' :: FilePath
name' = FilePath
prog_dir FilePath -> FilePath -> FilePath
</> Text -> FilePath
T.unpack ((Char -> Char) -> Text -> Text
T.map Char -> Char
escape Text
name)
      case Result -> Maybe Text
stdErr Result
res of
        Maybe Text
Nothing -> Text -> Text -> Text -> IO ()
problem Text
prog_name Text
name Text
"no log recorded"
        Just Text
text -> FilePath -> Text -> IO ()
T.writeFile (FilePath
name' FilePath -> FilePath -> FilePath
<.> FilePath
".log") Text
text
      case Result -> Maybe ProfilingReport
report Result
res of
        Maybe ProfilingReport
Nothing -> Text -> Text -> Text -> IO ()
problem Text
prog_name Text
name Text
"no profiling information"
        Just ProfilingReport
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      let tf :: TargetFiles
tf =
            TargetFiles
              { summaryFile :: FilePath
summaryFile = FilePath
name' FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
".summary",
                timelineFile :: FilePath
timelineFile = FilePath
name' FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
".timeline",
                htmlIndexFile :: FilePath
htmlIndexFile = FilePath
name' FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"-index.html",
                htmlDir :: FilePath
htmlDir = FilePath
name' FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
".html/"
              }
      if Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust (Result -> Maybe Text
stdErr Result
res) Bool -> Bool -> Bool
|| Maybe ProfilingReport -> Bool
forall a. Maybe a -> Bool
isJust (Result -> Maybe ProfilingReport
report Result
res)
        then do
          TargetFiles -> Maybe Text -> Maybe ProfilingReport -> IO ()
writeAnalysis TargetFiles
tf (Result -> Maybe Text
stdErr Result
res) (Result -> Maybe ProfilingReport
report Result
res)
          Maybe (Text, FilePath) -> IO (Maybe (Text, FilePath))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Text, FilePath) -> IO (Maybe (Text, FilePath)))
-> Maybe (Text, FilePath) -> IO (Maybe (Text, FilePath))
forall a b. (a -> b) -> a -> b
$ (Text, FilePath) -> Maybe (Text, FilePath)
forall a. a -> Maybe a
Just (Text
name, FilePath -> FilePath -> FilePath
makeRelative FilePath
prog_dir (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ TargetFiles -> FilePath
htmlIndexFile TargetFiles
tf)
        else Maybe (Text, FilePath) -> IO (Maybe (Text, FilePath))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Text, FilePath)
forall a. Maybe a
Nothing

-- | Write an index of generated reports, with paths relative to the index.
writeNavigationIndex :: FilePath -> T.Text -> [(T.Text, FilePath)] -> IO ()
writeNavigationIndex :: FilePath -> Text -> [(Text, FilePath)] -> IO ()
writeNavigationIndex FilePath
path Text
title [(Text, FilePath)]
links =
  FilePath -> Text -> IO ()
writeLazyTextFile FilePath
path (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ MarkupM () -> Text
H.renderHtml (MarkupM () -> Text) -> MarkupM () -> Text
forall a b. (a -> b) -> a -> b
$ MarkupM () -> MarkupM ()
H.docTypeHtml (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
    MarkupM () -> MarkupM ()
H.head (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
      MarkupM ()
H.meta MarkupM () -> Attribute -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
A.charset AttributeValue
"utf-8"
      MarkupM () -> MarkupM ()
H.title (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ Text -> MarkupM ()
H.text Text
title
      MarkupM () -> MarkupM ()
H.style (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ Text -> MarkupM ()
H.text Text
cssFile
    MarkupM () -> MarkupM ()
H.body (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ do
      MarkupM () -> MarkupM ()
H.h2 (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ Text -> MarkupM ()
H.text Text
title
      MarkupM () -> MarkupM ()
H.ul (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ [(Text, FilePath)]
-> ((Text, FilePath) -> MarkupM ()) -> MarkupM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Text, FilePath)]
links (((Text, FilePath) -> MarkupM ()) -> MarkupM ())
-> ((Text, FilePath) -> MarkupM ()) -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ \(Text
label, FilePath
target) ->
        MarkupM () -> MarkupM ()
H.li (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ MarkupM () -> MarkupM ()
H.a (MarkupM () -> MarkupM ()) -> Attribute -> MarkupM () -> MarkupM ()
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
A.href (FilePath -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue (FilePath -> AttributeValue) -> FilePath -> AttributeValue
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
escapePath FilePath
target) (MarkupM () -> MarkupM ()) -> MarkupM () -> MarkupM ()
forall a b. (a -> b) -> a -> b
$ Text -> MarkupM ()
H.text Text
label
  where
    -- Percent-encode UTF-8 bytes, retaining separators and URI-unreserved bytes.
    escapePath :: FilePath -> FilePath
escapePath =
      (Char -> FilePath) -> FilePath -> FilePath
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> FilePath
escapeByte (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> FilePath
BS.unpack (ByteString -> FilePath)
-> (FilePath -> ByteString) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BS.fromStrict (ByteString -> ByteString)
-> (FilePath -> ByteString) -> FilePath -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 (Text -> ByteString)
-> (FilePath -> Text) -> FilePath -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack
    escapeByte :: Char -> FilePath
escapeByte Char
c
      | Char -> Bool
isAscii Char
c Bool -> Bool -> Bool
&& (Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> FilePath -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'-', Char
'.', Char
'/', Char
'_', Char
'~']) = [Char
c]
      | Bool
otherwise = FilePath -> Int -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%%%02X" (Char -> Int
ord Char
c)

readFileSafely :: FilePath -> IO (Either String BS.ByteString)
readFileSafely :: FilePath -> IO (Either FilePath ByteString)
readFileSafely FilePath
filepath =
  (ByteString -> Either FilePath ByteString
forall a b. b -> Either a b
Right (ByteString -> Either FilePath ByteString)
-> IO ByteString -> IO (Either FilePath ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO ByteString
BS.readFile FilePath
filepath) IO (Either FilePath ByteString)
-> (IOError -> IO (Either FilePath ByteString))
-> IO (Either FilePath ByteString)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` IOError -> IO (Either FilePath ByteString)
forall {f :: * -> *} {b}.
Applicative f =>
IOError -> f (Either FilePath b)
couldNotRead
  where
    couldNotRead :: IOError -> f (Either FilePath b)
couldNotRead IOError
e = Either FilePath b -> f (Either FilePath b)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FilePath b -> f (Either FilePath b))
-> Either FilePath b -> f (Either FilePath b)
forall a b. (a -> b) -> a -> b
$ FilePath -> Either FilePath b
forall a b. a -> Either a b
Left (FilePath -> Either FilePath b) -> FilePath -> Either FilePath b
forall a b. (a -> b) -> a -> b
$ IOError -> FilePath
forall a. Show a => a -> FilePath
show (IOError
e :: IOError)

onFile :: FilePath -> IO ()
onFile :: FilePath -> IO ()
onFile FilePath
json_path = do
  s <- FilePath -> IO (Either FilePath ByteString)
readFileSafely FilePath
json_path
  case s of
    Left FilePath
a -> do
      Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr FilePath
a
      ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO ()) -> ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
2
    Right ByteString
s' ->
      case ByteString -> Either FilePath [BenchResult]
decodeBenchResults ByteString
s' of
        Left FilePath
_ ->
          case ByteString -> Maybe ProfilingReport
decodeProfilingReport ByteString
s' of
            Maybe ProfilingReport
Nothing -> do
              Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
                FilePath
"Cannot recognise " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
json_path FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" as benchmark results or a profiling report."
            Just ProfilingReport
pr ->
              FilePath -> ProfilingReport -> IO ()
analyseProfilingReport FilePath
json_path ProfilingReport
pr
        Right [BenchResult]
br -> FilePath -> [BenchResult] -> IO ()
analyseBenchResults FilePath
json_path [BenchResult]
br

-- | Run @futhark profile@.
main :: String -> [String] -> IO ()
main :: FilePath -> [FilePath] -> IO ()
main = ()
-> [FunOptDescr ()]
-> FilePath
-> ([FilePath] -> () -> Maybe (IO ()))
-> FilePath
-> [FilePath]
-> IO ()
forall cfg.
cfg
-> [FunOptDescr cfg]
-> FilePath
-> ([FilePath] -> cfg -> Maybe (IO ()))
-> FilePath
-> [FilePath]
-> IO ()
mainWithOptions () [] FilePath
"[files]" [FilePath] -> () -> Maybe (IO ())
forall {t :: * -> *}.
Foldable t =>
t FilePath -> () -> Maybe (IO ())
f
  where
    f :: t FilePath -> () -> Maybe (IO ())
f t FilePath
files () = IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$ (FilePath -> IO ()) -> t FilePath -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FilePath -> IO ()
onFile t FilePath
files