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