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