mirror of
https://github.com/haskell/haskell-language-server.git
synced 2024-09-11 08:45:35 +03:00
Extract the benchmarking Shake rules to a standalone Cabal package (haskell/ghcide#941)
* [bench-hist] break down in rule functions * Extract the benchmarking Shake rules to a shake-bench package There's some room for reusing the rules used in the historic benchmarking suite in other projects. This change makes that a bit easier and improves the documentation and code structure. The new structure is: - lib:shake-bench - a Cabal library with functions to generate Shake rules - ghcide:bench:benchHist - the ghcide instantiation of the above Shake rules That's not to say that shake-bench is completely decoupled from ghcide - there are still plenty of assumptions on how the benchmarks are organized, their outputs, etc. But with a little bit of effort, it should be easy to make these rules more reusable * Fix nix build * Fix license * hlints and redundant imports * more hlints * Exclude shake-bench from the stack build
This commit is contained in:
parent
c47f892df8
commit
14af467e97
@ -63,7 +63,6 @@
|
||||
- {name: GeneralizedNewtypeDeriving, within: []}
|
||||
- {name: LambdaCase, within: []}
|
||||
- {name: NamedFieldPuns, within: []}
|
||||
- {name: OverloadedStrings, within: []}
|
||||
- {name: PackageImports, within: []}
|
||||
- {name: RecordWildCards, within: []}
|
||||
- {name: ScopedTypeVariables, within: []}
|
||||
|
2
fmt.sh
2
fmt.sh
@ -1,3 +1,3 @@
|
||||
#!/usr/bin/env bash
|
||||
set -eou pipefail
|
||||
curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s src exe bench/exe test/exe --with-group=extra
|
||||
curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s src exe bench shake-bench/src test/exe --with-group=extra
|
||||
|
@ -4,9 +4,6 @@ samples: 100
|
||||
|
||||
buildTool: cabal
|
||||
|
||||
# Path to the ghcide-bench binary to use for experiments
|
||||
ghcideBench: ghcide-bench
|
||||
|
||||
# Output folder for the experiments
|
||||
outputFolder: bench-results
|
||||
|
||||
|
@ -38,491 +38,110 @@
|
||||
> cabal bench --benchmark-options "bench-results/HEAD/results.csv bench-results/HEAD/edit.diff.svg"
|
||||
|
||||
-}
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DerivingStrategies#-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# OPTIONS -Wno-orphans #-}
|
||||
|
||||
import Control.Applicative (Alternative (empty))
|
||||
import Control.Monad (when, forM, forM_, replicateM)
|
||||
import Data.Char (toLower)
|
||||
import Data.Foldable (find)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Yaml ((.!=), (.:?), FromJSON (..), ToJSON (..), Value (..), decodeFileThrow)
|
||||
import Data.Yaml (FromJSON (..), decodeFileThrow)
|
||||
import Development.Benchmark.Rules
|
||||
import Development.Shake
|
||||
import Development.Shake.Classes (Binary, Hashable, NFData)
|
||||
import Experiments.Types (getExampleName, exampleToOptions, Example(..))
|
||||
import GHC.Exts (IsList (..))
|
||||
import Experiments.Types (Example, exampleToOptions)
|
||||
import qualified Experiments.Types as E
|
||||
import GHC.Generics (Generic)
|
||||
import qualified Graphics.Rendering.Chart.Backend.Diagrams as E
|
||||
import Graphics.Rendering.Chart.Easy ((.=))
|
||||
import qualified Graphics.Rendering.Chart.Easy as E
|
||||
import Numeric.Natural (Natural)
|
||||
import System.Directory
|
||||
import System.FilePath
|
||||
import qualified Text.ParserCombinators.ReadP as P
|
||||
import Text.Read (Read (..), get, readMaybe, readP_to_Prec)
|
||||
import GHC.Stack (HasCallStack)
|
||||
import Data.List (transpose)
|
||||
|
||||
|
||||
config :: FilePath
|
||||
config = "bench/config.yaml"
|
||||
|
||||
-- | Read the config without dependency
|
||||
readConfigIO :: FilePath -> IO Config
|
||||
readConfigIO :: FilePath -> IO (Config BuildSystem)
|
||||
readConfigIO = decodeFileThrow
|
||||
|
||||
newtype GetExample = GetExample String deriving newtype (Binary, Eq, Hashable, NFData, Show)
|
||||
newtype GetExamples = GetExamples () deriving newtype (Binary, Eq, Hashable, NFData, Show)
|
||||
newtype GetSamples = GetSamples () deriving newtype (Binary, Eq, Hashable, NFData, Show)
|
||||
newtype GetExperiments = GetExperiments () deriving newtype (Binary, Eq, Hashable, NFData, Show)
|
||||
newtype GetVersions = GetVersions () deriving newtype (Binary, Eq, Hashable, NFData, Show)
|
||||
newtype GetParent = GetParent Text deriving newtype (Binary, Eq, Hashable, NFData, Show)
|
||||
newtype GetCommitId = GetCommitId String deriving newtype (Binary, Eq, Hashable, NFData, Show)
|
||||
|
||||
instance IsExample Example where getExampleName = E.getExampleName
|
||||
type instance RuleResult GetExample = Maybe Example
|
||||
type instance RuleResult GetExamples = [Example]
|
||||
type instance RuleResult GetSamples = Natural
|
||||
type instance RuleResult GetExperiments = [Unescaped String]
|
||||
type instance RuleResult GetVersions = [GitCommit]
|
||||
type instance RuleResult GetParent = Text
|
||||
type instance RuleResult GetCommitId = String
|
||||
|
||||
main :: IO ()
|
||||
main = shakeArgs shakeOptions {shakeChange = ChangeModtimeAndDigest} $ do
|
||||
want ["all"]
|
||||
createBuildSystem $ \resource -> do
|
||||
configStatic <- liftIO $ readConfigIO config
|
||||
let build = outputFolder configStatic
|
||||
buildRules build ghcideBuildRules
|
||||
benchRules build resource (MkBenchRules (benchGhcide $ samples configStatic) "ghcide")
|
||||
csvRules build
|
||||
svgRules build
|
||||
action $ allTargets build
|
||||
|
||||
readConfig <- newCache $ \fp -> need [fp] >> liftIO (readConfigIO fp)
|
||||
|
||||
_ <- addOracle $ \GetSamples {} -> samples <$> readConfig config
|
||||
_ <- addOracle $ \GetExperiments {} -> experiments <$> readConfig config
|
||||
_ <- addOracle $ \GetVersions {} -> versions <$> readConfig config
|
||||
_ <- addOracle $ \GetExamples{} -> examples <$> readConfig config
|
||||
_ <- addOracle $ \(GetParent name) -> findPrev name . versions <$> readConfig config
|
||||
_ <- addOracle $ \(GetExample name) -> find (\e -> getExampleName e == name) . examples <$> readConfig config
|
||||
|
||||
let readVersions = askOracle $ GetVersions ()
|
||||
readExperiments = askOracle $ GetExperiments ()
|
||||
readExamples = askOracle $ GetExamples ()
|
||||
readSamples = askOracle $ GetSamples ()
|
||||
getParent = askOracle . GetParent
|
||||
getExample = askOracle . GetExample
|
||||
|
||||
configStatic <- liftIO $ readConfigIO config
|
||||
ghcideBenchPath <- ghcideBench <$> liftIO (readConfigIO config)
|
||||
let build = outputFolder configStatic
|
||||
buildSystem = buildTool configStatic
|
||||
|
||||
phony "all" $ do
|
||||
Config {..} <- readConfig config
|
||||
|
||||
need $
|
||||
[build </> getExampleName e </> "results.csv" | e <- examples ] ++
|
||||
[build </> "results.csv"]
|
||||
++ [ build </> getExampleName ex </> escaped (escapeExperiment e) <.> "svg"
|
||||
| e <- experiments
|
||||
, ex <- examples
|
||||
]
|
||||
++ [ build </> getExampleName ex </> T.unpack (humanName ver) </> escaped (escapeExperiment e) <.> mode <.> "svg"
|
||||
| e <- experiments,
|
||||
ex <- examples,
|
||||
ver <- versions,
|
||||
mode <- ["", "diff"]
|
||||
]
|
||||
|
||||
build -/- "*/commitid" %> \out -> do
|
||||
alwaysRerun
|
||||
|
||||
let [_,ver,_] = splitDirectories out
|
||||
mbEntry <- find ((== T.pack ver) . humanName) <$> readVersions
|
||||
let gitThing :: String
|
||||
gitThing = maybe ver (T.unpack . gitName) mbEntry
|
||||
Stdout commitid <- command [] "git" ["rev-list", "-n", "1", gitThing]
|
||||
writeFileChanged out $ init commitid
|
||||
|
||||
priority 10 $ [ build -/- "HEAD/ghcide"
|
||||
, build -/- "HEAD/ghc.path"
|
||||
]
|
||||
&%> \[out, ghcpath] -> do
|
||||
liftIO $ createDirectoryIfMissing True $ dropFileName out
|
||||
need =<< getDirectoryFiles "." ["src//*.hs", "exe//*.hs", "ghcide.cabal"]
|
||||
cmd_ $ buildGhcide buildSystem (takeDirectory out)
|
||||
ghcLoc <- findGhc "." buildSystem
|
||||
writeFile' ghcpath ghcLoc
|
||||
|
||||
[ build -/- "*/ghcide",
|
||||
build -/- "*/ghc.path"
|
||||
]
|
||||
&%> \[out, ghcpath] -> do
|
||||
let [b, ver, _] = splitDirectories out
|
||||
liftIO $ createDirectoryIfMissing True $ dropFileName out
|
||||
commitid <- readFile' $ b </> ver </> "commitid"
|
||||
cmd_ $ "git worktree add bench-temp " ++ commitid
|
||||
flip actionFinally (cmd_ (s "git worktree remove bench-temp --force")) $ do
|
||||
ghcLoc <- findGhc "bench-temp" buildSystem
|
||||
cmd_ [Cwd "bench-temp"] $ buildGhcide buildSystem (".." </> takeDirectory out)
|
||||
writeFile' ghcpath ghcLoc
|
||||
|
||||
build -/- "*/*/results.csv" %> \out -> do
|
||||
experiments <- readExperiments
|
||||
|
||||
let allResultFiles = [takeDirectory out </> escaped (escapeExperiment e) <.> "csv" | e <- experiments]
|
||||
allResults <- traverse readFileLines allResultFiles
|
||||
|
||||
let header = head $ head allResults
|
||||
results = map tail allResults
|
||||
writeFileChanged out $ unlines $ header : concat results
|
||||
|
||||
ghcideBenchResource <- newResource "ghcide-bench" 1
|
||||
|
||||
priority 0 $
|
||||
[ build -/- "*/*/*.csv",
|
||||
build -/- "*/*/*.benchmark-gcStats",
|
||||
build -/- "*/*/*.log"
|
||||
]
|
||||
&%> \[outcsv, _outGc, outLog] -> do
|
||||
let [_, exampleName, ver, exp] = splitDirectories outcsv
|
||||
example <- fromMaybe (error $ "Unknown example " <> exampleName) <$> getExample exampleName
|
||||
samples <- readSamples
|
||||
liftIO $ createDirectoryIfMissing True $ dropFileName outcsv
|
||||
let ghcide = build </> ver </> "ghcide"
|
||||
ghcpath = build </> ver </> "ghc.path"
|
||||
need [ghcide, ghcpath]
|
||||
ghcPath <- readFile' ghcpath
|
||||
withResource ghcideBenchResource 1 $ do
|
||||
command_
|
||||
[ EchoStdout False,
|
||||
FileStdout outLog,
|
||||
RemEnv "NIX_GHC_LIBDIR",
|
||||
RemEnv "GHC_PACKAGE_PATH",
|
||||
AddPath [takeDirectory ghcPath, "."] []
|
||||
]
|
||||
ghcideBenchPath $
|
||||
[ "--timeout=3000",
|
||||
"-v",
|
||||
"--samples=" <> show samples,
|
||||
"--csv=" <> outcsv,
|
||||
"--ghcide-options= +RTS -I0.5 -RTS",
|
||||
"--ghcide=" <> ghcide,
|
||||
"--select",
|
||||
unescaped (unescapeExperiment (Escaped $ dropExtension exp))
|
||||
] ++
|
||||
exampleToOptions example ++
|
||||
[ "--stack" | Stack == buildSystem]
|
||||
cmd_ Shell $ "mv *.benchmark-gcStats " <> dropFileName outcsv
|
||||
|
||||
build -/- "results.csv" %> \out -> do
|
||||
examples <- map getExampleName <$> readExamples
|
||||
let allResultFiles = [build </> e </> "results.csv" | e <- examples]
|
||||
|
||||
allResults <- traverse readFileLines allResultFiles
|
||||
|
||||
let header = head $ head allResults
|
||||
results = map tail allResults
|
||||
header' = "example, " <> header
|
||||
results' = zipWith (\e -> map (\l -> e <> ", " <> l)) examples results
|
||||
|
||||
writeFileChanged out $ unlines $ header' : concat results'
|
||||
|
||||
build -/- "*/results.csv" %> \out -> do
|
||||
versions <- map (T.unpack . humanName) <$> readVersions
|
||||
let example = takeFileName $ takeDirectory out
|
||||
allResultFiles =
|
||||
[build </> example </> v </> "results.csv" | v <- versions]
|
||||
|
||||
allResults <- traverse readFileLines allResultFiles
|
||||
|
||||
let header = head $ head allResults
|
||||
results = map tail allResults
|
||||
header' = "version, " <> header
|
||||
results' = zipWith (\v -> map (\l -> v <> ", " <> l)) versions results
|
||||
|
||||
writeFileChanged out $ unlines $ header' : interleave results'
|
||||
|
||||
priority 2 $
|
||||
build -/- "*/*/*.diff.svg" %> \out -> do
|
||||
let [b, example, ver, exp_] = splitDirectories out
|
||||
exp = Escaped $ dropExtension $ dropExtension exp_
|
||||
prev <- getParent $ T.pack ver
|
||||
|
||||
runLog <- loadRunLog b example exp ver
|
||||
runLogPrev <- loadRunLog b example exp $ T.unpack prev
|
||||
|
||||
let diagram = Diagram Live [runLog, runLogPrev] title
|
||||
title = show (unescapeExperiment exp) <> " - live bytes over time compared"
|
||||
plotDiagram True diagram out
|
||||
|
||||
priority 1 $
|
||||
build -/- "*/*/*.svg" %> \out -> do
|
||||
let [b, example, ver, exp] = splitDirectories out
|
||||
runLog <- loadRunLog b example (Escaped $ dropExtension exp) ver
|
||||
let diagram = Diagram Live [runLog] title
|
||||
title = ver <> " live bytes over time"
|
||||
plotDiagram True diagram out
|
||||
|
||||
build -/- "*/*.svg" %> \out -> do
|
||||
let exp = Escaped $ dropExtension $ takeFileName out
|
||||
example = takeFileName $ takeDirectory out
|
||||
versions <- readVersions
|
||||
|
||||
runLogs <- forM (filter include versions) $ \v -> do
|
||||
loadRunLog build example exp $ T.unpack $ humanName v
|
||||
|
||||
let diagram = Diagram Live runLogs title
|
||||
title = show (unescapeExperiment exp) <> " - live bytes over time"
|
||||
plotDiagram False diagram out
|
||||
ghcideBuildRules :: MkBuildRules BuildSystem
|
||||
ghcideBuildRules = MkBuildRules findGhcForBuildSystem "ghcide" buildGhcide
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
buildGhcide :: BuildSystem -> String -> String
|
||||
buildGhcide Cabal out = unwords
|
||||
["cabal install"
|
||||
,"exe:ghcide"
|
||||
,"--installdir=" ++ out
|
||||
,"--install-method=copy"
|
||||
,"--overwrite-policy=always"
|
||||
,"--ghc-options -rtsopts"
|
||||
]
|
||||
buildGhcide Stack out =
|
||||
"stack --local-bin-path=" <> out
|
||||
<> " build ghcide:ghcide --copy-bins --ghc-options -rtsopts"
|
||||
|
||||
|
||||
findGhc :: FilePath -> BuildSystem -> Action FilePath
|
||||
findGhc _cwd Cabal =
|
||||
liftIO $ fromMaybe (error "ghc is not in the PATH") <$> findExecutable "ghc"
|
||||
findGhc cwd Stack = do
|
||||
Stdout ghcLoc <- cmd [Cwd cwd] (s "stack exec which ghc")
|
||||
return ghcLoc
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Config = Config
|
||||
data Config buildSystem = Config
|
||||
{ experiments :: [Unescaped String],
|
||||
examples :: [Example],
|
||||
samples :: Natural,
|
||||
versions :: [GitCommit],
|
||||
-- | Path to the ghcide-bench binary for the experiments
|
||||
ghcideBench :: FilePath,
|
||||
-- | Output folder ('foo' works, 'foo/bar' does not)
|
||||
outputFolder :: String,
|
||||
buildTool :: BuildSystem
|
||||
buildTool :: buildSystem
|
||||
}
|
||||
deriving (Generic, Show)
|
||||
deriving anyclass (FromJSON)
|
||||
|
||||
data GitCommit = GitCommit
|
||||
{ -- | A git hash, tag or branch name (e.g. v0.1.0)
|
||||
gitName :: Text,
|
||||
-- | A human understandable name (e.g. fix-collisions-leak)
|
||||
name :: Maybe Text,
|
||||
-- | The human understandable name of the parent, if specified explicitly
|
||||
parent :: Maybe Text,
|
||||
-- | Whether to include this version in the top chart
|
||||
include :: Bool
|
||||
}
|
||||
deriving (Binary, Eq, Hashable, Generic, NFData, Show)
|
||||
createBuildSystem :: (Resource -> Rules a) -> Rules a
|
||||
createBuildSystem userRules = do
|
||||
readConfig <- newCache $ \fp -> need [fp] >> liftIO (readConfigIO fp)
|
||||
|
||||
instance FromJSON GitCommit where
|
||||
parseJSON (String s) = pure $ GitCommit s Nothing Nothing True
|
||||
parseJSON (Object (toList -> [(name, String gitName)])) =
|
||||
pure $ GitCommit gitName (Just name) Nothing True
|
||||
parseJSON (Object (toList -> [(name, Object props)])) =
|
||||
GitCommit
|
||||
<$> props .:? "git" .!= name
|
||||
<*> pure (Just name)
|
||||
<*> props .:? "parent"
|
||||
<*> props .:? "include" .!= True
|
||||
parseJSON _ = empty
|
||||
_ <- addOracle $ \GetExperiments {} -> experiments <$> readConfig config
|
||||
_ <- addOracle $ \GetVersions {} -> versions <$> readConfig config
|
||||
_ <- addOracle $ \GetExamples{} -> examples <$> readConfig config
|
||||
_ <- addOracle $ \(GetExample name) -> find (\e -> getExampleName e == name) . examples <$> readConfig config
|
||||
_ <- addOracle $ \GetBuildSystem {} -> buildTool <$> readConfig config
|
||||
|
||||
instance ToJSON GitCommit where
|
||||
toJSON GitCommit {..} =
|
||||
case name of
|
||||
Nothing -> String gitName
|
||||
Just n -> Object $ fromList [(n, String gitName)]
|
||||
benchResource <- newResource "ghcide-bench" 1
|
||||
|
||||
humanName :: GitCommit -> Text
|
||||
humanName GitCommit {..} = fromMaybe gitName name
|
||||
userRules benchResource
|
||||
|
||||
findPrev :: Text -> [GitCommit] -> Text
|
||||
findPrev name (x : y : xx)
|
||||
| humanName y == name = humanName x
|
||||
| otherwise = findPrev name (y : xx)
|
||||
findPrev name _ = name
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data BuildSystem = Cabal | Stack
|
||||
deriving (Eq, Read, Show)
|
||||
|
||||
instance FromJSON BuildSystem where
|
||||
parseJSON x = fromString . map toLower <$> parseJSON x
|
||||
where
|
||||
fromString "stack" = Stack
|
||||
fromString "cabal" = Cabal
|
||||
fromString other = error $ "Unknown build system: " <> other
|
||||
|
||||
instance ToJSON BuildSystem where
|
||||
toJSON = toJSON . show
|
||||
----------------------------------------------------------------------------------------------------
|
||||
|
||||
-- | A line in the output of -S
|
||||
data Frame = Frame
|
||||
{ allocated, copied, live :: !Int,
|
||||
user, elapsed, totUser, totElapsed :: !Double,
|
||||
generation :: !Int
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
instance Read Frame where
|
||||
readPrec = do
|
||||
spaces
|
||||
allocated <- readPrec @Int <* spaces
|
||||
copied <- readPrec @Int <* spaces
|
||||
live <- readPrec @Int <* spaces
|
||||
user <- readPrec @Double <* spaces
|
||||
elapsed <- readPrec @Double <* spaces
|
||||
totUser <- readPrec @Double <* spaces
|
||||
totElapsed <- readPrec @Double <* spaces
|
||||
_ <- readPrec @Int <* spaces
|
||||
_ <- readPrec @Int <* spaces
|
||||
"(Gen: " <- replicateM 7 get
|
||||
generation <- readPrec @Int
|
||||
')' <- get
|
||||
return Frame {..}
|
||||
where
|
||||
spaces = readP_to_Prec $ const P.skipSpaces
|
||||
|
||||
data TraceMetric = Allocated | Copied | Live | User | Elapsed
|
||||
deriving (Generic, Enum, Bounded, Read)
|
||||
|
||||
instance Show TraceMetric where
|
||||
show Allocated = "Allocated bytes"
|
||||
show Copied = "Copied bytes"
|
||||
show Live = "Live bytes"
|
||||
show User = "User time"
|
||||
show Elapsed = "Elapsed time"
|
||||
|
||||
frameMetric :: TraceMetric -> Frame -> Double
|
||||
frameMetric Allocated = fromIntegral . allocated
|
||||
frameMetric Copied = fromIntegral . copied
|
||||
frameMetric Live = fromIntegral . live
|
||||
frameMetric Elapsed = elapsed
|
||||
frameMetric User = user
|
||||
|
||||
data Diagram = Diagram
|
||||
{ traceMetric :: TraceMetric,
|
||||
runLogs :: [RunLog],
|
||||
title :: String
|
||||
}
|
||||
deriving (Generic)
|
||||
|
||||
-- | A file path containing the output of -S for a given run
|
||||
data RunLog = RunLog
|
||||
{ runVersion :: !String,
|
||||
_runExample :: !String,
|
||||
_runExperiment :: !String,
|
||||
runFrames :: ![Frame],
|
||||
runSuccess :: !Bool
|
||||
}
|
||||
|
||||
loadRunLog :: HasCallStack => FilePath -> String -> Escaped FilePath -> FilePath -> Action RunLog
|
||||
loadRunLog buildF example exp ver = do
|
||||
let log_fp = buildF </> example </> ver </> escaped exp <.> "benchmark-gcStats"
|
||||
csv_fp = replaceExtension log_fp "csv"
|
||||
log <- readFileLines log_fp
|
||||
csv <- readFileLines csv_fp
|
||||
let frames =
|
||||
[ f
|
||||
| l <- log,
|
||||
Just f <- [readMaybe l],
|
||||
-- filter out gen 0 events as there are too many
|
||||
generation f == 1
|
||||
buildGhcide :: BuildSystem -> [CmdOption] -> FilePath -> Action ()
|
||||
buildGhcide Cabal args out = do
|
||||
command_ args "cabal"
|
||||
["install"
|
||||
,"exe:ghcide"
|
||||
,"--installdir=" ++ out
|
||||
,"--install-method=copy"
|
||||
,"--overwrite-policy=always"
|
||||
,"--ghc-options=-rtsopts"
|
||||
]
|
||||
success = case map (T.split (== ',') . T.pack) csv of
|
||||
[_header, _name:s:_] | Just s <- readMaybe (T.unpack s) -> s
|
||||
_ -> error $ "Cannot parse: " <> csv_fp
|
||||
return $ RunLog ver example (dropExtension $ escaped exp) frames success
|
||||
|
||||
plotDiagram :: Bool -> Diagram -> FilePath -> Action ()
|
||||
plotDiagram includeFailed t@Diagram {traceMetric, runLogs} out = do
|
||||
let extract = frameMetric traceMetric
|
||||
liftIO $ E.toFile E.def out $ do
|
||||
E.layout_title .= title t
|
||||
E.setColors myColors
|
||||
forM_ runLogs $ \rl ->
|
||||
when (includeFailed || runSuccess rl) $ E.plot $ do
|
||||
lplot <- E.line
|
||||
(runVersion rl ++ if runSuccess rl then "" else " (FAILED)")
|
||||
[ [ (totElapsed f, extract f)
|
||||
| f <- runFrames rl
|
||||
]
|
||||
]
|
||||
return (lplot E.& E.plot_lines_style . E.line_width E.*~ 2)
|
||||
buildGhcide Stack args out =
|
||||
command_ args "stack"
|
||||
["--local-bin-path=" <> out
|
||||
,"build"
|
||||
,"ghcide:ghcide"
|
||||
,"--copy-bins"
|
||||
,"--ghc-options=-rtsopts"
|
||||
]
|
||||
|
||||
s :: String -> String
|
||||
s = id
|
||||
benchGhcide
|
||||
:: Natural -> BuildSystem -> [CmdOption] -> BenchProject Example -> Action ()
|
||||
benchGhcide samples buildSystem args BenchProject{..} =
|
||||
command_ args "ghcide-bench" $
|
||||
[ "--timeout=3000",
|
||||
"-v",
|
||||
"--samples=" <> show samples,
|
||||
"--csv=" <> outcsv,
|
||||
"--ghcide=" <> exePath,
|
||||
"--select",
|
||||
unescaped (unescapeExperiment experiment)
|
||||
] ++
|
||||
exampleToOptions example ++
|
||||
[ "--stack" | Stack == buildSystem
|
||||
] ++
|
||||
exeExtraArgs
|
||||
|
||||
(-/-) :: FilePattern -> FilePattern -> FilePattern
|
||||
a -/- b = a <> "/" <> b
|
||||
|
||||
newtype Escaped a = Escaped {escaped :: a}
|
||||
|
||||
newtype Unescaped a = Unescaped {unescaped :: a}
|
||||
deriving newtype (Show, FromJSON, ToJSON, Eq, NFData, Binary, Hashable)
|
||||
|
||||
escapeExperiment :: Unescaped String -> Escaped String
|
||||
escapeExperiment = Escaped . map f . unescaped
|
||||
where
|
||||
f ' ' = '_'
|
||||
f other = other
|
||||
|
||||
unescapeExperiment :: Escaped String -> Unescaped String
|
||||
unescapeExperiment = Unescaped . map f . escaped
|
||||
where
|
||||
f '_' = ' '
|
||||
f other = other
|
||||
|
||||
interleave :: [[a]] -> [a]
|
||||
interleave = concat . transpose
|
||||
|
||||
myColors :: [E.AlphaColour Double]
|
||||
myColors = map E.opaque
|
||||
[ E.blue
|
||||
, E.green
|
||||
, E.red
|
||||
, E.orange
|
||||
, E.yellow
|
||||
, E.violet
|
||||
, E.black
|
||||
, E.gold
|
||||
, E.brown
|
||||
, E.hotpink
|
||||
, E.aliceblue
|
||||
, E.aqua
|
||||
, E.beige
|
||||
, E.bisque
|
||||
, E.blueviolet
|
||||
, E.burlywood
|
||||
, E.cadetblue
|
||||
, E.chartreuse
|
||||
, E.coral
|
||||
, E.crimson
|
||||
, E.darkblue
|
||||
, E.darkgray
|
||||
, E.darkgreen
|
||||
, E.darkkhaki
|
||||
, E.darkmagenta
|
||||
, E.deeppink
|
||||
, E.dodgerblue
|
||||
, E.firebrick
|
||||
, E.forestgreen
|
||||
, E.fuchsia
|
||||
, E.greenyellow
|
||||
, E.lightsalmon
|
||||
, E.seagreen
|
||||
, E.olive
|
||||
, E.sandybrown
|
||||
, E.sienna
|
||||
, E.peru
|
||||
]
|
||||
|
@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
{-# LANGUAGE ImplicitParams #-}
|
||||
@ -273,19 +272,16 @@ runBenchmarksFun dir allBenchmarks = do
|
||||
outputRow $ (map . map) (const '-') paddedHeaders
|
||||
forM_ rowsHuman $ \row -> outputRow $ zipWith pad pads row
|
||||
where
|
||||
gcStats name = escapeSpaces (name <> ".benchmark-gcStats")
|
||||
cmd name dir =
|
||||
unwords $
|
||||
[ ghcide ?config,
|
||||
"--lsp",
|
||||
"--test",
|
||||
"--cwd",
|
||||
dir,
|
||||
"+RTS",
|
||||
"-S" <> gcStats name
|
||||
dir
|
||||
]
|
||||
++ case otMemoryProfiling ?config of
|
||||
Just dir -> ["-l", "-ol" ++ (dir </> (map (\c -> if c == ' ' then '-' else c) name) <.> "eventlog")]
|
||||
Just dir -> ["-l", "-ol" ++ (dir </> map (\c -> if c == ' ' then '-' else c) name <.> "eventlog")]
|
||||
Nothing -> []
|
||||
++ [ "-RTS" ]
|
||||
++ ghcideOptions ?config
|
||||
@ -293,7 +289,7 @@ runBenchmarksFun dir allBenchmarks = do
|
||||
[ ["--shake-profiling", path] | Just path <- [shakeProfiling ?config]
|
||||
]
|
||||
++ ["--verbose" | verbose ?config]
|
||||
++ if isJust (otMemoryProfiling ?config) then [ "--ot-memory-profiling" ] else []
|
||||
++ ["--ot-memory-profiling" | Just _ <- [otMemoryProfiling ?config]]
|
||||
lspTestCaps =
|
||||
fullCaps {_window = Just $ WindowClientCapabilities $ Just True}
|
||||
conf =
|
||||
|
@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
module Experiments.Types where
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Experiments.Types (module Experiments.Types ) where
|
||||
|
||||
import Data.Aeson
|
||||
import Data.Version
|
||||
|
@ -1,4 +1,4 @@
|
||||
packages: . ./hie-compat/
|
||||
packages: . ./hie-compat/ ./shake-bench/
|
||||
|
||||
test-show-details: direct
|
||||
|
||||
|
@ -208,7 +208,6 @@ benchmark benchHist
|
||||
hs-source-dirs: bench/hist bench/lib
|
||||
other-modules: Experiments.Types
|
||||
build-tool-depends:
|
||||
ghcide:ghcide,
|
||||
ghcide:ghcide-bench
|
||||
default-extensions:
|
||||
BangPatterns
|
||||
@ -218,7 +217,6 @@ benchmark benchHist
|
||||
GeneralizedNewtypeDeriving
|
||||
LambdaCase
|
||||
NamedFieldPuns
|
||||
OverloadedStrings
|
||||
RecordWildCards
|
||||
ScopedTypeVariables
|
||||
StandaloneDeriving
|
||||
@ -229,12 +227,8 @@ benchmark benchHist
|
||||
build-depends:
|
||||
aeson,
|
||||
base == 4.*,
|
||||
Chart,
|
||||
Chart-diagrams,
|
||||
diagrams,
|
||||
diagrams-svg,
|
||||
shake-bench == 0.1.*,
|
||||
directory,
|
||||
extra >= 1.7.2,
|
||||
filepath,
|
||||
shake,
|
||||
text,
|
||||
@ -392,7 +386,7 @@ executable ghcide-bench
|
||||
text
|
||||
hs-source-dirs: bench/lib bench/exe
|
||||
include-dirs: include
|
||||
ghc-options: -threaded -Wall -Wno-name-shadowing
|
||||
ghc-options: -threaded -Wall -Wno-name-shadowing -rtsopts
|
||||
main-is: Main.hs
|
||||
other-modules:
|
||||
Experiments
|
||||
|
@ -4,6 +4,11 @@ cradle:
|
||||
multi:
|
||||
- path: "./test/data"
|
||||
config: { cradle: { none: } }
|
||||
- path: "./shake-bench/src"
|
||||
config:
|
||||
cradle:
|
||||
cabal:
|
||||
component: "lib:shake-bench"
|
||||
- path: "./"
|
||||
config:
|
||||
cradle:
|
||||
|
@ -14,14 +14,21 @@ let
|
||||
});
|
||||
};
|
||||
};
|
||||
gitignoreSource = (import sources.gitignore { inherit (pkgs) lib; }).gitignoreSource;
|
||||
extend = haskellPackages:
|
||||
(haskellPackages.override sharedOverrides).extend (pkgs.haskell.lib.packageSourceOverrides {
|
||||
ghcide = gitignoreSource ../.;
|
||||
hie-compat = gitignoreSource ../hie-compat;
|
||||
shake-bench = gitignoreSource ../shake-bench;
|
||||
});
|
||||
in
|
||||
{
|
||||
inherit (import sources.gitignore { inherit (pkgs) lib; }) gitignoreSource;
|
||||
inherit gitignoreSource;
|
||||
ourHaskell = pkgs.haskell // {
|
||||
packages = pkgs.haskell.packages // {
|
||||
# relax upper bounds on ghc 8.10.x versions (and skip running tests)
|
||||
ghc8101 = pkgs.haskell.packages.ghc8101.override sharedOverrides;
|
||||
ghc8102 = pkgs.haskell.packages.ghc8102.override sharedOverrides;
|
||||
ghc8101 = extend pkgs.haskell.packages.ghc8101;
|
||||
ghc8102 = extend pkgs.haskell.packages.ghc8102;
|
||||
};
|
||||
};
|
||||
};
|
||||
|
@ -17,14 +17,15 @@ let defaultCompiler = "ghc" + lib.replaceStrings ["."] [""] haskellPackages.ghc.
|
||||
if compiler == "default"
|
||||
then ourHaskell.packages.${defaultCompiler}
|
||||
else ourHaskell.packages.${compiler};
|
||||
ghcide = p: haskell.lib.doCheck
|
||||
(p.callCabal2nixWithOptions "ghcide" (nixpkgs.gitignoreSource ./.) "--benchmark" {});
|
||||
isSupported = compiler == "default" || compiler == defaultCompiler;
|
||||
in
|
||||
haskellPackagesForProject.shellFor {
|
||||
inherit withHoogle;
|
||||
doBenchmark = true;
|
||||
packages = p: [ (if isSupported then ghcide p else p.ghc-paths) ];
|
||||
packages = p:
|
||||
if isSupported
|
||||
then [p.ghcide p.hie-compat p.shake-bench]
|
||||
else [p.ghc-paths];
|
||||
buildInputs = [
|
||||
gmp
|
||||
zlib
|
||||
|
@ -3,6 +3,7 @@ resolver: nightly-2020-09-02
|
||||
packages:
|
||||
- .
|
||||
- ./hie-compat/
|
||||
|
||||
extra-deps:
|
||||
- haskell-lsp-0.22.0.0
|
||||
- haskell-lsp-types-0.22.0.0
|
||||
|
201
shake-bench/LICENSE
Normal file
201
shake-bench/LICENSE
Normal file
@ -0,0 +1,201 @@
|
||||
Apache License
|
||||
Version 2.0, January 2004
|
||||
http://www.apache.org/licenses/
|
||||
|
||||
TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION
|
||||
|
||||
1. Definitions.
|
||||
|
||||
"License" shall mean the terms and conditions for use, reproduction,
|
||||
and distribution as defined by Sections 1 through 9 of this document.
|
||||
|
||||
"Licensor" shall mean the copyright owner or entity authorized by
|
||||
the copyright owner that is granting the License.
|
||||
|
||||
"Legal Entity" shall mean the union of the acting entity and all
|
||||
other entities that control, are controlled by, or are under common
|
||||
control with that entity. For the purposes of this definition,
|
||||
"control" means (i) the power, direct or indirect, to cause the
|
||||
direction or management of such entity, whether by contract or
|
||||
otherwise, or (ii) ownership of fifty percent (50%) or more of the
|
||||
outstanding shares, or (iii) beneficial ownership of such entity.
|
||||
|
||||
"You" (or "Your") shall mean an individual or Legal Entity
|
||||
exercising permissions granted by this License.
|
||||
|
||||
"Source" form shall mean the preferred form for making modifications,
|
||||
including but not limited to software source code, documentation
|
||||
source, and configuration files.
|
||||
|
||||
"Object" form shall mean any form resulting from mechanical
|
||||
transformation or translation of a Source form, including but
|
||||
not limited to compiled object code, generated documentation,
|
||||
and conversions to other media types.
|
||||
|
||||
"Work" shall mean the work of authorship, whether in Source or
|
||||
Object form, made available under the License, as indicated by a
|
||||
copyright notice that is included in or attached to the work
|
||||
(an example is provided in the Appendix below).
|
||||
|
||||
"Derivative Works" shall mean any work, whether in Source or Object
|
||||
form, that is based on (or derived from) the Work and for which the
|
||||
editorial revisions, annotations, elaborations, or other modifications
|
||||
represent, as a whole, an original work of authorship. For the purposes
|
||||
of this License, Derivative Works shall not include works that remain
|
||||
separable from, or merely link (or bind by name) to the interfaces of,
|
||||
the Work and Derivative Works thereof.
|
||||
|
||||
"Contribution" shall mean any work of authorship, including
|
||||
the original version of the Work and any modifications or additions
|
||||
to that Work or Derivative Works thereof, that is intentionally
|
||||
submitted to Licensor for inclusion in the Work by the copyright owner
|
||||
or by an individual or Legal Entity authorized to submit on behalf of
|
||||
the copyright owner. For the purposes of this definition, "submitted"
|
||||
means any form of electronic, verbal, or written communication sent
|
||||
to the Licensor or its representatives, including but not limited to
|
||||
communication on electronic mailing lists, source code control systems,
|
||||
and issue tracking systems that are managed by, or on behalf of, the
|
||||
Licensor for the purpose of discussing and improving the Work, but
|
||||
excluding communication that is conspicuously marked or otherwise
|
||||
designated in writing by the copyright owner as "Not a Contribution."
|
||||
|
||||
"Contributor" shall mean Licensor and any individual or Legal Entity
|
||||
on behalf of whom a Contribution has been received by Licensor and
|
||||
subsequently incorporated within the Work.
|
||||
|
||||
2. Grant of Copyright License. Subject to the terms and conditions of
|
||||
this License, each Contributor hereby grants to You a perpetual,
|
||||
worldwide, non-exclusive, no-charge, royalty-free, irrevocable
|
||||
copyright license to reproduce, prepare Derivative Works of,
|
||||
publicly display, publicly perform, sublicense, and distribute the
|
||||
Work and such Derivative Works in Source or Object form.
|
||||
|
||||
3. Grant of Patent License. Subject to the terms and conditions of
|
||||
this License, each Contributor hereby grants to You a perpetual,
|
||||
worldwide, non-exclusive, no-charge, royalty-free, irrevocable
|
||||
(except as stated in this section) patent license to make, have made,
|
||||
use, offer to sell, sell, import, and otherwise transfer the Work,
|
||||
where such license applies only to those patent claims licensable
|
||||
by such Contributor that are necessarily infringed by their
|
||||
Contribution(s) alone or by combination of their Contribution(s)
|
||||
with the Work to which such Contribution(s) was submitted. If You
|
||||
institute patent litigation against any entity (including a
|
||||
cross-claim or counterclaim in a lawsuit) alleging that the Work
|
||||
or a Contribution incorporated within the Work constitutes direct
|
||||
or contributory patent infringement, then any patent licenses
|
||||
granted to You under this License for that Work shall terminate
|
||||
as of the date such litigation is filed.
|
||||
|
||||
4. Redistribution. You may reproduce and distribute copies of the
|
||||
Work or Derivative Works thereof in any medium, with or without
|
||||
modifications, and in Source or Object form, provided that You
|
||||
meet the following conditions:
|
||||
|
||||
(a) You must give any other recipients of the Work or
|
||||
Derivative Works a copy of this License; and
|
||||
|
||||
(b) You must cause any modified files to carry prominent notices
|
||||
stating that You changed the files; and
|
||||
|
||||
(c) You must retain, in the Source form of any Derivative Works
|
||||
that You distribute, all copyright, patent, trademark, and
|
||||
attribution notices from the Source form of the Work,
|
||||
excluding those notices that do not pertain to any part of
|
||||
the Derivative Works; and
|
||||
|
||||
(d) If the Work includes a "NOTICE" text file as part of its
|
||||
distribution, then any Derivative Works that You distribute must
|
||||
include a readable copy of the attribution notices contained
|
||||
within such NOTICE file, excluding those notices that do not
|
||||
pertain to any part of the Derivative Works, in at least one
|
||||
of the following places: within a NOTICE text file distributed
|
||||
as part of the Derivative Works; within the Source form or
|
||||
documentation, if provided along with the Derivative Works; or,
|
||||
within a display generated by the Derivative Works, if and
|
||||
wherever such third-party notices normally appear. The contents
|
||||
of the NOTICE file are for informational purposes only and
|
||||
do not modify the License. You may add Your own attribution
|
||||
notices within Derivative Works that You distribute, alongside
|
||||
or as an addendum to the NOTICE text from the Work, provided
|
||||
that such additional attribution notices cannot be construed
|
||||
as modifying the License.
|
||||
|
||||
You may add Your own copyright statement to Your modifications and
|
||||
may provide additional or different license terms and conditions
|
||||
for use, reproduction, or distribution of Your modifications, or
|
||||
for any such Derivative Works as a whole, provided Your use,
|
||||
reproduction, and distribution of the Work otherwise complies with
|
||||
the conditions stated in this License.
|
||||
|
||||
5. Submission of Contributions. Unless You explicitly state otherwise,
|
||||
any Contribution intentionally submitted for inclusion in the Work
|
||||
by You to the Licensor shall be under the terms and conditions of
|
||||
this License, without any additional terms or conditions.
|
||||
Notwithstanding the above, nothing herein shall supersede or modify
|
||||
the terms of any separate license agreement you may have executed
|
||||
with Licensor regarding such Contributions.
|
||||
|
||||
6. Trademarks. This License does not grant permission to use the trade
|
||||
names, trademarks, service marks, or product names of the Licensor,
|
||||
except as required for reasonable and customary use in describing the
|
||||
origin of the Work and reproducing the content of the NOTICE file.
|
||||
|
||||
7. Disclaimer of Warranty. Unless required by applicable law or
|
||||
agreed to in writing, Licensor provides the Work (and each
|
||||
Contributor provides its Contributions) on an "AS IS" BASIS,
|
||||
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
|
||||
implied, including, without limitation, any warranties or conditions
|
||||
of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A
|
||||
PARTICULAR PURPOSE. You are solely responsible for determining the
|
||||
appropriateness of using or redistributing the Work and assume any
|
||||
risks associated with Your exercise of permissions under this License.
|
||||
|
||||
8. Limitation of Liability. In no event and under no legal theory,
|
||||
whether in tort (including negligence), contract, or otherwise,
|
||||
unless required by applicable law (such as deliberate and grossly
|
||||
negligent acts) or agreed to in writing, shall any Contributor be
|
||||
liable to You for damages, including any direct, indirect, special,
|
||||
incidental, or consequential damages of any character arising as a
|
||||
result of this License or out of the use or inability to use the
|
||||
Work (including but not limited to damages for loss of goodwill,
|
||||
work stoppage, computer failure or malfunction, or any and all
|
||||
other commercial damages or losses), even if such Contributor
|
||||
has been advised of the possibility of such damages.
|
||||
|
||||
9. Accepting Warranty or Additional Liability. While redistributing
|
||||
the Work or Derivative Works thereof, You may choose to offer,
|
||||
and charge a fee for, acceptance of support, warranty, indemnity,
|
||||
or other liability obligations and/or rights consistent with this
|
||||
License. However, in accepting such obligations, You may act only
|
||||
on Your own behalf and on Your sole responsibility, not on behalf
|
||||
of any other Contributor, and only if You agree to indemnify,
|
||||
defend, and hold each Contributor harmless for any liability
|
||||
incurred by, or claims asserted against, such Contributor by reason
|
||||
of your accepting any such warranty or additional liability.
|
||||
|
||||
END OF TERMS AND CONDITIONS
|
||||
|
||||
APPENDIX: How to apply the Apache License to your work.
|
||||
|
||||
To apply the Apache License to your work, attach the following
|
||||
boilerplate notice, with the fields enclosed by brackets "[]"
|
||||
replaced with your own identifying information. (Don't include
|
||||
the brackets!) The text should be enclosed in the appropriate
|
||||
comment syntax for the file format. We also recommend that a
|
||||
file or class name and description of purpose be included on the
|
||||
same "printed page" as the copyright notice for easier
|
||||
identification within third-party archives.
|
||||
|
||||
Copyright 2020-2021 Jose Iborra Lopez
|
||||
|
||||
Licensed under the Apache License, Version 2.0 (the "License");
|
||||
you may not use this file except in compliance with the License.
|
||||
You may obtain a copy of the License at
|
||||
|
||||
http://www.apache.org/licenses/LICENSE-2.0
|
||||
|
||||
Unless required by applicable law or agreed to in writing, software
|
||||
distributed under the License is distributed on an "AS IS" BASIS,
|
||||
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
See the License for the specific language governing permissions and
|
||||
limitations under the License.
|
44
shake-bench/shake-bench.cabal
Normal file
44
shake-bench/shake-bench.cabal
Normal file
@ -0,0 +1,44 @@
|
||||
cabal-version: 2.2
|
||||
name: shake-bench
|
||||
version: 0.1.0.0
|
||||
synopsis: Build rules for historical benchmarking
|
||||
license: Apache-2.0
|
||||
license-file: LICENSE
|
||||
author: Pepe Iborra
|
||||
maintainer: pepeiborra@gmail.com
|
||||
category: Development
|
||||
build-type: Simple
|
||||
description:
|
||||
A library Shake rules to build and run benchmarks for multiple revisions of a project.
|
||||
An example of usage can be found in the ghcide benchmark suite
|
||||
|
||||
library
|
||||
exposed-modules: Development.Benchmark.Rules
|
||||
hs-source-dirs: src
|
||||
build-depends:
|
||||
aeson,
|
||||
base == 4.*,
|
||||
Chart,
|
||||
Chart-diagrams,
|
||||
diagrams,
|
||||
diagrams-svg,
|
||||
directory,
|
||||
extra >= 1.7.2,
|
||||
filepath,
|
||||
shake,
|
||||
text
|
||||
default-language: Haskell2010
|
||||
default-extensions:
|
||||
BangPatterns
|
||||
DeriveFunctor
|
||||
DeriveGeneric
|
||||
FlexibleContexts
|
||||
GeneralizedNewtypeDeriving
|
||||
LambdaCase
|
||||
NamedFieldPuns
|
||||
RecordWildCards
|
||||
ScopedTypeVariables
|
||||
StandaloneDeriving
|
||||
TupleSections
|
||||
TypeApplications
|
||||
ViewPatterns
|
568
shake-bench/src/Development/Benchmark/Rules.hs
Normal file
568
shake-bench/src/Development/Benchmark/Rules.hs
Normal file
@ -0,0 +1,568 @@
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
{- |
|
||||
This module provides a bunch of Shake rules to build multiple revisions of a
|
||||
project and analyse their performance.
|
||||
|
||||
It assumes a project bench suite composed of examples that runs a fixed set
|
||||
of experiments on every example
|
||||
|
||||
Your code must implement all of the GetFoo oracles and the IsExample class,
|
||||
instantiate the Shake rules, and probably 'want' a set of targets.
|
||||
|
||||
The results of the benchmarks and the analysis are recorded in the file
|
||||
system, using the following structure:
|
||||
|
||||
<build-folder>
|
||||
├── binaries
|
||||
│ └── <git-reference>
|
||||
│ ├── ghc.path - path to ghc used to build the executable
|
||||
│ └── <executable> - binary for this version
|
||||
│ └── commitid - Git commit id for this reference
|
||||
├─ <example>
|
||||
│ ├── results.csv - aggregated results for all the versions
|
||||
│ └── <git-reference>
|
||||
│ ├── <experiment>.benchmark-gcStats - 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>.log - bench stdout
|
||||
│ └── results.csv - results of all the experiments for the example
|
||||
├── results.csv - aggregated results of all the experiments and versions
|
||||
└── <experiment>.svg - graph of bytes over elapsed time, for all the included versions
|
||||
|
||||
For diff graphs, the "previous version" is the preceding entry in the list of versions
|
||||
in the config file. A possible improvement is to obtain this info via `git rev-list`.
|
||||
-}
|
||||
module Development.Benchmark.Rules
|
||||
(
|
||||
buildRules, MkBuildRules(..),
|
||||
benchRules, MkBenchRules(..), BenchProject(..),
|
||||
csvRules,
|
||||
svgRules,
|
||||
allTargets,
|
||||
GetExample(..), GetExamples(..),
|
||||
IsExample(..), RuleResultForExample,
|
||||
GetExperiments(..),
|
||||
GetVersions(..),
|
||||
GetCommitId(..),
|
||||
GetBuildSystem(..),
|
||||
BuildSystem(..), findGhcForBuildSystem,
|
||||
Escaped(..), Unescaped(..), escapeExperiment, unescapeExperiment,
|
||||
GitCommit
|
||||
|
||||
) where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
import Data.Aeson (FromJSON (..),
|
||||
ToJSON (..),
|
||||
Value (..), (.!=),
|
||||
(.:?))
|
||||
import Data.List (find, transpose)
|
||||
import Data.List.Extra (lower)
|
||||
import Data.Maybe (fromMaybe)
|
||||
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 Graphics.Rendering.Chart.Easy ((.=))
|
||||
import qualified Graphics.Rendering.Chart.Easy as E
|
||||
import System.Directory (findExecutable, createDirectoryIfMissing)
|
||||
import System.FilePath
|
||||
import qualified Text.ParserCombinators.ReadP as P
|
||||
import Text.Read (Read (..), get,
|
||||
readMaybe,
|
||||
readP_to_Prec)
|
||||
|
||||
newtype GetExperiments = GetExperiments () deriving newtype (Binary, Eq, Hashable, NFData, Show)
|
||||
newtype GetVersions = GetVersions () deriving newtype (Binary, Eq, Hashable, NFData, Show)
|
||||
newtype GetParent = GetParent Text deriving newtype (Binary, Eq, Hashable, NFData, Show)
|
||||
newtype GetCommitId = GetCommitId String deriving newtype (Binary, Eq, Hashable, NFData, Show)
|
||||
newtype GetBuildSystem = GetBuildSystem () deriving newtype (Binary, Eq, Hashable, NFData, Show)
|
||||
newtype GetExample = GetExample String deriving newtype (Binary, Eq, Hashable, NFData, Show)
|
||||
newtype GetExamples = GetExamples () deriving newtype (Binary, Eq, Hashable, NFData, Show)
|
||||
|
||||
type instance RuleResult GetExperiments = [Unescaped String]
|
||||
type instance RuleResult GetVersions = [GitCommit]
|
||||
type instance RuleResult GetParent = Text
|
||||
type instance RuleResult GetCommitId = String
|
||||
type instance RuleResult GetBuildSystem = BuildSystem
|
||||
|
||||
type RuleResultForExample e =
|
||||
( RuleResult GetExample ~ Maybe e
|
||||
, RuleResult GetExamples ~ [e]
|
||||
, IsExample e)
|
||||
|
||||
-- | Knowledge needed to run an example
|
||||
class (Binary e, Eq e, Hashable e, NFData e, Show e, Typeable e) => IsExample e where
|
||||
getExampleName :: e -> String
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
allTargets :: RuleResultForExample e => FilePath -> Action ()
|
||||
allTargets buildFolder = do
|
||||
experiments <- askOracle $ GetExperiments ()
|
||||
examples <- askOracle $ GetExamples ()
|
||||
versions <- askOracle $ GetVersions ()
|
||||
need $
|
||||
[buildFolder </> getExampleName e </> "results.csv" | e <- examples ] ++
|
||||
[buildFolder </> "results.csv"]
|
||||
++ [ buildFolder </> getExampleName ex </> escaped (escapeExperiment e) <.> "svg"
|
||||
| e <- experiments
|
||||
, ex <- examples
|
||||
]
|
||||
++ [ buildFolder </>
|
||||
getExampleName ex </>
|
||||
T.unpack (humanName ver) </>
|
||||
escaped (escapeExperiment e) <.> mode <.> "svg"
|
||||
| e <- experiments,
|
||||
ex <- examples,
|
||||
ver <- versions,
|
||||
mode <- ["", "diff"]
|
||||
]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
type OutputFolder = FilePath
|
||||
|
||||
data MkBuildRules buildSystem = MkBuildRules
|
||||
{ -- | Return the path to the GHC executable to use for the project found in the cwd
|
||||
findGhc :: buildSystem -> FilePath -> IO FilePath
|
||||
-- | Name of the binary produced by 'buildProject'
|
||||
, executableName :: String
|
||||
-- | Build the project found in the cwd and save the build artifacts in the output folder
|
||||
, buildProject :: buildSystem
|
||||
-> [CmdOption]
|
||||
-> OutputFolder
|
||||
-> Action ()
|
||||
}
|
||||
|
||||
-- | Rules that drive a build system to build various revisions of a project
|
||||
buildRules :: FilePattern -> MkBuildRules BuildSystem -> Rules ()
|
||||
-- TODO generalize BuildSystem
|
||||
buildRules build MkBuildRules{..} = do
|
||||
-- query git for the commitid for a version
|
||||
build -/- "binaries/*/commitid" %> \out -> do
|
||||
alwaysRerun
|
||||
|
||||
let [_,_,ver,_] = splitDirectories out
|
||||
mbEntry <- find ((== T.pack ver) . humanName) <$> askOracle (GetVersions ())
|
||||
let gitThing :: String
|
||||
gitThing = maybe ver (T.unpack . gitName) mbEntry
|
||||
Stdout commitid <- command [] "git" ["rev-list", "-n", "1", gitThing]
|
||||
writeFileChanged out $ init commitid
|
||||
|
||||
-- build rules for HEAD
|
||||
priority 10 $ [ build -/- "binaries/HEAD/" <> executableName
|
||||
, build -/- "binaries/HEAD/ghc.path"
|
||||
]
|
||||
&%> \[out, ghcpath] -> do
|
||||
liftIO $ createDirectoryIfMissing True $ dropFileName out
|
||||
-- TOOD more precise dependency tracking
|
||||
need =<< getDirectoryFiles "." ["//*.hs", "*.cabal"]
|
||||
buildSystem <- askOracle $ GetBuildSystem ()
|
||||
buildProject buildSystem [Cwd "."] (takeDirectory out)
|
||||
ghcLoc <- liftIO $ findGhc buildSystem "."
|
||||
writeFile' ghcpath ghcLoc
|
||||
|
||||
-- build rules for non HEAD revisions
|
||||
[build -/- "binaries/*/" <> executableName
|
||||
,build -/- "binaries/*/ghc.path"
|
||||
] &%> \[out, ghcPath] -> do
|
||||
let [_, _binaries, _ver, _] = splitDirectories out
|
||||
liftIO $ createDirectoryIfMissing True $ dropFileName out
|
||||
commitid <- readFile' $ takeDirectory out </> "commitid"
|
||||
cmd_ $ "git worktree add bench-temp " ++ commitid
|
||||
buildSystem <- askOracle $ GetBuildSystem ()
|
||||
flip actionFinally (cmd_ ("git worktree remove bench-temp --force" :: String)) $ do
|
||||
ghcLoc <- liftIO $ findGhc buildSystem "bench-temp"
|
||||
buildProject buildSystem [Cwd "bench-temp"] (".." </> takeDirectory out)
|
||||
writeFile' ghcPath ghcLoc
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
data MkBenchRules buildSystem example = MkBenchRules
|
||||
{ benchProject :: buildSystem -> [CmdOption] -> BenchProject example -> Action ()
|
||||
-- | Name of the executable to benchmark. Should match the one used to 'MkBuildRules'
|
||||
, executableName :: String
|
||||
}
|
||||
|
||||
data BenchProject example = BenchProject
|
||||
{ outcsv :: FilePath -- ^ where to save the CSV output
|
||||
, exePath :: FilePath -- ^ where to find the executable for benchmarking
|
||||
, exeExtraArgs :: [String] -- ^ extra args for the executable
|
||||
, example :: example -- ^ example to benchmark
|
||||
, experiment :: Escaped String -- ^ experiment to run
|
||||
}
|
||||
|
||||
-- TODO generalize BuildSystem
|
||||
benchRules :: RuleResultForExample example => FilePattern -> Resource -> MkBenchRules BuildSystem example -> Rules ()
|
||||
benchRules build benchResource MkBenchRules{..} = do
|
||||
-- run an experiment
|
||||
priority 0 $
|
||||
[ build -/- "*/*/*.csv",
|
||||
build -/- "*/*/*.benchmark-gcStats",
|
||||
build -/- "*/*/*.log"
|
||||
]
|
||||
&%> \[outcsv, outGc, outLog] -> do
|
||||
let [_, exampleName, ver, exp] = splitDirectories outcsv
|
||||
example <- fromMaybe (error $ "Unknown example " <> exampleName)
|
||||
<$> askOracle (GetExample exampleName)
|
||||
buildSystem <- askOracle $ GetBuildSystem ()
|
||||
liftIO $ createDirectoryIfMissing True $ dropFileName outcsv
|
||||
let exePath = build </> "binaries" </> ver </> executableName
|
||||
exeExtraArgs = ["+RTS", "-I0.5", "-S" <> takeFileName outGc, "-RTS"]
|
||||
ghcPath = build </> "binaries" </> ver </> "ghc.path"
|
||||
experiment = Escaped $ dropExtension exp
|
||||
need [exePath, ghcPath]
|
||||
ghcPath <- readFile' ghcPath
|
||||
withResource benchResource 1 $ do
|
||||
benchProject buildSystem
|
||||
[ EchoStdout False,
|
||||
FileStdout outLog,
|
||||
RemEnv "NIX_GHC_LIBDIR",
|
||||
RemEnv "GHC_PACKAGE_PATH",
|
||||
AddPath [takeDirectory ghcPath, "."] []
|
||||
]
|
||||
BenchProject{..}
|
||||
cmd_ Shell $ "mv *.benchmark-gcStats " <> dropFileName outcsv
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Rules to aggregate the CSV output of individual experiments
|
||||
csvRules :: forall example . RuleResultForExample example => FilePattern -> Rules ()
|
||||
csvRules build = do
|
||||
-- build results for every experiment*example
|
||||
build -/- "*/*/results.csv" %> \out -> do
|
||||
experiments <- askOracle $ GetExperiments ()
|
||||
|
||||
let allResultFiles = [takeDirectory out </> escaped (escapeExperiment e) <.> "csv" | e <- experiments]
|
||||
allResults <- traverse readFileLines allResultFiles
|
||||
|
||||
let header = head $ head allResults
|
||||
results = map tail allResults
|
||||
writeFileChanged out $ unlines $ header : concat results
|
||||
|
||||
-- aggregate all experiments for an example
|
||||
build -/- "*/results.csv" %> \out -> do
|
||||
versions <- map (T.unpack . humanName) <$> askOracle (GetVersions ())
|
||||
let example = takeFileName $ takeDirectory out
|
||||
allResultFiles =
|
||||
[build </> example </> v </> "results.csv" | v <- versions]
|
||||
|
||||
allResults <- traverse readFileLines allResultFiles
|
||||
|
||||
let header = head $ head allResults
|
||||
results = map tail allResults
|
||||
header' = "version, " <> header
|
||||
results' = zipWith (\v -> map (\l -> v <> ", " <> l)) versions results
|
||||
|
||||
writeFileChanged out $ unlines $ header' : interleave results'
|
||||
|
||||
-- aggregate all examples
|
||||
build -/- "results.csv" %> \out -> do
|
||||
examples <- map (getExampleName @example) <$> askOracle (GetExamples ())
|
||||
let allResultFiles = [build </> e </> "results.csv" | e <- examples]
|
||||
|
||||
allResults <- traverse readFileLines allResultFiles
|
||||
|
||||
let header = head $ head allResults
|
||||
results = map tail allResults
|
||||
header' = "example, " <> header
|
||||
results' = zipWith (\e -> map (\l -> e <> ", " <> l)) examples results
|
||||
|
||||
writeFileChanged out $ unlines $ header' : concat results'
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Rules to produce charts for the GC stats
|
||||
svgRules :: FilePattern -> Rules ()
|
||||
svgRules build = do
|
||||
|
||||
_ <- addOracle $ \(GetParent name) -> findPrev name <$> askOracle (GetVersions ())
|
||||
|
||||
-- chart GC stats for an experiment on a given revision
|
||||
priority 1 $
|
||||
build -/- "*/*/*.svg" %> \out -> do
|
||||
let [b, example, ver, exp] = splitDirectories out
|
||||
runLog <- loadRunLog b example (Escaped $ dropExtension exp) ver
|
||||
let diagram = Diagram Live [runLog] title
|
||||
title = ver <> " live bytes over time"
|
||||
plotDiagram True diagram out
|
||||
|
||||
-- chart of GC stats for an experiment on this and the previous revision
|
||||
priority 2 $
|
||||
build -/- "*/*/*.diff.svg" %> \out -> do
|
||||
let [b, example, ver, exp_] = splitDirectories out
|
||||
exp = Escaped $ dropExtension $ dropExtension exp_
|
||||
prev <- askOracle $ GetParent $ T.pack ver
|
||||
|
||||
runLog <- loadRunLog b example exp ver
|
||||
runLogPrev <- loadRunLog b example exp $ T.unpack prev
|
||||
|
||||
let diagram = Diagram Live [runLog, runLogPrev] title
|
||||
title = show (unescapeExperiment exp) <> " - live bytes over time compared"
|
||||
plotDiagram True diagram out
|
||||
|
||||
-- aggregated chart of GC stats for all the revisions
|
||||
build -/- "*/*.svg" %> \out -> do
|
||||
let exp = Escaped $ dropExtension $ takeFileName out
|
||||
example = takeFileName $ takeDirectory out
|
||||
versions <- askOracle $ GetVersions ()
|
||||
|
||||
runLogs <- forM (filter include versions) $ \v -> do
|
||||
loadRunLog build example exp $ T.unpack $ humanName v
|
||||
|
||||
let diagram = Diagram Live runLogs title
|
||||
title = show (unescapeExperiment exp) <> " - live bytes over time"
|
||||
plotDiagram False diagram out
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Default build system that handles Cabal and Stack
|
||||
data BuildSystem = Cabal | Stack
|
||||
deriving (Eq, Read, Show, Generic)
|
||||
deriving (Binary, Hashable, NFData)
|
||||
|
||||
findGhcForBuildSystem :: BuildSystem -> FilePath -> IO FilePath
|
||||
findGhcForBuildSystem Cabal _cwd =
|
||||
liftIO $ fromMaybe (error "ghc is not in the PATH") <$> findExecutable "ghc"
|
||||
findGhcForBuildSystem Stack cwd = do
|
||||
Stdout ghcLoc <- cmd [Cwd cwd] ("stack exec which ghc" :: String)
|
||||
return ghcLoc
|
||||
|
||||
instance FromJSON BuildSystem where
|
||||
parseJSON x = fromString . lower <$> parseJSON x
|
||||
where
|
||||
fromString "stack" = Stack
|
||||
fromString "cabal" = Cabal
|
||||
fromString other = error $ "Unknown build system: " <> other
|
||||
|
||||
instance ToJSON BuildSystem where
|
||||
toJSON = toJSON . show
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data GitCommit = GitCommit
|
||||
{ -- | A git hash, tag or branch name (e.g. v0.1.0)
|
||||
gitName :: Text,
|
||||
-- | A human understandable name (e.g. fix-collisions-leak)
|
||||
name :: Maybe Text,
|
||||
-- | The human understandable name of the parent, if specified explicitly
|
||||
parent :: Maybe Text,
|
||||
-- | Whether to include this version in the top chart
|
||||
include :: Bool
|
||||
}
|
||||
deriving (Binary, Eq, Hashable, Generic, NFData, Show)
|
||||
|
||||
instance FromJSON GitCommit where
|
||||
parseJSON (String s) = pure $ GitCommit s Nothing Nothing True
|
||||
parseJSON (Object (toList -> [(name, String gitName)])) =
|
||||
pure $ GitCommit gitName (Just name) Nothing True
|
||||
parseJSON (Object (toList -> [(name, Object props)])) =
|
||||
GitCommit
|
||||
<$> props .:? "git" .!= name
|
||||
<*> pure (Just name)
|
||||
<*> props .:? "parent"
|
||||
<*> props .:? "include" .!= True
|
||||
parseJSON _ = empty
|
||||
|
||||
instance ToJSON GitCommit where
|
||||
toJSON GitCommit {..} =
|
||||
case name of
|
||||
Nothing -> String gitName
|
||||
Just n -> Object $ fromList [(n, String gitName)]
|
||||
|
||||
humanName :: GitCommit -> Text
|
||||
humanName GitCommit {..} = fromMaybe gitName name
|
||||
|
||||
findPrev :: Text -> [GitCommit] -> Text
|
||||
findPrev name (x : y : xx)
|
||||
| humanName y == name = humanName x
|
||||
| otherwise = findPrev name (y : xx)
|
||||
findPrev name _ = name
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | A line in the output of -S
|
||||
data Frame = Frame
|
||||
{ allocated, copied, live :: !Int,
|
||||
user, elapsed, totUser, totElapsed :: !Double,
|
||||
generation :: !Int
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
instance Read Frame where
|
||||
readPrec = do
|
||||
spaces
|
||||
allocated <- readPrec @Int <* spaces
|
||||
copied <- readPrec @Int <* spaces
|
||||
live <- readPrec @Int <* spaces
|
||||
user <- readPrec @Double <* spaces
|
||||
elapsed <- readPrec @Double <* spaces
|
||||
totUser <- readPrec @Double <* spaces
|
||||
totElapsed <- readPrec @Double <* spaces
|
||||
_ <- readPrec @Int <* spaces
|
||||
_ <- readPrec @Int <* spaces
|
||||
"(Gen: " <- replicateM 7 get
|
||||
generation <- readPrec @Int
|
||||
')' <- get
|
||||
return Frame {..}
|
||||
where
|
||||
spaces = readP_to_Prec $ const P.skipSpaces
|
||||
|
||||
-- | A file path containing the output of -S for a given run
|
||||
data RunLog = RunLog
|
||||
{ runVersion :: !String,
|
||||
_runExample :: !String,
|
||||
_runExperiment :: !String,
|
||||
runFrames :: ![Frame],
|
||||
runSuccess :: !Bool
|
||||
}
|
||||
|
||||
loadRunLog :: HasCallStack => FilePath -> String -> Escaped FilePath -> FilePath -> Action RunLog
|
||||
loadRunLog buildF example exp ver = do
|
||||
let log_fp = buildF </> example </> ver </> escaped exp <.> "benchmark-gcStats"
|
||||
csv_fp = replaceExtension log_fp "csv"
|
||||
log <- readFileLines log_fp
|
||||
csv <- readFileLines csv_fp
|
||||
let frames =
|
||||
[ f
|
||||
| l <- log,
|
||||
Just f <- [readMaybe l],
|
||||
-- filter out gen 0 events as there are too many
|
||||
generation f == 1
|
||||
]
|
||||
-- TODO this assumes a certain structure in the CSV file
|
||||
success = case map (T.split (== ',') . T.pack) csv of
|
||||
[_header, _name:s:_] | Just s <- readMaybe (T.unpack s) -> s
|
||||
_ -> error $ "Cannot parse: " <> csv_fp
|
||||
return $ RunLog ver example (dropExtension $ escaped exp) frames success
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data TraceMetric = Allocated | Copied | Live | User | Elapsed
|
||||
deriving (Generic, Enum, Bounded, Read)
|
||||
|
||||
instance Show TraceMetric where
|
||||
show Allocated = "Allocated bytes"
|
||||
show Copied = "Copied bytes"
|
||||
show Live = "Live bytes"
|
||||
show User = "User time"
|
||||
show Elapsed = "Elapsed time"
|
||||
|
||||
frameMetric :: TraceMetric -> Frame -> Double
|
||||
frameMetric Allocated = fromIntegral . allocated
|
||||
frameMetric Copied = fromIntegral . copied
|
||||
frameMetric Live = fromIntegral . live
|
||||
frameMetric Elapsed = elapsed
|
||||
frameMetric User = user
|
||||
|
||||
data Diagram = Diagram
|
||||
{ traceMetric :: TraceMetric,
|
||||
runLogs :: [RunLog],
|
||||
title :: String
|
||||
}
|
||||
deriving (Generic)
|
||||
|
||||
plotDiagram :: Bool -> Diagram -> FilePath -> Action ()
|
||||
plotDiagram includeFailed t@Diagram {traceMetric, runLogs} out = do
|
||||
let extract = frameMetric traceMetric
|
||||
liftIO $ E.toFile E.def out $ do
|
||||
E.layout_title .= title t
|
||||
E.setColors myColors
|
||||
forM_ runLogs $ \rl ->
|
||||
when (includeFailed || runSuccess rl) $ E.plot $ do
|
||||
lplot <- E.line
|
||||
(runVersion rl ++ if runSuccess rl then "" else " (FAILED)")
|
||||
[ [ (totElapsed f, extract f)
|
||||
| f <- runFrames rl
|
||||
]
|
||||
]
|
||||
return (lplot E.& E.plot_lines_style . E.line_width E.*~ 2)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
newtype Escaped a = Escaped {escaped :: a}
|
||||
|
||||
newtype Unescaped a = Unescaped {unescaped :: a}
|
||||
deriving newtype (Show, FromJSON, ToJSON, Eq, NFData, Binary, Hashable)
|
||||
|
||||
escapeExperiment :: Unescaped String -> Escaped String
|
||||
escapeExperiment = Escaped . map f . unescaped
|
||||
where
|
||||
f ' ' = '_'
|
||||
f other = other
|
||||
|
||||
unescapeExperiment :: Escaped String -> Unescaped String
|
||||
unescapeExperiment = Unescaped . map f . escaped
|
||||
where
|
||||
f '_' = ' '
|
||||
f other = other
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
(-/-) :: FilePattern -> FilePattern -> FilePattern
|
||||
a -/- b = a <> "/" <> b
|
||||
|
||||
interleave :: [[a]] -> [a]
|
||||
interleave = concat . transpose
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
myColors :: [E.AlphaColour Double]
|
||||
myColors = map E.opaque
|
||||
[ E.blue
|
||||
, E.green
|
||||
, E.red
|
||||
, E.orange
|
||||
, E.yellow
|
||||
, E.violet
|
||||
, E.black
|
||||
, E.gold
|
||||
, E.brown
|
||||
, E.hotpink
|
||||
, E.aliceblue
|
||||
, E.aqua
|
||||
, E.beige
|
||||
, E.bisque
|
||||
, E.blueviolet
|
||||
, E.burlywood
|
||||
, E.cadetblue
|
||||
, E.chartreuse
|
||||
, E.coral
|
||||
, E.crimson
|
||||
, E.darkblue
|
||||
, E.darkgray
|
||||
, E.darkgreen
|
||||
, E.darkkhaki
|
||||
, E.darkmagenta
|
||||
, E.deeppink
|
||||
, E.dodgerblue
|
||||
, E.firebrick
|
||||
, E.forestgreen
|
||||
, E.fuchsia
|
||||
, E.greenyellow
|
||||
, E.lightsalmon
|
||||
, E.seagreen
|
||||
, E.olive
|
||||
, E.sandybrown
|
||||
, E.sienna
|
||||
, E.peru
|
||||
]
|
Loading…
Reference in New Issue
Block a user