Add ShowArg for single string options, clean up code.
[hadrian.git] / src / Oracles / Flag.hs
1 {-# LANGUAGE TypeFamilies, FlexibleInstances, MultiParamTypeClasses #-}
2
3 module Oracles.Flag (
4 module Control.Monad,
5 module Prelude,
6 Flag (..),
7 test, when, unless, not, (&&), (||)
8 ) where
9
10 import Control.Monad hiding (when, unless)
11 import qualified Prelude
12 import Prelude hiding (not, (&&), (||))
13 import Base
14 import Util
15 import Oracles.Base
16
17 data Flag = LaxDeps
18 | DynamicGhcPrograms
19 | GccIsClang
20 | GccLt46
21 | CrossCompiling
22 | Validating
23 | SupportsPackageKey
24 | SolarisBrokenShld
25 | SplitObjectsBroken
26 | GhcUnregisterised
27
28 -- TODO: Give the warning *only once* per key
29 test :: Flag -> Action Bool
30 test flag = do
31 (key, defaultValue) <- return $ case flag of
32 LaxDeps -> ("lax-dependencies" , False)
33 DynamicGhcPrograms -> ("dynamic-ghc-programs" , False)
34 GccIsClang -> ("gcc-is-clang" , False)
35 GccLt46 -> ("gcc-lt-46" , False)
36 CrossCompiling -> ("cross-compiling" , False)
37 Validating -> ("validating" , False)
38 SupportsPackageKey -> ("supports-package-key" , False)
39 SolarisBrokenShld -> ("solaris-broken-shld" , False)
40 SplitObjectsBroken -> ("split-objects-broken" , False)
41 GhcUnregisterised -> ("ghc-unregisterised" , False)
42 let defaultString = if defaultValue then "YES" else "NO"
43 value <- askConfigWithDefault key $ -- TODO: warn just once
44 do putColoured Dull Red $ "\nFlag '"
45 ++ key
46 ++ "' not set in configuration files. "
47 ++ "Proceeding with default value '"
48 ++ defaultString
49 ++ "'.\n"
50 return defaultString
51 return $ value == "YES"
52
53 class ToCondition a where
54 toCondition :: a -> Condition
55
56 instance ToCondition Condition where
57 toCondition = id
58
59 instance ToCondition Bool where
60 toCondition = return
61
62 instance ToCondition Flag where
63 toCondition = test
64
65 when :: (ToCondition a, Monoid m) => a -> Action m -> Action m
66 when x act = do
67 bool <- toCondition x
68 if bool then act else mempty
69
70 unless :: (ToCondition a, Monoid m) => a -> Action m -> Action m
71 unless x act = do
72 bool <- toCondition x
73 if bool then mempty else act
74
75 class Not a where
76 type NotResult a
77 not :: a -> NotResult a
78
79 instance Not Bool where
80 type NotResult Bool = Bool
81 not = Prelude.not
82
83 instance Not Condition where
84 type NotResult Condition = Condition
85 not = fmap not
86
87 instance Not Flag where
88 type NotResult Flag = Condition
89 not = not . toCondition
90
91 class AndOr a b where
92 type AndOrResult a b
93 (&&) :: a -> b -> AndOrResult a b
94 (||) :: a -> b -> AndOrResult a b
95
96 infixr 3 &&
97 infixr 2 ||
98
99 instance AndOr Bool Bool where
100 type AndOrResult Bool Bool = Bool
101 (&&) = (Prelude.&&)
102 (||) = (Prelude.||)
103
104 instance ToCondition a => AndOr Condition a where
105 type AndOrResult Condition a = Condition
106 x && y = (&&) <$> x <*> toCondition y
107 x || y = (||) <$> x <*> toCondition y
108
109 instance ToCondition a => AndOr Flag a where
110 type AndOrResult Flag a = Condition
111 x && y = toCondition x && y
112 x || y = toCondition x || y
113
114 -- TODO: need more instances to handle Bool as first argument of (&&), (||)