Commit f35e05df authored by Duncan Coutts's avatar Duncan Coutts
Browse files

New infrastructure for tracking changes in files and values

A FileMonitor is an abstraction for monitoring the status of files,
as well as changes in an in-memory value. Files can be tracked by file
modification time, or mod time plus content. We can also track files
that are expected not to exist (to help implement search paths). We can
also have file globs.

The abstraction is useful for re-running actions when input files or
values change. This pattern is captured by the Rebuild monad.

This adds a dependency on the hashable package (used by
unordered-containers). If this is a problem we can extract just the hash
function we need.

This is not used yet, so there's a temporary import just to make sure it
gets compiled.
parent a15318ce
This diff is collapsed.
{-# LANGUAGE DeriveGeneric #-}
module Distribution.Client.Glob
( GlobAtom(..)
, Glob (..)
, globMatches
) where
import Data.List (stripPrefix)
import Control.Monad (liftM2)
import Distribution.Compat.Binary
import GHC.Generics (Generic)
import Distribution.Text
import Distribution.Compat.ReadP
import qualified Text.PrettyPrint as Disp
-- | A piece of a globbing pattern
data GlobAtom = WildCard
| Literal String
| Union [Glob]
deriving (Eq, Show, Generic)
instance Binary GlobAtom
-- | A single directory or file component of a globbed path
newtype Glob = Glob [GlobAtom]
deriving (Eq, Show, Generic)
instance Binary Glob
-- | Test whether a file path component matches a globbing pattern
--
globMatches :: Glob -> String -> Bool
globMatches (Glob atoms) = goStart atoms
where
-- From the man page, glob(7):
-- "If a filename starts with a '.', this character must be
-- matched explicitly."
go, goStart :: [GlobAtom] -> String -> Bool
goStart (WildCard:_) ('.':_) = False
goStart (Union globs:rest) cs = any (\(Glob glob) ->
goStart (glob ++ rest) cs) globs
goStart rest cs = go rest cs
go [] "" = True
go (Literal lit:rest) cs
| Just cs' <- stripPrefix lit cs
= go rest cs'
| otherwise = False
go [WildCard] "" = True
go (WildCard:rest) (c:cs) = go rest (c:cs) || go (WildCard:rest) cs
go (Union globs:rest) cs = any (\(Glob glob) ->
go (glob ++ rest) cs) globs
go [] (_:_) = False
go (_:_) "" = False
instance Text Glob where
disp (Glob atoms) = Disp.hcat (map dispAtom atoms)
where
dispAtom WildCard = Disp.char '*'
dispAtom (Literal str) = Disp.text (escape str)
dispAtom (Union globs) = Disp.braces
(Disp.hcat (Disp.punctuate (Disp.char ',')
(map disp globs)))
escape [] = []
escape (c:cs)
| isGlobEscapedChar c = '\\' : c : escape cs
| otherwise = c : escape cs
parse = Glob `fmap` many1 globAtom
where
globAtom :: ReadP r GlobAtom
globAtom = literal +++ wildcard +++ union
wildcard = char '*' >> return WildCard
union = between (char '{') (char '}')
(fmap (Union . map Glob) $ sepBy1 (many1 globAtom) (char ','))
literal = Literal `fmap` many1'
where
litchar = normal +++ escape
normal = satisfy (not . isGlobEscapedChar)
escape = char '\\' >> satisfy isGlobEscapedChar
many1' :: ReadP r [Char]
many1' = liftM2 (:) litchar many'
many' :: ReadP r [Char]
many' = many1' <++ return []
isGlobEscapedChar :: Char -> Bool
isGlobEscapedChar '*' = True
isGlobEscapedChar '{' = True
isGlobEscapedChar '}' = True
isGlobEscapedChar ',' = True
isGlobEscapedChar '\\' = True
isGlobEscapedChar '/' = True
isGlobEscapedChar _ = False
\ No newline at end of file
{-# 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,
-- * Setting up file monitoring
monitorFiles,
MonitorFilePath(..),
monitorFileSearchPath,
FilePathGlob(..),
-- * Using a file monitor
FileMonitor(..),
newFileMonitor,
rerunIfChanged,
-- * Utils
matchFileGlob,
) where
import Distribution.Client.FileMonitor
( MonitorFilePath(..), monitorFileSearchPath
, FilePathGlob(..), matchFileGlob
, FileMonitor(..), newFileMonitor
, MonitorChanged(..), MonitorChangedReason(..)
, checkFileMonitorChanged, updateFileMonitor )
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
import Distribution.Compat.Binary (Binary)
import System.FilePath (takeFileName)
-- | 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'.
--
newtype Rebuild a = Rebuild (StateT [MonitorFilePath] IO a)
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'.
--
monitorFiles :: [MonitorFilePath] -> Rebuild ()
monitorFiles filespecs = Rebuild (State.modify (filespecs++))
-- | Run a 'Rebuild' IO action.
unRebuild :: Rebuild a -> IO (a, [MonitorFilePath])
unRebuild (Rebuild action) = runStateT action []
-- | Run a 'Rebuild' IO action.
runRebuild :: Rebuild a -> IO a
runRebuild (Rebuild action) = evalStateT action []
-- | 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'.
--
rerunIfChanged :: (Eq a, Binary a, Binary b)
=> Verbosity
-> FilePath
-> FileMonitor a b
-> a
-> Rebuild b
-> Rebuild b
rerunIfChanged verbosity rootDir monitor key action = do
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
(result, files) <- liftIO $ unRebuild action
liftIO $ updateFileMonitor monitor rootDir files key result
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"
......@@ -66,6 +66,10 @@ import Distribution.Client.Targets
import qualified Distribution.Client.List as List
( list, info )
--TODO: temporary import, just to force these modules to be built.
-- It will be replaced by import of new build command once merged.
import Distribution.Client.RebuildMonad ()
import Distribution.Client.Install (install)
import Distribution.Client.Configure (configure)
import Distribution.Client.Update (update)
......
......@@ -143,8 +143,10 @@ executable cabal
Distribution.Client.Exec
Distribution.Client.Fetch
Distribution.Client.FetchUtils
Distribution.Client.FileMonitor
Distribution.Client.Freeze
Distribution.Client.Get
Distribution.Client.Glob
Distribution.Client.GlobalFlags
Distribution.Client.GZipUtils
Distribution.Client.Haddock
......@@ -165,6 +167,7 @@ executable cabal
Distribution.Client.ParseUtils
Distribution.Client.PlanIndex
Distribution.Client.Run
Distribution.Client.RebuildMonad
Distribution.Client.Sandbox
Distribution.Client.Sandbox.Index
Distribution.Client.Sandbox.PackageEnvironment
......@@ -200,6 +203,7 @@ executable cabal
Cabal >= 1.23.1 && < 1.24,
containers >= 0.4 && < 0.6,
filepath >= 1.3 && < 1.5,
hashable >= 1.0 && < 2,
HTTP >= 4000.1.5 && < 4000.4,
mtl >= 2.0 && < 3,
pretty >= 1.1 && < 1.2,
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment