RebuildMonad.hs 5.89 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- | An abstraction for re-running actions if values or files have changed.
--
-- This is not a full-blown make-style incremental build system, it's a bit
-- more ad-hoc than that, but it's easier to integrate with existing code.
--
-- It's a convenient interface to the "Distribution.Client.FileMonitor"
-- functions.
--
module Distribution.Client.RebuildMonad (
    -- * Rebuild monad
    Rebuild,
    runRebuild,
16
    askRoot,
17
18
19

    -- * Setting up file monitoring
    monitorFiles,
20
21
22
23
24
    MonitorFilePath,
    monitorFile,
    monitorFileHashed,
    monitorNonExistentFile,
    monitorDirectory,
25
    monitorNonExistentDirectory,
26
27
    monitorDirectoryExistence,
    monitorFileOrDirectory,
28
    monitorFileSearchPath,
29
30
31
    monitorFileHashedSearchPath,
    -- ** Monitoring file globs
    monitorFileGlob,
32
    monitorFileGlobExistence,
33
    FilePathGlob(..),
34
35
36
    FilePathRoot(..),
    FilePathGlobRel(..),
    GlobPiece(..),
37
38
39
40
41
42
43
44

    -- * Using a file monitor
    FileMonitor(..),
    newFileMonitor,
    rerunIfChanged,

    -- * Utils
    matchFileGlob,
45
46
47
    getDirectoryContentsMonitored,
    createDirectoryMonitored,
    monitorDirectoryStatus,
48
49
  ) where

50
51
52
import Distribution.Client.FileMonitor
import Distribution.Client.Glob hiding (matchFileGlob)
import qualified Distribution.Client.Glob as Glob (matchFileGlob)
53
54
55
56
57
58
59
60

import Distribution.Simple.Utils (debug)
import Distribution.Verbosity    (Verbosity)

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
import Control.Monad.State as State
61
import Control.Monad.Reader as Reader
62
63
import Distribution.Compat.Binary     (Binary)
import System.FilePath (takeFileName)
64
import System.Directory
65
66
67
68
69
70


-- | A monad layered on top of 'IO' to help with re-running actions when the
-- input files and values they depend on change. The crucial operations are
-- 'rerunIfChanged' and 'monitorFiles'.
--
71
newtype Rebuild a = Rebuild (ReaderT FilePath (StateT [MonitorFilePath] IO) a)
72
73
74
75
76
77
78
  deriving (Functor, Applicative, Monad, MonadIO)

-- | Use this wihin the body action of 'rerunIfChanged' to declare that the
-- action depends on the given files. This can be based on what the action
-- actually did. It is these files that will be checked for changes next
-- time 'rerunIfChanged' is called for that 'FileMonitor'.
--
79
80
81
-- Relative paths are interpreted as relative to an implicit root, ultimately
-- passed in to 'runRebuild'.
--
82
83
84
85
monitorFiles :: [MonitorFilePath] -> Rebuild ()
monitorFiles filespecs = Rebuild (State.modify (filespecs++))

-- | Run a 'Rebuild' IO action.
86
87
unRebuild :: FilePath -> Rebuild a -> IO (a, [MonitorFilePath])
unRebuild rootDir (Rebuild action) = runStateT (runReaderT action rootDir) []
88
89

-- | Run a 'Rebuild' IO action.
90
91
92
93
94
95
runRebuild :: FilePath -> Rebuild a -> IO a
runRebuild rootDir (Rebuild action) = evalStateT (runReaderT action rootDir) []

-- | The root that relative paths are interpreted as being relative to.
askRoot :: Rebuild FilePath
askRoot = Rebuild Reader.ask
96
97
98
99
100
101
102
103
104
105

-- | This captures the standard use pattern for a 'FileMonitor': given a
-- monitor, an action and the input value the action depends on, either
-- re-run the action to get its output, or if the value and files the action
-- depends on have not changed then return a previously cached action result.
--
-- The result is still in the 'Rebuild' monad, so these can be nested.
--
-- Do not share 'FileMonitor's between different uses of 'rerunIfChanged'.
--
106
rerunIfChanged :: (Binary a, Binary b)
107
108
109
110
111
               => Verbosity
               -> FileMonitor a b
               -> a
               -> Rebuild b
               -> Rebuild b
112
113
rerunIfChanged verbosity monitor key action = do
    rootDir <- askRoot
114
115
116
117
118
119
120
121
122
123
124
    changed <- liftIO $ checkFileMonitorChanged monitor rootDir key
    case changed of
      MonitorUnchanged result files -> do
        liftIO $ debug verbosity $ "File monitor '" ++ monitorName
                                                    ++ "' unchanged."
        monitorFiles files
        return result

      MonitorChanged reason -> do
        liftIO $ debug verbosity $ "File monitor '" ++ monitorName
                                ++ "' changed: " ++ showReason reason
125
        startTime <- liftIO $ beginUpdateFileMonitor
126
        (result, files) <- liftIO $ unRebuild rootDir action
127
128
        liftIO $ updateFileMonitor monitor rootDir
                                   (Just startTime) files key result
129
130
131
132
133
134
135
136
137
138
        monitorFiles files
        return result
  where
    monitorName = takeFileName (fileMonitorCacheFile monitor)

    showReason (MonitoredFileChanged file) = "file " ++ file
    showReason (MonitoredValueChanged _)   = "monitor value changed"
    showReason  MonitorFirstRun            = "first run"
    showReason  MonitorCorruptCache        = "invalid cache file"

Duncan Coutts's avatar
Duncan Coutts committed
139
140
141
142

-- | Utility to match a file glob against the file system, starting from a
-- given root directory. The results are all relative to the given root.
--
143
-- Since this operates in the 'Rebuild' monad, it also monitors the given glob
Duncan Coutts's avatar
Duncan Coutts committed
144
145
-- for changes.
--
146
147
148
matchFileGlob :: FilePathGlob -> Rebuild [FilePath]
matchFileGlob glob = do
    root <- askRoot
149
    monitorFiles [monitorFileGlobExistence glob]
150
    liftIO $ Glob.matchFileGlob root glob
Duncan Coutts's avatar
Duncan Coutts committed
151

152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
getDirectoryContentsMonitored :: FilePath -> Rebuild [FilePath]
getDirectoryContentsMonitored dir = do
    monitorFiles [monitorDirectory dir]
    liftIO $ getDirectoryContents dir

createDirectoryMonitored :: Bool -> FilePath -> Rebuild ()
createDirectoryMonitored createParents dir = do
    monitorFiles [monitorDirectoryExistence dir]
    liftIO $ createDirectoryIfMissing createParents dir

-- | Monitor a directory as in 'monitorDirectory' if it currently exists or
-- as 'monitorNonExistentDirectory' if it does not.
monitorDirectoryStatus :: FilePath -> Rebuild ()
monitorDirectoryStatus dir = do
    exists <- liftIO $ doesDirectoryExist dir
    monitorFiles [if exists
                    then monitorDirectory dir
                    else monitorNonExistentDirectory dir]