{-# LANGUAGE AllowAmbiguousTypes       #-}
{-# LANGUAGE ApplicativeDo             #-}
{-# LANGUAGE ConstraintKinds           #-}
{-# LANGUAGE DeriveAnyClass            #-}
{-# LANGUAGE DerivingStrategies        #-}
{-# LANGUAGE DuplicateRecordFields     #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE OverloadedStrings         #-}
{-# LANGUAGE RankNTypes                #-}
{-# LANGUAGE TypeFamilies              #-}

{- |
    This module provides a bunch of Shake rules to build multiple revisions of a
    project and analyse their performance.

    It assumes a project bench suite composed of examples that runs a fixed set
    of experiments on every example

    Your code must implement all of the GetFoo oracles and the IsExample class,
    instantiate the Shake rules, and probably 'want' a set of targets.

    The results of the benchmarks and the analysis are recorded in the file
    system, using the following structure:

    <build-folder>
    ├── binaries
    │   └── <git-reference>
    │        ├── ghc.path                         - path to ghc used to build the executable
    │        └── <executable>                     - binary for this version
    │        └── commitid                         - Git commit id for this reference
    ├─ <example>
    │   ├── results.csv                           - aggregated results for all the versions
    │   └── <git-reference>
    │       ├── <experiment>.gcStats.log          - RTS -s output
    │       ├── <experiment>.csv                  - stats for the experiment
    │       ├── <experiment>.svg                  - Graph of bytes over elapsed time
    │       ├── <experiment>.diff.svg             - idem, including the previous version
    │       ├── <experiment>.heap.svg             - Heap profile
    │       ├── <experiment>.log                  - bench stdout
    │       └── results.csv                       - results of all the experiments for the example
    ├── results.csv        - aggregated results of all the experiments and versions
    └── <experiment>.svg   - graph of bytes over elapsed time, for all the included versions

   For diff graphs, the "previous version" is the preceding entry in the list of versions
   in the config file. A possible improvement is to obtain this info via `git rev-list`.
 -}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module Development.Benchmark.Rules
  (
      buildRules, MkBuildRules(..),
      benchRules, MkBenchRules(..), BenchProject(..), ProfilingMode(..),
      csvRules,
      svgRules,
      heapProfileRules,
      phonyRules,
      allTargetsForExample,
      GetExample(..), GetExamples(..),
      IsExample(..), RuleResultForExample,
      GetExperiments(..),
      GetVersions(..),
      GetCommitId(..),
      GetBuildSystem(..),
      BuildSystem(..), findGhcForBuildSystem,
      Escaped(..), Unescaped(..), escapeExperiment, unescapeExperiment,
      GitCommit

  ) where

import           Control.Applicative
import           Control.Lens                              ((^.))
import           Control.Monad
import           Data.Aeson                                (FromJSON (..),
                                                            ToJSON (..),
                                                            Value (..), object,
                                                            (.!=), (.:?), (.=))
import           Data.Aeson.Lens                           (_Object)
import           Data.Char                                 (isDigit)
import           Data.List                                 (find, isInfixOf,
                                                            stripPrefix,
                                                            transpose)
import           Data.List.Extra                           (lower)
import           Data.Maybe                                (fromMaybe)
import           Data.String                               (fromString)
import           Data.Text                                 (Text)
import qualified Data.Text                                 as T
import           Development.Shake
import           Development.Shake.Classes                 (Binary, Hashable,
                                                            NFData, Typeable)
import           GHC.Exts                                  (IsList (toList),
                                                            fromList)
import           GHC.Generics                              (Generic)
import           GHC.Stack                                 (HasCallStack)
import qualified Graphics.Rendering.Chart.Backend.Diagrams as E
import qualified Graphics.Rendering.Chart.Easy             as E
import           System.Directory                          (createDirectoryIfMissing,
                                                            findExecutable,
                                                            renameFile)
import           System.FilePath
import           System.Time.Extra                         (Seconds)
import qualified Text.ParserCombinators.ReadP              as P
import           Text.Printf
import           Text.Read                                 (Read (..), get,
                                                            readMaybe,
                                                            readP_to_Prec)

newtype GetExperiments = GetExperiments () deriving newtype (Get GetExperiments
[GetExperiments] -> Put
GetExperiments -> Put
(GetExperiments -> Put)
-> Get GetExperiments
-> ([GetExperiments] -> Put)
-> Binary GetExperiments
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [GetExperiments] -> Put
$cputList :: [GetExperiments] -> Put
get :: Get GetExperiments
$cget :: Get GetExperiments
put :: GetExperiments -> Put
$cput :: GetExperiments -> Put
Binary, GetExperiments -> GetExperiments -> Bool
(GetExperiments -> GetExperiments -> Bool)
-> (GetExperiments -> GetExperiments -> Bool) -> Eq GetExperiments
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GetExperiments -> GetExperiments -> Bool
$c/= :: GetExperiments -> GetExperiments -> Bool
== :: GetExperiments -> GetExperiments -> Bool
$c== :: GetExperiments -> GetExperiments -> Bool
Eq, Eq GetExperiments
Eq GetExperiments
-> (Int -> GetExperiments -> Int)
-> (GetExperiments -> Int)
-> Hashable GetExperiments
Int -> GetExperiments -> Int
GetExperiments -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: GetExperiments -> Int
$chash :: GetExperiments -> Int
hashWithSalt :: Int -> GetExperiments -> Int
$chashWithSalt :: Int -> GetExperiments -> Int
$cp1Hashable :: Eq GetExperiments
Hashable, GetExperiments -> ()
(GetExperiments -> ()) -> NFData GetExperiments
forall a. (a -> ()) -> NFData a
rnf :: GetExperiments -> ()
$crnf :: GetExperiments -> ()
NFData, Int -> GetExperiments -> ShowS
[GetExperiments] -> ShowS
GetExperiments -> String
(Int -> GetExperiments -> ShowS)
-> (GetExperiments -> String)
-> ([GetExperiments] -> ShowS)
-> Show GetExperiments
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GetExperiments] -> ShowS
$cshowList :: [GetExperiments] -> ShowS
show :: GetExperiments -> String
$cshow :: GetExperiments -> String
showsPrec :: Int -> GetExperiments -> ShowS
$cshowsPrec :: Int -> GetExperiments -> ShowS
Show)
newtype GetVersions = GetVersions () deriving newtype (Get GetVersions
[GetVersions] -> Put
GetVersions -> Put
(GetVersions -> Put)
-> Get GetVersions -> ([GetVersions] -> Put) -> Binary GetVersions
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [GetVersions] -> Put
$cputList :: [GetVersions] -> Put
get :: Get GetVersions
$cget :: Get GetVersions
put :: GetVersions -> Put
$cput :: GetVersions -> Put
Binary, GetVersions -> GetVersions -> Bool
(GetVersions -> GetVersions -> Bool)
-> (GetVersions -> GetVersions -> Bool) -> Eq GetVersions
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GetVersions -> GetVersions -> Bool
$c/= :: GetVersions -> GetVersions -> Bool
== :: GetVersions -> GetVersions -> Bool
$c== :: GetVersions -> GetVersions -> Bool
Eq, Eq GetVersions
Eq GetVersions
-> (Int -> GetVersions -> Int)
-> (GetVersions -> Int)
-> Hashable GetVersions
Int -> GetVersions -> Int
GetVersions -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: GetVersions -> Int
$chash :: GetVersions -> Int
hashWithSalt :: Int -> GetVersions -> Int
$chashWithSalt :: Int -> GetVersions -> Int
$cp1Hashable :: Eq GetVersions
Hashable, GetVersions -> ()
(GetVersions -> ()) -> NFData GetVersions
forall a. (a -> ()) -> NFData a
rnf :: GetVersions -> ()
$crnf :: GetVersions -> ()
NFData, Int -> GetVersions -> ShowS
[GetVersions] -> ShowS
GetVersions -> String
(Int -> GetVersions -> ShowS)
-> (GetVersions -> String)
-> ([GetVersions] -> ShowS)
-> Show GetVersions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GetVersions] -> ShowS
$cshowList :: [GetVersions] -> ShowS
show :: GetVersions -> String
$cshow :: GetVersions -> String
showsPrec :: Int -> GetVersions -> ShowS
$cshowsPrec :: Int -> GetVersions -> ShowS
Show)
newtype GetParent = GetParent Text deriving newtype (Get GetParent
[GetParent] -> Put
GetParent -> Put
(GetParent -> Put)
-> Get GetParent -> ([GetParent] -> Put) -> Binary GetParent
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [GetParent] -> Put
$cputList :: [GetParent] -> Put
get :: Get GetParent
$cget :: Get GetParent
put :: GetParent -> Put
$cput :: GetParent -> Put
Binary, GetParent -> GetParent -> Bool
(GetParent -> GetParent -> Bool)
-> (GetParent -> GetParent -> Bool) -> Eq GetParent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GetParent -> GetParent -> Bool
$c/= :: GetParent -> GetParent -> Bool
== :: GetParent -> GetParent -> Bool
$c== :: GetParent -> GetParent -> Bool
Eq, Eq GetParent
Eq GetParent
-> (Int -> GetParent -> Int)
-> (GetParent -> Int)
-> Hashable GetParent
Int -> GetParent -> Int
GetParent -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: GetParent -> Int
$chash :: GetParent -> Int
hashWithSalt :: Int -> GetParent -> Int
$chashWithSalt :: Int -> GetParent -> Int
$cp1Hashable :: Eq GetParent
Hashable, GetParent -> ()
(GetParent -> ()) -> NFData GetParent
forall a. (a -> ()) -> NFData a
rnf :: GetParent -> ()
$crnf :: GetParent -> ()
NFData, Int -> GetParent -> ShowS
[GetParent] -> ShowS
GetParent -> String
(Int -> GetParent -> ShowS)
-> (GetParent -> String)
-> ([GetParent] -> ShowS)
-> Show GetParent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GetParent] -> ShowS
$cshowList :: [GetParent] -> ShowS
show :: GetParent -> String
$cshow :: GetParent -> String
showsPrec :: Int -> GetParent -> ShowS
$cshowsPrec :: Int -> GetParent -> ShowS
Show)
newtype GetCommitId = GetCommitId String deriving newtype (Get GetCommitId
[GetCommitId] -> Put
GetCommitId -> Put
(GetCommitId -> Put)
-> Get GetCommitId -> ([GetCommitId] -> Put) -> Binary GetCommitId
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [GetCommitId] -> Put
$cputList :: [GetCommitId] -> Put
get :: Get GetCommitId
$cget :: Get GetCommitId
put :: GetCommitId -> Put
$cput :: GetCommitId -> Put
Binary, GetCommitId -> GetCommitId -> Bool
(GetCommitId -> GetCommitId -> Bool)
-> (GetCommitId -> GetCommitId -> Bool) -> Eq GetCommitId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GetCommitId -> GetCommitId -> Bool
$c/= :: GetCommitId -> GetCommitId -> Bool
== :: GetCommitId -> GetCommitId -> Bool
$c== :: GetCommitId -> GetCommitId -> Bool
Eq, Eq GetCommitId
Eq GetCommitId
-> (Int -> GetCommitId -> Int)
-> (GetCommitId -> Int)
-> Hashable GetCommitId
Int -> GetCommitId -> Int
GetCommitId -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: GetCommitId -> Int
$chash :: GetCommitId -> Int
hashWithSalt :: Int -> GetCommitId -> Int
$chashWithSalt :: Int -> GetCommitId -> Int
$cp1Hashable :: Eq GetCommitId
Hashable, GetCommitId -> ()
(GetCommitId -> ()) -> NFData GetCommitId
forall a. (a -> ()) -> NFData a
rnf :: GetCommitId -> ()
$crnf :: GetCommitId -> ()
NFData, Int -> GetCommitId -> ShowS
[GetCommitId] -> ShowS
GetCommitId -> String
(Int -> GetCommitId -> ShowS)
-> (GetCommitId -> String)
-> ([GetCommitId] -> ShowS)
-> Show GetCommitId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GetCommitId] -> ShowS
$cshowList :: [GetCommitId] -> ShowS
show :: GetCommitId -> String
$cshow :: GetCommitId -> String
showsPrec :: Int -> GetCommitId -> ShowS
$cshowsPrec :: Int -> GetCommitId -> ShowS
Show)
newtype GetBuildSystem = GetBuildSystem () deriving newtype (Get GetBuildSystem
[GetBuildSystem] -> Put
GetBuildSystem -> Put
(GetBuildSystem -> Put)
-> Get GetBuildSystem
-> ([GetBuildSystem] -> Put)
-> Binary GetBuildSystem
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [GetBuildSystem] -> Put
$cputList :: [GetBuildSystem] -> Put
get :: Get GetBuildSystem
$cget :: Get GetBuildSystem
put :: GetBuildSystem -> Put
$cput :: GetBuildSystem -> Put
Binary, GetBuildSystem -> GetBuildSystem -> Bool
(GetBuildSystem -> GetBuildSystem -> Bool)
-> (GetBuildSystem -> GetBuildSystem -> Bool) -> Eq GetBuildSystem
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GetBuildSystem -> GetBuildSystem -> Bool
$c/= :: GetBuildSystem -> GetBuildSystem -> Bool
== :: GetBuildSystem -> GetBuildSystem -> Bool
$c== :: GetBuildSystem -> GetBuildSystem -> Bool
Eq, Eq GetBuildSystem
Eq GetBuildSystem
-> (Int -> GetBuildSystem -> Int)
-> (GetBuildSystem -> Int)
-> Hashable GetBuildSystem
Int -> GetBuildSystem -> Int
GetBuildSystem -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: GetBuildSystem -> Int
$chash :: GetBuildSystem -> Int
hashWithSalt :: Int -> GetBuildSystem -> Int
$chashWithSalt :: Int -> GetBuildSystem -> Int
$cp1Hashable :: Eq GetBuildSystem
Hashable, GetBuildSystem -> ()
(GetBuildSystem -> ()) -> NFData GetBuildSystem
forall a. (a -> ()) -> NFData a
rnf :: GetBuildSystem -> ()
$crnf :: GetBuildSystem -> ()
NFData, Int -> GetBuildSystem -> ShowS
[GetBuildSystem] -> ShowS
GetBuildSystem -> String
(Int -> GetBuildSystem -> ShowS)
-> (GetBuildSystem -> String)
-> ([GetBuildSystem] -> ShowS)
-> Show GetBuildSystem
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GetBuildSystem] -> ShowS
$cshowList :: [GetBuildSystem] -> ShowS
show :: GetBuildSystem -> String
$cshow :: GetBuildSystem -> String
showsPrec :: Int -> GetBuildSystem -> ShowS
$cshowsPrec :: Int -> GetBuildSystem -> ShowS
Show)
newtype GetExample = GetExample String deriving newtype (Get GetExample
[GetExample] -> Put
GetExample -> Put
(GetExample -> Put)
-> Get GetExample -> ([GetExample] -> Put) -> Binary GetExample
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [GetExample] -> Put
$cputList :: [GetExample] -> Put
get :: Get GetExample
$cget :: Get GetExample
put :: GetExample -> Put
$cput :: GetExample -> Put
Binary, GetExample -> GetExample -> Bool
(GetExample -> GetExample -> Bool)
-> (GetExample -> GetExample -> Bool) -> Eq GetExample
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GetExample -> GetExample -> Bool
$c/= :: GetExample -> GetExample -> Bool
== :: GetExample -> GetExample -> Bool
$c== :: GetExample -> GetExample -> Bool
Eq, Eq GetExample
Eq GetExample
-> (Int -> GetExample -> Int)
-> (GetExample -> Int)
-> Hashable GetExample
Int -> GetExample -> Int
GetExample -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: GetExample -> Int
$chash :: GetExample -> Int
hashWithSalt :: Int -> GetExample -> Int
$chashWithSalt :: Int -> GetExample -> Int
$cp1Hashable :: Eq GetExample
Hashable, GetExample -> ()
(GetExample -> ()) -> NFData GetExample
forall a. (a -> ()) -> NFData a
rnf :: GetExample -> ()
$crnf :: GetExample -> ()
NFData, Int -> GetExample -> ShowS
[GetExample] -> ShowS
GetExample -> String
(Int -> GetExample -> ShowS)
-> (GetExample -> String)
-> ([GetExample] -> ShowS)
-> Show GetExample
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GetExample] -> ShowS
$cshowList :: [GetExample] -> ShowS
show :: GetExample -> String
$cshow :: GetExample -> String
showsPrec :: Int -> GetExample -> ShowS
$cshowsPrec :: Int -> GetExample -> ShowS
Show)
newtype GetExamples = GetExamples () deriving newtype (Get GetExamples
[GetExamples] -> Put
GetExamples -> Put
(GetExamples -> Put)
-> Get GetExamples -> ([GetExamples] -> Put) -> Binary GetExamples
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [GetExamples] -> Put
$cputList :: [GetExamples] -> Put
get :: Get GetExamples
$cget :: Get GetExamples
put :: GetExamples -> Put
$cput :: GetExamples -> Put
Binary, GetExamples -> GetExamples -> Bool
(GetExamples -> GetExamples -> Bool)
-> (GetExamples -> GetExamples -> Bool) -> Eq GetExamples
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GetExamples -> GetExamples -> Bool
$c/= :: GetExamples -> GetExamples -> Bool
== :: GetExamples -> GetExamples -> Bool
$c== :: GetExamples -> GetExamples -> Bool
Eq, Eq GetExamples
Eq GetExamples
-> (Int -> GetExamples -> Int)
-> (GetExamples -> Int)
-> Hashable GetExamples
Int -> GetExamples -> Int
GetExamples -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: GetExamples -> Int
$chash :: GetExamples -> Int
hashWithSalt :: Int -> GetExamples -> Int
$chashWithSalt :: Int -> GetExamples -> Int
$cp1Hashable :: Eq GetExamples
Hashable, GetExamples -> ()
(GetExamples -> ()) -> NFData GetExamples
forall a. (a -> ()) -> NFData a
rnf :: GetExamples -> ()
$crnf :: GetExamples -> ()
NFData, Int -> GetExamples -> ShowS
[GetExamples] -> ShowS
GetExamples -> String
(Int -> GetExamples -> ShowS)
-> (GetExamples -> String)
-> ([GetExamples] -> ShowS)
-> Show GetExamples
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GetExamples] -> ShowS
$cshowList :: [GetExamples] -> ShowS
show :: GetExamples -> String
$cshow :: GetExamples -> String
showsPrec :: Int -> GetExamples -> ShowS
$cshowsPrec :: Int -> GetExamples -> ShowS
Show)

type instance RuleResult GetExperiments = [Unescaped String]
type instance RuleResult GetVersions = [GitCommit]
type instance RuleResult GetParent = Text
type instance RuleResult GetCommitId = String
type instance RuleResult GetBuildSystem = BuildSystem

type RuleResultForExample e =
    ( RuleResult GetExample ~ Maybe e
    , RuleResult GetExamples ~ [e]
    , IsExample e)

-- | Knowledge needed to run an example

class (Binary e, Eq e, Hashable e, NFData e, Show e, Typeable e) => IsExample e where
    getExampleName :: e -> String

--------------------------------------------------------------------------------


allTargetsForExample :: IsExample e => ProfilingMode -> FilePath -> e -> Action [FilePath]
allTargetsForExample :: ProfilingMode -> String -> e -> Action [String]
allTargetsForExample ProfilingMode
prof String
baseFolder e
ex = do
    [Unescaped String]
experiments <- GetExperiments -> Action [Unescaped String]
forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
q -> Action a
askOracle (GetExperiments -> Action [Unescaped String])
-> GetExperiments -> Action [Unescaped String]
forall a b. (a -> b) -> a -> b
$ () -> GetExperiments
GetExperiments ()
    [GitCommit]
versions    <- GetVersions -> Action [GitCommit]
forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
q -> Action a
askOracle (GetVersions -> Action [GitCommit])
-> GetVersions -> Action [GitCommit]
forall a b. (a -> b) -> a -> b
$ () -> GetVersions
GetVersions ()
    let buildFolder :: String
buildFolder = String
baseFolder String -> ShowS
</> ProfilingMode -> String
profilingPath ProfilingMode
prof
    return $
        [String
buildFolder String -> ShowS
</> e -> String
forall e. IsExample e => e -> String
getExampleName e
ex String -> ShowS
</> String
"results.csv"]
        [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ String
buildFolder String -> ShowS
</> e -> String
forall e. IsExample e => e -> String
getExampleName e
ex String -> ShowS
</> Escaped String -> String
forall a. Escaped a -> a
escaped (Unescaped String -> Escaped String
escapeExperiment Unescaped String
e) String -> ShowS
<.> String
"svg"
             | Unescaped String
e <- [Unescaped String]
experiments
           ]
        [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ String
buildFolder String -> ShowS
</>
             e -> String
forall e. IsExample e => e -> String
getExampleName e
ex String -> ShowS
</>
             Text -> String
T.unpack (GitCommit -> Text
humanName GitCommit
ver) String -> ShowS
</>
             Escaped String -> String
forall a. Escaped a -> a
escaped (Unescaped String -> Escaped String
escapeExperiment Unescaped String
e) String -> ShowS
<.> String
mode
             | Unescaped String
e <- [Unescaped String]
experiments,
               GitCommit
ver <- [GitCommit]
versions,
               String
mode <- [String
"svg", String
"diff.svg"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"heap.svg" | ProfilingMode
prof ProfilingMode -> ProfilingMode -> Bool
forall a. Eq a => a -> a -> Bool
/= ProfilingMode
NoProfiling]
           ]

allBinaries :: FilePath -> String -> Action [FilePath]
allBinaries :: String -> String -> Action [String]
allBinaries String
buildFolder String
executableName = do
    [GitCommit]
versions <- GetVersions -> Action [GitCommit]
forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
q -> Action a
askOracle (GetVersions -> Action [GitCommit])
-> GetVersions -> Action [GitCommit]
forall a b. (a -> b) -> a -> b
$ () -> GetVersions
GetVersions ()
    return $
        [ String
buildFolder String -> ShowS
</> String
"binaries" String -> ShowS
</> Text -> String
T.unpack (GitCommit -> Text
humanName GitCommit
ver) String -> ShowS
</> String
executableName
        | GitCommit
ver <- [GitCommit]
versions]

-- | Generate a set of phony rules:

--     * <prefix>all

--     * <prefix><example>  for each example

phonyRules
    :: (Traversable t, IsExample e)
    => String         -- ^ prefix

    -> String         -- ^ Executable name

    -> ProfilingMode
    -> FilePath
    -> t e
    -> Rules ()
phonyRules :: String -> String -> ProfilingMode -> String -> t e -> Rules ()
phonyRules String
prefix String
executableName ProfilingMode
prof String
buildFolder t e
examples = do
    t e -> (e -> Rules ()) -> Rules ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ t e
examples ((e -> Rules ()) -> Rules ()) -> (e -> Rules ()) -> Rules ()
forall a b. (a -> b) -> a -> b
$ \e
ex ->
        Located => String -> Action () -> Rules ()
String -> Action () -> Rules ()
phony (String
prefix String -> ShowS
forall a. Semigroup a => a -> a -> a
<> e -> String
forall e. IsExample e => e -> String
getExampleName e
ex) (Action () -> Rules ()) -> Action () -> Rules ()
forall a b. (a -> b) -> a -> b
$ Located => [String] -> Action ()
[String] -> Action ()
need ([String] -> Action ()) -> Action [String] -> Action ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
            ProfilingMode -> String -> e -> Action [String]
forall e.
IsExample e =>
ProfilingMode -> String -> e -> Action [String]
allTargetsForExample ProfilingMode
prof String
buildFolder e
ex
    Located => String -> Action () -> Rules ()
String -> Action () -> Rules ()
phony (String
prefix String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"all") (Action () -> Rules ()) -> Action () -> Rules ()
forall a b. (a -> b) -> a -> b
$ do
        t [String]
exampleTargets <- t e -> (e -> Action [String]) -> Action (t [String])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM t e
examples ((e -> Action [String]) -> Action (t [String]))
-> (e -> Action [String]) -> Action (t [String])
forall a b. (a -> b) -> a -> b
$ \e
ex ->
            ProfilingMode -> String -> e -> Action [String]
forall e.
IsExample e =>
ProfilingMode -> String -> e -> Action [String]
allTargetsForExample ProfilingMode
prof String
buildFolder e
ex
        Located => [String] -> Action ()
[String] -> Action ()
need ([String] -> Action ()) -> [String] -> Action ()
forall a b. (a -> b) -> a -> b
$ (String
buildFolder String -> ShowS
</> ProfilingMode -> String
profilingPath ProfilingMode
prof String -> ShowS
</> String
"results.csv")
             String -> [String] -> [String]
forall a. a -> [a] -> [a]
: t [String] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat t [String]
exampleTargets
    Located => String -> Action () -> Rules ()
String -> Action () -> Rules ()
phony (String
prefix String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"all-binaries") (Action () -> Rules ()) -> Action () -> Rules ()
forall a b. (a -> b) -> a -> b
$ Located => [String] -> Action ()
[String] -> Action ()
need ([String] -> Action ()) -> Action [String] -> Action ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> String -> Action [String]
allBinaries String
buildFolder String
executableName
--------------------------------------------------------------------------------

type OutputFolder = FilePath

data MkBuildRules buildSystem = MkBuildRules
  { -- | Return the path to the GHC executable to use for the project found in the cwd

    MkBuildRules buildSystem -> buildSystem -> String -> IO String
findGhc            :: buildSystem -> FilePath -> IO FilePath
    -- | Name of the binary produced by 'buildProject'

  , MkBuildRules buildSystem -> String
executableName     :: String
    -- | An action that captures the source dependencies, used for the HEAD build

  , MkBuildRules buildSystem -> Action ()
projectDepends     :: Action ()
    -- | Build the project found in the cwd and save the build artifacts in the output folder

  , MkBuildRules buildSystem
-> buildSystem -> [CmdOption] -> String -> Action ()
buildProject       :: buildSystem
                       -> [CmdOption]
                       -> OutputFolder
                       -> Action ()
  }

-- | Rules that drive a build system to build various revisions of a project

buildRules :: FilePattern -> MkBuildRules BuildSystem -> Rules ()
-- TODO generalize BuildSystem

buildRules :: String -> MkBuildRules BuildSystem -> Rules ()
buildRules String
build MkBuildRules{String
Action ()
BuildSystem -> String -> IO String
BuildSystem -> [CmdOption] -> String -> Action ()
buildProject :: BuildSystem -> [CmdOption] -> String -> Action ()
projectDepends :: Action ()
executableName :: String
findGhc :: BuildSystem -> String -> IO String
$sel:buildProject:MkBuildRules :: forall buildSystem.
MkBuildRules buildSystem
-> buildSystem -> [CmdOption] -> String -> Action ()
$sel:projectDepends:MkBuildRules :: forall buildSystem. MkBuildRules buildSystem -> Action ()
$sel:executableName:MkBuildRules :: forall buildSystem. MkBuildRules buildSystem -> String
$sel:findGhc:MkBuildRules :: forall buildSystem.
MkBuildRules buildSystem -> buildSystem -> String -> IO String
..} = do
  -- query git for the commitid for a version

  String
build String -> ShowS
-/- String
"binaries/*/commitid" Located => String -> (String -> Action ()) -> Rules ()
String -> (String -> Action ()) -> Rules ()
%> \String
out -> do
      Action ()
alwaysRerun

      let [String
_,String
_,String
ver,String
_] = String -> [String]
splitDirectories String
out
      Maybe GitCommit
mbEntry <- (GitCommit -> Bool) -> [GitCommit] -> Maybe GitCommit
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Text
T.pack String
ver) (Text -> Bool) -> (GitCommit -> Text) -> GitCommit -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GitCommit -> Text
humanName) ([GitCommit] -> Maybe GitCommit)
-> Action [GitCommit] -> Action (Maybe GitCommit)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GetVersions -> Action [GitCommit]
forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
q -> Action a
askOracle (() -> GetVersions
GetVersions ())
      let gitThing :: String
          gitThing :: String
gitThing = String -> (GitCommit -> String) -> Maybe GitCommit -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
ver (Text -> String
T.unpack (Text -> String) -> (GitCommit -> Text) -> GitCommit -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GitCommit -> Text
gitName) Maybe GitCommit
mbEntry
      Stdout String
commitid <- [CmdOption] -> String -> [String] -> Action (Stdout String)
forall r.
(Located, CmdResult r) =>
[CmdOption] -> String -> [String] -> Action r
command [] String
"git" [String
"rev-list", String
"-n", String
"1", String
gitThing]
      String -> String -> Action ()
forall (m :: * -> *).
(MonadIO m, Located) =>
String -> String -> m ()
writeFileChanged String
out (String -> Action ()) -> String -> Action ()
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. [a] -> [a]
init String
commitid

  -- build rules for HEAD

  Double -> Rules () -> Rules ()
forall a. Double -> Rules a -> Rules a
priority Double
10 (Rules () -> Rules ()) -> Rules () -> Rules ()
forall a b. (a -> b) -> a -> b
$ [ String
build String -> ShowS
-/- String
"binaries/HEAD/" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
executableName
                , String
build String -> ShowS
-/- String
"binaries/HEAD/ghc.path"
                ]
    Located => [String] -> ([String] -> Action ()) -> Rules ()
[String] -> ([String] -> Action ()) -> Rules ()
&%> \[String
out, String
ghcpath] -> do
      Action ()
projectDepends
      IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ShowS
dropFileName String
out
      BuildSystem
buildSystem <- GetBuildSystem -> Action BuildSystem
forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
q -> Action a
askOracle (GetBuildSystem -> Action BuildSystem)
-> GetBuildSystem -> Action BuildSystem
forall a b. (a -> b) -> a -> b
$ () -> GetBuildSystem
GetBuildSystem ()
      BuildSystem -> [CmdOption] -> String -> Action ()
buildProject BuildSystem
buildSystem [String -> CmdOption
Cwd String
"."] (ShowS
takeDirectory String
out)
      String
ghcLoc <- IO String -> Action String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> Action String) -> IO String -> Action String
forall a b. (a -> b) -> a -> b
$ BuildSystem -> String -> IO String
findGhc BuildSystem
buildSystem String
"."
      String -> String -> Action ()
forall (m :: * -> *).
(MonadIO m, Located) =>
String -> String -> m ()
writeFile' String
ghcpath String
ghcLoc

  -- build rules for non HEAD revisions

  [String
build String -> ShowS
-/- String
"binaries/*/" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
executableName
   ,String
build String -> ShowS
-/- String
"binaries/*/ghc.path"
   ] Located => [String] -> ([String] -> Action ()) -> Rules ()
[String] -> ([String] -> Action ()) -> Rules ()
&%> \[String
out, String
ghcPath] -> do
      let [String
_, String
_binaries, String
ver, String
_] = String -> [String]
splitDirectories String
out
      IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ShowS
dropFileName String
out
      String
commitid <- Located => String -> Action String
String -> Action String
readFile' (String -> Action String) -> String -> Action String
forall a b. (a -> b) -> a -> b
$ ShowS
takeDirectory String
out String -> ShowS
</> String
"commitid"
      String -> Action ()
forall args. (Located, CmdArguments args, Unit args) => args
cmd_ (String -> Action ()) -> String -> Action ()
forall a b. (a -> b) -> a -> b
$ String
"git worktree add bench-temp-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ver String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
commitid
      BuildSystem
buildSystem <- GetBuildSystem -> Action BuildSystem
forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
q -> Action a
askOracle (GetBuildSystem -> Action BuildSystem)
-> GetBuildSystem -> Action BuildSystem
forall a b. (a -> b) -> a -> b
$ () -> GetBuildSystem
GetBuildSystem ()
      (Action () -> IO () -> Action ())
-> IO () -> Action () -> Action ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Action () -> IO () -> Action ()
forall a b. Action a -> IO b -> Action a
actionFinally (String -> IO ()
forall args. (Located, CmdArguments args, Unit args) => args
cmd_ (String
"git worktree remove bench-temp-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
ver String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" --force" :: String)) (Action () -> Action ()) -> Action () -> Action ()
forall a b. (a -> b) -> a -> b
$ do
        String
ghcLoc <- IO String -> Action String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> Action String) -> IO String -> Action String
forall a b. (a -> b) -> a -> b
$ BuildSystem -> String -> IO String
findGhc BuildSystem
buildSystem String
ver
        BuildSystem -> [CmdOption] -> String -> Action ()
buildProject BuildSystem
buildSystem [String -> CmdOption
Cwd (String -> CmdOption) -> String -> CmdOption
forall a b. (a -> b) -> a -> b
$ String
"bench-temp-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
ver] (String
".." String -> ShowS
</> ShowS
takeDirectory String
out)
        String -> String -> Action ()
forall (m :: * -> *).
(MonadIO m, Located) =>
String -> String -> m ()
writeFile' String
ghcPath String
ghcLoc

--------------------------------------------------------------------------------

data MkBenchRules buildSystem example =  forall setup. MkBenchRules
  {
  -- | Workaround for Shake not allowing to call 'askOracle' from 'benchProject

    ()
setupProject :: Action setup
  -- | An action that invokes the executable to run the benchmark

  , ()
benchProject :: setup -> buildSystem -> [CmdOption] -> BenchProject example -> Action ()
  -- | An action that performs any necessary warmup. Will only be invoked once

  , MkBenchRules buildSystem example
-> buildSystem -> String -> [CmdOption] -> example -> Action ()
warmupProject :: buildSystem -> FilePath -> [CmdOption] -> example -> Action ()
  -- | Name of the executable to benchmark. Should match the one used to 'MkBuildRules'

  , MkBenchRules buildSystem example -> String
executableName :: String
  }

data BenchProject example = BenchProject
    { BenchProject example -> String
outcsv       :: FilePath         -- ^ where to save the CSV output

    , BenchProject example -> String
exePath      :: FilePath         -- ^ where to find the executable for benchmarking

    , BenchProject example -> [String]
exeExtraArgs :: [String]         -- ^ extra args for the executable

    , BenchProject example -> example
example      :: example          -- ^ example to benchmark

    , BenchProject example -> Escaped String
experiment   :: Escaped String   -- ^ experiment to run

    }

data ProfilingMode = NoProfiling | CheapHeapProfiling Seconds
    deriving (ProfilingMode -> ProfilingMode -> Bool
(ProfilingMode -> ProfilingMode -> Bool)
-> (ProfilingMode -> ProfilingMode -> Bool) -> Eq ProfilingMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ProfilingMode -> ProfilingMode -> Bool
$c/= :: ProfilingMode -> ProfilingMode -> Bool
== :: ProfilingMode -> ProfilingMode -> Bool
$c== :: ProfilingMode -> ProfilingMode -> Bool
Eq)

profilingP :: String -> Maybe ProfilingMode
profilingP :: String -> Maybe ProfilingMode
profilingP String
"unprofiled" = ProfilingMode -> Maybe ProfilingMode
forall a. a -> Maybe a
Just ProfilingMode
NoProfiling
profilingP String
inp | Just String
delay <- String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"profiled-" String
inp, Just Double
i <- String -> Maybe Double
forall a. Read a => String -> Maybe a
readMaybe String
delay = ProfilingMode -> Maybe ProfilingMode
forall a. a -> Maybe a
Just (ProfilingMode -> Maybe ProfilingMode)
-> ProfilingMode -> Maybe ProfilingMode
forall a b. (a -> b) -> a -> b
$ Double -> ProfilingMode
CheapHeapProfiling Double
i
profilingP String
_ = Maybe ProfilingMode
forall a. Maybe a
Nothing

profilingPath :: ProfilingMode -> FilePath
profilingPath :: ProfilingMode -> String
profilingPath ProfilingMode
NoProfiling            = String
"unprofiled"
profilingPath (CheapHeapProfiling Double
i) = String
"profiled-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Double -> String
forall a. Show a => a -> String
show Double
i

-- TODO generalize BuildSystem

benchRules :: RuleResultForExample example => FilePattern -> MkBenchRules BuildSystem example -> Rules ()
benchRules :: String -> MkBenchRules BuildSystem example -> Rules ()
benchRules String
build MkBenchRules{String
Action setup
setup
-> BuildSystem -> [CmdOption] -> BenchProject example -> Action ()
BuildSystem -> String -> [CmdOption] -> example -> Action ()
executableName :: String
warmupProject :: BuildSystem -> String -> [CmdOption] -> example -> Action ()
benchProject :: setup
-> BuildSystem -> [CmdOption] -> BenchProject example -> Action ()
setupProject :: Action setup
$sel:executableName:MkBenchRules :: forall buildSystem example.
MkBenchRules buildSystem example -> String
$sel:warmupProject:MkBenchRules :: forall buildSystem example.
MkBenchRules buildSystem example
-> buildSystem -> String -> [CmdOption] -> example -> Action ()
$sel:benchProject:MkBenchRules :: ()
$sel:setupProject:MkBenchRules :: ()
..} = do

  Resource
benchResource <- String -> Int -> Rules Resource
newResource String
"ghcide-bench" Int
1
  -- warmup an example

  String
build String -> ShowS
-/- String
"binaries/*/*.warmup" Located => String -> (String -> Action ()) -> Rules ()
String -> (String -> Action ()) -> Rules ()
%> \String
out -> do
        let [String
_, String
_, String
ver, String
exampleName] = String -> [String]
splitDirectories (ShowS
dropExtension String
out)
        let exePath :: String
exePath = String
build String -> ShowS
</> String
"binaries" String -> ShowS
</> String
ver String -> ShowS
</> String
executableName
            ghcPath :: String
ghcPath = String
build String -> ShowS
</> String
"binaries" String -> ShowS
</> String
ver String -> ShowS
</> String
"ghc.path"
        Located => [String] -> Action ()
[String] -> Action ()
need [String
exePath, String
ghcPath]
        BuildSystem
buildSystem <- GetBuildSystem -> Action BuildSystem
forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
q -> Action a
askOracle  (GetBuildSystem -> Action BuildSystem)
-> GetBuildSystem -> Action BuildSystem
forall a b. (a -> b) -> a -> b
$ () -> GetBuildSystem
GetBuildSystem ()
        example
example <- example -> Maybe example -> example
forall a. a -> Maybe a -> a
fromMaybe (String -> example
forall a. Located => String -> a
error (String -> example) -> String -> example
forall a b. (a -> b) -> a -> b
$ String
"Unknown example " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
exampleName)
                    (Maybe example -> example)
-> Action (Maybe example) -> Action example
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GetExample -> Action (Maybe example)
forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
q -> Action a
askOracle (String -> GetExample
GetExample String
exampleName)
        let exeExtraArgs :: [a]
exeExtraArgs = []
            outcsv :: String
outcsv = String
""
            experiment :: Escaped String
experiment = String -> Escaped String
forall a. a -> Escaped a
Escaped String
"hover"
        Resource -> Int -> Action () -> Action ()
forall a. Resource -> Int -> Action a -> Action a
withResource Resource
benchResource Int
1 (Action () -> Action ()) -> Action () -> Action ()
forall a b. (a -> b) -> a -> b
$ BuildSystem -> String -> [CmdOption] -> example -> Action ()
warmupProject BuildSystem
buildSystem String
exePath
              [ Bool -> CmdOption
EchoStdout Bool
False,
                String -> CmdOption
FileStdout String
out,
                String -> CmdOption
RemEnv String
"NIX_GHC_LIBDIR",
                String -> CmdOption
RemEnv String
"GHC_PACKAGE_PATH",
                [String] -> [String] -> CmdOption
AddPath [ShowS
takeDirectory String
ghcPath, String
"."] []
              ]
              example
example
  -- run an experiment

  Double -> Rules () -> Rules ()
forall a. Double -> Rules a -> Rules a
priority Double
0 (Rules () -> Rules ()) -> Rules () -> Rules ()
forall a b. (a -> b) -> a -> b
$
    [ String
build String -> ShowS
-/- String
"*/*/*/*.csv",
      String
build String -> ShowS
-/- String
"*/*/*/*.gcStats.log",
      String
build String -> ShowS
-/- String
"*/*/*/*.output.log",
      String
build String -> ShowS
-/- String
"*/*/*/*.eventlog",
      String
build String -> ShowS
-/- String
"*/*/*/*.hp"
    ] Located => [String] -> ([String] -> Action ()) -> Rules ()
[String] -> ([String] -> Action ()) -> Rules ()
&%> \[String
outcsv, String
outGc, String
outLog, String
outEventlog, String
outHp] -> do
        let [String
_, String
flavour, String
exampleName, String
ver, String
exp] = String -> [String]
splitDirectories String
outcsv
            prof :: ProfilingMode
prof = ProfilingMode -> Maybe ProfilingMode -> ProfilingMode
forall a. a -> Maybe a -> a
fromMaybe (String -> ProfilingMode
forall a. Located => String -> a
error (String -> ProfilingMode) -> String -> ProfilingMode
forall a b. (a -> b) -> a -> b
$ String
"Not a valid profiling mode: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
flavour) (Maybe ProfilingMode -> ProfilingMode)
-> Maybe ProfilingMode -> ProfilingMode
forall a b. (a -> b) -> a -> b
$ String -> Maybe ProfilingMode
profilingP String
flavour
        example
example <- example -> Maybe example -> example
forall a. a -> Maybe a -> a
fromMaybe (String -> example
forall a. Located => String -> a
error (String -> example) -> String -> example
forall a b. (a -> b) -> a -> b
$ String
"Unknown example " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
exampleName)
                    (Maybe example -> example)
-> Action (Maybe example) -> Action example
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GetExample -> Action (Maybe example)
forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
q -> Action a
askOracle (String -> GetExample
GetExample String
exampleName)
        BuildSystem
buildSystem <- GetBuildSystem -> Action BuildSystem
forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
q -> Action a
askOracle  (GetBuildSystem -> Action BuildSystem)
-> GetBuildSystem -> Action BuildSystem
forall a b. (a -> b) -> a -> b
$ () -> GetBuildSystem
GetBuildSystem ()
        setup
setupRes    <- Action setup
setupProject
        IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ShowS
dropFileName String
outcsv
        let exePath :: String
exePath    = String
build String -> ShowS
</> String
"binaries" String -> ShowS
</> String
ver String -> ShowS
</> String
executableName
            exeExtraArgs :: [String]
exeExtraArgs =
                [ String
"+RTS"
                , String
"-l"
                , String
"-S" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
outGc]
             [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                [[ String
"-h"
                  , String
"-i" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Double -> String
forall a. Show a => a -> String
show Double
i
                  , String
"-qg"]
                 | CheapHeapProfiling Double
i <- [ProfilingMode
prof]]
             [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"-RTS"]
            ghcPath :: String
ghcPath    = String
build String -> ShowS
</> String
"binaries" String -> ShowS
</> String
ver String -> ShowS
</> String
"ghc.path"
            warmupPath :: String
warmupPath = String
build String -> ShowS
</> String
"binaries" String -> ShowS
</> String
ver String -> ShowS
</> String
exampleName String -> ShowS
<.> String
"warmup"
            experiment :: Escaped String
experiment = String -> Escaped String
forall a. a -> Escaped a
Escaped (String -> Escaped String) -> String -> Escaped String
forall a b. (a -> b) -> a -> b
$ ShowS
dropExtension String
exp
        Located => [String] -> Action ()
[String] -> Action ()
need [String
exePath, String
ghcPath, String
warmupPath]
        String
ghcPath <- Located => String -> Action String
String -> Action String
readFile' String
ghcPath
        Resource -> Int -> Action () -> Action ()
forall a. Resource -> Int -> Action a -> Action a
withResource Resource
benchResource Int
1 (Action () -> Action ()) -> Action () -> Action ()
forall a b. (a -> b) -> a -> b
$ do
          setup
-> BuildSystem -> [CmdOption] -> BenchProject example -> Action ()
benchProject setup
setupRes BuildSystem
buildSystem
              [ Bool -> CmdOption
EchoStdout Bool
False,
                String -> CmdOption
FileStdout String
outLog,
                String -> CmdOption
RemEnv String
"NIX_GHC_LIBDIR",
                String -> CmdOption
RemEnv String
"GHC_PACKAGE_PATH",
                [String] -> [String] -> CmdOption
AddPath [ShowS
takeDirectory String
ghcPath, String
"."] []
              ]
              BenchProject :: forall example.
String
-> String
-> [String]
-> example
-> Escaped String
-> BenchProject example
BenchProject {example
String
[String]
Escaped String
experiment :: Escaped String
exeExtraArgs :: [String]
exePath :: String
example :: example
outcsv :: String
$sel:experiment:BenchProject :: Escaped String
$sel:example:BenchProject :: example
$sel:exeExtraArgs:BenchProject :: [String]
$sel:exePath:BenchProject :: String
$sel:outcsv:BenchProject :: String
..}
        IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
renameFile String
"ghcide.eventlog" String
outEventlog
        IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ case ProfilingMode
prof of
            CheapHeapProfiling{} -> String -> String -> IO ()
renameFile String
"ghcide.hp" String
outHp
            ProfilingMode
NoProfiling          -> String -> String -> IO ()
writeFile String
outHp String
dummyHp

        -- extend csv output with allocation data

        [String]
csvContents <- IO [String] -> Action [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> Action [String]) -> IO [String] -> Action [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines (String -> [String]) -> IO String -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
readFile String
outcsv
        let header :: String
header = [String] -> String
forall a. [a] -> a
head [String]
csvContents
            results :: [String]
results = [String] -> [String]
forall a. [a] -> [a]
tail [String]
csvContents
            header' :: String
header' = String
header String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", maxResidency, allocatedBytes"
        [String]
results' <- [String] -> (String -> Action String) -> Action [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
results ((String -> Action String) -> Action [String])
-> (String -> Action String) -> Action [String]
forall a b. (a -> b) -> a -> b
$ \String
row -> do
            (Int
maxResidency, Int
allocations) <- IO (Int, Int) -> Action (Int, Int)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
                    (String -> (Int, Int)
parseMaxResidencyAndAllocations (String -> (Int, Int)) -> IO String -> IO (Int, Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
readFile String
outGc)
            String -> Action String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Action String) -> String -> Action String
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"%s, %s, %s" String
row (Int -> String
showMB Int
maxResidency) (Int -> String
showMB Int
allocations)
        let csvContents' :: [String]
csvContents' = String
header' String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
results'
        String -> [String] -> Action ()
forall (m :: * -> *).
(MonadIO m, Located) =>
String -> [String] -> m ()
writeFileLines String
outcsv [String]
csvContents'
    where
        showMB :: Int -> String
        showMB :: Int -> String
showMB Int
x = Int -> String
forall a. Show a => a -> String
show (Int
x Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
20::Int)) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"MB"

-- Parse the max residency and allocations in RTS -s output

parseMaxResidencyAndAllocations :: String -> (Int, Int)
parseMaxResidencyAndAllocations :: String -> (Int, Int)
parseMaxResidencyAndAllocations String
input =
    (String -> Int
f String
"maximum residency", String -> Int
f String
"bytes allocated in the heap")
  where
    inps :: [String]
inps = [String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
input
    f :: String -> Int
f String
label = case (String -> Bool) -> [String] -> Maybe String
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (String
label String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf`) [String]
inps of
        Just String
l  -> String -> Int
forall a. Read a => String -> a
read (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
isDigit ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. [a] -> a
head ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> [String]
words String
l
        Maybe String
Nothing -> -Int
1


--------------------------------------------------------------------------------


-- | Rules to aggregate the CSV output of individual experiments

csvRules :: forall example . RuleResultForExample example => FilePattern -> Rules ()
csvRules :: String -> Rules ()
csvRules String
build = do
  -- build results for every experiment*example

  String
build String -> ShowS
-/- String
"*/*/*/results.csv" Located => String -> (String -> Action ()) -> Rules ()
String -> (String -> Action ()) -> Rules ()
%> \String
out -> do
      [Unescaped String]
experiments <- GetExperiments -> Action [Unescaped String]
forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
q -> Action a
askOracle (GetExperiments -> Action [Unescaped String])
-> GetExperiments -> Action [Unescaped String]
forall a b. (a -> b) -> a -> b
$ () -> GetExperiments
GetExperiments ()

      let allResultFiles :: [String]
allResultFiles = [ShowS
takeDirectory String
out String -> ShowS
</> Escaped String -> String
forall a. Escaped a -> a
escaped (Unescaped String -> Escaped String
escapeExperiment Unescaped String
e) String -> ShowS
<.> String
"csv" | Unescaped String
e <- [Unescaped String]
experiments]
      [[String]]
allResults <- (String -> Action [String]) -> [String] -> Action [[String]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Located => String -> Action [String]
String -> Action [String]
readFileLines [String]
allResultFiles

      let header :: String
header = [String] -> String
forall a. [a] -> a
head ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall a. [a] -> a
head [[String]]
allResults
          results :: [[String]]
results = ([String] -> [String]) -> [[String]] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map [String] -> [String]
forall a. [a] -> [a]
tail [[String]]
allResults
      String -> String -> Action ()
forall (m :: * -> *).
(MonadIO m, Located) =>
String -> String -> m ()
writeFileChanged String
out (String -> Action ()) -> String -> Action ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
header String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[String]]
results

  -- aggregate all experiments for an example

  String
build String -> ShowS
-/- String
"*/*/results.csv" Located => String -> (String -> Action ()) -> Rules ()
String -> (String -> Action ()) -> Rules ()
%> \String
out -> do
    [String]
versions <- (GitCommit -> String) -> [GitCommit] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
T.unpack (Text -> String) -> (GitCommit -> Text) -> GitCommit -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GitCommit -> Text
humanName) ([GitCommit] -> [String]) -> Action [GitCommit] -> Action [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GetVersions -> Action [GitCommit]
forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
q -> Action a
askOracle (() -> GetVersions
GetVersions ())
    let allResultFiles :: [String]
allResultFiles = [ShowS
takeDirectory String
out String -> ShowS
</> String
v String -> ShowS
</> String
"results.csv" | String
v <- [String]
versions]

    [[String]]
allResults <- (String -> Action [String]) -> [String] -> Action [[String]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Located => String -> Action [String]
String -> Action [String]
readFileLines [String]
allResultFiles

    let header :: String
header = [String] -> String
forall a. [a] -> a
head ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall a. [a] -> a
head [[String]]
allResults
        results :: [[String]]
results = ([String] -> [String]) -> [[String]] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map [String] -> [String]
forall a. [a] -> [a]
tail [[String]]
allResults
        header' :: String
header' = String
"version, " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
header
        results' :: [[String]]
results' = (String -> [String] -> [String])
-> [String] -> [[String]] -> [[String]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\String
v -> ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\String
l -> String
v String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
l)) [String]
versions [[String]]
results

    String -> String -> Action ()
forall (m :: * -> *).
(MonadIO m, Located) =>
String -> String -> m ()
writeFileChanged String
out (String -> Action ()) -> String -> Action ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
header' String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [[String]] -> [String]
forall a. [[a]] -> [a]
interleave [[String]]
results'

  -- aggregate all examples

  String
build String -> ShowS
-/- String
"*/results.csv" Located => String -> (String -> Action ()) -> Rules ()
String -> (String -> Action ()) -> Rules ()
%> \String
out -> do
    [String]
examples <- (example -> String) -> [example] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (IsExample example => example -> String
forall e. IsExample e => e -> String
getExampleName @example) ([example] -> [String]) -> Action [example] -> Action [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GetExamples -> Action [example]
forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
q -> Action a
askOracle (() -> GetExamples
GetExamples ())
    let allResultFiles :: [String]
allResultFiles = [ShowS
takeDirectory String
out String -> ShowS
</> String
e String -> ShowS
</> String
"results.csv" | String
e <- [String]
examples]

    [[String]]
allResults <- (String -> Action [String]) -> [String] -> Action [[String]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Located => String -> Action [String]
String -> Action [String]
readFileLines [String]
allResultFiles

    let header :: String
header = [String] -> String
forall a. [a] -> a
head ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall a. [a] -> a
head [[String]]
allResults
        results :: [[String]]
results = ([String] -> [String]) -> [[String]] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map [String] -> [String]
forall a. [a] -> [a]
tail [[String]]
allResults
        header' :: String
header' = String
"example, " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
header
        results' :: [[String]]
results' = (String -> [String] -> [String])
-> [String] -> [[String]] -> [[String]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\String
e -> ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\String
l -> String
e String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
l)) [String]
examples [[String]]
results

    String -> String -> Action ()
forall (m :: * -> *).
(MonadIO m, Located) =>
String -> String -> m ()
writeFileChanged String
out (String -> Action ()) -> String -> Action ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
header' String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[String]]
results'

--------------------------------------------------------------------------------


-- | Rules to produce charts for the GC stats

svgRules :: FilePattern -> Rules ()
svgRules :: String -> Rules ()
svgRules String
build = do
  Rules (GetParent -> Action Text) -> Rules ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Rules (GetParent -> Action Text) -> Rules ())
-> Rules (GetParent -> Action Text) -> Rules ()
forall a b. (a -> b) -> a -> b
$ (GetParent -> Action Text) -> Rules (GetParent -> Action Text)
forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a, Located) =>
(q -> Action a) -> Rules (q -> Action a)
addOracle ((GetParent -> Action Text) -> Rules (GetParent -> Action Text))
-> (GetParent -> Action Text) -> Rules (GetParent -> Action Text)
forall a b. (a -> b) -> a -> b
$ \(GetParent Text
name) -> Text -> [GitCommit] -> Text
findPrev Text
name ([GitCommit] -> Text) -> Action [GitCommit] -> Action Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GetVersions -> Action [GitCommit]
forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
q -> Action a
askOracle (() -> GetVersions
GetVersions ())
  -- chart GC stats for an experiment on a given revision

  Double -> Rules () -> Rules ()
forall a. Double -> Rules a -> Rules a
priority Double
1 (Rules () -> Rules ()) -> Rules () -> Rules ()
forall a b. (a -> b) -> a -> b
$
    String
build String -> ShowS
-/- String
"*/*/*/*.svg" Located => String -> (String -> Action ()) -> Rules ()
String -> (String -> Action ()) -> Rules ()
%> \String
out -> do
      let [String
_, String
_, String
_example, String
ver, String
_exp] = String -> [String]
splitDirectories String
out
      RunLog
runLog <- Located => Escaped String -> String -> Action RunLog
Escaped String -> String -> Action RunLog
loadRunLog (String -> Escaped String
forall a. a -> Escaped a
Escaped (String -> Escaped String) -> String -> Escaped String
forall a b. (a -> b) -> a -> b
$ String -> ShowS
replaceExtension String
out String
"csv") String
ver
      let diagram :: Diagram
diagram = TraceMetric -> [RunLog] -> String -> Diagram
Diagram TraceMetric
Live [RunLog
runLog] String
title
          title :: String
title = String
ver String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" live bytes over time"
      Bool -> Diagram -> String -> Action ()
plotDiagram Bool
True Diagram
diagram String
out

  -- chart of GC stats for an experiment on this and the previous revision

  Double -> Rules () -> Rules ()
forall a. Double -> Rules a -> Rules a
priority Double
2 (Rules () -> Rules ()) -> Rules () -> Rules ()
forall a b. (a -> b) -> a -> b
$
    String
build String -> ShowS
-/- String
"*/*/*/*.diff.svg" Located => String -> (String -> Action ()) -> Rules ()
String -> (String -> Action ()) -> Rules ()
%> \String
out -> do
      let [String
b, String
flav, String
example, String
ver, String
exp_] = String -> [String]
splitDirectories String
out
          exp :: Escaped String
exp = String -> Escaped String
forall a. a -> Escaped a
Escaped (String -> Escaped String) -> String -> Escaped String
forall a b. (a -> b) -> a -> b
$ ShowS
dropExtension2 String
exp_
      String
prev <- (Text -> String) -> Action Text -> Action String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> String
T.unpack (Action Text -> Action String) -> Action Text -> Action String
forall a b. (a -> b) -> a -> b
$ GetParent -> Action Text
forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
q -> Action a
askOracle (GetParent -> Action Text) -> GetParent -> Action Text
forall a b. (a -> b) -> a -> b
$ Text -> GetParent
GetParent (Text -> GetParent) -> Text -> GetParent
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
ver

      RunLog
runLog <- Located => Escaped String -> String -> Action RunLog
Escaped String -> String -> Action RunLog
loadRunLog (String -> Escaped String
forall a. a -> Escaped a
Escaped (String -> Escaped String) -> String -> Escaped String
forall a b. (a -> b) -> a -> b
$ String -> ShowS
replaceExtension (ShowS
dropExtension String
out) String
"csv") String
ver
      RunLog
runLogPrev <- Located => Escaped String -> String -> Action RunLog
Escaped String -> String -> Action RunLog
loadRunLog (String -> Escaped String
forall a. a -> Escaped a
Escaped (String -> Escaped String) -> String -> Escaped String
forall a b. (a -> b) -> a -> b
$ [String] -> String
joinPath [String
b,String
flav, String
example, String
prev, String -> ShowS
replaceExtension (ShowS
dropExtension String
exp_) String
"csv"]) String
prev

      let diagram :: Diagram
diagram = TraceMetric -> [RunLog] -> String -> Diagram
Diagram TraceMetric
Live [RunLog
runLog, RunLog
runLogPrev] String
title
          title :: String
title = Unescaped String -> String
forall a. Show a => a -> String
show (Escaped String -> Unescaped String
unescapeExperiment Escaped String
exp) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" - live bytes over time compared"
      Bool -> Diagram -> String -> Action ()
plotDiagram Bool
True Diagram
diagram String
out

  -- aggregated chart of GC stats for all the revisions

  String
build String -> ShowS
-/- String
"*/*/*.svg" Located => String -> (String -> Action ()) -> Rules ()
String -> (String -> Action ()) -> Rules ()
%> \String
out -> do
    let exp :: Escaped String
exp = String -> Escaped String
forall a. a -> Escaped a
Escaped (String -> Escaped String) -> String -> Escaped String
forall a b. (a -> b) -> a -> b
$ ShowS
dropExtension ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
takeFileName String
out
    [GitCommit]
versions <- GetVersions -> Action [GitCommit]
forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
q -> Action a
askOracle (GetVersions -> Action [GitCommit])
-> GetVersions -> Action [GitCommit]
forall a b. (a -> b) -> a -> b
$ () -> GetVersions
GetVersions ()

    [RunLog]
runLogs <- [GitCommit] -> (GitCommit -> Action RunLog) -> Action [RunLog]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ((GitCommit -> Bool) -> [GitCommit] -> [GitCommit]
forall a. (a -> Bool) -> [a] -> [a]
filter GitCommit -> Bool
include [GitCommit]
versions) ((GitCommit -> Action RunLog) -> Action [RunLog])
-> (GitCommit -> Action RunLog) -> Action [RunLog]
forall a b. (a -> b) -> a -> b
$ \GitCommit
v -> do
      let v' :: String
v' = Text -> String
T.unpack (GitCommit -> Text
humanName GitCommit
v)
      Located => Escaped String -> String -> Action RunLog
Escaped String -> String -> Action RunLog
loadRunLog (String -> Escaped String
forall a. a -> Escaped a
Escaped (String -> Escaped String) -> String -> Escaped String
forall a b. (a -> b) -> a -> b
$ ShowS
takeDirectory String
out String -> ShowS
</> String
v' String -> ShowS
</> String -> ShowS
replaceExtension (ShowS
takeFileName String
out) String
"csv") String
v'

    let diagram :: Diagram
diagram = TraceMetric -> [RunLog] -> String -> Diagram
Diagram TraceMetric
Live [RunLog]
runLogs String
title
        title :: String
title = Unescaped String -> String
forall a. Show a => a -> String
show (Escaped String -> Unescaped String
unescapeExperiment Escaped String
exp) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" - live bytes over time"
    Bool -> Diagram -> String -> Action ()
plotDiagram Bool
False Diagram
diagram String
out

heapProfileRules :: FilePattern -> Rules ()
heapProfileRules :: String -> Rules ()
heapProfileRules String
build = do
  Double -> Rules () -> Rules ()
forall a. Double -> Rules a -> Rules a
priority Double
3 (Rules () -> Rules ()) -> Rules () -> Rules ()
forall a b. (a -> b) -> a -> b
$
    String
build String -> ShowS
-/- String
"*/*/*/*.heap.svg" Located => String -> (String -> Action ()) -> Rules ()
String -> (String -> Action ()) -> Rules ()
%> \String
out -> do
      let hpFile :: String
hpFile = ShowS
dropExtension2 String
out String -> ShowS
<.> String
"hp"
      Located => [String] -> Action ()
[String] -> Action ()
need [String
hpFile]
      String -> [String] -> Action ()
forall args. (Located, CmdArguments args, Unit args) => args
cmd_ (String
"hp2pretty" :: String) [String
hpFile]
      IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
renameFile (ShowS
dropExtension String
hpFile String -> ShowS
<.> String
"svg") String
out

dropExtension2 :: FilePath -> FilePath
dropExtension2 :: ShowS
dropExtension2 = ShowS
dropExtension ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
dropExtension
--------------------------------------------------------------------------------

--------------------------------------------------------------------------------


-- | Default build system that handles Cabal and Stack

data BuildSystem = Cabal | Stack
  deriving (BuildSystem -> BuildSystem -> Bool
(BuildSystem -> BuildSystem -> Bool)
-> (BuildSystem -> BuildSystem -> Bool) -> Eq BuildSystem
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BuildSystem -> BuildSystem -> Bool
$c/= :: BuildSystem -> BuildSystem -> Bool
== :: BuildSystem -> BuildSystem -> Bool
$c== :: BuildSystem -> BuildSystem -> Bool
Eq, ReadPrec [BuildSystem]
ReadPrec BuildSystem
Int -> ReadS BuildSystem
ReadS [BuildSystem]
(Int -> ReadS BuildSystem)
-> ReadS [BuildSystem]
-> ReadPrec BuildSystem
-> ReadPrec [BuildSystem]
-> Read BuildSystem
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [BuildSystem]
$creadListPrec :: ReadPrec [BuildSystem]
readPrec :: ReadPrec BuildSystem
$creadPrec :: ReadPrec BuildSystem
readList :: ReadS [BuildSystem]
$creadList :: ReadS [BuildSystem]
readsPrec :: Int -> ReadS BuildSystem
$creadsPrec :: Int -> ReadS BuildSystem
Read, Int -> BuildSystem -> ShowS
[BuildSystem] -> ShowS
BuildSystem -> String
(Int -> BuildSystem -> ShowS)
-> (BuildSystem -> String)
-> ([BuildSystem] -> ShowS)
-> Show BuildSystem
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BuildSystem] -> ShowS
$cshowList :: [BuildSystem] -> ShowS
show :: BuildSystem -> String
$cshow :: BuildSystem -> String
showsPrec :: Int -> BuildSystem -> ShowS
$cshowsPrec :: Int -> BuildSystem -> ShowS
Show, (forall x. BuildSystem -> Rep BuildSystem x)
-> (forall x. Rep BuildSystem x -> BuildSystem)
-> Generic BuildSystem
forall x. Rep BuildSystem x -> BuildSystem
forall x. BuildSystem -> Rep BuildSystem x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep BuildSystem x -> BuildSystem
$cfrom :: forall x. BuildSystem -> Rep BuildSystem x
Generic)
  deriving (Get BuildSystem
[BuildSystem] -> Put
BuildSystem -> Put
(BuildSystem -> Put)
-> Get BuildSystem -> ([BuildSystem] -> Put) -> Binary BuildSystem
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [BuildSystem] -> Put
$cputList :: [BuildSystem] -> Put
get :: Get BuildSystem
$cget :: Get BuildSystem
put :: BuildSystem -> Put
$cput :: BuildSystem -> Put
Binary, Eq BuildSystem
Eq BuildSystem
-> (Int -> BuildSystem -> Int)
-> (BuildSystem -> Int)
-> Hashable BuildSystem
Int -> BuildSystem -> Int
BuildSystem -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: BuildSystem -> Int
$chash :: BuildSystem -> Int
hashWithSalt :: Int -> BuildSystem -> Int
$chashWithSalt :: Int -> BuildSystem -> Int
$cp1Hashable :: Eq BuildSystem
Hashable, BuildSystem -> ()
(BuildSystem -> ()) -> NFData BuildSystem
forall a. (a -> ()) -> NFData a
rnf :: BuildSystem -> ()
$crnf :: BuildSystem -> ()
NFData)

findGhcForBuildSystem :: BuildSystem -> FilePath -> IO FilePath
findGhcForBuildSystem :: BuildSystem -> String -> IO String
findGhcForBuildSystem BuildSystem
Cabal String
_cwd =
    IO String -> IO String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> IO String) -> IO String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (ShowS
forall a. Located => String -> a
error String
"ghc is not in the PATH") (Maybe String -> String) -> IO (Maybe String) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
findExecutable String
"ghc"
findGhcForBuildSystem BuildSystem
Stack String
cwd = do
    Stdout String
ghcLoc <- ([CmdOption] -> String -> IO (Stdout String)) :-> Action Any
forall args r. (Located, CmdArguments args) => args
cmd [String -> CmdOption
Cwd String
cwd] (String
"stack exec which ghc" :: String)
    String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
ghcLoc

instance FromJSON BuildSystem where
    parseJSON :: Value -> Parser BuildSystem
parseJSON Value
x = String -> BuildSystem
fromString (String -> BuildSystem) -> ShowS -> String -> BuildSystem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
lower (String -> BuildSystem) -> Parser String -> Parser BuildSystem
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser String
forall a. FromJSON a => Value -> Parser a
parseJSON Value
x
      where
        fromString :: String -> BuildSystem
fromString String
"stack" = BuildSystem
Stack
        fromString String
"cabal" = BuildSystem
Cabal
        fromString String
other   = String -> BuildSystem
forall a. Located => String -> a
error (String -> BuildSystem) -> String -> BuildSystem
forall a b. (a -> b) -> a -> b
$ String
"Unknown build system: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
other

instance ToJSON BuildSystem where
    toJSON :: BuildSystem -> Value
toJSON = String -> Value
forall a. ToJSON a => a -> Value
toJSON (String -> Value)
-> (BuildSystem -> String) -> BuildSystem -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildSystem -> String
forall a. Show a => a -> String
show

--------------------------------------------------------------------------------


data GitCommit = GitCommit
  { -- | A git hash, tag or branch name (e.g. v0.1.0)

    GitCommit -> Text
gitName :: Text,
    -- | A human understandable name (e.g. fix-collisions-leak)

    GitCommit -> Maybe Text
name    :: Maybe Text,
    -- | The human understandable name of the parent, if specified explicitly

    GitCommit -> Maybe Text
parent  :: Maybe Text,
    -- | Whether to include this version in the top chart

    GitCommit -> Bool
include :: Bool
  }
  deriving (Get GitCommit
[GitCommit] -> Put
GitCommit -> Put
(GitCommit -> Put)
-> Get GitCommit -> ([GitCommit] -> Put) -> Binary GitCommit
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [GitCommit] -> Put
$cputList :: [GitCommit] -> Put
get :: Get GitCommit
$cget :: Get GitCommit
put :: GitCommit -> Put
$cput :: GitCommit -> Put
Binary, GitCommit -> GitCommit -> Bool
(GitCommit -> GitCommit -> Bool)
-> (GitCommit -> GitCommit -> Bool) -> Eq GitCommit
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GitCommit -> GitCommit -> Bool
$c/= :: GitCommit -> GitCommit -> Bool
== :: GitCommit -> GitCommit -> Bool
$c== :: GitCommit -> GitCommit -> Bool
Eq, Eq GitCommit
Eq GitCommit
-> (Int -> GitCommit -> Int)
-> (GitCommit -> Int)
-> Hashable GitCommit
Int -> GitCommit -> Int
GitCommit -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: GitCommit -> Int
$chash :: GitCommit -> Int
hashWithSalt :: Int -> GitCommit -> Int
$chashWithSalt :: Int -> GitCommit -> Int
$cp1Hashable :: Eq GitCommit
Hashable, (forall x. GitCommit -> Rep GitCommit x)
-> (forall x. Rep GitCommit x -> GitCommit) -> Generic GitCommit
forall x. Rep GitCommit x -> GitCommit
forall x. GitCommit -> Rep GitCommit x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep GitCommit x -> GitCommit
$cfrom :: forall x. GitCommit -> Rep GitCommit x
Generic, GitCommit -> ()
(GitCommit -> ()) -> NFData GitCommit
forall a. (a -> ()) -> NFData a
rnf :: GitCommit -> ()
$crnf :: GitCommit -> ()
NFData, Int -> GitCommit -> ShowS
[GitCommit] -> ShowS
GitCommit -> String
(Int -> GitCommit -> ShowS)
-> (GitCommit -> String)
-> ([GitCommit] -> ShowS)
-> Show GitCommit
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GitCommit] -> ShowS
$cshowList :: [GitCommit] -> ShowS
show :: GitCommit -> String
$cshow :: GitCommit -> String
showsPrec :: Int -> GitCommit -> ShowS
$cshowsPrec :: Int -> GitCommit -> ShowS
Show)

instance FromJSON GitCommit where
  parseJSON :: Value -> Parser GitCommit
parseJSON (String Text
s) = GitCommit -> Parser GitCommit
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GitCommit -> Parser GitCommit) -> GitCommit -> Parser GitCommit
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Maybe Text -> Bool -> GitCommit
GitCommit Text
s Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing Bool
True
  parseJSON o :: Value
o@(Object Object
_) = do
    let keymap :: HashMap Text Value
keymap = Value
o Value
-> Getting (HashMap Text Value) Value (HashMap Text Value)
-> HashMap Text Value
forall s a. s -> Getting a s a -> a
^. Getting (HashMap Text Value) Value (HashMap Text Value)
forall t. AsValue t => Prism' t (HashMap Text Value)
_Object
    case HashMap Text Value -> [Item (HashMap Text Value)]
forall l. IsList l => l -> [Item l]
toList HashMap Text Value
keymap of
      [(name, String gitName)] -> GitCommit -> Parser GitCommit
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GitCommit -> Parser GitCommit) -> GitCommit -> Parser GitCommit
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Maybe Text -> Bool -> GitCommit
GitCommit Text
gitName (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
name) Maybe Text
forall a. Maybe a
Nothing Bool
True
      [(name, Object props)] ->
        Text -> Maybe Text -> Maybe Text -> Bool -> GitCommit
GitCommit
          (Text -> Maybe Text -> Maybe Text -> Bool -> GitCommit)
-> Parser Text
-> Parser (Maybe Text -> Maybe Text -> Bool -> GitCommit)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
props Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"git"  Parser (Maybe Text) -> Text -> Parser Text
forall a. Parser (Maybe a) -> a -> Parser a
.!= Text
name
          Parser (Maybe Text -> Maybe Text -> Bool -> GitCommit)
-> Parser (Maybe Text) -> Parser (Maybe Text -> Bool -> GitCommit)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Text -> Parser (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
name)
          Parser (Maybe Text -> Bool -> GitCommit)
-> Parser (Maybe Text) -> Parser (Bool -> GitCommit)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
props Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"parent"
          Parser (Bool -> GitCommit) -> Parser Bool -> Parser GitCommit
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
props Object -> Key -> Parser (Maybe Bool)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"include" Parser (Maybe Bool) -> Bool -> Parser Bool
forall a. Parser (Maybe a) -> a -> Parser a
.!= Bool
True
      [Item (HashMap Text Value)]
_ -> Parser GitCommit
forall (f :: * -> *) a. Alternative f => f a
empty
  parseJSON Value
_ = Parser GitCommit
forall (f :: * -> *) a. Alternative f => f a
empty

instance ToJSON GitCommit where
  toJSON :: GitCommit -> Value
toJSON GitCommit {Bool
Maybe Text
Text
include :: Bool
parent :: Maybe Text
name :: Maybe Text
gitName :: Text
$sel:parent:GitCommit :: GitCommit -> Maybe Text
$sel:name:GitCommit :: GitCommit -> Maybe Text
$sel:include:GitCommit :: GitCommit -> Bool
$sel:gitName:GitCommit :: GitCommit -> Text
..} =
    case Maybe Text
name of
      Maybe Text
Nothing -> Text -> Value
String Text
gitName
      Just Text
n  -> [Pair] -> Value
object [String -> Key
forall a. IsString a => String -> a
fromString (Text -> String
T.unpack Text
n) Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
gitName]

humanName :: GitCommit -> Text
humanName :: GitCommit -> Text
humanName GitCommit {Bool
Maybe Text
Text
include :: Bool
parent :: Maybe Text
name :: Maybe Text
gitName :: Text
$sel:parent:GitCommit :: GitCommit -> Maybe Text
$sel:name:GitCommit :: GitCommit -> Maybe Text
$sel:include:GitCommit :: GitCommit -> Bool
$sel:gitName:GitCommit :: GitCommit -> Text
..} = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
gitName Maybe Text
name

findPrev :: Text -> [GitCommit] -> Text
findPrev :: Text -> [GitCommit] -> Text
findPrev Text
name (GitCommit
x : GitCommit
y : [GitCommit]
xx)
  | GitCommit -> Text
humanName GitCommit
y Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name = GitCommit -> Text
humanName GitCommit
x
  | Bool
otherwise = Text -> [GitCommit] -> Text
findPrev Text
name (GitCommit
y GitCommit -> [GitCommit] -> [GitCommit]
forall a. a -> [a] -> [a]
: [GitCommit]
xx)
findPrev Text
name [GitCommit]
_ = Text
name

--------------------------------------------------------------------------------


-- | A line in the output of -S

data Frame = Frame
  { Frame -> Int
allocated, Frame -> Int
copied, Frame -> Int
live            :: !Int,
    Frame -> Double
user, Frame -> Double
elapsed, Frame -> Double
totUser, Frame -> Double
totElapsed :: !Double,
    Frame -> Int
generation                         :: !Int
  }
  deriving (Int -> Frame -> ShowS
[Frame] -> ShowS
Frame -> String
(Int -> Frame -> ShowS)
-> (Frame -> String) -> ([Frame] -> ShowS) -> Show Frame
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Frame] -> ShowS
$cshowList :: [Frame] -> ShowS
show :: Frame -> String
$cshow :: Frame -> String
showsPrec :: Int -> Frame -> ShowS
$cshowsPrec :: Int -> Frame -> ShowS
Show)

instance Read Frame where
  readPrec :: ReadPrec Frame
readPrec = do
    ReadPrec ()
spaces
    Int
allocated <- Read Int => ReadPrec Int
forall a. Read a => ReadPrec a
readPrec @Int ReadPrec Int -> ReadPrec () -> ReadPrec Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadPrec ()
spaces
    Int
copied <- Read Int => ReadPrec Int
forall a. Read a => ReadPrec a
readPrec @Int ReadPrec Int -> ReadPrec () -> ReadPrec Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadPrec ()
spaces
    Int
live <- Read Int => ReadPrec Int
forall a. Read a => ReadPrec a
readPrec @Int ReadPrec Int -> ReadPrec () -> ReadPrec Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadPrec ()
spaces
    Double
user <- Read Double => ReadPrec Double
forall a. Read a => ReadPrec a
readPrec @Double ReadPrec Double -> ReadPrec () -> ReadPrec Double
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadPrec ()
spaces
    Double
elapsed <- Read Double => ReadPrec Double
forall a. Read a => ReadPrec a
readPrec @Double ReadPrec Double -> ReadPrec () -> ReadPrec Double
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadPrec ()
spaces
    Double
totUser <- Read Double => ReadPrec Double
forall a. Read a => ReadPrec a
readPrec @Double ReadPrec Double -> ReadPrec () -> ReadPrec Double
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadPrec ()
spaces
    Double
totElapsed <- Read Double => ReadPrec Double
forall a. Read a => ReadPrec a
readPrec @Double ReadPrec Double -> ReadPrec () -> ReadPrec Double
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadPrec ()
spaces
    Int
_ <- Read Int => ReadPrec Int
forall a. Read a => ReadPrec a
readPrec @Int ReadPrec Int -> ReadPrec () -> ReadPrec Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadPrec ()
spaces
    Int
_ <- Read Int => ReadPrec Int
forall a. Read a => ReadPrec a
readPrec @Int ReadPrec Int -> ReadPrec () -> ReadPrec Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadPrec ()
spaces
    String
"(Gen:  " <- Int -> ReadPrec Char -> ReadPrec String
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
7 ReadPrec Char
get
    Int
generation <- Read Int => ReadPrec Int
forall a. Read a => ReadPrec a
readPrec @Int
    Char
')' <- ReadPrec Char
get
    Frame -> ReadPrec Frame
forall (m :: * -> *) a. Monad m => a -> m a
return Frame :: Int
-> Int
-> Int
-> Double
-> Double
-> Double
-> Double
-> Int
-> Frame
Frame {Double
Int
generation :: Int
totElapsed :: Double
totUser :: Double
elapsed :: Double
user :: Double
live :: Int
copied :: Int
allocated :: Int
$sel:generation:Frame :: Int
$sel:totElapsed:Frame :: Double
$sel:totUser:Frame :: Double
$sel:elapsed:Frame :: Double
$sel:user:Frame :: Double
$sel:live:Frame :: Int
$sel:copied:Frame :: Int
$sel:allocated:Frame :: Int
..}
    where
      spaces :: ReadPrec ()
spaces = (Int -> ReadP ()) -> ReadPrec ()
forall a. (Int -> ReadP a) -> ReadPrec a
readP_to_Prec ((Int -> ReadP ()) -> ReadPrec ())
-> (Int -> ReadP ()) -> ReadPrec ()
forall a b. (a -> b) -> a -> b
$ ReadP () -> Int -> ReadP ()
forall a b. a -> b -> a
const ReadP ()
P.skipSpaces

-- | A file path containing the output of -S for a given run

data RunLog = RunLog
  { RunLog -> String
runVersion :: !String,
    RunLog -> [Frame]
runFrames  :: ![Frame],
    RunLog -> Bool
runSuccess :: !Bool
  }

loadRunLog :: HasCallStack => Escaped FilePath -> String -> Action RunLog
loadRunLog :: Escaped String -> String -> Action RunLog
loadRunLog (Escaped String
csv_fp) String
ver = do
  let log_fp :: String
log_fp = String -> ShowS
replaceExtension String
csv_fp String
"gcStats.log"
  [String]
log <- Located => String -> Action [String]
String -> Action [String]
readFileLines String
log_fp
  [String]
csv <- Located => String -> Action [String]
String -> Action [String]
readFileLines String
csv_fp
  let frames :: [Frame]
frames =
        [ Frame
f
          | String
l <- [String]
log,
            Just Frame
f <- [String -> Maybe Frame
forall a. Read a => String -> Maybe a
readMaybe String
l],
            -- filter out gen 0 events as there are too many

            Frame -> Int
generation Frame
f Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
        ]
      -- TODO this assumes a certain structure in the CSV file

      success :: Bool
success = case (String -> [Text]) -> [String] -> [[Text]]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',') (Text -> [Text]) -> (String -> Text) -> String -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) [String]
csv of
          [[Text]
_header, Text
_name:Text
s:[Text]
_] | Just Bool
s <- String -> Maybe Bool
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
T.unpack Text
s) -> Bool
s
          [[Text]]
_ -> String -> Bool
forall a. Located => String -> a
error (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ String
"Cannot parse: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
csv_fp
  RunLog -> Action RunLog
forall (m :: * -> *) a. Monad m => a -> m a
return (RunLog -> Action RunLog) -> RunLog -> Action RunLog
forall a b. (a -> b) -> a -> b
$ String -> [Frame] -> Bool -> RunLog
RunLog String
ver [Frame]
frames Bool
success

--------------------------------------------------------------------------------


data TraceMetric = Allocated | Copied | Live | User | Elapsed
  deriving ((forall x. TraceMetric -> Rep TraceMetric x)
-> (forall x. Rep TraceMetric x -> TraceMetric)
-> Generic TraceMetric
forall x. Rep TraceMetric x -> TraceMetric
forall x. TraceMetric -> Rep TraceMetric x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TraceMetric x -> TraceMetric
$cfrom :: forall x. TraceMetric -> Rep TraceMetric x
Generic, Int -> TraceMetric
TraceMetric -> Int
TraceMetric -> [TraceMetric]
TraceMetric -> TraceMetric
TraceMetric -> TraceMetric -> [TraceMetric]
TraceMetric -> TraceMetric -> TraceMetric -> [TraceMetric]
(TraceMetric -> TraceMetric)
-> (TraceMetric -> TraceMetric)
-> (Int -> TraceMetric)
-> (TraceMetric -> Int)
-> (TraceMetric -> [TraceMetric])
-> (TraceMetric -> TraceMetric -> [TraceMetric])
-> (TraceMetric -> TraceMetric -> [TraceMetric])
-> (TraceMetric -> TraceMetric -> TraceMetric -> [TraceMetric])
-> Enum TraceMetric
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: TraceMetric -> TraceMetric -> TraceMetric -> [TraceMetric]
$cenumFromThenTo :: TraceMetric -> TraceMetric -> TraceMetric -> [TraceMetric]
enumFromTo :: TraceMetric -> TraceMetric -> [TraceMetric]
$cenumFromTo :: TraceMetric -> TraceMetric -> [TraceMetric]
enumFromThen :: TraceMetric -> TraceMetric -> [TraceMetric]
$cenumFromThen :: TraceMetric -> TraceMetric -> [TraceMetric]
enumFrom :: TraceMetric -> [TraceMetric]
$cenumFrom :: TraceMetric -> [TraceMetric]
fromEnum :: TraceMetric -> Int
$cfromEnum :: TraceMetric -> Int
toEnum :: Int -> TraceMetric
$ctoEnum :: Int -> TraceMetric
pred :: TraceMetric -> TraceMetric
$cpred :: TraceMetric -> TraceMetric
succ :: TraceMetric -> TraceMetric
$csucc :: TraceMetric -> TraceMetric
Enum, TraceMetric
TraceMetric -> TraceMetric -> Bounded TraceMetric
forall a. a -> a -> Bounded a
maxBound :: TraceMetric
$cmaxBound :: TraceMetric
minBound :: TraceMetric
$cminBound :: TraceMetric
Bounded, ReadPrec [TraceMetric]
ReadPrec TraceMetric
Int -> ReadS TraceMetric
ReadS [TraceMetric]
(Int -> ReadS TraceMetric)
-> ReadS [TraceMetric]
-> ReadPrec TraceMetric
-> ReadPrec [TraceMetric]
-> Read TraceMetric
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [TraceMetric]
$creadListPrec :: ReadPrec [TraceMetric]
readPrec :: ReadPrec TraceMetric
$creadPrec :: ReadPrec TraceMetric
readList :: ReadS [TraceMetric]
$creadList :: ReadS [TraceMetric]
readsPrec :: Int -> ReadS TraceMetric
$creadsPrec :: Int -> ReadS TraceMetric
Read)

instance Show TraceMetric where
  show :: TraceMetric -> String
show TraceMetric
Allocated = String
"Allocated bytes"
  show TraceMetric
Copied    = String
"Copied bytes"
  show TraceMetric
Live      = String
"Live bytes"
  show TraceMetric
User      = String
"User time"
  show TraceMetric
Elapsed   = String
"Elapsed time"

frameMetric :: TraceMetric -> Frame -> Double
frameMetric :: TraceMetric -> Frame -> Double
frameMetric TraceMetric
Allocated = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> (Frame -> Int) -> Frame -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Frame -> Int
allocated
frameMetric TraceMetric
Copied    = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> (Frame -> Int) -> Frame -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Frame -> Int
copied
frameMetric TraceMetric
Live      = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> (Frame -> Int) -> Frame -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Frame -> Int
live
frameMetric TraceMetric
Elapsed   = Frame -> Double
elapsed
frameMetric TraceMetric
User      = Frame -> Double
user

data Diagram = Diagram
  { Diagram -> TraceMetric
traceMetric :: TraceMetric,
    Diagram -> [RunLog]
runLogs     :: [RunLog],
    Diagram -> String
title       :: String
  }
  deriving ((forall x. Diagram -> Rep Diagram x)
-> (forall x. Rep Diagram x -> Diagram) -> Generic Diagram
forall x. Rep Diagram x -> Diagram
forall x. Diagram -> Rep Diagram x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Diagram x -> Diagram
$cfrom :: forall x. Diagram -> Rep Diagram x
Generic)

plotDiagram :: Bool -> Diagram -> FilePath -> Action ()
plotDiagram :: Bool -> Diagram -> String -> Action ()
plotDiagram Bool
includeFailed t :: Diagram
t@Diagram {TraceMetric
traceMetric :: TraceMetric
$sel:traceMetric:Diagram :: Diagram -> TraceMetric
traceMetric, [RunLog]
runLogs :: [RunLog]
$sel:runLogs:Diagram :: Diagram -> [RunLog]
runLogs} String
out = do
  let extract :: Frame -> Double
extract = TraceMetric -> Frame -> Double
frameMetric TraceMetric
traceMetric
  IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ FileOptions -> String -> EC (Layout Double Double) () -> IO ()
forall r.
(Default r, ToRenderable r) =>
FileOptions -> String -> EC r () -> IO ()
E.toFile FileOptions
forall a. Default a => a
E.def String
out (EC (Layout Double Double) () -> IO ())
-> EC (Layout Double Double) () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    (String -> Identity String)
-> Layout Double Double -> Identity (Layout Double Double)
forall x y. Lens' (Layout x y) String
E.layout_title ((String -> Identity String)
 -> Layout Double Double -> Identity (Layout Double Double))
-> String -> EC (Layout Double Double) ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
E..= Diagram -> String
title Diagram
t
    [AlphaColour Double] -> EC (Layout Double Double) ()
forall l. [AlphaColour Double] -> EC l ()
E.setColors [AlphaColour Double]
myColors
    [RunLog]
-> (RunLog -> EC (Layout Double Double) ())
-> EC (Layout Double Double) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [RunLog]
runLogs ((RunLog -> EC (Layout Double Double) ())
 -> EC (Layout Double Double) ())
-> (RunLog -> EC (Layout Double Double) ())
-> EC (Layout Double Double) ()
forall a b. (a -> b) -> a -> b
$ \RunLog
rl ->
      Bool
-> EC (Layout Double Double) () -> EC (Layout Double Double) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
includeFailed Bool -> Bool -> Bool
|| RunLog -> Bool
runSuccess RunLog
rl) (EC (Layout Double Double) () -> EC (Layout Double Double) ())
-> EC (Layout Double Double) () -> EC (Layout Double Double) ()
forall a b. (a -> b) -> a -> b
$ EC (Layout Double Double) (PlotLines Double Double)
-> EC (Layout Double Double) ()
forall (p :: * -> * -> *) x y.
ToPlot p =>
EC (Layout x y) (p x y) -> EC (Layout x y) ()
E.plot (EC (Layout Double Double) (PlotLines Double Double)
 -> EC (Layout Double Double) ())
-> EC (Layout Double Double) (PlotLines Double Double)
-> EC (Layout Double Double) ()
forall a b. (a -> b) -> a -> b
$ do
        PlotLines Double Double
lplot <- String
-> [[(Double, Double)]]
-> EC (Layout Double Double) (PlotLines Double Double)
forall x y l. String -> [[(x, y)]] -> EC l (PlotLines x y)
E.line
            (RunLog -> String
runVersion RunLog
rl String -> ShowS
forall a. [a] -> [a] -> [a]
++ if RunLog -> Bool
runSuccess RunLog
rl then String
"" else String
" (FAILED)")
            [ [ (Frame -> Double
totElapsed Frame
f, Frame -> Double
extract Frame
f)
                | Frame
f <- RunLog -> [Frame]
runFrames RunLog
rl
                ]
            ]
        return (PlotLines Double Double
lplot PlotLines Double Double
-> (PlotLines Double Double -> PlotLines Double Double)
-> PlotLines Double Double
forall a b. a -> (a -> b) -> b
E.& (LineStyle -> Identity LineStyle)
-> PlotLines Double Double -> Identity (PlotLines Double Double)
forall x y. Lens' (PlotLines x y) LineStyle
E.plot_lines_style ((LineStyle -> Identity LineStyle)
 -> PlotLines Double Double -> Identity (PlotLines Double Double))
-> ((Double -> Identity Double) -> LineStyle -> Identity LineStyle)
-> (Double -> Identity Double)
-> PlotLines Double Double
-> Identity (PlotLines Double Double)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Identity Double) -> LineStyle -> Identity LineStyle
Lens' LineStyle Double
E.line_width ((Double -> Identity Double)
 -> PlotLines Double Double -> Identity (PlotLines Double Double))
-> Double -> PlotLines Double Double -> PlotLines Double Double
forall a s t. Num a => ASetter s t a a -> a -> s -> t
E.*~ Double
2)

--------------------------------------------------------------------------------


newtype Escaped a = Escaped {Escaped a -> a
escaped :: a}

newtype Unescaped a = Unescaped {Unescaped a -> a
unescaped :: a}
  deriving newtype (Int -> Unescaped a -> ShowS
[Unescaped a] -> ShowS
Unescaped a -> String
(Int -> Unescaped a -> ShowS)
-> (Unescaped a -> String)
-> ([Unescaped a] -> ShowS)
-> Show (Unescaped a)
forall a. Show a => Int -> Unescaped a -> ShowS
forall a. Show a => [Unescaped a] -> ShowS
forall a. Show a => Unescaped a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Unescaped a] -> ShowS
$cshowList :: forall a. Show a => [Unescaped a] -> ShowS
show :: Unescaped a -> String
$cshow :: forall a. Show a => Unescaped a -> String
showsPrec :: Int -> Unescaped a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Unescaped a -> ShowS
Show, Value -> Parser [Unescaped a]
Value -> Parser (Unescaped a)
(Value -> Parser (Unescaped a))
-> (Value -> Parser [Unescaped a]) -> FromJSON (Unescaped a)
forall a. FromJSON a => Value -> Parser [Unescaped a]
forall a. FromJSON a => Value -> Parser (Unescaped a)
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Unescaped a]
$cparseJSONList :: forall a. FromJSON a => Value -> Parser [Unescaped a]
parseJSON :: Value -> Parser (Unescaped a)
$cparseJSON :: forall a. FromJSON a => Value -> Parser (Unescaped a)
FromJSON, [Unescaped a] -> Encoding
[Unescaped a] -> Value
Unescaped a -> Encoding
Unescaped a -> Value
(Unescaped a -> Value)
-> (Unescaped a -> Encoding)
-> ([Unescaped a] -> Value)
-> ([Unescaped a] -> Encoding)
-> ToJSON (Unescaped a)
forall a. ToJSON a => [Unescaped a] -> Encoding
forall a. ToJSON a => [Unescaped a] -> Value
forall a. ToJSON a => Unescaped a -> Encoding
forall a. ToJSON a => Unescaped a -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Unescaped a] -> Encoding
$ctoEncodingList :: forall a. ToJSON a => [Unescaped a] -> Encoding
toJSONList :: [Unescaped a] -> Value
$ctoJSONList :: forall a. ToJSON a => [Unescaped a] -> Value
toEncoding :: Unescaped a -> Encoding
$ctoEncoding :: forall a. ToJSON a => Unescaped a -> Encoding
toJSON :: Unescaped a -> Value
$ctoJSON :: forall a. ToJSON a => Unescaped a -> Value
ToJSON, Unescaped a -> Unescaped a -> Bool
(Unescaped a -> Unescaped a -> Bool)
-> (Unescaped a -> Unescaped a -> Bool) -> Eq (Unescaped a)
forall a. Eq a => Unescaped a -> Unescaped a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Unescaped a -> Unescaped a -> Bool
$c/= :: forall a. Eq a => Unescaped a -> Unescaped a -> Bool
== :: Unescaped a -> Unescaped a -> Bool
$c== :: forall a. Eq a => Unescaped a -> Unescaped a -> Bool
Eq, Unescaped a -> ()
(Unescaped a -> ()) -> NFData (Unescaped a)
forall a. NFData a => Unescaped a -> ()
forall a. (a -> ()) -> NFData a
rnf :: Unescaped a -> ()
$crnf :: forall a. NFData a => Unescaped a -> ()
NFData, Get (Unescaped a)
[Unescaped a] -> Put
Unescaped a -> Put
(Unescaped a -> Put)
-> Get (Unescaped a)
-> ([Unescaped a] -> Put)
-> Binary (Unescaped a)
forall a. Binary a => Get (Unescaped a)
forall a. Binary a => [Unescaped a] -> Put
forall a. Binary a => Unescaped a -> Put
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [Unescaped a] -> Put
$cputList :: forall a. Binary a => [Unescaped a] -> Put
get :: Get (Unescaped a)
$cget :: forall a. Binary a => Get (Unescaped a)
put :: Unescaped a -> Put
$cput :: forall a. Binary a => Unescaped a -> Put
Binary, Eq (Unescaped a)
Eq (Unescaped a)
-> (Int -> Unescaped a -> Int)
-> (Unescaped a -> Int)
-> Hashable (Unescaped a)
Int -> Unescaped a -> Int
Unescaped a -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
forall a. Hashable a => Eq (Unescaped a)
forall a. Hashable a => Int -> Unescaped a -> Int
forall a. Hashable a => Unescaped a -> Int
hash :: Unescaped a -> Int
$chash :: forall a. Hashable a => Unescaped a -> Int
hashWithSalt :: Int -> Unescaped a -> Int
$chashWithSalt :: forall a. Hashable a => Int -> Unescaped a -> Int
$cp1Hashable :: forall a. Hashable a => Eq (Unescaped a)
Hashable)

escapeExperiment :: Unescaped String -> Escaped String
escapeExperiment :: Unescaped String -> Escaped String
escapeExperiment = String -> Escaped String
forall a. a -> Escaped a
Escaped (String -> Escaped String)
-> (Unescaped String -> String)
-> Unescaped String
-> Escaped String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
f ShowS -> (Unescaped String -> String) -> Unescaped String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unescaped String -> String
forall a. Unescaped a -> a
unescaped
  where
    f :: Char -> Char
f Char
' '   = Char
'_'
    f Char
other = Char
other

unescapeExperiment :: Escaped String -> Unescaped String
unescapeExperiment :: Escaped String -> Unescaped String
unescapeExperiment = String -> Unescaped String
forall a. a -> Unescaped a
Unescaped (String -> Unescaped String)
-> (Escaped String -> String) -> Escaped String -> Unescaped String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
f ShowS -> (Escaped String -> String) -> Escaped String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Escaped String -> String
forall a. Escaped a -> a
escaped
  where
    f :: Char -> Char
f Char
'_'   = Char
' '
    f Char
other = Char
other

--------------------------------------------------------------------------------


(-/-) :: FilePattern -> FilePattern -> FilePattern
String
a -/- :: String -> ShowS
-/- String
b = String
a String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"/" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
b

interleave :: [[a]] -> [a]
interleave :: [[a]] -> [a]
interleave = [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[a]] -> [a]) -> ([[a]] -> [[a]]) -> [[a]] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[a]] -> [[a]]
forall a. [[a]] -> [[a]]
transpose

--------------------------------------------------------------------------------


myColors :: [E.AlphaColour Double]
myColors :: [AlphaColour Double]
myColors = (Colour Double -> AlphaColour Double)
-> [Colour Double] -> [AlphaColour Double]
forall a b. (a -> b) -> [a] -> [b]
map Colour Double -> AlphaColour Double
forall a. Num a => Colour a -> AlphaColour a
E.opaque
  [ Colour Double
forall a. (Ord a, Floating a) => Colour a
E.blue
  , Colour Double
forall a. (Ord a, Floating a) => Colour a
E.green
  , Colour Double
forall a. (Ord a, Floating a) => Colour a
E.red
  , Colour Double
forall a. (Ord a, Floating a) => Colour a
E.orange
  , Colour Double
forall a. (Ord a, Floating a) => Colour a
E.yellow
  , Colour Double
forall a. (Ord a, Floating a) => Colour a
E.violet
  , Colour Double
forall a. Num a => Colour a
E.black
  , Colour Double
forall a. (Ord a, Floating a) => Colour a
E.gold
  , Colour Double
forall a. (Ord a, Floating a) => Colour a
E.brown
  , Colour Double
forall a. (Ord a, Floating a) => Colour a
E.hotpink
  , Colour Double
forall a. (Ord a, Floating a) => Colour a
E.aliceblue
  , Colour Double
forall a. (Ord a, Floating a) => Colour a
E.aqua
  , Colour Double
forall a. (Ord a, Floating a) => Colour a
E.beige
  , Colour Double
forall a. (Ord a, Floating a) => Colour a
E.bisque
  , Colour Double
forall a. (Ord a, Floating a) => Colour a
E.blueviolet
  , Colour Double
forall a. (Ord a, Floating a) => Colour a
E.burlywood
  , Colour Double
forall a. (Ord a, Floating a) => Colour a
E.cadetblue
  , Colour Double
forall a. (Ord a, Floating a) => Colour a
E.chartreuse
  , Colour Double
forall a. (Ord a, Floating a) => Colour a
E.coral
  , Colour Double
forall a. (Ord a, Floating a) => Colour a
E.crimson
  , Colour Double
forall a. (Ord a, Floating a) => Colour a
E.darkblue
  , Colour Double
forall a. (Ord a, Floating a) => Colour a
E.darkgray
  , Colour Double
forall a. (Ord a, Floating a) => Colour a
E.darkgreen
  , Colour Double
forall a. (Ord a, Floating a) => Colour a
E.darkkhaki
  , Colour Double
forall a. (Ord a, Floating a) => Colour a
E.darkmagenta
  , Colour Double
forall a. (Ord a, Floating a) => Colour a
E.deeppink
  , Colour Double
forall a. (Ord a, Floating a) => Colour a
E.dodgerblue
  , Colour Double
forall a. (Ord a, Floating a) => Colour a
E.firebrick
  , Colour Double
forall a. (Ord a, Floating a) => Colour a
E.forestgreen
  , Colour Double
forall a. (Ord a, Floating a) => Colour a
E.fuchsia
  , Colour Double
forall a. (Ord a, Floating a) => Colour a
E.greenyellow
  , Colour Double
forall a. (Ord a, Floating a) => Colour a
E.lightsalmon
  , Colour Double
forall a. (Ord a, Floating a) => Colour a
E.seagreen
  , Colour Double
forall a. (Ord a, Floating a) => Colour a
E.olive
  , Colour Double
forall a. (Ord a, Floating a) => Colour a
E.sandybrown
  , Colour Double
forall a. (Ord a, Floating a) => Colour a
E.sienna
  , Colour Double
forall a. (Ord a, Floating a) => Colour a
E.peru
  ]

dummyHp :: String
dummyHp :: String
dummyHp =
    String
"JOB \"ghcide\" \
    \DATE \"Sun Jan 31 09:30 2021\" \
    \SAMPLE_UNIT \"seconds\" \
    \VALUE_UNIT \"bytes\" \
    \BEGIN_SAMPLE 0.000000 \
    \END_SAMPLE 0.000000"