never executed always true always false
1 {-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, BangPatterns #-}
2
3 -- | An abstraction for re-running actions if values or files have changed.
4 --
5 -- This is not a full-blown make-style incremental build system, it's a bit
6 -- more ad-hoc than that, but it's easier to integrate with existing code.
7 --
8 -- It's a convenient interface to the "Distribution.Client.FileMonitor"
9 -- functions.
10 --
11 module Distribution.Client.RebuildMonad (
12 -- * Rebuild monad
13 Rebuild,
14 runRebuild,
15 execRebuild,
16 askRoot,
17
18 -- * Setting up file monitoring
19 monitorFiles,
20 MonitorFilePath,
21 monitorFile,
22 monitorFileHashed,
23 monitorNonExistentFile,
24 monitorDirectory,
25 monitorNonExistentDirectory,
26 monitorDirectoryExistence,
27 monitorFileOrDirectory,
28 monitorFileSearchPath,
29 monitorFileHashedSearchPath,
30 -- ** Monitoring file globs
31 monitorFileGlob,
32 monitorFileGlobExistence,
33 FilePathGlob(..),
34 FilePathRoot(..),
35 FilePathGlobRel(..),
36 GlobPiece(..),
37
38 -- * Using a file monitor
39 FileMonitor(..),
40 newFileMonitor,
41 rerunIfChanged,
42
43 -- * Utils
44 delayInitSharedResource,
45 delayInitSharedResources,
46 matchFileGlob,
47 getDirectoryContentsMonitored,
48 createDirectoryMonitored,
49 monitorDirectoryStatus,
50 doesFileExistMonitored,
51 need,
52 needIfExists,
53 findFileWithExtensionMonitored,
54 findFirstFileMonitored,
55 findFileMonitored,
56 ) where
57
58 import Prelude ()
59 import Distribution.Client.Compat.Prelude
60
61 import Distribution.Client.FileMonitor
62 import Distribution.Client.Glob hiding (matchFileGlob)
63 import qualified Distribution.Client.Glob as Glob (matchFileGlob)
64
65 import Distribution.Simple.Utils (debug)
66
67 import qualified Data.Map.Strict as Map
68 import Control.Monad.State as State
69 import Control.Monad.Reader as Reader
70 import Control.Concurrent.MVar (MVar, newMVar, modifyMVar)
71 import System.FilePath
72 import System.Directory
73
74
75 -- | A monad layered on top of 'IO' to help with re-running actions when the
76 -- input files and values they depend on change. The crucial operations are
77 -- 'rerunIfChanged' and 'monitorFiles'.
78 --
79 newtype Rebuild a = Rebuild (ReaderT FilePath (StateT [MonitorFilePath] IO) a)
80 deriving (Functor, Applicative, Monad, MonadIO)
81
82 -- | Use this wihin the body action of 'rerunIfChanged' to declare that the
83 -- action depends on the given files. This can be based on what the action
84 -- actually did. It is these files that will be checked for changes next
85 -- time 'rerunIfChanged' is called for that 'FileMonitor'.
86 --
87 -- Relative paths are interpreted as relative to an implicit root, ultimately
88 -- passed in to 'runRebuild'.
89 --
90 monitorFiles :: [MonitorFilePath] -> Rebuild ()
91 monitorFiles filespecs = Rebuild (State.modify (filespecs++))
92
93 -- | Run a 'Rebuild' IO action.
94 unRebuild :: FilePath -> Rebuild a -> IO (a, [MonitorFilePath])
95 unRebuild rootDir (Rebuild action) = runStateT (runReaderT action rootDir) []
96
97 -- | Run a 'Rebuild' IO action.
98 runRebuild :: FilePath -> Rebuild a -> IO a
99 runRebuild rootDir (Rebuild action) = evalStateT (runReaderT action rootDir) []
100
101 -- | Run a 'Rebuild' IO action.
102 execRebuild :: FilePath -> Rebuild a -> IO [MonitorFilePath]
103 execRebuild rootDir (Rebuild action) = execStateT (runReaderT action rootDir) []
104
105 -- | The root that relative paths are interpreted as being relative to.
106 askRoot :: Rebuild FilePath
107 askRoot = Rebuild Reader.ask
108
109 -- | This captures the standard use pattern for a 'FileMonitor': given a
110 -- monitor, an action and the input value the action depends on, either
111 -- re-run the action to get its output, or if the value and files the action
112 -- depends on have not changed then return a previously cached action result.
113 --
114 -- The result is still in the 'Rebuild' monad, so these can be nested.
115 --
116 -- Do not share 'FileMonitor's between different uses of 'rerunIfChanged'.
117 --
118 rerunIfChanged :: (Binary a, Structured a, Binary b, Structured b)
119 => Verbosity
120 -> FileMonitor a b
121 -> a
122 -> Rebuild b
123 -> Rebuild b
124 rerunIfChanged verbosity monitor key action = do
125 rootDir <- askRoot
126 changed <- liftIO $ checkFileMonitorChanged monitor rootDir key
127 case changed of
128 MonitorUnchanged result files -> do
129 liftIO $ debug verbosity $ "File monitor '" ++ monitorName
130 ++ "' unchanged."
131 monitorFiles files
132 return result
133
134 MonitorChanged reason -> do
135 liftIO $ debug verbosity $ "File monitor '" ++ monitorName
136 ++ "' changed: " ++ showReason reason
137 startTime <- liftIO $ beginUpdateFileMonitor
138 (result, files) <- liftIO $ unRebuild rootDir action
139 liftIO $ updateFileMonitor monitor rootDir
140 (Just startTime) files key result
141 monitorFiles files
142 return result
143 where
144 monitorName = takeFileName (fileMonitorCacheFile monitor)
145
146 showReason (MonitoredFileChanged file) = "file " ++ file
147 showReason (MonitoredValueChanged _) = "monitor value changed"
148 showReason MonitorFirstRun = "first run"
149 showReason MonitorCorruptCache = "invalid cache file"
150
151
152 -- | When using 'rerunIfChanged' for each element of a list of actions, it is
153 -- sometimes the case that each action needs to make use of some resource. e.g.
154 --
155 -- > sequence
156 -- > [ rerunIfChanged verbosity monitor key $ do
157 -- > resource <- mkResource
158 -- > ... -- use the resource
159 -- > | ... ]
160 --
161 -- For efficiency one would like to share the resource between the actions
162 -- but the straightforward way of doing this means initialising it every time
163 -- even when no actions need re-running.
164 --
165 -- > resource <- mkResource
166 -- > sequence
167 -- > [ rerunIfChanged verbosity monitor key $ do
168 -- > ... -- use the resource
169 -- > | ... ]
170 --
171 -- This utility allows one to get the best of both worlds:
172 --
173 -- > getResource <- delayInitSharedResource mkResource
174 -- > sequence
175 -- > [ rerunIfChanged verbosity monitor key $ do
176 -- > resource <- getResource
177 -- > ... -- use the resource
178 -- > | ... ]
179 --
180 delayInitSharedResource :: forall a. IO a -> Rebuild (Rebuild a)
181 delayInitSharedResource action = do
182 var <- liftIO (newMVar Nothing)
183 return (liftIO (getOrInitResource var))
184 where
185 getOrInitResource :: MVar (Maybe a) -> IO a
186 getOrInitResource var =
187 modifyMVar var $ \mx ->
188 case mx of
189 Just x -> return (Just x, x)
190 Nothing -> do
191 x <- action
192 return (Just x, x)
193
194
195 -- | Much like 'delayInitSharedResource' but for a keyed set of resources.
196 --
197 -- > getResource <- delayInitSharedResource mkResource
198 -- > sequence
199 -- > [ rerunIfChanged verbosity monitor key $ do
200 -- > resource <- getResource key
201 -- > ... -- use the resource
202 -- > | ... ]
203 --
204 delayInitSharedResources :: forall k v. Ord k
205 => (k -> IO v)
206 -> Rebuild (k -> Rebuild v)
207 delayInitSharedResources action = do
208 var <- liftIO (newMVar Map.empty)
209 return (liftIO . getOrInitResource var)
210 where
211 getOrInitResource :: MVar (Map k v) -> k -> IO v
212 getOrInitResource var k =
213 modifyMVar var $ \m ->
214 case Map.lookup k m of
215 Just x -> return (m, x)
216 Nothing -> do
217 x <- action k
218 let !m' = Map.insert k x m
219 return (m', x)
220
221
222 -- | Utility to match a file glob against the file system, starting from a
223 -- given root directory. The results are all relative to the given root.
224 --
225 -- Since this operates in the 'Rebuild' monad, it also monitors the given glob
226 -- for changes.
227 --
228 matchFileGlob :: FilePathGlob -> Rebuild [FilePath]
229 matchFileGlob glob = do
230 root <- askRoot
231 monitorFiles [monitorFileGlobExistence glob]
232 liftIO $ Glob.matchFileGlob root glob
233
234 getDirectoryContentsMonitored :: FilePath -> Rebuild [FilePath]
235 getDirectoryContentsMonitored dir = do
236 exists <- monitorDirectoryStatus dir
237 if exists
238 then liftIO $ getDirectoryContents dir
239 else return []
240
241 createDirectoryMonitored :: Bool -> FilePath -> Rebuild ()
242 createDirectoryMonitored createParents dir = do
243 monitorFiles [monitorDirectoryExistence dir]
244 liftIO $ createDirectoryIfMissing createParents dir
245
246 -- | Monitor a directory as in 'monitorDirectory' if it currently exists or
247 -- as 'monitorNonExistentDirectory' if it does not.
248 monitorDirectoryStatus :: FilePath -> Rebuild Bool
249 monitorDirectoryStatus dir = do
250 exists <- liftIO $ doesDirectoryExist dir
251 monitorFiles [if exists
252 then monitorDirectory dir
253 else monitorNonExistentDirectory dir]
254 return exists
255
256 -- | Like 'doesFileExist', but in the 'Rebuild' monad. This does
257 -- NOT track the contents of 'FilePath'; use 'need' in that case.
258 doesFileExistMonitored :: FilePath -> Rebuild Bool
259 doesFileExistMonitored f = do
260 root <- askRoot
261 exists <- liftIO $ doesFileExist (root </> f)
262 monitorFiles [if exists
263 then monitorFileExistence f
264 else monitorNonExistentFile f]
265 return exists
266
267 -- | Monitor a single file
268 need :: FilePath -> Rebuild ()
269 need f = monitorFiles [monitorFileHashed f]
270
271 -- | Monitor a file if it exists; otherwise check for when it
272 -- gets created. This is a bit better for recompilation avoidance
273 -- because sometimes users give bad package metadata, and we don't
274 -- want to repeatedly rebuild in this case (which we would if we
275 -- need'ed a non-existent file).
276 needIfExists :: FilePath -> Rebuild ()
277 needIfExists f = do
278 root <- askRoot
279 exists <- liftIO $ doesFileExist (root </> f)
280 monitorFiles [if exists
281 then monitorFileHashed f
282 else monitorNonExistentFile f]
283
284 -- | Like 'findFileWithExtension', but in the 'Rebuild' monad.
285 findFileWithExtensionMonitored
286 :: [String]
287 -> [FilePath]
288 -> FilePath
289 -> Rebuild (Maybe FilePath)
290 findFileWithExtensionMonitored extensions searchPath baseName =
291 findFirstFileMonitored id
292 [ path </> baseName <.> ext
293 | path <- nub searchPath
294 , ext <- nub extensions ]
295
296 -- | Like 'findFirstFile', but in the 'Rebuild' monad.
297 findFirstFileMonitored :: (a -> FilePath) -> [a] -> Rebuild (Maybe a)
298 findFirstFileMonitored file = findFirst
299 where findFirst [] = return Nothing
300 findFirst (x:xs) = do exists <- doesFileExistMonitored (file x)
301 if exists
302 then return (Just x)
303 else findFirst xs
304
305 -- | Like 'findFile', but in the 'Rebuild' monad.
306 findFileMonitored :: [FilePath] -> FilePath -> Rebuild (Maybe FilePath)
307 findFileMonitored searchPath fileName =
308 findFirstFileMonitored id
309 [ path </> fileName
310 | path <- nub searchPath]