[commit: Cabal] master: Add a Benchmark data type for representing 'benchmark' sections (ed2bd8f)

[Ian Lynagh]

Repository : ssh://darcs.haskell.org//srv/darcs/packages/Cabal

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/ed2bd8fba59ce78a838ef19d5e4dd624360784aa

>---------------------------------------------------------------

commit ed2bd8fba59ce78a838ef19d5e4dd624360784aa
Author: Johan Tibell <johan.tibell at gmail.com>
Date:   Tue Oct 11 17:58:49 2011 +0000

    Add a Benchmark data type for representing 'benchmark' sections

>---------------------------------------------------------------

 cabal/Distribution/PackageDescription.hs |  123 +++++++++++++++++++++++++++++-
 1 files changed, 119 insertions(+), 4 deletions(-)

diff --git a/cabal/Distribution/PackageDescription.hs b/cabal/Distribution/PackageDescription.hs
index 35370ee..244d453 100644
--- a/cabal/Distribution/PackageDescription.hs
+++ b/cabal/Distribution/PackageDescription.hs
@@ -8,10 +8,10 @@
 --
 -- This defines the data structure for the @.cabal@ file format. There are
 -- several parts to this structure. It has top level info and then 'Library',
--- 'Executable', and 'TestSuite' sections each of which have associated
--- 'BuildInfo' data that's used to build the library, exe, or test. To further
--- complicate things there is both a 'PackageDescription' and a
--- 'GenericPackageDescription'. This distinction relates to cabal
+-- 'Executable', 'TestSuite', and 'Benchmark' sections each of which have
+-- associated 'BuildInfo' data that's used to build the library, exe, test, or
+-- benchmark.  To further complicate things there is both a 'PackageDescription'
+-- and a 'GenericPackageDescription'. This distinction relates to cabal
 -- configurations. When we initially read a @.cabal@ file we get a
 -- 'GenericPackageDescription' which has all the conditional sections.
 -- Before actually building a package we have to decide
@@ -85,6 +85,15 @@ module Distribution.PackageDescription (
         testModules,
         enabledTests,
 
+        -- * Benchmarks
+        Benchmark(..),
+        BenchmarkInterface(..),
+        BenchmarkType(..),
+        benchmarkType,
+        knownBenchmarkTypes,
+        emptyBenchmark,
+        benchmarkModules,
+
         -- * Build information
         BuildInfo(..),
         emptyBuildInfo,
@@ -501,6 +510,112 @@ testType test = case testInterface test of
   TestSuiteUnsupported testtype -> testtype
 
 -- ---------------------------------------------------------------------------
+-- The Benchmark type
+
+-- | A \"benchmark\" stanza in a cabal file.
+--
+data Benchmark = Benchmark {
+        benchmarkName      :: String,
+        benchmarkInterface :: BenchmarkInterface,
+        benchmarkBuildInfo :: BuildInfo,
+        benchmarkEnabled   :: Bool
+        -- TODO: See TODO for 'testEnabled'.
+    }
+    deriving (Show, Read, Eq)
+
+-- | The benchmark interfaces that are currently defined. Each
+-- benchmark must specify which interface it supports.
+--
+-- More interfaces may be defined in future, either new revisions or
+-- totally new interfaces.
+--
+data BenchmarkInterface =
+
+     -- | Benchmark interface \"exitcode-stdio-1.0\". The benchmark
+     -- takes the form of an executable. It returns a zero exit code
+     -- for success, non-zero for failure. The stdout and stderr
+     -- channels may be logged. It takes no command line parameters
+     -- and nothing on stdin.
+     --
+     BenchmarkExeV10 Version FilePath
+
+     -- | A benchmark that does not conform to one of the above
+     -- interfaces for the given reason (e.g. unknown benchmark type).
+     --
+   | BenchmarkUnsupported BenchmarkType
+   deriving (Eq, Read, Show)
+
+instance Monoid Benchmark where
+    mempty = Benchmark {
+        benchmarkName      = mempty,
+        benchmarkInterface = mempty,
+        benchmarkBuildInfo = mempty,
+        benchmarkEnabled   = False
+    }
+
+    mappend a b = Benchmark {
+        benchmarkName      = combine' benchmarkName,
+        benchmarkInterface = combine  benchmarkInterface,
+        benchmarkBuildInfo = combine  benchmarkBuildInfo,
+        benchmarkEnabled   = if benchmarkEnabled a then True
+                             else benchmarkEnabled b
+    }
+        where combine   field = field a `mappend` field b
+              combine' f = case (f a, f b) of
+                        ("", x) -> x
+                        (x, "") -> x
+                        (x, y) -> error "Ambiguous values for benchmark field: '"
+                            ++ x ++ "' and '" ++ y ++ "'"
+
+instance Monoid BenchmarkInterface where
+    mempty  =  BenchmarkUnsupported (BenchmarkTypeUnknown mempty (Version [] []))
+    mappend a (BenchmarkUnsupported _) = a
+    mappend _ b                        = b
+
+emptyBenchmark :: Benchmark
+emptyBenchmark = mempty
+
+-- | Get all the module names from a benchmark.
+benchmarkModules :: Benchmark -> [ModuleName]
+benchmarkModules benchmark = otherModules (benchmarkBuildInfo benchmark)
+
+-- | The \"benchmark-type\" field in the benchmark stanza.
+--
+data BenchmarkType = BenchmarkTypeExe Version
+                     -- ^ \"type: exitcode-stdio-x.y\"
+                   | BenchmarkTypeUnknown String Version
+                     -- ^ Some unknown benchmark type e.g. \"type: foo\"
+    deriving (Show, Read, Eq)
+
+knownBenchmarkTypes :: [BenchmarkType]
+knownBenchmarkTypes = [ BenchmarkTypeExe (Version [1,0] []) ]
+
+instance Text BenchmarkType where
+  disp (BenchmarkTypeExe ver)          = text "exitcode-stdio-" <> disp ver
+  disp (BenchmarkTypeUnknown name ver) = text name <> char '-' <> disp ver
+
+  parse = do
+    cs   <- Parse.sepBy1 component (Parse.char '-')
+    _    <- Parse.char '-'
+    ver  <- parse
+    let name = concat (intersperse "-" cs)
+    return $! case lowercase name of
+      "exitcode-stdio" -> BenchmarkTypeExe ver
+      _                -> BenchmarkTypeUnknown name ver
+
+    where
+      component = do
+        cs <- Parse.munch1 Char.isAlphaNum
+        if all Char.isDigit cs then Parse.pfail else return cs
+        -- each component must contain an alphabetic character, to avoid
+        -- ambiguity in identifiers like foo-1 (the 1 is the version number).
+
+benchmarkType :: Benchmark -> BenchmarkType
+benchmarkType benchmark = case benchmarkInterface benchmark of
+  BenchmarkExeV10 ver _              -> BenchmarkTypeExe ver
+  BenchmarkUnsupported benchmarktype -> benchmarktype
+
+-- ---------------------------------------------------------------------------
 -- The BuildInfo type
 
 -- Consider refactoring into executable and library versions.