1
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
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
|
{-# LANGUAGE MultiParamTypeClasses, TypeFamilies #-}
module Hadrian.Expression (
-- * Expressions
Expr, Predicate, Args,
-- ** Construction and modification
expr, exprIO, arg, remove,
-- ** Predicates
(?), input, inputs, output, outputs, VerboseCommand (..), verboseCommand,
-- ** Evaluation
interpret, interpretInContext,
-- * Convenient accessors
getBuildRoot, getContext, getBuilder, getOutputs, getInputs, getInput, getOutput
) where
import Control.Monad.Extra
import Control.Monad.Trans
import Control.Monad.Trans.Reader
import Development.Shake
import Development.Shake.Classes
import qualified Hadrian.Target as Target
import Hadrian.Target (Target, target)
import Hadrian.Utilities
-- | 'Expr' @c b a@ is a computation that produces a value of type 'Action' @a@
-- and can read parameters of the current build 'Target' @c b@.
newtype Expr c b a = Expr (ReaderT (Target c b) Action a)
deriving (Applicative, Functor, Monad)
instance Semigroup a => Semigroup (Expr c b a) where
Expr x <> Expr y = Expr $ (<>) <$> x <*> y
-- TODO: The 'Semigroup a' constraint will at some point become redundant.
instance (Semigroup a, Monoid a) => Monoid (Expr c b a) where
mempty = pure mempty
mappend = (<>)
-- | Expressions that compute a Boolean value.
type Predicate c b = Expr c b Bool
-- | Expressions that compute lists of arguments to be passed to builders.
type Args c b = Expr c b [String]
-- | Lift actions independent from the current build 'Target' into the 'Expr'
-- monad.
expr :: Action a -> Expr c b a
expr = Expr . lift
-- | Lift IO computations independent from the current build 'Target' into the
-- 'Expr' monad.
exprIO :: IO a -> Expr c b a
exprIO = Expr . liftIO
-- | Remove given elements from a list expression.
remove :: Eq a => [a] -> Expr c b [a] -> Expr c b [a]
remove xs e = filter (`notElem` xs) <$> e
-- | Add a single argument to 'Args'.
arg :: String -> Args c b
arg = pure . pure
-- | Values that can be converted to a 'Predicate'.
class ToPredicate p c b where
toPredicate :: p -> Predicate c b
infixr 3 ?
-- | Apply a predicate to an expression.
(?) :: (Monoid a, ToPredicate p c b) => p -> Expr c b a -> Expr c b a
p ? e = do
bool <- toPredicate p
if bool then e else mempty
instance ToPredicate Bool c b where
toPredicate = pure
instance ToPredicate p c b => ToPredicate (Action p) c b where
toPredicate = toPredicate . expr
instance (c ~ c', b ~ b', ToPredicate p c' b') => ToPredicate (Expr c b p) c' b' where
toPredicate p = toPredicate =<< p
-- | Interpret a given expression according to the given 'Target'.
interpret :: Target c b -> Expr c b a -> Action a
interpret target (Expr e) = runReaderT e target
-- | Interpret a given expression by looking only at the given 'Context'.
interpretInContext :: c -> Expr c b a -> Action a
interpretInContext c = interpret $ target c
(error "contextOnlyTarget: builder not set")
(error "contextOnlyTarget: inputs not set" )
(error "contextOnlyTarget: outputs not set")
-- | Get the directory of build results.
getBuildRoot :: Expr c b FilePath
getBuildRoot = expr buildRoot
-- | Get the current build 'Context'.
getContext :: Expr c b c
getContext = Expr $ asks Target.context
-- | Get the 'Builder' for the current 'Target'.
getBuilder :: Expr c b b
getBuilder = Expr $ asks Target.builder
-- | Get the input files of the current 'Target'.
getInputs :: Expr c b [FilePath]
getInputs = Expr $ asks Target.inputs
-- | Run 'getInputs' and check that the result contains one input file only.
getInput :: (Show b, Show c) => Expr c b FilePath
getInput = Expr $ do
target <- ask
fromSingleton ("Exactly one input file expected in " ++ show target) <$>
asks Target.inputs
-- | Get the files produced by the current 'Target'.
getOutputs :: Expr c b [FilePath]
getOutputs = Expr $ asks Target.outputs
-- | Run 'getOutputs' and check that the result contains one output file only.
getOutput :: (Show b, Show c) => Expr c b FilePath
getOutput = Expr $ do
target <- ask
fromSingleton ("Exactly one output file expected in " ++ show target) <$>
asks Target.outputs
-- | Does any of the input files match a given pattern?
input :: FilePattern -> Predicate c b
input f = any (f ?==) <$> getInputs
-- | Does any of the input files match any of the given patterns?
inputs :: [FilePattern] -> Predicate c b
inputs = anyM input
-- | Does any of the output files match a given pattern?
output :: FilePattern -> Predicate c b
output f = any (f ?==) <$> getOutputs
-- | Does any of the output files match any of the given patterns?
outputs :: [FilePattern] -> Predicate c b
outputs = anyM output
newtype VerboseCommand c b = VerboseCommand { predicate :: Predicate c b }
deriving Typeable
verboseCommand :: (ShakeValue c, ShakeValue b) => Predicate c b
verboseCommand = predicate =<< expr (userSetting . VerboseCommand $ return False)
|
