Flag.hs 2.93 KB
Newer Older
1
{-# LANGUAGE TypeFamilies, FlexibleInstances, MultiParamTypeClasses #-}
2
3
4
5
6
7
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
54
55
56
57
58
59
60
61
62
63
64
65
66
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

module Oracles.Flag (
    module Control.Monad,
    module Prelude,
    Flag (..), 
    Condition, test, when, unless, not, (&&), (||)
    ) 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
when x args = do
    bool <- toCondition x
    if bool then args else mempty

unless :: (ToCondition a, Monoid m) => a -> Action m -> Action m
unless x args = do
    bool <- toCondition x
    if bool then mempty else args

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