{-# 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 and configurations
    │   ├── <experiment>.svg                      - graph of bytes over elapsed time, for all the versions and configurations
    |   └── <git-reference>
    │       └── <configuration>
    │           ├── <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 examples, experiments, versions and configurations
    └── <experiment>.svg   - graph of bytes over elapsed time, for all the examples, experiments, versions and configurations

   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(..), OutputFolder, ProjectRoot,
      benchRules, MkBenchRules(..), BenchProject(..), ProfilingMode(..),
      csvRules,
      svgRules,
      heapProfileRules,
      phonyRules,
      allTargetsForExample,
      GetExample(..), GetExamples(..),
      IsExample(..), RuleResultForExample,
      GetExperiments(..),
      GetVersions(..),
      GetCommitId(..),
      GetBuildSystem(..),
      GetConfigurations(..), Configuration(..),
      BuildSystem(..), findGhcForBuildSystem,
      Escaped(..), Unescaped(..), escapeExperiment, unescapeExperiment,
      GitCommit

  ) where

import           Control.Applicative
import           Control.Lens                              (preview, view, (^.))
import           Control.Monad
import qualified Control.Monad.State                       as S
import           Data.Aeson                                (FromJSON (..),
                                                            ToJSON (..),
                                                            Value (..), object,
                                                            (.!=), (.:?), (.=))
import           Data.Aeson.Lens                           (AsJSON (_JSON),
                                                            _Object, _String)
import           Data.ByteString.Lazy                      (ByteString)
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           Numeric.Natural
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
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
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
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
Hashable, GetExperiments -> ()
forall a. (a -> ()) -> NFData a
rnf :: GetExperiments -> ()
$crnf :: GetExperiments -> ()
NFData, Int -> GetExperiments -> ShowS
[GetExperiments] -> ShowS
GetExperiments -> String
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
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
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
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
Hashable, GetVersions -> ()
forall a. (a -> ()) -> NFData a
rnf :: GetVersions -> ()
$crnf :: GetVersions -> ()
NFData, Int -> GetVersions -> ShowS
[GetVersions] -> ShowS
GetVersions -> String
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
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
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
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
Hashable, GetParent -> ()
forall a. (a -> ()) -> NFData a
rnf :: GetParent -> ()
$crnf :: GetParent -> ()
NFData, Int -> GetParent -> ShowS
[GetParent] -> ShowS
GetParent -> String
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
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
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
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
Hashable, GetCommitId -> ()
forall a. (a -> ()) -> NFData a
rnf :: GetCommitId -> ()
$crnf :: GetCommitId -> ()
NFData, Int -> GetCommitId -> ShowS
[GetCommitId] -> ShowS
GetCommitId -> String
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
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
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
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
Hashable, GetBuildSystem -> ()
forall a. (a -> ()) -> NFData a
rnf :: GetBuildSystem -> ()
$crnf :: GetBuildSystem -> ()
NFData, Int -> GetBuildSystem -> ShowS
[GetBuildSystem] -> ShowS
GetBuildSystem -> String
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
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
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
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
Hashable, GetExample -> ()
forall a. (a -> ()) -> NFData a
rnf :: GetExample -> ()
$crnf :: GetExample -> ()
NFData, Int -> GetExample -> ShowS
[GetExample] -> ShowS
GetExample -> String
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
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
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
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
Hashable, GetExamples -> ()
forall a. (a -> ()) -> NFData a
rnf :: GetExamples -> ()
$crnf :: GetExamples -> ()
NFData, Int -> GetExamples -> ShowS
[GetExamples] -> ShowS
GetExamples -> String
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)
newtype GetConfigurations = GetConfigurations () deriving newtype (Get GetConfigurations
[GetConfigurations] -> Put
GetConfigurations -> Put
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [GetConfigurations] -> Put
$cputList :: [GetConfigurations] -> Put
get :: Get GetConfigurations
$cget :: Get GetConfigurations
put :: GetConfigurations -> Put
$cput :: GetConfigurations -> Put
Binary, GetConfigurations -> GetConfigurations -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GetConfigurations -> GetConfigurations -> Bool
$c/= :: GetConfigurations -> GetConfigurations -> Bool
== :: GetConfigurations -> GetConfigurations -> Bool
$c== :: GetConfigurations -> GetConfigurations -> Bool
Eq, Eq GetConfigurations
Int -> GetConfigurations -> Int
GetConfigurations -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: GetConfigurations -> Int
$chash :: GetConfigurations -> Int
hashWithSalt :: Int -> GetConfigurations -> Int
$chashWithSalt :: Int -> GetConfigurations -> Int
Hashable, GetConfigurations -> ()
forall a. (a -> ()) -> NFData a
rnf :: GetConfigurations -> ()
$crnf :: GetConfigurations -> ()
NFData, Int -> GetConfigurations -> ShowS
[GetConfigurations] -> ShowS
GetConfigurations -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GetConfigurations] -> ShowS
$cshowList :: [GetConfigurations] -> ShowS
show :: GetConfigurations -> String
$cshow :: GetConfigurations -> String
showsPrec :: Int -> GetConfigurations -> ShowS
$cshowsPrec :: Int -> GetConfigurations -> 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)

data Configuration = Configuration {Configuration -> String
confName :: String, Configuration -> ByteString
confValue :: ByteString}
    deriving (Get Configuration
[Configuration] -> Put
Configuration -> Put
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [Configuration] -> Put
$cputList :: [Configuration] -> Put
get :: Get Configuration
$cget :: Get Configuration
put :: Configuration -> Put
$cput :: Configuration -> Put
Binary, Configuration -> Configuration -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Configuration -> Configuration -> Bool
$c/= :: Configuration -> Configuration -> Bool
== :: Configuration -> Configuration -> Bool
$c== :: Configuration -> Configuration -> Bool
Eq, forall x. Rep Configuration x -> Configuration
forall x. Configuration -> Rep Configuration x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Configuration x -> Configuration
$cfrom :: forall x. Configuration -> Rep Configuration x
Generic, Eq Configuration
Int -> Configuration -> Int
Configuration -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: Configuration -> Int
$chash :: Configuration -> Int
hashWithSalt :: Int -> Configuration -> Int
$chashWithSalt :: Int -> Configuration -> Int
Hashable, Configuration -> ()
forall a. (a -> ()) -> NFData a
rnf :: Configuration -> ()
$crnf :: Configuration -> ()
NFData, Int -> Configuration -> ShowS
[Configuration] -> ShowS
Configuration -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Configuration] -> ShowS
$cshowList :: [Configuration] -> ShowS
show :: Configuration -> String
$cshow :: Configuration -> String
showsPrec :: Int -> Configuration -> ShowS
$cshowsPrec :: Int -> Configuration -> ShowS
Show, Typeable)
type instance RuleResult GetConfigurations = [Configuration]

-- | 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 :: forall e.
IsExample e =>
ProfilingMode -> String -> e -> Action [String]
allTargetsForExample ProfilingMode
prof String
baseFolder e
ex = do
    [Unescaped String]
experiments <- forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
q -> Action a
askOracle forall a b. (a -> b) -> a -> b
$ () -> GetExperiments
GetExperiments ()
    [GitCommit]
versions    <- forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
q -> Action a
askOracle forall a b. (a -> b) -> a -> b
$ () -> GetVersions
GetVersions ()
    [Configuration]
configurations <- forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
q -> Action a
askOracle forall a b. (a -> b) -> a -> b
$ () -> GetConfigurations
GetConfigurations ()
    let buildFolder :: String
buildFolder = String
baseFolder String -> ShowS
</> ProfilingMode -> String
profilingPath ProfilingMode
prof
    return $
        [String
buildFolder String -> ShowS
</> forall e. IsExample e => e -> String
getExampleName e
ex String -> ShowS
</> String
"results.csv"]
        forall a. [a] -> [a] -> [a]
++ [ String
buildFolder String -> ShowS
</> forall e. IsExample e => e -> String
getExampleName e
ex String -> ShowS
</> forall a. Escaped a -> a
escaped (Unescaped String -> Escaped String
escapeExperiment Unescaped String
e) String -> ShowS
<.> String
"svg"
             | Unescaped String
e <- [Unescaped String]
experiments
           ]
        forall a. [a] -> [a] -> [a]
++ [ String
buildFolder String -> ShowS
</>
             forall e. IsExample e => e -> String
getExampleName e
ex String -> ShowS
</>
             Text -> String
T.unpack (GitCommit -> Text
humanName GitCommit
ver) String -> ShowS
</>
             String
confName String -> ShowS
</>
             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,
               Configuration{String
confName :: String
$sel:confName:Configuration :: Configuration -> String
confName} <- [Configuration]
configurations,
               String
mode <- [String
"svg", String
"diff.svg"] forall a. [a] -> [a] -> [a]
++ [String
"heap.svg" | ProfilingMode
prof 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 <- forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
q -> Action a
askOracle 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 :: forall (t :: * -> *) e.
(Traversable t, IsExample e) =>
String -> String -> ProfilingMode -> String -> t e -> Rules ()
phonyRules String
prefix String
executableName ProfilingMode
prof String
buildFolder t e
examples = do
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ t e
examples forall a b. (a -> b) -> a -> b
$ \e
ex ->
        HasCallStack => String -> Action () -> Rules ()
phony (String
prefix forall a. Semigroup a => a -> a -> a
<> forall e. IsExample e => e -> String
getExampleName e
ex) forall a b. (a -> b) -> a -> b
$ HasCallStack => [String] -> Action ()
need forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
            forall e.
IsExample e =>
ProfilingMode -> String -> e -> Action [String]
allTargetsForExample ProfilingMode
prof String
buildFolder e
ex
    HasCallStack => String -> Action () -> Rules ()
phony (String
prefix forall a. Semigroup a => a -> a -> a
<> String
"all") forall a b. (a -> b) -> a -> b
$ do
        t [String]
exampleTargets <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM t e
examples forall a b. (a -> b) -> a -> b
$ \e
ex ->
            forall e.
IsExample e =>
ProfilingMode -> String -> e -> Action [String]
allTargetsForExample ProfilingMode
prof String
buildFolder e
ex
        HasCallStack => [String] -> Action ()
need forall a b. (a -> b) -> a -> b
$ (String
buildFolder String -> ShowS
</> ProfilingMode -> String
profilingPath ProfilingMode
prof String -> ShowS
</> String
"results.csv")
             forall a. a -> [a] -> [a]
: forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat t [String]
exampleTargets
    HasCallStack => String -> Action () -> Rules ()
phony (String
prefix forall a. Semigroup a => a -> a -> a
<> String
"all-binaries") forall a b. (a -> b) -> a -> b
$ HasCallStack => [String] -> Action ()
need 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
type ProjectRoot = FilePath

data MkBuildRules buildSystem = MkBuildRules
  { -- | Return the path to the GHC executable to use for the project found in the cwd
    forall buildSystem.
MkBuildRules buildSystem -> buildSystem -> String -> IO String
findGhc            :: buildSystem -> FilePath -> IO FilePath
    -- | Name of the binary produced by 'buildProject'
  , forall buildSystem. MkBuildRules buildSystem -> String
executableName     :: String
    -- | An action that captures the source dependencies, used for the HEAD build
  , forall buildSystem. MkBuildRules buildSystem -> Action ()
projectDepends     :: Action ()
    -- | Build the project found in the given path and save the build artifacts in the output folder
  , forall buildSystem.
MkBuildRules buildSystem
-> buildSystem -> String -> String -> Action ()
buildProject       :: buildSystem
                       -> ProjectRoot
                       -> 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 -> String -> String -> Action ()
buildProject :: BuildSystem -> String -> String -> Action ()
projectDepends :: Action ()
executableName :: String
findGhc :: BuildSystem -> String -> IO String
$sel:buildProject:MkBuildRules :: forall buildSystem.
MkBuildRules buildSystem
-> buildSystem -> String -> 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" HasCallStack => String -> (String -> Action ()) -> Rules ()
%> \String
out -> do
      Action ()
alwaysRerun

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

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

  -- build rules for non HEAD revisions
  [String
build String -> ShowS
-/- String
"binaries/*/" forall a. Semigroup a => a -> a -> a
<> String
executableName
   ,String
build String -> ShowS
-/- String
"binaries/*/ghc.path"
   ] HasCallStack => [String] -> ([String] -> Action ()) -> Rules ()
&%> \[String
out, String
ghcPath] -> do
      let [String
_, String
_binaries, String
ver, String
_] = String -> [String]
splitDirectories String
out
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True forall a b. (a -> b) -> a -> b
$ ShowS
dropFileName String
out
      String
commitid <- HasCallStack => String -> Action String
readFile' forall a b. (a -> b) -> a -> b
$ ShowS
takeDirectory String
out String -> ShowS
</> String
"commitid"
      forall args. (HasCallStack, CmdArguments args, Unit args) => args
cmd_ forall a b. (a -> b) -> a -> b
$ String
"git worktree add bench-temp-" forall a. [a] -> [a] -> [a]
++ String
ver forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
commitid
      BuildSystem
buildSystem <- forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
q -> Action a
askOracle forall a b. (a -> b) -> a -> b
$ () -> GetBuildSystem
GetBuildSystem ()
      forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. Action a -> IO b -> Action a
actionFinally (forall args. (HasCallStack, CmdArguments args, Unit args) => args
cmd_ (String
"git worktree remove bench-temp-" forall a. Semigroup a => a -> a -> a
<> String
ver forall a. Semigroup a => a -> a -> a
<> String
" --force" :: String)) forall a b. (a -> b) -> a -> b
$ do
        String
ghcLoc <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ BuildSystem -> String -> IO String
findGhc BuildSystem
buildSystem String
ver
        BuildSystem -> String -> String -> Action ()
buildProject BuildSystem
buildSystem (String
"bench-temp-" forall a. Semigroup a => a -> a -> a
<> String
ver) (String
".." String -> ShowS
</> ShowS
takeDirectory String
out)
        forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
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
  , forall buildSystem example.
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'
  , forall buildSystem example.
MkBenchRules buildSystem example -> String
executableName :: String
  -- | Number of concurrent benchmarks to run
  , forall buildSystem example.
MkBenchRules buildSystem example -> Natural
parallelism :: Natural
  }

data BenchProject example = BenchProject
    { forall example. BenchProject example -> String
outcsv        :: FilePath         -- ^ where to save the CSV output
    , forall example. BenchProject example -> String
exePath       :: FilePath         -- ^ where to find the executable for benchmarking
    , forall example. BenchProject example -> [String]
exeExtraArgs  :: [String]         -- ^ extra args for the executable
    , forall example. BenchProject example -> example
example       :: example          -- ^ example to benchmark
    , forall example. BenchProject example -> Escaped String
experiment    :: Escaped String   -- ^ experiment to run
    , forall example. BenchProject example -> ByteString
configuration :: ByteString      -- ^ configuration to use
    }

data ProfilingMode = NoProfiling | CheapHeapProfiling Seconds
    deriving (ProfilingMode -> ProfilingMode -> Bool
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" = forall a. a -> Maybe a
Just ProfilingMode
NoProfiling
profilingP String
inp | Just String
delay <- forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"profiled-" String
inp, Just Double
i <- forall a. Read a => String -> Maybe a
readMaybe String
delay = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Double -> ProfilingMode
CheapHeapProfiling Double
i
profilingP String
_ = forall a. Maybe a
Nothing

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

-- TODO generalize BuildSystem
benchRules :: RuleResultForExample example => FilePattern -> MkBenchRules BuildSystem example -> Rules ()
benchRules :: forall example.
RuleResultForExample example =>
String -> MkBenchRules BuildSystem example -> Rules ()
benchRules String
build MkBenchRules{Natural
String
Action setup
setup
-> BuildSystem -> [CmdOption] -> BenchProject example -> Action ()
BuildSystem -> String -> [CmdOption] -> example -> Action ()
parallelism :: Natural
executableName :: String
warmupProject :: BuildSystem -> String -> [CmdOption] -> example -> Action ()
benchProject :: setup
-> BuildSystem -> [CmdOption] -> BenchProject example -> Action ()
setupProject :: Action setup
$sel:parallelism:MkBenchRules :: forall buildSystem example.
MkBenchRules buildSystem example -> Natural
$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" (forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
parallelism)
  -- warmup an example
  String
build String -> ShowS
-/- String
"binaries/*/*.warmup" HasCallStack => 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"
        HasCallStack => [String] -> Action ()
need [String
exePath, String
ghcPath]
        BuildSystem
buildSystem <- forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
q -> Action a
askOracle  forall a b. (a -> b) -> a -> b
$ () -> GetBuildSystem
GetBuildSystem ()
        example
example <- forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Unknown example " forall a. Semigroup a => a -> a -> a
<> String
exampleName)
                    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall a. a -> Escaped a
Escaped String
"hover"
        forall a. Resource -> Int -> Action a -> Action a
withResource Resource
benchResource Int
1 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
  forall a. Double -> Rules a -> Rules a
priority Double
0 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"
    ] HasCallStack => [String] -> ([String] -> Action ()) -> Rules ()
&%> \[String
outcsv, String
outGc, String
outLog, String
outEventlog, String
outHp] -> do
        let [String
_, String
flavour, String
exampleName, String
ver, String
conf, String
exp] = String -> [String]
splitDirectories String
outcsv
            prof :: ProfilingMode
prof = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Not a valid profiling mode: " forall a. Semigroup a => a -> a -> a
<> String
flavour) forall a b. (a -> b) -> a -> b
$ String -> Maybe ProfilingMode
profilingP String
flavour
        example
example <- forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Unknown example " forall a. Semigroup a => a -> a -> a
<> String
exampleName)
                    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
q -> Action a
askOracle (String -> GetExample
GetExample String
exampleName)
        BuildSystem
buildSystem <- forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
q -> Action a
askOracle  forall a b. (a -> b) -> a -> b
$ () -> GetBuildSystem
GetBuildSystem ()
        [Configuration]
configurations <- forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
q -> Action a
askOracle forall a b. (a -> b) -> a -> b
$ () -> GetConfigurations
GetConfigurations ()
        setup
setupRes    <- Action setup
setupProject
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True 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
"-ol" forall a. Semigroup a => a -> a -> a
<> String
outEventlog
                , String
"-S" forall a. Semigroup a => a -> a -> a
<> String
outGc]
             forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                [[ String
"-h"
                  , String
"-i" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Double
i
                  , String
"-po" forall a. Semigroup a => a -> a -> a
<> String
outHp
                  , String
"-qg"]
                 | CheapHeapProfiling Double
i <- [ProfilingMode
prof]]
             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 = forall a. a -> Escaped a
Escaped forall a b. (a -> b) -> a -> b
$ ShowS
dropExtension String
exp
            Just Configuration{String
ByteString
confValue :: ByteString
confName :: String
$sel:confValue:Configuration :: Configuration -> ByteString
$sel:confName:Configuration :: Configuration -> String
..} = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Configuration{String
confName :: String
$sel:confName:Configuration :: Configuration -> String
confName} -> String
confName forall a. Eq a => a -> a -> Bool
== String
conf) [Configuration]
configurations
            configuration :: ByteString
configuration = ByteString
confValue
        HasCallStack => [String] -> Action ()
need [String
exePath, String
ghcPath, String
warmupPath]
        String
ghcPath <- HasCallStack => String -> Action String
readFile' String
ghcPath
        forall a. Resource -> Int -> Action a -> Action a
withResource Resource
benchResource Int
1 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 {example
String
[String]
ByteString
Escaped String
configuration :: ByteString
experiment :: Escaped String
exeExtraArgs :: [String]
exePath :: String
example :: example
outcsv :: String
$sel:configuration:BenchProject :: ByteString
$sel:experiment:BenchProject :: Escaped String
$sel:example:BenchProject :: example
$sel:exeExtraArgs:BenchProject :: [String]
$sel:exePath:BenchProject :: String
$sel:outcsv:BenchProject :: String
..}
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ case ProfilingMode
prof of
            ProfilingMode
NoProfiling -> String -> String -> IO ()
writeFile String
outHp String
dummyHp
            ProfilingMode
_           -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

        -- extend csv output with allocation data
        [String]
csvContents <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> [String]
lines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
readFile String
outcsv
        let header :: String
header = forall a. [a] -> a
head [String]
csvContents
            results :: [String]
results = forall a. [a] -> [a]
tail [String]
csvContents
            header' :: String
header' = String
header forall a. Semigroup a => a -> a -> a
<> String
", maxResidency, allocatedBytes"
        [String]
results' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
results forall a b. (a -> b) -> a -> b
$ \String
row -> do
            (Int
maxResidency, Int
allocations) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
                    (String -> (Int, Int)
parseMaxResidencyAndAllocations forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
readFile String
outGc)
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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' forall a. a -> [a] -> [a]
: [String]
results'
        forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
String -> [String] -> m ()
writeFileLines String
outcsv [String]
csvContents'
    where
        showMB :: Int -> String
        showMB :: Int -> String
showMB Int
x = forall a. Show a => a -> String
show (Int
x forall a. Integral a => a -> a -> a
`div` Int
2forall a b. (Num a, Integral b) => a -> b -> a
^(Int
20::Int)) 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 = forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
input
    f :: String -> Int
f String
label = case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (String
label forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf`) [String]
inps of
        Just String
l  -> forall a. Read a => String -> a
read forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
isDigit forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head 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 :: forall example. RuleResultForExample example => String -> Rules ()
csvRules String
build = do
  -- build results for every experiment*example
  String
build String -> ShowS
-/- String
"*/*/*/*/results.csv" HasCallStack => String -> (String -> Action ()) -> Rules ()
%> \String
out -> do
      [Unescaped String]
experiments <- forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
q -> Action a
askOracle forall a b. (a -> b) -> a -> b
$ () -> GetExperiments
GetExperiments ()

      let allResultFiles :: [String]
allResultFiles = [ShowS
takeDirectory String
out String -> ShowS
</> 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 <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse HasCallStack => String -> Action [String]
readFileLines [String]
allResultFiles

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

  -- aggregate all configurations for an experiment
  String
build String -> ShowS
-/- String
"*/*/*/results.csv" HasCallStack => String -> (String -> Action ()) -> Rules ()
%> \String
out -> do
    [String]
configurations <- forall a b. (a -> b) -> [a] -> [b]
map Configuration -> String
confName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
q -> Action a
askOracle (() -> GetConfigurations
GetConfigurations ())
    let allResultFiles :: [String]
allResultFiles = [ShowS
takeDirectory String
out String -> ShowS
</> String
c String -> ShowS
</> String
"results.csv" | String
c <- [String]
configurations ]

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

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

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

  -- aggregate all experiments for an example
  String
build String -> ShowS
-/- String
"*/*/results.csv" HasCallStack => String -> (String -> Action ()) -> Rules ()
%> \String
out -> do
    [String]
versions <- forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. GitCommit -> Text
humanName) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse HasCallStack => String -> Action [String]
readFileLines [String]
allResultFiles

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

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

  -- aggregate all examples
  String
build String -> ShowS
-/- String
"*/results.csv" HasCallStack => String -> (String -> Action ()) -> Rules ()
%> \String
out -> do
    [String]
examples <- forall a b. (a -> b) -> [a] -> [b]
map (forall e. IsExample e => e -> String
getExampleName @example) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse HasCallStack => String -> Action [String]
readFileLines [String]
allResultFiles

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

    forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
String -> String -> m ()
writeFileChanged String
out forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ String
header' forall a. a -> [a] -> [a]
: 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
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a, HasCallStack) =>
(q -> Action a) -> Rules (q -> Action a)
addOracle forall a b. (a -> b) -> a -> b
$ \(GetParent Text
name) -> Text -> [GitCommit] -> Text
findPrev Text
name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
  forall a. Double -> Rules a -> Rules a
priority Double
1 forall a b. (a -> b) -> a -> b
$
    String
build String -> ShowS
-/- String
"*/*/*/*/*.svg" HasCallStack => String -> (String -> Action ()) -> Rules ()
%> \String
out -> do
      let [String
_, String
_, String
_example, String
ver, String
conf, String
_exp] = String -> [String]
splitDirectories String
out
      RunLog
runLog <- HasCallStack => Escaped String -> String -> String -> Action RunLog
loadRunLog (forall a. a -> Escaped a
Escaped forall a b. (a -> b) -> a -> b
$ String -> ShowS
replaceExtension String
out String
"csv") String
ver String
conf
      let diagram :: Diagram
diagram = TraceMetric -> [RunLog] -> String -> Diagram
Diagram TraceMetric
Live [RunLog
runLog] String
title
          title :: String
title = String
ver 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
  forall a. Double -> Rules a -> Rules a
priority Double
2 forall a b. (a -> b) -> a -> b
$
    String
build String -> ShowS
-/- String
"*/*/*/*/*.diff.svg" HasCallStack => String -> (String -> Action ()) -> Rules ()
%> \String
out -> do
      let [String
b, String
flav, String
example, String
ver, String
conf, String
exp_] = String -> [String]
splitDirectories String
out
          exp :: Escaped String
exp = forall a. a -> Escaped a
Escaped forall a b. (a -> b) -> a -> b
$ ShowS
dropExtension2 String
exp_
      String
prev <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
q -> Action a
askOracle forall a b. (a -> b) -> a -> b
$ Text -> GetParent
GetParent forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
ver

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

      let diagram :: Diagram
diagram = TraceMetric -> [RunLog] -> String -> Diagram
Diagram TraceMetric
Live [RunLog
runLog, RunLog
runLogPrev] String
title
          title :: String
title = forall a. Show a => a -> String
show (Escaped String -> Unescaped String
unescapeExperiment Escaped String
exp) 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 configurations
  String
build String -> ShowS
-/- String
"*/*/*/*.svg" HasCallStack => String -> (String -> Action ()) -> Rules ()
%> \String
out -> do
    let exp :: Escaped String
exp = forall a. a -> Escaped a
Escaped forall a b. (a -> b) -> a -> b
$ ShowS
dropExtension forall a b. (a -> b) -> a -> b
$ ShowS
takeFileName String
out
        [String
b, String
flav, String
example, String
ver] = String -> [String]
splitDirectories String
out
    [GitCommit]
versions <- forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
q -> Action a
askOracle forall a b. (a -> b) -> a -> b
$ () -> GetVersions
GetVersions ()
    [Configuration]
configurations <- forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
q -> Action a
askOracle forall a b. (a -> b) -> a -> b
$ () -> GetConfigurations
GetConfigurations ()

    [RunLog]
runLogs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Configuration]
configurations forall a b. (a -> b) -> a -> b
$ \Configuration{String
confName :: String
$sel:confName:Configuration :: Configuration -> String
confName} -> do
      HasCallStack => Escaped String -> String -> String -> Action RunLog
loadRunLog (forall a. a -> Escaped a
Escaped forall a b. (a -> b) -> a -> b
$ ShowS
takeDirectory String
out String -> ShowS
</> String
confName String -> ShowS
</> String -> ShowS
replaceExtension (ShowS
takeFileName String
out) String
"csv") String
ver String
confName

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

  -- aggregated chart of GC stats for all the revisions
  String
build String -> ShowS
-/- String
"*/*/*.svg" HasCallStack => String -> (String -> Action ()) -> Rules ()
%> \String
out -> do
    let exp :: Escaped String
exp = forall a. a -> Escaped a
Escaped forall a b. (a -> b) -> a -> b
$ ShowS
dropExtension forall a b. (a -> b) -> a -> b
$ ShowS
takeFileName String
out
    [GitCommit]
versions <- forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
q -> Action a
askOracle forall a b. (a -> b) -> a -> b
$ () -> GetVersions
GetVersions ()
    [Configuration]
configurations <- forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
q -> Action a
askOracle forall a b. (a -> b) -> a -> b
$ () -> GetConfigurations
GetConfigurations ()

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

    let diagram :: Diagram
diagram = TraceMetric -> [RunLog] -> String -> Diagram
Diagram TraceMetric
Live (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[RunLog]]
runLogs) String
title
        title :: String
title = forall a. Show a => a -> String
show (Escaped String -> Unescaped String
unescapeExperiment Escaped String
exp) 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
  forall a. Double -> Rules a -> Rules a
priority Double
3 forall a b. (a -> b) -> a -> b
$
    String
build String -> ShowS
-/- String
"*/*/*/*/*.heap.svg" HasCallStack => String -> (String -> Action ()) -> Rules ()
%> \String
out -> do
      let hpFile :: String
hpFile = ShowS
dropExtension2 String
out String -> ShowS
<.> String
"hp"
      HasCallStack => [String] -> Action ()
need [String
hpFile]
      forall args. (HasCallStack, CmdArguments args, Unit args) => args
cmd_ (String
"hp2pretty" :: String) [String
hpFile]
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 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
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]
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
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. 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
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
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
Hashable, 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 =
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"ghc is not in the PATH") 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 <- forall args r. (HasCallStack, CmdArguments args) => args
cmd [String -> CmdOption
Cwd String
cwd] (String
"stack exec which ghc" :: 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
lower forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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   = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Unknown build system: " forall a. Semigroup a => a -> a -> a
<> String
other

instance ToJSON BuildSystem where
    toJSON :: BuildSystem -> Value
toJSON = forall a. ToJSON a => a -> Value
toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
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
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
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
Hashable, 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 -> ()
forall a. (a -> ()) -> NFData a
rnf :: GitCommit -> ()
$crnf :: GitCommit -> ()
NFData, Int -> GitCommit -> ShowS
[GitCommit] -> ShowS
GitCommit -> String
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) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Maybe Text -> Bool -> GitCommit
GitCommit Text
s forall a. Maybe a
Nothing forall a. Maybe a
Nothing Bool
True
  parseJSON o :: Value
o@(Object KeyMap Value
_) = do
    let keymap :: KeyMap Value
keymap = Value
o forall s a. s -> Getting a s a -> a
^. forall t. AsValue t => Prism' t (KeyMap Value)
_Object
    case forall l. IsList l => l -> [Item l]
toList KeyMap Value
keymap of
      -- excuse the aeson 2.0 compatibility hack
      [(forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview forall t. AsValue t => Prism' t Text
_String forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> Value
toJSON -> Just Text
name, String Text
gitName)] ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Maybe Text -> Bool -> GitCommit
GitCommit Text
gitName (forall a. a -> Maybe a
Just Text
name) forall a. Maybe a
Nothing Bool
True
      [(forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview forall t. AsValue t => Prism' t Text
_String forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> Value
toJSON -> Just Text
name, Object KeyMap Value
props)] ->
        Text -> Maybe Text -> Maybe Text -> Bool -> GitCommit
GitCommit
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyMap Value
props forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"git"  forall a. Parser (Maybe a) -> a -> Parser a
.!= Text
name
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just Text
name)
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> KeyMap Value
props forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"parent"
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> KeyMap Value
props forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"include" forall a. Parser (Maybe a) -> a -> Parser a
.!= Bool
True
      [Item (KeyMap Value)]
_ -> forall (f :: * -> *) a. Alternative f => f a
empty
  parseJSON Value
_ = 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  -> [(Key, Value)] -> Value
object [forall a. IsString a => String -> a
fromString (Text -> String
T.unpack Text
n) 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
..} = 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 forall a. Eq a => a -> a -> Bool
== Text
name = GitCommit -> Text
humanName GitCommit
x
  | Bool
otherwise = Text -> [GitCommit] -> Text
findPrev Text
name (GitCommit
y 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
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 <- forall a. Read a => ReadPrec a
readPrec @Int forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadPrec ()
spaces
    Int
copied <- forall a. Read a => ReadPrec a
readPrec @Int forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadPrec ()
spaces
    Int
live <- forall a. Read a => ReadPrec a
readPrec @Int forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadPrec ()
spaces
    Double
user <- forall a. Read a => ReadPrec a
readPrec @Double forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadPrec ()
spaces
    Double
elapsed <- forall a. Read a => ReadPrec a
readPrec @Double forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadPrec ()
spaces
    Double
totUser <- forall a. Read a => ReadPrec a
readPrec @Double forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadPrec ()
spaces
    Double
totElapsed <- forall a. Read a => ReadPrec a
readPrec @Double forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadPrec ()
spaces
    Int
_ <- forall a. Read a => ReadPrec a
readPrec @Int forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadPrec ()
spaces
    Int
_ <- forall a. Read a => ReadPrec a
readPrec @Int forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadPrec ()
spaces
    String
"(Gen:  " <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
7 ReadPrec Char
get
    Int
generation <- forall a. Read a => ReadPrec a
readPrec @Int
    Char
')' <- ReadPrec Char
get
    forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall a. (Int -> ReadP a) -> ReadPrec a
readP_to_Prec forall a b. (a -> b) -> a -> b
$ 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 -> String
runConfiguration :: !String,
    RunLog -> [Frame]
runFrames        :: ![Frame],
    RunLog -> Bool
runSuccess       :: !Bool,
    RunLog -> Maybe Double
runFirstReponse  :: !(Maybe Seconds)
  }

loadRunLog :: HasCallStack => Escaped FilePath -> String -> String -> Action RunLog
loadRunLog :: HasCallStack => Escaped String -> String -> String -> Action RunLog
loadRunLog (Escaped String
csv_fp) String
ver String
conf = do
  let log_fp :: String
log_fp = String -> ShowS
replaceExtension String
csv_fp String
"gcStats.log"
  [String]
log <- HasCallStack => String -> Action [String]
readFileLines String
log_fp
  [String]
csv <- HasCallStack => String -> Action [String]
readFileLines String
csv_fp
  let frames :: [Frame]
frames =
        [ Frame
f
          | String
l <- [String]
log,
            Just Frame
f <- [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 forall a. Eq a => a -> a -> Bool
== Int
1
        ]
      -- TODO this assumes a certain structure in the CSV file
      (Bool
success, Maybe Double
firstResponse) = case forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
T.strip forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> [Text]
T.split (forall a. Eq a => a -> a -> Bool
== Char
',') forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) [String]
csv of
          [[Text]
header, [Text]
row]
            | let table :: [(Text, Text)]
table = forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
header [Text]
row
                  timeForFirstResponse :: Maybe Seconds
                  timeForFirstResponse :: Maybe Double
timeForFirstResponse = forall a. Read a => String -> Maybe a
readMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"firstBuildTime" [(Text, Text)]
table
            , Just Text
s <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"success" [(Text, Text)]
table
            , Just Bool
s <- forall a. Read a => String -> Maybe a
readMaybe (Text -> String
T.unpack Text
s)
            -> (Bool
s,Maybe Double
timeForFirstResponse)
          [[Text]]
_ -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Cannot parse: " forall a. Semigroup a => a -> a -> a
<> String
csv_fp
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> String -> [Frame] -> Bool -> Maybe Double -> RunLog
RunLog String
ver String
conf [Frame]
frames Bool
success Maybe Double
firstResponse

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

data TraceMetric = Allocated | Copied | Live | User | Elapsed
  deriving (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]
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
forall a. a -> a -> Bounded a
maxBound :: TraceMetric
$cmaxBound :: TraceMetric
minBound :: TraceMetric
$cminBound :: TraceMetric
Bounded, ReadPrec [TraceMetric]
ReadPrec TraceMetric
Int -> ReadS TraceMetric
ReadS [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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Frame -> Int
allocated
frameMetric TraceMetric
Copied    = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Frame -> Int
copied
frameMetric TraceMetric
Live      = forall a b. (Integral a, Num b) => a -> b
fromIntegral 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. 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
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall r.
(Default r, ToRenderable r) =>
FileOptions -> String -> EC r () -> IO ()
E.toFile forall a. Default a => a
E.def String
out forall a b. (a -> b) -> a -> b
$ do
    forall x y. Lens' (Layout x y) String
E.layout_title forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
E..= Diagram -> String
title Diagram
t
    forall l. [AlphaColour Double] -> EC l ()
E.setColors [AlphaColour Double]
myColors
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [RunLog]
runLogs forall a b. (a -> b) -> a -> b
$ \RunLog
rl ->
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
includeFailed Bool -> Bool -> Bool
|| RunLog -> Bool
runSuccess RunLog
rl) forall a b. (a -> b) -> a -> b
$ do
        -- Get the color we are going to use
        ~(AlphaColour Double
c:[AlphaColour Double]
_) <- forall a l. State CState a -> EC l a
E.liftCState forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
E.view Lens' CState [AlphaColour Double]
E.colors)
        forall (p :: * -> * -> *) x y.
ToPlot p =>
EC (Layout x y) (p x y) -> EC (Layout x y) ()
E.plot forall a b. (a -> b) -> a -> b
$ do
          PlotLines Double Double
lplot <- forall x y l. String -> [[(x, y)]] -> EC l (PlotLines x y)
E.line
              (RunLog -> String
runVersion RunLog
rl forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ RunLog -> String
runConfiguration RunLog
rl 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 forall a b. a -> (a -> b) -> b
E.& forall x y. Lens' (PlotLines x y) LineStyle
E.plot_lines_style forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' LineStyle Double
E.line_width forall a s t. Num a => ASetter s t a a -> a -> s -> t
E.*~ Double
2)
        case RunLog -> Maybe Double
runFirstReponse RunLog
rl of
          Just Double
t -> forall (p :: * -> * -> *) x y.
ToPlot p =>
EC (Layout x y) (p x y) -> EC (Layout x y) ()
E.plot forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
              forall a b. String -> LineStyle -> a -> Plot a b
E.vlinePlot (String
"First build: " forall a. [a] -> [a] -> [a]
++ RunLog -> String
runVersion RunLog
rl) (LineStyle
E.defaultPlotLineStyle forall a b. a -> (a -> b) -> b
E.& Lens' LineStyle (AlphaColour Double)
E.line_color forall s t a b. ASetter s t a b -> b -> s -> t
E..~ AlphaColour Double
c) Double
t
          Maybe Double
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

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

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

newtype Unescaped a = Unescaped {forall a. Unescaped a -> a
unescaped :: a}
  deriving newtype (Int -> Unescaped a -> ShowS
[Unescaped a] -> ShowS
Unescaped a -> String
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)
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
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
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 -> ()
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
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, 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
Hashable)

escapeExperiment :: Unescaped String -> Escaped String
escapeExperiment :: Unescaped String -> Escaped String
escapeExperiment = forall a. a -> Escaped a
Escaped forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a. a -> Unescaped a
Unescaped forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. Semigroup a => a -> a -> a
<> String
"/" forall a. Semigroup a => a -> a -> a
<> String
b

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

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

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