cabal-install/src/Distribution/Client/RebuildMonad.hs

   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 within 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 :: forall a. (a -> FilePath) -> [a] -> Rebuild (Maybe a)
 298 findFirstFileMonitored file = findFirst
 299   where findFirst        :: [a] -> Rebuild (Maybe a)
 300         findFirst []     = return Nothing
 301         findFirst (x:xs) = do exists <- doesFileExistMonitored (file x)
 302                               if exists
 303                                 then return (Just x)
 304                                 else findFirst xs
 305
 306 -- | Like 'findFile', but in the 'Rebuild' monad.
 307 findFileMonitored :: [FilePath] -> FilePath -> Rebuild (Maybe FilePath)
 308 findFileMonitored searchPath fileName =
 309   findFirstFileMonitored id
 310     [ path </> fileName
 311     | path <- nub searchPath]