Flag.hs 3.03 KB
Newer Older
1
{-# LANGUAGE TypeFamilies, FlexibleInstances, MultiParamTypeClasses #-}
2
3
4
5
6

module Oracles.Flag (
    module Control.Monad,
    module Prelude,
    Flag (..), 
7
    test, when, unless, not, (&&), (||), (<?>)
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
    ) where

import Control.Monad hiding (when, unless)
import qualified Prelude
import Prelude hiding (not, (&&), (||))
import Base
import Oracles.Base

data Flag = LaxDeps | DynamicGhcPrograms
          | GccIsClang | GccLt46 | CrossCompiling | Validating
          | SupportsPackageKey

test :: Flag -> Action Bool
test flag = do
    (key, defaultValue) <- return $ case flag of
        LaxDeps            -> ("lax-dependencies"     , False) -- TODO: move flags to a separate file
        DynamicGhcPrograms -> ("dynamic-ghc-programs" , False)
        GccIsClang         -> ("gcc-is-clang"         , False)
        GccLt46            -> ("gcc-lt-46"            , False)
        CrossCompiling     -> ("cross-compiling"      , False)
        Validating         -> ("validating"           , False)
        SupportsPackageKey -> ("supports-package-key" , False)
    let defaultString = if defaultValue then "YES" else "NO"
    value <- askConfigWithDefault key $
        do putLoud $ "\nFlag '" -- TODO: Give the warning *only once* per key
                ++ key
                ++ "' not set in configuration files. "
                ++ "Proceeding with default value '"
                ++ defaultString
                ++ "'.\n"
           return defaultString
    return $ value == "YES"

class ToCondition a where
    toCondition :: a -> Condition

instance ToCondition Condition where
    toCondition = id

instance ToCondition Bool where
    toCondition = return

instance ToCondition Flag where
    toCondition = test

when :: (ToCondition a, Monoid m) => a -> Action m -> Action m
Andrey Mokhov's avatar
Andrey Mokhov committed
54
when x act = do
55
    bool <- toCondition x
Andrey Mokhov's avatar
Andrey Mokhov committed
56
    if bool then act else mempty
57
58

unless :: (ToCondition a, Monoid m) => a -> Action m -> Action m
Andrey Mokhov's avatar
Andrey Mokhov committed
59
unless x act = do
60
    bool <- toCondition x
Andrey Mokhov's avatar
Andrey Mokhov committed
61
    if bool then mempty else act
62

63
64
65
66
-- Infix version of when
(<?>) :: (ToCondition a, Monoid m) => a -> Action m -> Action m
(<?>) = when

67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
class Not a where
    type NotResult a
    not :: a -> NotResult a

instance Not Bool where
    type NotResult Bool = Bool
    not = Prelude.not

instance Not Condition where
    type NotResult Condition = Condition
    not x = not <$> (toCondition x)

instance Not Flag where
    type NotResult Flag = Condition
    not x = not (toCondition x)

class AndOr a b where
    type AndOrResult a b
    (&&) :: a -> b -> AndOrResult a b
    (||) :: a -> b -> AndOrResult a b

infixr 3 &&
infixr 2 ||

instance AndOr Bool Bool where
    type AndOrResult Bool Bool = Bool
    (&&) = (Prelude.&&)
    (||) = (Prelude.||)

instance ToCondition a => AndOr Condition a where
    type AndOrResult Condition a = Condition
    x && y = (Prelude.&&) <$> toCondition x <*> toCondition y
    x || y = (Prelude.||) <$> toCondition x <*> toCondition y

instance ToCondition a => AndOr Flag a where
    type AndOrResult Flag a = Condition
    x && y = toCondition x && y
    x || y = toCondition x || y