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