14a5b6557f94f6a6740dbdc990bd30a130bb3ae9
[gipeda.git] / src / BenchmarkSettings.hs
1 {-# LANGUAGE OverloadedStrings, DeriveGeneric #-}
2 module BenchmarkSettings where
3
4 import Data.Yaml
5 import Data.Aeson
6 import qualified Data.Vector as V
7 import Data.Functor
8 import Control.Applicative
9 import Control.Monad
10 import Data.Monoid
11 import Data.Maybe
12 import GHC.Generics (Generic)
13
14
15 data NumberType = IntegralNT | SmallIntegralNT | FloatingNT
16     deriving (Show)
17
18 instance ToJSON NumberType where
19     toJSON IntegralNT =      String "integral"
20     toJSON SmallIntegralNT = String "small integral"
21     toJSON FloatingNT =      String "floating"
22
23 type BenchName = String
24 data BenchSettings = BenchSettings
25     { smallerIsBetter :: Bool
26     , unit :: String
27     , numberType :: NumberType
28     , group :: String
29     , threshold :: Double
30     , important :: Bool
31     }
32     deriving (Show, Generic)
33 instance ToJSON BenchSettings
34
35 defaultBenchSettings :: BenchSettings
36 defaultBenchSettings = BenchSettings True "" IntegralNT "" 3 True
37
38 newtype S = S { unS :: BenchName -> BenchSettings }
39 newtype SM = SM (BenchName -> (BenchSettings -> BenchSettings))
40
41 instance Monoid SM where
42     mempty = SM (const id)
43     mappend (SM f) (SM g) = SM (\n -> g n . f n)
44
45 instance FromJSON NumberType where
46     parseJSON = withText "type" $ \t -> case t of
47         "small integral" -> return SmallIntegralNT
48         "integral" -> return IntegralNT
49         "float" -> return FloatingNT
50         v -> fail $ "Unknown \"type\": " ++ show v
51
52 -- Very naive glob, * only at the end
53 matches :: String -> String -> Bool
54 matches [] [] = True
55 matches _ ('*':[]) = True
56 matches (x:xs) (m:ms) = x == m && matches xs ms
57
58 instance FromJSON SM where
59     parseJSON (Object o) = do
60         m <- o .: "match"
61         mt <- o .:? "type"
62         mu <- o .:? "unit"
63         mg <- o .:? "group"
64         ms <- o .:? "smallerIsBetter"
65         mth <- o .:? "threshold"
66         mi <- o .:? "important"
67         return $ SM $ \n b ->
68             if n `matches` m then
69                b { numberType      = fromMaybe (numberType b) mt
70                  , unit            = fromMaybe (unit b) mu
71                  , group           = fromMaybe (group b) mg
72                  , smallerIsBetter = fromMaybe (smallerIsBetter b) ms
73                  , threshold       = fromMaybe (threshold b) mth
74                  , important       = fromMaybe (important b) mi
75                  }
76             else b
77     parseJSON _ = mzero
78
79 instance FromJSON S where
80     parseJSON (Array a) = do
81         mods <- mapM parseJSON (V.toList a)
82         let SM sm = mconcat mods
83         return $ S $ \n -> sm n defaultBenchSettings
84
85 data Settings = Settings
86    { title :: String
87    , cgitLink :: String
88    , logLink :: Maybe String
89    , limitRecent :: Integer
90    , start :: String
91    , interestingTags :: Maybe String
92    , benchSettings :: BenchName -> BenchSettings
93    }
94
95 instance FromJSON Settings where
96     parseJSON (Object v) =
97         Settings <$> v .: "title"
98                  <*> v .: "cgitLink"
99                  <*> v .:? "logLink"
100                  <*> v .: "limitRecent"
101                  <*> v .: "start"
102                  <*> v .:? "interestingTags"
103                  <*> (unS <$> v.: "benchmarks")
104     parseJSON _ = mzero
105
106
107 readSettings :: FilePath -> IO Settings
108 readSettings fname = either (error.show) id <$> decodeFileEither fname