Cabal/src/Distribution/Simple/Setup/Benchmark.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE DeriveDataTypeable #-}
   3 {-# LANGUAGE DeriveGeneric #-}
   4 {-# LANGUAGE FlexibleContexts #-}
   5 {-# LANGUAGE RankNTypes #-}
   6
   7 -----------------------------------------------------------------------------
   8
   9 -- |
  10 -- Module      :  Distribution.Simple.Benchmark
  11 -- Copyright   :  Isaac Jones 2003-2004
  12 --                Duncan Coutts 2007
  13 -- License     :  BSD3
  14 --
  15 -- Maintainer  :  cabal-devel@haskell.org
  16 -- Portability :  portable
  17 --
  18 -- Definition of the benchmarking command-line options.
  19 -- See: @Distribution.Simple.Setup@
  20 module Distribution.Simple.Setup.Benchmark
  21   ( BenchmarkFlags (..)
  22   , emptyBenchmarkFlags
  23   , defaultBenchmarkFlags
  24   , benchmarkCommand
  25   , benchmarkOptions'
  26   ) where
  27
  28 import Distribution.Compat.Prelude hiding (get)
  29 import Prelude ()
  30
  31 import Distribution.Simple.Command hiding (boolOpt, boolOpt')
  32 import Distribution.Simple.Flag
  33 import Distribution.Simple.InstallDirs
  34 import Distribution.Simple.Utils
  35 import Distribution.Verbosity
  36
  37 import Distribution.Simple.Setup.Common
  38
  39 -- ------------------------------------------------------------
  40
  41 -- * Benchmark flags
  42
  43 -- ------------------------------------------------------------
  44
  45 data BenchmarkFlags = BenchmarkFlags
  46   { benchmarkDistPref :: Flag FilePath
  47   , benchmarkVerbosity :: Flag Verbosity
  48   , benchmarkOptions :: [PathTemplate]
  49   }
  50   deriving (Show, Generic, Typeable)
  51
  52 instance Binary BenchmarkFlags
  53 instance Structured BenchmarkFlags
  54
  55 defaultBenchmarkFlags :: BenchmarkFlags
  56 defaultBenchmarkFlags =
  57   BenchmarkFlags
  58     { benchmarkDistPref = NoFlag
  59     , benchmarkVerbosity = Flag normal
  60     , benchmarkOptions = []
  61     }
  62
  63 benchmarkCommand :: CommandUI BenchmarkFlags
  64 benchmarkCommand =
  65   CommandUI
  66     { commandName = "bench"
  67     , commandSynopsis =
  68         "Run all/specific benchmarks."
  69     , commandDescription = Just $ \_pname ->
  70         wrapText $
  71           testOrBenchmarkHelpText "benchmark"
  72     , commandNotes = Nothing
  73     , commandUsage =
  74         usageAlternatives
  75           "bench"
  76           [ "[FLAGS]"
  77           , "BENCHCOMPONENTS [FLAGS]"
  78           ]
  79     , commandDefaultFlags = defaultBenchmarkFlags
  80     , commandOptions = benchmarkOptions'
  81     }
  82
  83 benchmarkOptions' :: ShowOrParseArgs -> [OptionField BenchmarkFlags]
  84 benchmarkOptions' showOrParseArgs =
  85   [ optionVerbosity
  86       benchmarkVerbosity
  87       (\v flags -> flags{benchmarkVerbosity = v})
  88   , optionDistPref
  89       benchmarkDistPref
  90       (\d flags -> flags{benchmarkDistPref = d})
  91       showOrParseArgs
  92   , option
  93       []
  94       ["benchmark-options"]
  95       ( "give extra options to benchmark executables "
  96           ++ "(name templates can use $pkgid, $compiler, "
  97           ++ "$os, $arch, $benchmark)"
  98       )
  99       benchmarkOptions
 100       (\v flags -> flags{benchmarkOptions = v})
 101       ( reqArg'
 102           "TEMPLATES"
 103           (map toPathTemplate . splitArgs)
 104           (const [])
 105       )
 106   , option
 107       []
 108       ["benchmark-option"]
 109       ( "give extra option to benchmark executables "
 110           ++ "(no need to quote options containing spaces, "
 111           ++ "name template can use $pkgid, $compiler, "
 112           ++ "$os, $arch, $benchmark)"
 113       )
 114       benchmarkOptions
 115       (\v flags -> flags{benchmarkOptions = v})
 116       ( reqArg'
 117           "TEMPLATE"
 118           (\x -> [toPathTemplate x])
 119           (map fromPathTemplate)
 120       )
 121   ]
 122
 123 emptyBenchmarkFlags :: BenchmarkFlags
 124 emptyBenchmarkFlags = mempty
 125
 126 instance Monoid BenchmarkFlags where
 127   mempty = gmempty
 128   mappend = (<>)
 129
 130 instance Semigroup BenchmarkFlags where
 131   (<>) = gmappend