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--
11module 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
58import Prelude ()
59import Distribution.Client.Compat.Prelude
60
61import Distribution.Client.FileMonitor
62import Distribution.Client.Glob hiding (matchFileGlob)
63import qualified Distribution.Client.Glob as Glob (matchFileGlob)
64
65import Distribution.Simple.Utils (debug)
66
67import qualified Data.Map.Strict as Map
68import Control.Monad.State as State
69import Control.Monad.Reader as Reader
70import Control.Concurrent.MVar (MVar, newMVar, modifyMVar)
71import System.FilePath
72import 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--
79newtype 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--
90monitorFiles :: [MonitorFilePath] -> Rebuild ()
91monitorFiles filespecs = Rebuild (State.modify (filespecs++))
92
93-- | Run a 'Rebuild' IO action.
94unRebuild :: FilePath -> Rebuild a -> IO (a, [MonitorFilePath])
95unRebuild rootDir (Rebuild action) = runStateT (runReaderT action rootDir) []
96
97-- | Run a 'Rebuild' IO action.
98runRebuild :: FilePath -> Rebuild a -> IO a
99runRebuild rootDir (Rebuild action) = evalStateT (runReaderT action rootDir) []
100
101-- | Run a 'Rebuild' IO action.
102execRebuild :: FilePath -> Rebuild a -> IO [MonitorFilePath]
103execRebuild rootDir (Rebuild action) = execStateT (runReaderT action rootDir) []
104
105-- | The root that relative paths are interpreted as being relative to.
106askRoot :: Rebuild FilePath
107askRoot = 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--
118rerunIfChanged :: (Binary a, Structured a, Binary b, Structured b)
119               => Verbosity
120               -> FileMonitor a b
121               -> a
122               -> Rebuild b
123               -> Rebuild b
124rerunIfChanged 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--
180delayInitSharedResource :: forall a. IO a -> Rebuild (Rebuild a)
181delayInitSharedResource 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--
204delayInitSharedResources :: forall k v. Ord k
205                         => (k -> IO v)
206                         -> Rebuild (k -> Rebuild v)
207delayInitSharedResources 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--
228matchFileGlob :: FilePathGlob -> Rebuild [FilePath]
229matchFileGlob glob = do
230    root <- askRoot
231    monitorFiles [monitorFileGlobExistence glob]
232    liftIO $ Glob.matchFileGlob root glob
233
234getDirectoryContentsMonitored :: FilePath -> Rebuild [FilePath]
235getDirectoryContentsMonitored dir = do
236    exists <- monitorDirectoryStatus dir
237    if exists
238      then liftIO $ getDirectoryContents dir
239      else return []
240
241createDirectoryMonitored :: Bool -> FilePath -> Rebuild ()
242createDirectoryMonitored 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.
248monitorDirectoryStatus :: FilePath -> Rebuild Bool
249monitorDirectoryStatus 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.
258doesFileExistMonitored :: FilePath -> Rebuild Bool
259doesFileExistMonitored 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
268need :: FilePath -> Rebuild ()
269need 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).
276needIfExists :: FilePath -> Rebuild ()
277needIfExists 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.
285findFileWithExtensionMonitored
286    :: [String]
287    -> [FilePath]
288    -> FilePath
289    -> Rebuild (Maybe FilePath)
290findFileWithExtensionMonitored 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.
297findFirstFileMonitored :: (a -> FilePath) -> [a] -> Rebuild (Maybe a)
298findFirstFileMonitored 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.
306findFileMonitored :: [FilePath] -> FilePath -> Rebuild (Maybe FilePath)
307findFileMonitored searchPath fileName =
308  findFirstFileMonitored id
309    [ path </> fileName
310    | path <- nub searchPath]
311