1{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveGeneric #-}
3
4module Distribution.Types.Benchmark (
5    Benchmark(..),
6    emptyBenchmark,
7    benchmarkType,
8    benchmarkModules,
9    benchmarkModulesAutogen
10) where
11
12import Prelude ()
13import Distribution.Compat.Prelude
14
15import Distribution.Types.BuildInfo
16import Distribution.Types.BenchmarkType
17import Distribution.Types.BenchmarkInterface
18import Distribution.Types.UnqualComponentName
19
20import Distribution.ModuleName
21
22import qualified Distribution.Types.BuildInfo.Lens as L
23
24-- | A \"benchmark\" stanza in a cabal file.
25--
26data Benchmark = Benchmark {
27        benchmarkName      :: UnqualComponentName,
28        benchmarkInterface :: BenchmarkInterface,
29        benchmarkBuildInfo :: BuildInfo
30    }
31    deriving (Generic, Show, Read, Eq, Typeable, Data)
32
33instance Binary Benchmark
34instance Structured Benchmark
35instance NFData Benchmark where rnf = genericRnf
36
37instance L.HasBuildInfo Benchmark where
38    buildInfo f (Benchmark x1 x2 x3) = fmap (\y1 -> Benchmark x1 x2 y1) (f x3)
39
40instance Monoid Benchmark where
41    mempty = Benchmark {
42        benchmarkName      = mempty,
43        benchmarkInterface = mempty,
44        benchmarkBuildInfo = mempty
45    }
46    mappend = (<>)
47
48instance Semigroup Benchmark where
49    a <> b = Benchmark {
50        benchmarkName      = combine' benchmarkName,
51        benchmarkInterface = combine  benchmarkInterface,
52        benchmarkBuildInfo = combine  benchmarkBuildInfo
53    }
54        where combine  field = field a `mappend` field b
55              combine' field = case ( unUnqualComponentName $ field a
56                                    , unUnqualComponentName $ field b) of
57                        ("", _) -> field b
58                        (_, "") -> field a
59                        (x, y) -> error $ "Ambiguous values for test field: '"
60                            ++ x ++ "' and '" ++ y ++ "'"
61
62emptyBenchmark :: Benchmark
63emptyBenchmark = mempty
64
65benchmarkType :: Benchmark -> BenchmarkType
66benchmarkType benchmark = case benchmarkInterface benchmark of
67  BenchmarkExeV10 ver _              -> BenchmarkTypeExe ver
68  BenchmarkUnsupported benchmarktype -> benchmarktype
69
70-- | Get all the module names from a benchmark.
71benchmarkModules :: Benchmark -> [ModuleName]
72benchmarkModules benchmark = otherModules (benchmarkBuildInfo benchmark)
73
74-- | Get all the auto generated module names from a benchmark.
75-- This are a subset of 'benchmarkModules'.
76benchmarkModulesAutogen :: Benchmark -> [ModuleName]
77benchmarkModulesAutogen benchmark = autogenModules (benchmarkBuildInfo benchmark)
78