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