hyperion (empty) → 0.1.0.0

raw patch · 19 files changed

+1284/−0 lines, 19 filesdep +QuickCheckdep +aesondep +ansi-wl-pprintsetup-changed

Dependencies added: QuickCheck, aeson, ansi-wl-pprint, base, bytestring, clock, containers, deepseq, directory, exceptions, filepath, generic-deriving, hashable, hspec, hyperion, lens, mtl, optparse-applicative, process, random, random-shuffle, statistics, text, time, unordered-containers, vector

Files

• LICENSE +30/−0
• README.md +72/−0
• Setup.hs +2/−0
• examples/end-to-end-benchmarks.hs +25/−0
• examples/micro-benchmarks.hs +33/−0
• hyperion.cabal +96/−0
• src/Hyperion.hs +5/−0
• src/Hyperion/Analysis.hs +66/−0
• src/Hyperion/Benchmark.hs +107/−0
• src/Hyperion/Internal.hs +65/−0
• src/Hyperion/Main.hs +313/−0
• src/Hyperion/Measurement.hs +85/−0
• src/Hyperion/PrintReport.hs +35/−0
• src/Hyperion/Report.hs +63/−0
• src/Hyperion/Run.hs +202/−0
• tests/Hyperion/BenchmarkSpec.hs +55/−0
• tests/Hyperion/MainSpec.hs +22/−0
• tests/Main.hs +7/−0
• tests/Spec.hs +1/−0

@@ -0,0 +1,30 @@+Copyright EURL Tweag (c) 2016-2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Author name here nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,72 @@+# Hyperion: Haskell-based systems benchmarking++[![Build Status](https://travis-ci.org/tweag/hyperion.svg?branch=master)](https://travis-ci.org/tweag/hyperion)++Hyperion is a DSL for writing benchmarks to measure and analyze+software performance. It is a lab for future [Criterion][criterion]+features.++## Getting started++### Build++You can build the [`micro benchmark example`](examples/micro-benchmarks.hs)+using stack:++``` shell+$ stack build+$ stack exec hyperion-micro-benchmark-example+```++### Example usage++The Hyperion DSL is a backwards compatible extension+to [Criterion][criterion]'s DSL (except for the rarely used `env`+combinator, which has a safer type). Here is an example:++``` haskell+benchmarks :: [Benchmark]+benchmarks =+    [ bench "id" (nf id ())+    , series [0,5..20] $ \n ->+        bgroup "pure-functions"+          [ bench "fact" (nf fact n)+          , bench "fib" (nf fib n)+          ]+    , series [1..4] $ \n ->+        series [1..n] $ \k ->+          bench "n choose k" $ nf (uncurry choose) (n, k)+    ]++main :: IO ()+main = defaultMain "hyperion-example-micro-benchmarks" benchmarks+```++By default Hyperion runs your benchmarks and pretty prints the+results. There are several command-line options that you can pass to+the executable, like printing the results to a JSON file or including+individual raw measurements. To see the full set of options run the+executable with `--help`:++``` shell+$ stack exec hyperion-micro-benchmark-example -- --help+Usage: hyperion-micro-benchmark-example ([--pretty] | [-j|--json PATH] |+                                        [-f|--flat PATH]) ([-l|--list] | [--run]+                                        | [--no-analyze]) [--raw]+                                        [--arg KEY:VAL] [NAME...]++Available options:+  -h,--help                Show this help text+  --pretty                 Pretty prints the measurements on stdout.+  -j,--json PATH           Where to write the json benchmarks output. Can be a+                           file name, a directory name or '-' for stdout.+  -f,--flat PATH           Where to write the json benchmarks output. Can be a+                           file name, a directory name or '-' for stdout.+  --version                Display version information+  -l,--list                List benchmark names+  --run                    Run benchmarks and analyze them (default)+  --no-analyze             Only run the benchmarks+  --raw                    Include raw measurement data in report.+  --arg KEY:VAL            Extra metadata to include in the report, in the+                           format key:value.+```

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,25 @@+#!/usr/bin/env stack+-- stack --no-nix-pure runghc --package hyperion++{-# LANGUAGE OverloadedLists #-}++module Main where++import Hyperion.Benchmark+import Hyperion.Run+import Hyperion.Main+import System.Process (system)++benchmarks :: [Benchmark]+benchmarks =+    [ bgroup "roundrip"+        [ bench "ping" (nfIO (system "ping -c1 8.8.8.8 > /dev/null")) ]+    ]++main :: IO ()+main = defaultMainWith config "hyperion-example-end-to-end" benchmarks+  where+    config = defaultConfig+      { configMonoidSamplingStrategy = return $ timeBound (5 * secs) (repeat 10)+      }+    secs = 10^(9::Int) * nanos where nanos = 1

@@ -0,0 +1,33 @@+#!/usr/bin/env stack+-- stack --no-nix-pure runghc --package hyperion++{-# LANGUAGE OverloadedLists #-}++module Main where++import Hyperion.Benchmark+import Hyperion.Main++fact, fib :: Int -> Int+fact n = if n == 0 then 1 else n * fact (n - 1)+fib n = case n of 0 -> 0; 1 -> 1; _ -> fib (n - 1) + fib (n - 2)++-- | Binomial coefficient+choose :: Int -> Int -> Int+choose n k = fact n `div` (fact k * fact (n - k))++benchmarks :: [Benchmark]+benchmarks =+    [ bench "id" (nf id ())+    , series [0,5..20] $ \n ->+        bgroup "pure-functions"+          [ bench "fact" (nf fact n)+          , bench "fib" (nf fib n)+          ]+    , series [1..4] $ \n ->+        series [1..n] $ \k ->+          bench "n choose k" $ nf (uncurry choose) (n, k)+    ]++main :: IO ()+main = defaultMain "hyperion-example-micro-benchmarks" benchmarks

@@ -0,0 +1,96 @@+name:                hyperion+version:             0.1.0.0+synopsis:            Reliable performance measurement with robust data export.+description:         Please see README.md+homepage:            https://github.com/tweag/hyperion#readme+author:              Tweag I/O+maintainer:          nicolas.mattia@tweag.io+license:             BSD3+license-file:        LICENSE+category:            Benchmarking+build-type:          Simple+extra-source-files:  README.md+cabal-version:       >=1.10++source-repository head+  type:     git+  location: https://github.com/tweag/hyperion++library+  hs-source-dirs: src+  exposed-modules:+    Hyperion+    Hyperion.Analysis+    Hyperion.Benchmark+    Hyperion.Internal+    Hyperion.Main+    Hyperion.Measurement+    Hyperion.PrintReport+    Hyperion.Report+    Hyperion.Run+  other-modules:+    Paths_hyperion+  build-depends:+    aeson >= 0.11,+    ansi-wl-pprint,+    base >= 4.9 && < 5,+    bytestring >= 0.10,+    containers >= 0.5,+    clock >= 0.7.2,+    deepseq >= 1.4,+    directory,+    exceptions >= 0.8,+    filepath,+    generic-deriving >= 1.11,+    hashable,+    lens >= 4.0,+    mtl >= 2.2,+    optparse-applicative >= 0.12,+    random >= 1.1,+    random-shuffle >= 0.0.4,+    statistics >= 0.13,+    text >= 1.2,+    time >= 1.0,+    unordered-containers >= 0.2,+    vector >= 0.11+  default-language: Haskell2010+  ghc-options:         -Wall++executable hyperion-micro-benchmark-example+  hs-source-dirs:      examples+  main-is:             micro-benchmarks.hs+  build-depends:+    base,+    hyperion,+    process+  default-language:    Haskell2010+  ghc-options:         -Wall++executable hyperion-end-to-end-benchmark-example+  hs-source-dirs:      examples+  main-is:             end-to-end-benchmarks.hs+  build-depends:+    base,+    hyperion,+    process+  default-language:    Haskell2010+  ghc-options:         -Wall++test-suite spec+  type:+    exitcode-stdio-1.0+  hs-source-dirs: tests+  main-is: Main.hs+  other-modules:+    Hyperion.BenchmarkSpec+    Hyperion.MainSpec+    Spec+  build-depends:+    base,+    hspec >= 2.2,+    hyperion,+    lens,+    QuickCheck >= 2.8,+    text,+    unordered-containers >= 0.2+  default-language: Haskell2010

@@ -0,0 +1,5 @@+module Hyperion+  ( module Hyperion.Benchmark+  ) where++import Hyperion.Benchmark

@@ -0,0 +1,66 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++module Hyperion.Analysis+  ( Parameter(..)+  , identifiers+  , analyze+  ) where++import Control.Lens+  ( Contravariant(..)+  , Fold+  , ala+  , foldMapOf+  , folded+  , to+  )++import Control.Lens.Each+import Data.Monoid+import Data.Traversable (for)+import Hyperion.Benchmark+import Hyperion.Internal+import Hyperion.Measurement+import Hyperion.Report++identifiers :: Fold Benchmark BenchmarkId+identifiers = go []+  where+    go :: [Component] -> Fold Benchmark BenchmarkId+    go comps f (Bench name _) = coerce $ f $ BenchmarkId $ comps <> [BenchC name]+    go comps f (Group name bks) = coerce $ (folded.go (comps <> [GroupC name])) f bks+    go comps f (Bracket _ _ g) = go comps f (g Empty)+    go comps f (Series xs g) =+      coerce $ for xs $ \x ->+        go (comps <> [SeriesC (Parameter x)]) f (g x)++    coerce :: (Contravariant f, Applicative f) => f a -> f b+    coerce = contramap (const ()) . fmap (const ())++analyze+  :: BenchmarkId -- ^ Benchmark identifier.+  -> Sample -- ^ Measurements.+  -> Report+analyze ident samp = Report+    { _reportBenchName = renderBenchmarkId ident+    , _reportBenchParams =+        map (\(Parameter x) -> fromEnum x) $ benchmarkParameters ident+    , _reportTimeInNanos =+        totalDuration / trueNumIterations+    , _reportCycles = Nothing+    , _reportAlloc = Nothing+    , _reportGarbageCollections = Nothing+    , _reportMeasurements = Just samp+    }+  where+    totalDuration =+      ala+        Sum+        (foldMapOf (measurements.each.duration.to realToFrac))+        samp+    trueNumIterations =+      ala+        Sum+        (foldMapOf (measurements.each.batchSize.to realToFrac))+        samp

@@ -0,0 +1,107 @@+{-# LANGUAGE GADTSyntax #-}+{-# LANGUAGE ExistentialQuantification #-}++module Hyperion.Benchmark+  ( -- * Benchmarks+    Benchmark(..)+  , bench+  , bgroup+  , env+  , series+  -- * Batches+  , Batch+  , runBatch+  , nf+  , nfIO+  , whnf+  , whnfIO+  -- * Environments+  , Env+  , use+  ) where++import Control.Exception (evaluate)+import Control.Monad.State.Strict (modify')+import Data.Monoid+import Data.Vector (Vector)+import Data.Int (Int64)+import Data.Text (Text)+import qualified Data.Text as Text+import Control.DeepSeq+import Hyperion.Internal++data Benchmark where+  Bench :: Text -> Batch () -> Benchmark+  Group :: Text -> [Benchmark] -> Benchmark+  Bracket :: NFData r => IO r -> (r -> IO ()) -> (Env r -> Benchmark) -> Benchmark+  Series :: (Show a, Enum a) => Vector a -> (a -> Benchmark) -> Benchmark++sp :: ShowS+sp = showChar ' '++instance Show Benchmark where+  showsPrec _ (Bench name _) =+      showString "Bench" . sp . shows name . sp . showString "_"+  showsPrec x (Group name bks) =+      showString "Group" . sp . shows name . sp . showsPrec x bks+  showsPrec x (Bracket _ _ f) =+      showString "Bracket" . sp . showString "(\\_ -> " . showsPrec x (f Empty) . showString ")"+  showsPrec x (Series xs f) =+      showString "Series" . sp . shows xs . sp . showsPrec x (f <$> xs)++bench :: String -> Batch () -> Benchmark+bench name batch = Bench (Text.pack name) batch++bgroup :: String -> [Benchmark] -> Benchmark+bgroup name bks = Group (Text.pack name) bks++series :: (Show a, Enum a) => Vector a -> (a -> Benchmark) -> Benchmark+series = Series++env+  :: NFData r+  => IO r -- ^ Acquire resource+  -> (r -> IO ()) -- ^ Finalize resource+  -> (Env r -> Benchmark)+  -> Benchmark+env = Bracket++-- | Apply an argument to a function, and evaluate the result to weak+-- head normal form (WHNF).+whnf :: (a -> b) -> a -> Batch ()+{-# INLINE whnf #-}+whnf f x = Batch $ modify' (<> pureFunc id f x)++-- | Apply an argument to a function, and evaluate the result to head+-- normal form (NF).+nf :: NFData b => (a -> b) -> a -> Batch ()+{-# INLINE nf #-}+nf f x = Batch $ modify' (<> pureFunc rnf f x)++pureFunc :: (b -> c) -> (a -> b) -> a -> Int64 -> IO ()+{-# INLINE pureFunc #-}+pureFunc reduce f0 x0 = go f0 x0+  where go f x n+          | n <= 0    = return ()+          | otherwise = evaluate (reduce (f x)) >> go f x (n-1)++-- | Perform an action, then evaluate its result to head normal form.+-- This is particularly useful for forcing a lazy 'IO' action to be+-- completely performed.+nfIO :: NFData a => IO a -> Batch ()+{-# INLINE nfIO #-}+nfIO m = Batch $ modify' (<> impure rnf m)++-- | Perform an action, then evaluate its result to weak head normal+-- form (WHNF).  This is useful for forcing an 'IO' action whose result+-- is an expression to be evaluated down to a more useful value.+whnfIO :: IO a -> Batch ()+{-# INLINE whnfIO #-}+whnfIO m = Batch $ modify' (<> impure id m)++impure :: (a -> b) -> IO a -> Int64 -> IO ()+{-# INLINE impure #-}+impure strategy a = go+  where go n+          | n <= 0    = return ()+          | otherwise = a >>= (evaluate . strategy) >> go (n-1)

@@ -0,0 +1,65 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Hyperion.Internal where++import Control.Monad.State.Strict (State, execState)+import Data.Function (on)+import Data.Hashable (Hashable(..))+import Data.Int+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as Text++newtype Batch a = Batch { unBatch :: State (Int64 -> IO ()) a }+  deriving (Functor, Applicative, Monad)++-- | Run a batch of the given size.+runBatch :: Batch () -> Int64 -> IO ()+{-# INLINE runBatch #-}+runBatch bk = execState (unBatch bk) mempty++data Env r = Empty | Resource r++use :: Env r -> Batch r+use Empty = error "use called on empty environment."+use (Resource x) = return x++data Parameter = forall a. (Show a, Enum a) => Parameter a++instance Eq Parameter where+  (==) = (==) `on` \(Parameter x) -> fromEnum x++instance Ord Parameter where+  compare = compare `on` \(Parameter x) -> fromEnum x++data Component+  = BenchC Text+  | GroupC Text+  | SeriesC Parameter+  deriving (Eq, Ord)++newtype BenchmarkId = BenchmarkId [Component]+  deriving (Eq, Ord)+++instance Hashable BenchmarkId where+  hashWithSalt s = hashWithSalt s . renderBenchmarkId++instance Show BenchmarkId where+  show = Text.unpack . renderBenchmarkId++renderBenchmarkId :: BenchmarkId -> Text+renderBenchmarkId (BenchmarkId comps0) = go "" comps0+  where+    go index [BenchC txt] = txt <> index+    go index (GroupC txt : comps) = txt <> index <> "/" <> go "" comps+    go index (SeriesC (Parameter x) : comps) =+        go (index <> ":" <> Text.pack (show x)) comps+    go _ _ = error "renderBenchmarkId: Impossible"++benchmarkParameters :: BenchmarkId -> [Parameter]+benchmarkParameters (BenchmarkId comps) =+    concatMap (\case SeriesC x -> [x]; _ -> []) comps

@@ -0,0 +1,313 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Hyperion.Main+  ( defaultMain+  , Mode(..)+  , ConfigMonoid(..)+  , ReportOutput(..)+  , nullOutputPath+  , defaultConfig+  , defaultMainWith+  ) where++import Control.Applicative+import Control.Exception (Exception, throwIO, bracket)+import Control.Lens ((&), (.~), (%~), (%@~), (^..), folded, imapped, mapped, to)+import Control.Monad (unless, mzero, void)+import qualified Data.Aeson as JSON+import qualified Data.ByteString.Lazy.Char8 as BS+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Data.List (group, sort)+import Data.Maybe (fromMaybe)+import Data.Monoid+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (pack, Text, unpack)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import Data.Time (getCurrentTime)+import Data.Typeable (Typeable)+import Data.Version (showVersion)+import GHC.Generics (Generic)+import Generics.Deriving.Monoid (memptydefault, mappenddefault)+import Hyperion.Analysis+import Hyperion.Benchmark+import Hyperion.Internal+import Hyperion.Measurement+import Hyperion.PrintReport+import Hyperion.Report+import Hyperion.Run+import qualified Options.Applicative as Options+import Paths_hyperion (version)+import System.Directory (createDirectoryIfMissing, doesDirectoryExist)+import System.Environment (getProgName)+import System.FilePath ((</>), (<.>))+import System.FilePath.Posix (hasTrailingPathSeparator)+import qualified System.IO as IO++data Mode = Version | List | Run | Analyze+  deriving (Eq, Ord, Show)++-- | Specify a particular way of reporting the benchmark results.+data ReportOutput a = ReportPretty | ReportJson a | ReportJsonFlat a+  deriving (Functor, Eq, Ord, Show)++-- | Context information about the benchmark.+data ContextInfo = ContextInfo+  { contextPackageName :: Text+  , contextExecutableName :: Text+  }++data ConfigMonoid = ConfigMonoid+  { configMonoidReportOutputs :: [ReportOutput FilePath]+  , configMonoidMode :: First Mode+  , configMonoidRaw :: First Bool+  , configMonoidSamplingStrategy :: First SamplingStrategy+  , configMonoidUserMetadata :: JSON.Object+  , configMonoidSelectorPatterns :: [Text]+  } deriving (Generic, Show)++instance Monoid ConfigMonoid where+  mempty = memptydefault+  mappend = mappenddefault++data Config = Config+  { configReportOutputs :: Set (ReportOutput FilePath)+  , configMode :: Mode+  , configRaw :: Bool+  , configSamplingStrategy :: SamplingStrategy+  , configUserMetadata :: JSON.Object+  , configSelectorPatterns :: [Text]+  } deriving (Generic, Show)++fromFirst :: a -> First a -> a+fromFirst x = fromMaybe x . getFirst++configFromMonoid :: ConfigMonoid -> Config+configFromMonoid ConfigMonoid{..} = Config+    { configReportOutputs =+        if null configMonoidReportOutputs+        then Set.singleton ReportPretty+        else Set.fromList configMonoidReportOutputs+    , configMode = fromFirst Analyze configMonoidMode+    , configRaw = fromFirst False configMonoidRaw+    , configSamplingStrategy = fromFirst defaultStrategy configMonoidSamplingStrategy+    , configUserMetadata = configMonoidUserMetadata+    , configSelectorPatterns = configMonoidSelectorPatterns+    }++options :: Options.Parser ConfigMonoid+options = do+     configMonoidReportOutputs <- many reportOutputParse+     configMonoidMode <-+       First <$> optional+         (Options.flag' Version+            (Options.long "version" <>+             Options.hidden <>+             Options.help "Display version information") <|>+          Options.flag' List+            (Options.long "list" <>+             Options.short 'l' <>+             Options.help "List benchmark names") <|>+          Options.flag' Analyze+            (Options.long "run" <>+             Options.help "Run benchmarks and analyze them (default)") <|>+          Options.flag' Run+            (Options.long "no-analyze" <>+             Options.help "Only run the benchmarks"))+     configMonoidRaw <-+       First <$> optional+         (Options.switch+            (Options.long "raw" <>+             Options.help "Include raw measurement data in report."))+     configMonoidUserMetadata <-+       HashMap.fromList <$> many+         (Options.option+            parseKV+            (Options.long "arg" <>+             Options.metavar "KEY:VAL" <>+             Options.help "Extra metadata to include in the report, in the format key:value."))+     configMonoidSelectorPatterns <-+       many+         (pack <$> Options.argument Options.str+            (Options.metavar "NAME..." ))+     pure ConfigMonoid{..}+  where+     -- TODO allow setting this from CLI.+    configMonoidSamplingStrategy = First Nothing+    parseKV = do+      txt <- Text.pack <$> Options.str+      case Text.splitOn ":" txt of+        [x,y] -> pure (x, JSON.String y)+        _ -> mzero++reportOutputParse :: Options.Parser (ReportOutput FilePath)+reportOutputParse =+    (ReportPretty <$ Options.flag' ()+       (Options.long "pretty" <>+        Options.help "Pretty prints the measurements on stdout.")) <|>+    (ReportJson <$> Options.strOption+      (Options.long "json" <>+       Options.short 'j' <>+       Options.help (unwords+          ["Where to write the json benchmarks output."+          ,"Can be a file name, a directory name or '-' for stdout."+          ]) <>+       Options.metavar "PATH")) <|>+    (ReportJsonFlat <$> Options.strOption+      (Options.long "flat" <>+       Options.short 'f' <>+       Options.help (unwords+          ["Where to write the json benchmarks output."+          ,"Can be a file name, a directory name or '-' for stdout."+          ]) <>+       Options.metavar "PATH"))++-- | The path to the null output file. This is @"nul"@ on Windows and+-- @"/dev/null"@ elsewhere.+nullOutputPath :: FilePath+#ifdef mingw32_HOST_OS+nullOutputPath = "nul"+#else+nullOutputPath = "/dev/null"+#endif++defaultConfig :: ConfigMonoid+defaultConfig = mempty++data DuplicateIdentifiers a = DuplicateIdentifiers [a]+instance (Show a, Typeable a) => Exception (DuplicateIdentifiers a)+instance Show a => Show (DuplicateIdentifiers a) where+  show (DuplicateIdentifiers ids) = "Duplicate identifiers: " <> show ids++doList :: [Benchmark] -> IO ()+doList bks =+    mapM_ Text.putStrLn $ bks^..folded.identifiers.to renderBenchmarkId++-- | Derive a 'SamplingStrategy' indexed by 'BenchmarkId' from the current+-- configuration.+indexedStrategy :: Config -> (BenchmarkId -> Maybe SamplingStrategy)+indexedStrategy Config{..} = case configSelectorPatterns of+    [] -> uniform configSamplingStrategy+    patts -> filtered f configSamplingStrategy+      where+        f bid = any (`Text.isPrefixOf` renderBenchmarkId bid) patts++doRun+  :: (BenchmarkId -> Maybe SamplingStrategy)+  -> [Benchmark]+  -> IO (HashMap BenchmarkId Sample)+doRun strategy bks = do+    let ids = bks^..folded.identifiers+    -- Better asymptotics than nub.+    unless (length (group (sort ids)) == length ids) $+      throwIO $ DuplicateIdentifiers [ n | n:_:_ <- group (sort ids) ]+    foldMap (runBenchmark strategy) bks++-- | Print the report.+printReport+  :: ReportOutput IO.Handle+  -> JSON.Object -- ^ Metadata+  -> HashMap BenchmarkId Report+  -> IO ()+-- XXX: should we print user metadata in pretty mode as well?+printReport ReportPretty _ report = printReports report+printReport (ReportJson h) metadata report =+    BS.hPutStrLn h $ JSON.encode $+      json metadata report+printReport (ReportJsonFlat h) metadata report =+    BS.hPutStrLn h $ JSON.encode $+      jsonFlat metadata report++-- | Open a 'Handle' for given report (if needed).+openReportHandle+  :: ContextInfo+  -> ReportOutput FilePath -> IO (ReportOutput IO.Handle)+openReportHandle _ ReportPretty = pure ReportPretty+openReportHandle cinfo (ReportJson path) =+    ReportJson <$> openReportFileHandle cinfo path+openReportHandle cinfo (ReportJsonFlat path) =+    ReportJsonFlat <$> openReportFileHandle cinfo path++openReportFileHandle :: ContextInfo -> FilePath -> IO IO.Handle+openReportFileHandle _ "-" = pure IO.stdout+openReportFileHandle cinfo path = do+    let packageName = unpack $ contextPackageName cinfo+        executableName = unpack $ contextExecutableName cinfo+    dirExists <- doesDirectoryExist path+    if dirExists ||+       hasTrailingPathSeparator path+    then do+      let filename = packageName <.> executableName <.> "json"+      createDirectoryIfMissing True path -- Creates the directory if needed.+      IO.openFile (path </> filename) IO.WriteMode+    else+      IO.openFile path IO.WriteMode++closeReportHandle :: ReportOutput IO.Handle -> IO ()+closeReportHandle ReportPretty = return ()+closeReportHandle (ReportJson h) = IO.hClose h+closeReportHandle (ReportJsonFlat h) = IO.hClose h++doAnalyze+  :: Config -- ^ Hyperion config.+  -> ContextInfo -- ^ Benchmark context information.+  -> [Benchmark] -- ^ Benchmarks to be run.+  -> IO ()+doAnalyze Config{..} cinfo bks = do+    results <- doRun (indexedStrategy Config{..}) bks+    let strip+          | configRaw = id+          | otherwise = reportMeasurements .~ Nothing+        report = results & imapped %@~ analyze & mapped %~ strip+    now <- getCurrentTime+    let -- TODO Use output of hostname(1) as reasonable default.+        hostId = Nothing :: Maybe Text+        metadata =+          configUserMetadata+          -- Prepend user metadata so that the user can rewrite @timestamp@,+          -- for instance.+            <> HashMap.fromList [ "timestamp" JSON..= now, "location" JSON..= hostId ]+    void $ bracket+      (mapM (openReportHandle cinfo)+        $ Set.toList configReportOutputs)+      (mapM_ closeReportHandle)+      (mapM (\h -> printReport h metadata report))++defaultMainWith+  :: ConfigMonoid -- ^ Preset Hyperion config.+  -> String -- ^ Package name, user provided.+  -> [Benchmark] -- ^ Benchmarks to be run.+  -> IO ()+defaultMainWith presetConfig packageName bks = do+    executableName <- getProgName -- Name of the executable that launched the benches.+    cmdlineConfig <-+      Options.execParser+        (Options.info+          (Options.helper <*> options)+          Options.fullDesc)+    let config = configFromMonoid (cmdlineConfig <> presetConfig)+        cinfo = ContextInfo+          { contextPackageName = pack packageName+          , contextExecutableName = pack executableName+          }+    case config of+      Config{..} -> case configMode of+        Version -> putStrLn $ "Hyperion " <> showVersion version+        List -> doList bks+        Run -> do+          _ <- doRun (indexedStrategy config) bks+          return ()+        Analyze -> doAnalyze config cinfo bks++defaultMain+  :: String -- ^ Package name, user provided.+  -> [Benchmark] -- ^ Benchmarks to be run.+  -> IO ()+defaultMain = defaultMainWith defaultConfig

@@ -0,0 +1,85 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module Hyperion.Measurement+  ( Measurement(..)+  , batchSize+  , duration+  , Sample(..)+  , measurements+  ) where++import Data.Aeson (FromJSON, ToJSON)+import Data.Aeson.TH+import Data.Int+import Control.Lens.TH (makeLenses)+import Control.Monad (liftM)+import qualified Data.Vector.Generic as GV+import qualified Data.Vector.Generic.Mutable as GMV+import qualified Data.Vector.Unboxed as UV++data Measurement = Measurement+  { _batchSize :: {-# UNPACK #-} !Int64+  , _duration :: {-# UNPACK #-} !Int64+  }+  deriving (Eq, Ord, Show)+makeLenses ''Measurement+deriveJSON defaultOptions{ fieldLabelModifier = drop 1 } ''Measurement++instance UV.Unbox Measurement++newtype Sample = Sample { _measurements :: UV.Vector Measurement }+  deriving (Eq, Monoid, Ord, Show)+makeLenses ''Sample++deriving instance FromJSON Sample+deriving instance ToJSON Sample++newtype instance UV.MVector s Measurement = MV_Measurement (UV.MVector s (Int64, Int64))+newtype instance UV.Vector Measurement = V_Measurement  (UV.Vector (Int64, Int64))++instance GMV.MVector UV.MVector Measurement where+  {-# INLINE basicLength #-}+  {-# INLINE basicUnsafeSlice #-}+  {-# INLINE basicOverlaps #-}+  {-# INLINE basicUnsafeNew #-}+  {-# INLINE basicInitialize #-}+  {-# INLINE basicUnsafeReplicate #-}+  {-# INLINE basicUnsafeRead #-}+  {-# INLINE basicUnsafeWrite #-}+  {-# INLINE basicClear #-}+  {-# INLINE basicSet #-}+  {-# INLINE basicUnsafeCopy #-}+  {-# INLINE basicUnsafeGrow #-}+  basicLength (MV_Measurement v) = GMV.basicLength v+  basicUnsafeSlice i n (MV_Measurement v) = MV_Measurement $ GMV.basicUnsafeSlice i n v+  basicOverlaps (MV_Measurement v1) (MV_Measurement v2) = GMV.basicOverlaps v1 v2+  basicUnsafeNew n = MV_Measurement `liftM` GMV.basicUnsafeNew n+  basicInitialize (MV_Measurement v) = GMV.basicInitialize v+  basicUnsafeReplicate n (Measurement x y) = MV_Measurement `liftM` GMV.basicUnsafeReplicate n (x,y)+  basicUnsafeRead (MV_Measurement v) i = uncurry Measurement `liftM` GMV.basicUnsafeRead v i+  basicUnsafeWrite (MV_Measurement v) i (Measurement x y) = GMV.basicUnsafeWrite v i (x,y)+  basicClear (MV_Measurement v) = GMV.basicClear v+  basicSet (MV_Measurement v) (Measurement x y) = GMV.basicSet v (x,y)+  basicUnsafeCopy (MV_Measurement v1) (MV_Measurement v2) = GMV.basicUnsafeCopy v1 v2+  basicUnsafeMove (MV_Measurement v1) (MV_Measurement v2) = GMV.basicUnsafeMove v1 v2+  basicUnsafeGrow (MV_Measurement v) n = MV_Measurement `liftM` GMV.basicUnsafeGrow v n++instance GV.Vector UV.Vector Measurement where+  {-# INLINE basicUnsafeFreeze #-}+  {-# INLINE basicUnsafeThaw #-}+  {-# INLINE basicLength #-}+  {-# INLINE basicUnsafeSlice #-}+  {-# INLINE basicUnsafeIndexM #-}+  {-# INLINE elemseq #-}+  basicUnsafeFreeze (MV_Measurement v) = V_Measurement `liftM` GV.basicUnsafeFreeze v+  basicUnsafeThaw (V_Measurement v) = MV_Measurement `liftM` GV.basicUnsafeThaw v+  basicLength (V_Measurement v) = GV.basicLength v+  basicUnsafeSlice i n (V_Measurement v) = V_Measurement $ GV.basicUnsafeSlice i n v+  basicUnsafeIndexM (V_Measurement v) i = uncurry Measurement `liftM` GV.basicUnsafeIndexM v i+  basicUnsafeCopy (MV_Measurement mv) (V_Measurement v) = GV.basicUnsafeCopy mv v+  elemseq _ (Measurement x y) z =+    GV.elemseq (undefined :: UV.Vector a) x $ GV.elemseq (undefined :: UV.Vector a) y z

@@ -0,0 +1,35 @@+{- This module is used for pretty printing the hyperion report.+ - This is mostly put in a separate module to avoid conflicts in+ - the imports of (<>) from Monoid an ansi-wl-pprint+ -}++module Hyperion.PrintReport (printReports) where++import Numeric+import Control.Lens (view)+import Data.Text (unpack)+import Data.HashMap.Strict (HashMap)+import Hyperion.Internal+import Hyperion.Report+import Text.PrettyPrint.ANSI.Leijen++formatReport :: Report -> Doc+formatReport report =+           green (bold (text (unpack (view reportBenchName report)))) <> line+           <> (indent 2 $ text ("Bench time: " ++ prettyNanos (view reportTimeInNanos report)))+           <> line+  where+    show2decs x= showFFloat (Just 2) x ""+    prettyNanos :: Double -> String+    prettyNanos x+      -- seconds+      | x > 1e9 = show2decs (x/1e9) ++ "s"+      -- milliseconds+      | x > 1e6 = show2decs (x/1e6) ++ "ms"+      -- microseconds+      | x > 1e3 = show2decs (x/1e3) ++ "us"+      | otherwise = show2decs x ++ "ns"++printReports :: HashMap BenchmarkId Report -> IO ()+printReports report = do+  putDoc $ foldMap formatReport report

@@ -0,0 +1,63 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}++module Hyperion.Report where++import Control.Lens.TH (makeLenses)+import Data.Monoid+import GHC.Generics (Generic)+import qualified Data.Aeson as JSON+import Data.Aeson ((.=))+import Data.Aeson.TH+import Data.Aeson.Types (camelTo2)+import Data.Bifunctor (first)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Data.Int+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Vector as V+import Hyperion.Measurement (Sample)+import Hyperion.Internal++data Report = Report+  { _reportBenchName :: !Text+  , _reportBenchParams :: [Int]+  , _reportTimeInNanos :: !Double+  , _reportCycles :: !(Maybe Double)+  , _reportAlloc :: !(Maybe Int64)+  , _reportGarbageCollections :: !(Maybe Int64)+  , _reportMeasurements :: !(Maybe Sample)+  } deriving (Generic)+makeLenses ''Report+deriveJSON defaultOptions{ fieldLabelModifier = camelTo2 '_' . drop (length @[] "_report") } ''Report++json+  :: JSON.Object -- ^ Metadata+  -> HashMap BenchmarkId Report -- ^ Report to encode+  -> JSON.Value+json md report =+    JSON.object+      [ "metadata" .= md+      , "results" .= HashMap.elems report+      ]++jsonFlat+  :: JSON.Object -- ^ Metadata+  -> HashMap BenchmarkId Report+  -- ^ Report to encode+  -> JSON.Value+jsonFlat md report = jsonList $ flip fmap (HashMap.elems report) $ \b ->+    JSON.object $+      HashMap.toList md <> (flatten $ JSON.toJSON b)+  where+    flatten (JSON.Object b) = concatMap splitParams $ HashMap.toList b+    flatten x = [("result", x)] -- XXX should never happen+    jsonList = JSON.Array . V.fromList+    -- flatten the benchmark params+    splitParams ("bench_params", JSON.Array xs) =+      fmap (first (mappend "x_" . Text.pack . show)) (zip [(1::Int)..] $ V.toList xs)+    splitParams x = [x]

@@ -0,0 +1,202 @@+-- | Run a hierarchical benchmark suite, collecting results.++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-}++module Hyperion.Run+  ( -- * Run benchmarks+    runBenchmark+    -- * Benchmark transformations+  , shuffle+  , reorder+    -- * Sampling strategy selectors+  , filtered+  , uniform+    -- * Sampling strategies+  , SamplingStrategy(..)+  , defaultStrategy+  , fixed+  , sample+  , geometric+  , timeBound+    -- * Strategy helpers+  , geometricSeries+  ) where++import Control.DeepSeq+import Control.Exception (evaluate)+import Control.Lens (foldMapOf)+import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow, bracket)+import Control.Monad.State.Class (MonadState)+import Control.Monad.State.Strict (StateT, evalStateT, get, put)+import Control.Monad.Trans (MonadTrans(..))+import Data.Int+import Data.List (mapAccumR)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Data.Sequence (ViewL((:<)), viewl)+import qualified Data.Vector.Unboxed as Unboxed+import Hyperion.Analysis (identifiers)+import Hyperion.Benchmark+import Hyperion.Internal+import Hyperion.Measurement+import qualified System.Clock as Clock+import System.Random (RandomGen(..))+import qualified System.Random.Shuffle as SRS+import Text.Show.Functions ()++-- | Local private copy of 'StateT' to hang our otherwise orphan 'Monoid'+-- instance to. This instance is missing from transformers.+newtype StateT' s m a = StateT' { unStateT' :: StateT s m a }+  deriving (Functor, Applicative, Monad, MonadCatch, MonadMask, MonadThrow, MonadState s, MonadTrans)++instance (Monad m, Monoid a) => Monoid (StateT' s m a) where+  mempty = lift (return mempty)+  mappend m1 m2 = mappend <$> m1 <*> m2++-- | Sampling strategy.+newtype SamplingStrategy = SamplingStrategy (Batch () -> IO Sample)+  deriving (Monoid, Show)++-- | Provided a sampling strategy (which can be keyed on the 'BenchmarkId'),+-- sample the runtime of all the benchmark cases in the given benchmark tree.+runBenchmark+  :: (BenchmarkId -> Maybe SamplingStrategy)+  -- ^ Name indexed batch sampling strategy.+  -> Benchmark+  -- ^ Benchmark to be run.+  -> IO (HashMap BenchmarkId Sample)+runBenchmark istrategy bk0 =+  -- Ignore the identifiers we find. Use fully qualified identifiers+  -- accumulated from the lens defined above. The order is DFS in both cases.+  evalStateT (unStateT' (go bk0)) (foldMapOf identifiers return bk0)+  where+    go (Bench _ batch) = do+      ident <- pop+      case (istrategy ident) of+        Nothing -> return HashMap.empty+        Just (SamplingStrategy f) ->+          HashMap.singleton ident <$> lift (f batch)+    go (Group _ bks) = foldMap (go) bks+    go (Bracket ini fini g) =+      bracket (lift (ini >>= evaluate . force)) (lift . fini) (go . g . Resource)+    go (Series xs g) = foldMap (go . g) xs++    pop = do+      x :< xs <- viewl <$> get+      put xs+      return x++-- | Time an action.+chrono :: IO () -> IO Int64+chrono act = do+    start <- Clock.getTime Clock.Monotonic+    act+    end <- Clock.getTime Clock.Monotonic+    return $ fromIntegral $ Clock.toNanoSecs $ Clock.diffTimeSpec start end++-- | Sample once a batch of fixed size.+fixed :: Int64 -> SamplingStrategy+fixed _batchSize = SamplingStrategy $ \batch -> do+    _duration <- chrono $ runBatch batch _batchSize+    return $ Sample $ Unboxed.singleton Measurement{..}++-- | Run a sampling strategy @n@ times.+sample :: Int64 -> SamplingStrategy -> SamplingStrategy+sample n strategy = mconcat $ replicate (fromIntegral n) strategy++-- | Sampling strategy that creates samples of the specified sizes with a time+-- bound. Sampling stops when either a sample has been sampled for each size or+-- when the total benchmark time is greater than the specified time bound.+--+-- The actual amount of time spent may be longer since hyperion will always+-- wait for a 'Sample' of a given size to complete.+timeBound+  :: Clock.TimeSpec -- ^ Time bound+  -> [Int64] -- ^ Sample sizes; may be infinite+  -> SamplingStrategy+timeBound maxTime batchSizes = SamplingStrategy $ \batch -> do+    start <- Clock.getTime Clock.Monotonic+    go batch start batchSizes mempty+  where+    go batch start (_batchSize:bss) smpl = do+      _duration <- chrono $ runBatch batch _batchSize+      let smpl' = smpl `mappend` (Sample $ Unboxed.singleton Measurement{..})+      now <- Clock.getTime Clock.Monotonic+      if Clock.diffTimeSpec start now > maxTime+        then return smpl'+        else go batch start bss smpl'+    go _ _ _ s = return s++-- | Sampling strategies that ignore the name index, i.e. are uniform across all+-- benchmarks.+uniform :: SamplingStrategy -> (BenchmarkId -> Maybe SamplingStrategy)+uniform = const . Just++-- | Sampling strategies that filters the benchmarks based on a predicate: a+-- benchmark is included iff the predicate is 'True'.+filtered+  :: (BenchmarkId -> Bool)+  -> SamplingStrategy+  -> (BenchmarkId -> Maybe SamplingStrategy)+filtered p ss bid =+    if p bid then Just ss else Nothing++-- | Default to 100 samples, for each batch size from 1 to 20 with a geometric+-- progression of 1.2.+defaultStrategy :: SamplingStrategy+defaultStrategy = geometric 100 20 1.2++-- | Batching strategy, following a geometric progression from 1+-- to the provided limit, with the given ratio.+geometric+  :: Int64 -- ^ Sample size.+  -> Int64 -- ^ Max batch size.+  -> Double -- ^ Ratio of geometric progression.+  -> SamplingStrategy+geometric nSamples limit ratio =+    foldMap (\size -> sample nSamples (fixed size)) (geometricSeries ratio limit)++geometricSeries+  :: Double -- ^ Geometric progress.+  -> Int64 -- ^ End of the series.+  -> [Int64]+geometricSeries ratio limit =+    if ratio > 1+    then+      takeWhile (<= limit) $+      squish $+      map truncate $+      map (ratio^) ([1..] :: [Int])+    else+      error "Geometric ratio must be bigger than 1"++-- | Our series starts its growth very slowly when we begin at 1, so we+-- eliminate repeated values.+-- NOTE: taken from Criterion.+squish :: (Eq a) => [a] -> [a]+squish ys = foldr go [] ys+  where go x xs = x : dropWhile (==x) xs++-- | Convenience wrapper around 'SRS.shuffle'.+shuffle :: RandomGen g => g -> [a] -> [a]+shuffle gen xs = SRS.shuffle' xs (length xs) gen++splitn :: RandomGen g => Int -> g -> [g]+splitn n gen = snd $ mapAccumR (flip (const split)) gen [1..n]++reorder+  :: RandomGen g+  => (g -> [Benchmark] -> [Benchmark])+  -> (g -> [Benchmark] -> [Benchmark])+reorder shuf gen0 bks0 =+    shuf gen0 (zipWith go (splitn (length bks0) gen0) bks0)+  where+    go _ bk@(Bench _ _) = bk+    go gen (Group name bks) =+        Group name (shuf gen (zipWith go (splitn (length bks) gen) bks))+    go gen (Bracket ini fini f) =+        Bracket ini fini (\x -> go gen (f x))+    go gen (Series xs f) =+        Series xs (\x -> go gen (f x))

@@ -0,0 +1,55 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Hyperion.BenchmarkSpec where++import Control.Lens ((^..), foldOf, to)+import Data.List (nub)+import Hyperion.Analysis+import Hyperion.Benchmark+import Hyperion.Run+import Test.Hspec+import Test.QuickCheck+  ( Arbitrary(..)+  , (==>)+  , elements+  , oneof+  , property+  , scale+  )+import Test.QuickCheck.Monadic (assert, monadicIO, run)++benchmarkNames, groupNames :: [String]+benchmarkNames = ["foo", "bar", "baz"]+groupNames = ["one", "two"]++instance Arbitrary Benchmark where+  arbitrary = scale (min 4) $ oneof+    [ bench <$>+        elements benchmarkNames <*>+        pure (nf id ())+    , bgroup <$>+        elements groupNames <*>+        arbitrary+    , env <$>+        pure (return ()) <*>+        pure (\_ -> return ()) <*>+        const <$> scale (max 0 . pred) arbitrary+    , series <$>+        pure [1,2,3 :: Int] <*>+        const <$> scale (max 0 . pred) arbitrary+    ]++hasSeries :: Benchmark -> Bool+hasSeries b = any (==':') (foldOf (identifiers.to show) b)++spec :: Spec+spec = do+    describe "runBenchmark" $ do+      it "returns as many samples as there are benchmarks" $ property $ \b ->+        not (hasSeries b) ==>+        monadicIO $ do+          results <- run $ runBenchmark (uniform (fixed 1)) b+          assert (length results == length (nub (b^..identifiers)))

@@ -0,0 +1,22 @@+module Hyperion.MainSpec where++import Control.Lens ((^..))+import Data.List (group, sort)+import Hyperion.Analysis+import Hyperion.BenchmarkSpec ()+import Hyperion.Main+import Test.Hspec+import Test.QuickCheck ((==>), expectFailure, property)+import Test.QuickCheck.Monadic (monadicIO, run)++spec :: Spec+spec = do+    describe "defaultMain" $ do+      it "checks for duplicate identifiers" $ property $ \b ->+        length (b^..identifiers) /= length (group (sort (b^..identifiers))) ==>+        expectFailure $ monadicIO $ run $+          defaultMainWith defaultConfig{configMonoidMode = return Run} "spec" [b]+      it "Analyzes uniquely identified benchmarks" $ property $ \b ->+        length (b^..identifiers) == length (group (sort (b^..identifiers))) ==>+        monadicIO $ run $+          defaultMainWith defaultConfig{configMonoidReportOutputs = [ReportJson nullOutputPath]} "specs" [b]

@@ -0,0 +1,7 @@+module Main where++import qualified Spec+import Test.Hspec++main :: IO ()+main = hspec Spec.spec

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}