Occurrrence analysis improvements for NOINLINE functions
[ghc.git] / hadrian / src / Hadrian / Expression.hs
1 {-# LANGUAGE MultiParamTypeClasses, TypeFamilies #-}
2 module Hadrian.Expression (
3 -- * Expressions
4 Expr, Predicate, Args,
5
6 -- ** Construction and modification
7 expr, exprIO, arg, remove,
8
9 -- ** Predicates
10 (?), input, inputs, output, outputs, VerboseCommand (..), verboseCommand,
11
12 -- ** Evaluation
13 interpret, interpretInContext,
14
15 -- * Convenient accessors
16 getBuildRoot, getContext, getBuilder, getOutputs, getInputs, getInput, getOutput
17 ) where
18
19 import Control.Monad.Extra
20 import Control.Monad.Trans
21 import Control.Monad.Trans.Reader
22 import Data.Semigroup
23 import Development.Shake
24 import Development.Shake.Classes
25
26 import qualified Hadrian.Target as Target
27 import Hadrian.Target (Target, target)
28 import Hadrian.Utilities
29
30 -- | 'Expr' @c b a@ is a computation that produces a value of type 'Action' @a@
31 -- and can read parameters of the current build 'Target' @c b@.
32 newtype Expr c b a = Expr (ReaderT (Target c b) Action a)
33 deriving (Applicative, Functor, Monad)
34
35 instance Semigroup a => Semigroup (Expr c b a) where
36 Expr x <> Expr y = Expr $ (<>) <$> x <*> y
37
38 -- TODO: The 'Semigroup a' constraint will at some point become redundant.
39 instance (Semigroup a, Monoid a) => Monoid (Expr c b a) where
40 mempty = pure mempty
41 mappend = (<>)
42
43 -- | Expressions that compute a Boolean value.
44 type Predicate c b = Expr c b Bool
45
46 -- | Expressions that compute lists of arguments to be passed to builders.
47 type Args c b = Expr c b [String]
48
49 -- | Lift actions independent from the current build 'Target' into the 'Expr'
50 -- monad.
51 expr :: Action a -> Expr c b a
52 expr = Expr . lift
53
54 -- | Lift IO computations independent from the current build 'Target' into the
55 -- 'Expr' monad.
56 exprIO :: IO a -> Expr c b a
57 exprIO = Expr . liftIO
58
59 -- | Remove given elements from a list expression.
60 remove :: Eq a => [a] -> Expr c b [a] -> Expr c b [a]
61 remove xs e = filter (`notElem` xs) <$> e
62
63 -- | Add a single argument to 'Args'.
64 arg :: String -> Args c b
65 arg = pure . pure
66
67 -- | Values that can be converted to a 'Predicate'.
68 class ToPredicate p c b where
69 toPredicate :: p -> Predicate c b
70
71 infixr 3 ?
72
73 -- | Apply a predicate to an expression.
74 (?) :: (Monoid a, Semigroup a, ToPredicate p c b) => p -> Expr c b a -> Expr c b a
75 p ? e = do
76 bool <- toPredicate p
77 if bool then e else mempty
78
79 instance ToPredicate Bool c b where
80 toPredicate = pure
81
82 instance ToPredicate p c b => ToPredicate (Action p) c b where
83 toPredicate = toPredicate . expr
84
85 instance (c ~ c', b ~ b', ToPredicate p c' b') => ToPredicate (Expr c b p) c' b' where
86 toPredicate p = toPredicate =<< p
87
88 -- | Interpret a given expression according to the given 'Target'.
89 interpret :: Target c b -> Expr c b a -> Action a
90 interpret target (Expr e) = runReaderT e target
91
92 -- | Interpret a given expression by looking only at the given 'Context'.
93 interpretInContext :: c -> Expr c b a -> Action a
94 interpretInContext c = interpret $ target c
95 (error "contextOnlyTarget: builder not set")
96 (error "contextOnlyTarget: inputs not set" )
97 (error "contextOnlyTarget: outputs not set")
98
99 -- | Get the directory of build results.
100 getBuildRoot :: Expr c b FilePath
101 getBuildRoot = expr buildRoot
102
103 -- | Get the current build 'Context'.
104 getContext :: Expr c b c
105 getContext = Expr $ asks Target.context
106
107 -- | Get the 'Builder' for the current 'Target'.
108 getBuilder :: Expr c b b
109 getBuilder = Expr $ asks Target.builder
110
111 -- | Get the input files of the current 'Target'.
112 getInputs :: Expr c b [FilePath]
113 getInputs = Expr $ asks Target.inputs
114
115 -- | Run 'getInputs' and check that the result contains one input file only.
116 getInput :: (Show b, Show c) => Expr c b FilePath
117 getInput = Expr $ do
118 target <- ask
119 fromSingleton ("Exactly one input file expected in " ++ show target) <$>
120 asks Target.inputs
121
122 -- | Get the files produced by the current 'Target'.
123 getOutputs :: Expr c b [FilePath]
124 getOutputs = Expr $ asks Target.outputs
125
126 -- | Run 'getOutputs' and check that the result contains one output file only.
127 getOutput :: (Show b, Show c) => Expr c b FilePath
128 getOutput = Expr $ do
129 target <- ask
130 fromSingleton ("Exactly one output file expected in " ++ show target) <$>
131 asks Target.outputs
132
133 -- | Does any of the input files match a given pattern?
134 input :: FilePattern -> Predicate c b
135 input f = any (f ?==) <$> getInputs
136
137 -- | Does any of the input files match any of the given patterns?
138 inputs :: [FilePattern] -> Predicate c b
139 inputs = anyM input
140
141 -- | Does any of the output files match a given pattern?
142 output :: FilePattern -> Predicate c b
143 output f = any (f ?==) <$> getOutputs
144
145 -- | Does any of the output files match any of the given patterns?
146 outputs :: [FilePattern] -> Predicate c b
147 outputs = anyM output
148
149 newtype VerboseCommand c b = VerboseCommand { predicate :: Predicate c b }
150 deriving Typeable
151
152 verboseCommand :: (ShakeValue c, ShakeValue b) => Predicate c b
153 verboseCommand = predicate =<< expr (userSetting . VerboseCommand $ return False)