New infrastructure: tracking changes in files and values

cabal-install/Distribution/Client/Glob.hs

@@ -0,0 +1,106 @@
+{-# 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

cabal-install/Distribution/Client/IndexUtils.hs

@@ -17,7 +17,9 @@
 module Distribution.Client.IndexUtils (
   getIndexFileAge,
   getInstalledPackages,
+  Configure.getInstalledPackagesMonitorFiles,
   getSourcePackages,
+  getSourcePackagesMonitorFiles,
 
   Index(..),
   PackageEntry(..),
@@ -52,7 +54,7 @@ import Distribution.Simple.Compiler
 import Distribution.Simple.Program
          ( ProgramConfiguration )
 import qualified Distribution.Simple.Configure as Configure
-         ( getInstalledPackages )
+         ( getInstalledPackages, getInstalledPackagesMonitorFiles )
 import Distribution.ParseUtils
          ( ParseResult(..) )
 import Distribution.Version
@@ -204,6 +206,13 @@ readRepoIndex verbosity repoCtxt repo =
 getIndexFileAge :: Repo -> IO Double
 getIndexFileAge repo = getFileAge $ repoLocalDir repo </> "00-index.tar"
 
+-- | A set of files (or directories) that can be monitored to detect when
+-- there might have been a change in the source packages.
+--
+getSourcePackagesMonitorFiles :: [Repo] -> [FilePath]
+getSourcePackagesMonitorFiles repos =
+    [ repoLocalDir repo </> "00-index.cache"
+    | repo <- repos ]
 
 -- | It is not necessary to call this, as the cache will be updated when the
 -- index is read normally. However you can do the work earlier if you like.

cabal-install/Distribution/Client/RebuildMonad.hs

@@ -0,0 +1,112 @@
+{-# 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"
+

cabal-install/Main.hs

@@ -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)

cabal-install/cabal-install.cabal

@@ -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,
@@ -255,6 +259,7 @@ Test-Suite unit-tests
     UnitTests.Distribution.Client.Dependency.Modular.PSQ
     UnitTests.Distribution.Client.Dependency.Modular.Solver
     UnitTests.Distribution.Client.Dependency.Modular.DSL
+    UnitTests.Distribution.Client.FileMonitor
     UnitTests.Distribution.Client.GZipUtils
     UnitTests.Distribution.Client.Sandbox
     UnitTests.Distribution.Client.Tar
@@ -270,6 +275,7 @@ Test-Suite unit-tests
         process,
         directory,
         filepath,
+        hashable,
         stm,
         tar,
         time,

cabal-install/tests/UnitTests.hs

@@ -11,6 +11,7 @@ import qualified UnitTests.Distribution.Client.Targets
 import qualified UnitTests.Distribution.Client.GZipUtils
 import qualified UnitTests.Distribution.Client.Dependency.Modular.PSQ
 import qualified UnitTests.Distribution.Client.Dependency.Modular.Solver
+import qualified UnitTests.Distribution.Client.FileMonitor
 
 tests :: TestTree
 tests = testGroup "Unit Tests" [
@@ -28,6 +29,8 @@ tests = testGroup "Unit Tests" [
         UnitTests.Distribution.Client.Dependency.Modular.PSQ.tests
   ,testGroup "UnitTests.Distribution.Client.Dependency.Modular.Solver"
         UnitTests.Distribution.Client.Dependency.Modular.Solver.tests
+  ,testGroup "UnitTests.Distribution.Client.FileMonitor"
+        UnitTests.Distribution.Client.FileMonitor.tests
   ]
 
 -- Extra options for running the test suite