Skip to content

Commit 8f77569

Browse files
dcouttsdcoutts
committed
Merge pull request #3102 from dcoutts/master
New infrastructure: tracking changes in files and values
2 parents 7f026ed + 1e1d82b commit 8f77569

File tree

8 files changed

+1687
-1
lines changed

8 files changed

+1687
-1
lines changed

‎cabal-install/Distribution/Client/FileMonitor.hs

Lines changed: 888 additions & 0 deletions
Large diffs are not rendered by default.

‎cabal-install/Distribution/Client/Glob.hs

Lines changed: 106 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,106 @@
1+
{-# LANGUAGE DeriveGeneric #-}
2+
3+
module Distribution.Client.Glob
4+
( GlobAtom(..)
5+
, Glob (..)
6+
, globMatches
7+
) where
8+
9+
import Data.List (stripPrefix)
10+
import Control.Monad (liftM2)
11+
import Distribution.Compat.Binary
12+
import GHC.Generics (Generic)
13+
14+
import Distribution.Text
15+
import Distribution.Compat.ReadP
16+
import qualified Text.PrettyPrint as Disp
17+
18+
19+
-- | A piece of a globbing pattern
20+
data GlobAtom = WildCard
21+
| Literal String
22+
| Union [Glob]
23+
deriving (Eq, Show, Generic)
24+
25+
instance Binary GlobAtom
26+
27+
-- | A single directory or file component of a globbed path
28+
newtype Glob = Glob [GlobAtom]
29+
deriving (Eq, Show, Generic)
30+
31+
instance Binary Glob
32+
33+
34+
-- | Test whether a file path component matches a globbing pattern
35+
--
36+
globMatches :: Glob -> String -> Bool
37+
globMatches (Glob atoms) = goStart atoms
38+
where
39+
-- From the man page, glob(7):
40+
-- "If a filename starts with a '.', this character must be
41+
-- matched explicitly."
42+
43+
go, goStart :: [GlobAtom] -> String -> Bool
44+
45+
goStart (WildCard:_) ('.':_) = False
46+
goStart (Union globs:rest) cs = any (\(Glob glob) ->
47+
goStart (glob ++ rest) cs) globs
48+
goStart rest cs = go rest cs
49+
50+
go [] "" = True
51+
go (Literal lit:rest) cs
52+
| Just cs' <- stripPrefix lit cs
53+
= go rest cs'
54+
| otherwise = False
55+
go [WildCard] "" = True
56+
go (WildCard:rest) (c:cs) = go rest (c:cs) || go (WildCard:rest) cs
57+
go (Union globs:rest) cs = any (\(Glob glob) ->
58+
go (glob ++ rest) cs) globs
59+
go [] (_:_) = False
60+
go (_:_) "" = False
61+
62+
instance Text Glob where
63+
disp (Glob atoms) = Disp.hcat (map dispAtom atoms)
64+
where
65+
dispAtom WildCard = Disp.char '*'
66+
dispAtom (Literal str) = Disp.text (escape str)
67+
dispAtom (Union globs) = Disp.braces
68+
(Disp.hcat (Disp.punctuate (Disp.char ',')
69+
(map disp globs)))
70+
71+
escape [] = []
72+
escape (c:cs)
73+
| isGlobEscapedChar c = '\\' : c : escape cs
74+
| otherwise = c : escape cs
75+
76+
parse = Glob `fmap` many1 globAtom
77+
where
78+
globAtom :: ReadP r GlobAtom
79+
globAtom = literal +++ wildcard +++ union
80+
81+
wildcard = char '*' >> return WildCard
82+
83+
union = between (char '{') (char '}')
84+
(fmap (Union . map Glob) $ sepBy1 (many1 globAtom) (char ','))
85+
86+
literal = Literal `fmap` many1'
87+
where
88+
litchar = normal +++ escape
89+
90+
normal = satisfy (not . isGlobEscapedChar)
91+
escape = char '\\' >> satisfy isGlobEscapedChar
92+
93+
many1' :: ReadP r [Char]
94+
many1' = liftM2 (:) litchar many'
95+
96+
many' :: ReadP r [Char]
97+
many' = many1' <++ return []
98+
99+
isGlobEscapedChar :: Char -> Bool
100+
isGlobEscapedChar '*' = True
101+
isGlobEscapedChar '{' = True
102+
isGlobEscapedChar '}' = True
103+
isGlobEscapedChar ',' = True
104+
isGlobEscapedChar '\\' = True
105+
isGlobEscapedChar '/' = True
106+
isGlobEscapedChar _ = False

‎cabal-install/Distribution/Client/IndexUtils.hs

Lines changed: 10 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -17,7 +17,9 @@
1717
module Distribution.Client.IndexUtils (
1818
getIndexFileAge,
1919
getInstalledPackages,
20+
Configure.getInstalledPackagesMonitorFiles,
2021
getSourcePackages,
22+
getSourcePackagesMonitorFiles,
2123

2224
Index(..),
2325
PackageEntry(..),
@@ -52,7 +54,7 @@ import Distribution.Simple.Compiler
5254
import Distribution.Simple.Program
5355
( ProgramConfiguration )
5456
import qualified Distribution.Simple.Configure as Configure
55-
( getInstalledPackages )
57+
( getInstalledPackages, getInstalledPackagesMonitorFiles )
5658
import Distribution.ParseUtils
5759
( ParseResult(..) )
5860
import Distribution.Version
@@ -204,6 +206,13 @@ readRepoIndex verbosity repoCtxt repo =
204206
getIndexFileAge :: Repo -> IO Double
205207
getIndexFileAge repo = getFileAge $ repoLocalDir repo </> "00-index.tar"
206208

209+
-- | A set of files (or directories) that can be monitored to detect when
210+
-- there might have been a change in the source packages.
211+
--
212+
getSourcePackagesMonitorFiles :: [Repo] -> [FilePath]
213+
getSourcePackagesMonitorFiles repos =
214+
[ repoLocalDir repo </> "00-index.cache"
215+
| repo <- repos ]
207216

208217
-- | It is not necessary to call this, as the cache will be updated when the
209218
-- index is read normally. However you can do the work earlier if you like.

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

Lines changed: 112 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,112 @@
1+
{-# LANGUAGE CPP #-}
2+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+
4+
-- | An abstraction for re-running actions if values or files have changed.
5+
--
6+
-- This is not a full-blown make-style incremental build system, it's a bit
7+
-- more ad-hoc than that, but it's easier to integrate with existing code.
8+
--
9+
-- It's a convenient interface to the "Distribution.Client.FileMonitor"
10+
-- functions.
11+
--
12+
module Distribution.Client.RebuildMonad (
13+
-- * Rebuild monad
14+
Rebuild,
15+
runRebuild,
16+
17+
-- * Setting up file monitoring
18+
monitorFiles,
19+
MonitorFilePath(..),
20+
monitorFileSearchPath,
21+
FilePathGlob(..),
22+
23+
-- * Using a file monitor
24+
FileMonitor(..),
25+
newFileMonitor,
26+
rerunIfChanged,
27+
28+
-- * Utils
29+
matchFileGlob,
30+
) where
31+
32+
import Distribution.Client.FileMonitor
33+
( MonitorFilePath(..), monitorFileSearchPath
34+
, FilePathGlob(..), matchFileGlob
35+
, FileMonitor(..), newFileMonitor
36+
, MonitorChanged(..), MonitorChangedReason(..)
37+
, checkFileMonitorChanged, updateFileMonitor )
38+
39+
import Distribution.Simple.Utils (debug)
40+
import Distribution.Verbosity (Verbosity)
41+
42+
#if !MIN_VERSION_base(4,8,0)
43+
import Control.Applicative
44+
#endif
45+
import Control.Monad.State as State
46+
import Distribution.Compat.Binary (Binary)
47+
import System.FilePath (takeFileName)
48+
49+
50+
-- | A monad layered on top of 'IO' to help with re-running actions when the
51+
-- input files and values they depend on change. The crucial operations are
52+
-- 'rerunIfChanged' and 'monitorFiles'.
53+
--
54+
newtype Rebuild a = Rebuild (StateT [MonitorFilePath] IO a)
55+
deriving (Functor, Applicative, Monad, MonadIO)
56+
57+
-- | Use this wihin the body action of 'rerunIfChanged' to declare that the
58+
-- action depends on the given files. This can be based on what the action
59+
-- actually did. It is these files that will be checked for changes next
60+
-- time 'rerunIfChanged' is called for that 'FileMonitor'.
61+
--
62+
monitorFiles :: [MonitorFilePath] -> Rebuild ()
63+
monitorFiles filespecs = Rebuild (State.modify (filespecs++))
64+
65+
-- | Run a 'Rebuild' IO action.
66+
unRebuild :: Rebuild a -> IO (a, [MonitorFilePath])
67+
unRebuild (Rebuild action) = runStateT action []
68+
69+
-- | Run a 'Rebuild' IO action.
70+
runRebuild :: Rebuild a -> IO a
71+
runRebuild (Rebuild action) = evalStateT action []
72+
73+
-- | This captures the standard use pattern for a 'FileMonitor': given a
74+
-- monitor, an action and the input value the action depends on, either
75+
-- re-run the action to get its output, or if the value and files the action
76+
-- depends on have not changed then return a previously cached action result.
77+
--
78+
-- The result is still in the 'Rebuild' monad, so these can be nested.
79+
--
80+
-- Do not share 'FileMonitor's between different uses of 'rerunIfChanged'.
81+
--
82+
rerunIfChanged :: (Eq a, Binary a, Binary b)
83+
=> Verbosity
84+
-> FilePath
85+
-> FileMonitor a b
86+
-> a
87+
-> Rebuild b
88+
-> Rebuild b
89+
rerunIfChanged verbosity rootDir monitor key action = do
90+
changed <- liftIO $ checkFileMonitorChanged monitor rootDir key
91+
case changed of
92+
MonitorUnchanged result files -> do
93+
liftIO $ debug verbosity $ "File monitor '" ++ monitorName
94+
++ "' unchanged."
95+
monitorFiles files
96+
return result
97+
98+
MonitorChanged reason -> do
99+
liftIO $ debug verbosity $ "File monitor '" ++ monitorName
100+
++ "' changed: " ++ showReason reason
101+
(result, files) <- liftIO $ unRebuild action
102+
liftIO $ updateFileMonitor monitor rootDir files key result
103+
monitorFiles files
104+
return result
105+
where
106+
monitorName = takeFileName (fileMonitorCacheFile monitor)
107+
108+
showReason (MonitoredFileChanged file) = "file " ++ file
109+
showReason (MonitoredValueChanged _) = "monitor value changed"
110+
showReason MonitorFirstRun = "first run"
111+
showReason MonitorCorruptCache = "invalid cache file"
112+

‎cabal-install/Main.hs

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -66,6 +66,10 @@ import Distribution.Client.Targets
6666
import qualified Distribution.Client.List as List
6767
( list, info )
6868

69+
--TODO: temporary import, just to force these modules to be built.
70+
-- It will be replaced by import of new build command once merged.
71+
import Distribution.Client.RebuildMonad ()
72+
6973
import Distribution.Client.Install (install)
7074
import Distribution.Client.Configure (configure)
7175
import Distribution.Client.Update (update)

‎cabal-install/cabal-install.cabal

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -149,8 +149,10 @@ executable cabal
149149
Distribution.Client.Exec
150150
Distribution.Client.Fetch
151151
Distribution.Client.FetchUtils
152+
Distribution.Client.FileMonitor
152153
Distribution.Client.Freeze
153154
Distribution.Client.Get
155+
Distribution.Client.Glob
154156
Distribution.Client.GlobalFlags
155157
Distribution.Client.GZipUtils
156158
Distribution.Client.Haddock
@@ -171,6 +173,7 @@ executable cabal
171173
Distribution.Client.ParseUtils
172174
Distribution.Client.PlanIndex
173175
Distribution.Client.Run
176+
Distribution.Client.RebuildMonad
174177
Distribution.Client.Sandbox
175178
Distribution.Client.Sandbox.Index
176179
Distribution.Client.Sandbox.PackageEnvironment
@@ -206,6 +209,7 @@ executable cabal
206209
Cabal >= 1.23.1 && < 1.24,
207210
containers >= 0.4 && < 0.6,
208211
filepath >= 1.3 && < 1.5,
212+
hashable >= 1.0 && < 2,
209213
HTTP >= 4000.1.5 && < 4000.4,
210214
mtl >= 2.0 && < 3,
211215
pretty >= 1.1 && < 1.2,
@@ -260,6 +264,7 @@ Test-Suite unit-tests
260264
UnitTests.Distribution.Client.Dependency.Modular.PSQ
261265
UnitTests.Distribution.Client.Dependency.Modular.Solver
262266
UnitTests.Distribution.Client.Dependency.Modular.DSL
267+
UnitTests.Distribution.Client.FileMonitor
263268
UnitTests.Distribution.Client.GZipUtils
264269
UnitTests.Distribution.Client.Sandbox
265270
UnitTests.Distribution.Client.Tar
@@ -275,6 +280,7 @@ Test-Suite unit-tests
275280
process,
276281
directory,
277282
filepath,
283+
hashable,
278284
stm,
279285
tar,
280286
time,

‎cabal-install/tests/UnitTests.hs

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,7 @@ import qualified UnitTests.Distribution.Client.Targets
1111
import qualified UnitTests.Distribution.Client.GZipUtils
1212
import qualified UnitTests.Distribution.Client.Dependency.Modular.PSQ
1313
import qualified UnitTests.Distribution.Client.Dependency.Modular.Solver
14+
import qualified UnitTests.Distribution.Client.FileMonitor
1415

1516
tests :: TestTree
1617
tests = testGroup "Unit Tests" [
@@ -28,6 +29,8 @@ tests = testGroup "Unit Tests" [
2829
UnitTests.Distribution.Client.Dependency.Modular.PSQ.tests
2930
,testGroup "UnitTests.Distribution.Client.Dependency.Modular.Solver"
3031
UnitTests.Distribution.Client.Dependency.Modular.Solver.tests
32+
,testGroup "UnitTests.Distribution.Client.FileMonitor"
33+
UnitTests.Distribution.Client.FileMonitor.tests
3134
]
3235

3336
-- Extra options for running the test suite

0 commit comments

Comments
 (0)