Merge pull request #3347 from dcoutts/monitor-cabal-files

Further refactoring and fixes for monitoring cabal files

cabal-install/Distribution/Client/FileMonitor.hs

@@ -19,6 +19,7 @@ module Distribution.Client.FileMonitor (
   monitorDirectoryExistence,
   monitorFileOrDirectory,
   monitorFileGlob,
+  monitorFileGlobExistence,
   monitorFileSearchPath,
   monitorFileHashedSearchPath,
 
@@ -156,6 +157,13 @@ monitorFileOrDirectory = MonitorFile FileModTime DirModTime
 monitorFileGlob :: FilePathGlob -> MonitorFilePath
 monitorFileGlob = MonitorFileGlob FileHashed DirExists
 
+-- | Monitor a set of files (or directories) identified by a file glob for
+-- existence only. The monitored glob is considered to have changed if the set
+-- of files matching the glob changes (i.e. creations or deletions).
+--
+monitorFileGlobExistence :: FilePathGlob -> MonitorFilePath
+monitorFileGlobExistence = MonitorFileGlob FileExists DirExists
+
 -- | Creates a list of files to monitor when you search for a file which
 -- unsuccessfully looked in @notFoundAtPaths@ before finding it at
 -- @foundAtPath@.

cabal-install/Distribution/Client/Glob.hs

@@ -55,8 +55,7 @@ data GlobPiece = WildCard
 
 data FilePathRoot
    = FilePathRelative
-   | FilePathUnixRoot
-   | FilePathWinDrive Char
+   | FilePathRoot FilePath -- ^ e.g. @"/"@, @"c:\"@ or result of 'takeDrive'
    | FilePathHomeDir
   deriving (Eq, Show, Generic)
 
@@ -76,9 +75,8 @@ instance Binary GlobPiece
 isTrivialFilePathGlob :: FilePathGlob -> Maybe FilePath
 isTrivialFilePathGlob (FilePathGlob root pathglob) =
     case root of
-      FilePathRelative       -> go []          pathglob
-      FilePathUnixRoot       -> go ["/"]       pathglob
-      FilePathWinDrive drive -> go [drive:":"] pathglob
+      FilePathRelative       -> go []      pathglob
+      FilePathRoot root'     -> go [root'] pathglob
       FilePathHomeDir        -> Nothing
   where
     go paths (GlobDir  [Literal path] globs) = go (path:paths) globs
@@ -95,10 +93,9 @@ isTrivialFilePathGlob (FilePathGlob root pathglob) =
 getFilePathRootDirectory :: FilePathRoot
                          -> FilePath      -- ^ root for relative paths
                          -> IO FilePath
-getFilePathRootDirectory  FilePathRelative     root = return root
-getFilePathRootDirectory  FilePathUnixRoot        _ = return "/"
-getFilePathRootDirectory (FilePathWinDrive drive) _ = return (drive:":")
-getFilePathRootDirectory  FilePathHomeDir         _ = getHomeDirectory
+getFilePathRootDirectory  FilePathRelative   root = return root
+getFilePathRootDirectory (FilePathRoot root) _    = return root
+getFilePathRootDirectory  FilePathHomeDir    _    = getHomeDirectory
 
 
 ------------------------------------------------------------------------------
@@ -180,21 +177,17 @@ instance Text FilePathGlob where
 
 instance Text FilePathRoot where
   disp  FilePathRelative    = Disp.empty
-  disp  FilePathUnixRoot    = Disp.char '/'
-  disp (FilePathWinDrive c) = Disp.char c
-                      Disp.<> Disp.char ':'
-                      Disp.<> Disp.char '\\'
-  disp FilePathHomeDir      = Disp.char '~'
-                      Disp.<> Disp.char '/'
+  disp (FilePathRoot root)  = Disp.text root
+  disp FilePathHomeDir      = Disp.char '~' Disp.<> Disp.char '/'
 
   parse =
-        (     (Parse.char '/' >> return FilePathUnixRoot)
+        (     (Parse.char '/' >> return (FilePathRoot "/"))
           +++ (Parse.char '~' >> Parse.char '/' >> return FilePathHomeDir)
           +++ (do drive <- Parse.satisfy (\c -> (c >= 'a' && c <= 'z')
                                              || (c >= 'A' && c <= 'Z'))
                   _ <- Parse.char ':'
                   _ <- Parse.char '/' +++ Parse.char '\\'
-                  return (FilePathWinDrive (toUpper drive)))
+                  return (FilePathRoot (toUpper drive : ":\\")))
         )
     <++ return FilePathRelative
 

cabal-install/Distribution/Client/ProjectConfig.hs

@@ -481,6 +481,10 @@ reportParseResult _verbosity filetype filename (ParseFailed err) =
 -- Reading packages in the project
 --
 
+-- | The location of a package as part of a project. Local file paths are
+-- either absolute (if the user specified it as such) or they are relative
+-- to the project root.
+--
 data ProjectPackageLocation =
      ProjectPackageLocalCabalFile FilePath
    | ProjectPackageLocalDirectory FilePath FilePath -- dir and .cabal file
@@ -591,7 +595,7 @@ findProjectPackages projectRootDir ProjectConfig{..} = do
       case simpleParse pkglocstr of
         Nothing   -> return Nothing
         Just glob -> liftM Just $ do
-          matches <- matchFileGlob projectRootDir glob
+          matches <- matchFileGlob glob
           case matches of
             [] | isJust (isTrivialFilePathGlob glob)
                -> return (Left (BadPackageLocationFile
@@ -621,29 +625,29 @@ findProjectPackages projectRootDir ProjectConfig{..} = do
     checkFilePackageMatch :: String -> Rebuild (Either BadPackageLocationMatch
                                                        ProjectPackageLocation)
     checkFilePackageMatch pkglocstr = do
-      let filename = projectRootDir </> pkglocstr
-      isDir  <- liftIO $ doesDirectoryExist filename
-      parentDirExists <- case takeDirectory filename of
+      -- The pkglocstr may be absolute or may be relative to the project root.
+      -- Either way, </> does the right thing here. We return relative paths if
+      -- they were relative in the first place.
+      let abspath = projectRootDir </> pkglocstr
+      isDir  <- liftIO $ doesDirectoryExist abspath
+      parentDirExists <- case takeDirectory abspath of
                            []  -> return False
                            dir -> liftIO $ doesDirectoryExist dir
       case () of
         _ | isDir
-         -> do let dirname = filename -- now we know its a dir
-               matches <- matchFileGlob dirname globStarDotCabal
+         -> do matches <- matchFileGlob (globStarDotCabal pkglocstr)
                case matches of
-                 [match]
+                 [cabalFile]
                      -> return (Right (ProjectPackageLocalDirectory
-                                         dirname cabalFile))
-                   where
-                     cabalFile = dirname </> match
+                                         pkglocstr cabalFile))
                  []  -> return (Left (BadLocDirNoCabalFile pkglocstr))
                  _   -> return (Left (BadLocDirManyCabalFiles pkglocstr))
 
-          | extensionIsTarGz filename
-         -> return (Right (ProjectPackageLocalTarball filename))
+          | extensionIsTarGz pkglocstr
+         -> return (Right (ProjectPackageLocalTarball pkglocstr))
 
-          | takeExtension filename == ".cabal"
-         -> return (Right (ProjectPackageLocalCabalFile filename))
+          | takeExtension pkglocstr == ".cabal"
+         -> return (Right (ProjectPackageLocalCabalFile pkglocstr))
 
           | parentDirExists
          -> return (Left (BadLocNonexistantFile pkglocstr))
@@ -656,9 +660,19 @@ findProjectPackages projectRootDir ProjectConfig{..} = do
                       && takeExtension (dropExtension f) == ".tar"
 
 
-globStarDotCabal :: FilePathGlob
-globStarDotCabal =
-    FilePathGlob FilePathRelative (GlobFile [WildCard, Literal ".cabal"])
+-- | A glob to find all the cabal files in a directory.
+--
+-- For a directory @some/dir/@, this is a glob of the form @some/dir/\*.cabal@.
+-- The directory part can be either absolute or relative.
+--
+globStarDotCabal :: FilePath -> FilePathGlob
+globStarDotCabal dir =
+    FilePathGlob
+      (if isAbsolute dir then FilePathRoot root else FilePathRelative)
+      (foldr (\d -> GlobDir [Literal d])
+             (GlobFile [WildCard, Literal ".cabal"]) dirComponents)
+  where
+    (root, dirComponents) = fmap splitDirectories (splitDrive dir)
 
 
 --TODO: [code cleanup] use sufficiently recent transformers package
@@ -670,6 +684,11 @@ mplusMaybeT ma mb = do
     Just x  -> return (Just x)
 
 
+-- | Read the @.cabal@ file of the given package.
+--
+-- Note here is where we convert from project-root relative paths to absolute
+-- paths.
+--
 readSourcePackage :: Verbosity -> ProjectPackageLocation
                   -> Rebuild UnresolvedSourcePackage
 readSourcePackage verbosity (ProjectPackageLocalCabalFile cabalFile) =
@@ -679,11 +698,12 @@ readSourcePackage verbosity (ProjectPackageLocalCabalFile cabalFile) =
 
 readSourcePackage verbosity (ProjectPackageLocalDirectory dir cabalFile) = do
     monitorFiles [monitorFileHashed cabalFile]
-    pkgdesc <- liftIO $ readPackageDescription verbosity cabalFile
+    root <- askRoot
+    pkgdesc <- liftIO $ readPackageDescription verbosity (root </> cabalFile)
     return SourcePackage {
       packageInfoId        = packageId pkgdesc,
       packageDescription   = pkgdesc,
-      packageSource        = LocalUnpackedPackage dir,
+      packageSource        = LocalUnpackedPackage (root </> dir),
       packageDescrOverride = Nothing
     }
 readSourcePackage _verbosity _ =

cabal-install/Distribution/Client/ProjectPlanning.hs

@@ -240,19 +240,19 @@ rebuildInstallPlan verbosity
                      cabalStorePackageDB
                    }
                    cliConfig =
-    runRebuild $ do
+    runRebuild projectRootDir $ do
     progsearchpath <- liftIO $ getSystemSearchPath
     let cliConfigPersistent = cliConfig { projectConfigBuildOnly = mempty }
 
     -- The overall improved plan is cached
-    rerunIfChanged verbosity projectRootDir fileMonitorImprovedPlan
+    rerunIfChanged verbosity fileMonitorImprovedPlan
                    -- react to changes in command line args and the path
                    (cliConfigPersistent, progsearchpath) $ do
 
       -- And so is the elaborated plan that the improved plan based on
       (elaboratedPlan, elaboratedShared,
        projectConfig) <-
-        rerunIfChanged verbosity projectRootDir fileMonitorElaboratedPlan
+        rerunIfChanged verbosity fileMonitorElaboratedPlan
                        (cliConfigPersistent, progsearchpath) $ do
 
           (projectConfig, projectConfigTransient) <- phaseReadProjectConfig
@@ -342,7 +342,7 @@ rebuildInstallPlan verbosity
                              }
                            } = do
         progsearchpath <- liftIO $ getSystemSearchPath
-        rerunIfChanged verbosity projectRootDir fileMonitorCompiler
+        rerunIfChanged verbosity fileMonitorCompiler
                        (hcFlavor, hcPath, hcPkg, progsearchpath,
                         packageConfigProgramPaths,
                         packageConfigProgramArgs,
@@ -420,7 +420,7 @@ rebuildInstallPlan verbosity
                    }
                    (compiler, platform, progdb)
                    localPackages =
-        rerunIfChanged verbosity projectRootDir fileMonitorSolverPlan
+        rerunIfChanged verbosity fileMonitorSolverPlan
                        (solverSettings, cabalPackageCacheDirectory,
                         localPackages, localPackagesEnabledStanzas,
                         compiler, platform, programsDbSignature progdb) $ do
@@ -496,7 +496,7 @@ rebuildInstallPlan verbosity
         liftIO $ debug verbosity "Elaborating the install plan..."
 
         sourcePackageHashes <-
-          rerunIfChanged verbosity projectRootDir fileMonitorSourceHashes
+          rerunIfChanged verbosity fileMonitorSourceHashes
                          (map packageId $ InstallPlan.toList solverPlan) $
             getPackageSourceHashes verbosity withRepoCtx solverPlan
 

cabal-install/Distribution/Client/RebuildMonad.hs

@@ -13,6 +13,7 @@ module Distribution.Client.RebuildMonad (
     -- * Rebuild monad
     Rebuild,
     runRebuild,
+    askRoot,
 
     -- * Setting up file monitoring
     monitorFiles,
@@ -27,6 +28,7 @@ module Distribution.Client.RebuildMonad (
     monitorFileHashedSearchPath,
     -- ** Monitoring file globs
     monitorFileGlob,
+    monitorFileGlobExistence,
     FilePathGlob(..),
     FilePathRoot(..),
     FilePathGlobRel(..),
@@ -52,6 +54,7 @@ import Distribution.Verbosity    (Verbosity)
 import Control.Applicative
 #endif
 import Control.Monad.State as State
+import Control.Monad.Reader as Reader
 import Distribution.Compat.Binary     (Binary)
 import System.FilePath (takeFileName)
 
@@ -60,24 +63,31 @@ import System.FilePath (takeFileName)
 -- input files and values they depend on change. The crucial operations are
 -- 'rerunIfChanged' and 'monitorFiles'.
 --
-newtype Rebuild a = Rebuild (StateT [MonitorFilePath] IO a)
+newtype Rebuild a = Rebuild (ReaderT FilePath (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'.
 --
+-- Relative paths are interpreted as relative to an implicit root, ultimately
+-- passed in to 'runRebuild'.
+--
 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 []
+unRebuild :: FilePath -> Rebuild a -> IO (a, [MonitorFilePath])
+unRebuild rootDir (Rebuild action) = runStateT (runReaderT action rootDir) []
 
 -- | Run a 'Rebuild' IO action.
-runRebuild :: Rebuild a -> IO a
-runRebuild (Rebuild action) = evalStateT action []
+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
 
 -- | This captures the standard use pattern for a 'FileMonitor': given a
 -- monitor, an action and the input value the action depends on, either
@@ -90,12 +100,12 @@ runRebuild (Rebuild action) = evalStateT action []
 --
 rerunIfChanged :: (Binary a, Binary b)
                => Verbosity
-               -> FilePath
                -> FileMonitor a b
                -> a
                -> Rebuild b
                -> Rebuild b
-rerunIfChanged verbosity rootDir monitor key action = do
+rerunIfChanged verbosity monitor key action = do
+    rootDir <- askRoot
     changed <- liftIO $ checkFileMonitorChanged monitor rootDir key
     case changed of
       MonitorUnchanged result files -> do
@@ -108,7 +118,7 @@ rerunIfChanged verbosity rootDir monitor key action = do
         liftIO $ debug verbosity $ "File monitor '" ++ monitorName
                                 ++ "' changed: " ++ showReason reason
         startTime <- liftIO $ beginUpdateFileMonitor
-        (result, files) <- liftIO $ unRebuild action
+        (result, files) <- liftIO $ unRebuild rootDir action
         liftIO $ updateFileMonitor monitor rootDir
                                    (Just startTime) files key result
         monitorFiles files
@@ -128,8 +138,9 @@ rerunIfChanged verbosity rootDir monitor key action = do
 -- Since this operates in the 'Rebuild' monad, it also monitrs the given glob
 -- for changes.
 --
-matchFileGlob :: FilePath -> FilePathGlob -> Rebuild [FilePath]
-matchFileGlob root glob = do
-    monitorFiles [monitorFileGlob glob]
+matchFileGlob :: FilePathGlob -> Rebuild [FilePath]
+matchFileGlob glob = do
+    root <- askRoot
+    monitorFiles [monitorFileGlobExistence glob]
     liftIO $ Glob.matchFileGlob root glob
 

cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/cabal.project

@@ -1 +1,4 @@
-packages: p/p.cabal q/q.cabal
+packages: p/p.cabal q/
+
+-- use both matching a .cabal file, and a dir
+-- since these are slightly different code paths

cabal-install/tests/UnitTests/Distribution/Client/Glob.hs

@@ -40,12 +40,12 @@ prop_roundtrip_printparse pathglob =
 testParseCases :: Assertion
 testParseCases = do
 
-  FilePathGlob FilePathUnixRoot GlobDirTrailing <- testparse "/"
+  FilePathGlob (FilePathRoot "/") GlobDirTrailing <- testparse "/"
   FilePathGlob FilePathHomeDir  GlobDirTrailing <- testparse "~/"
 
-  FilePathGlob (FilePathWinDrive 'A') GlobDirTrailing <- testparse "A:/"
-  FilePathGlob (FilePathWinDrive 'Z') GlobDirTrailing <- testparse "z:/"
-  FilePathGlob (FilePathWinDrive 'C') GlobDirTrailing <- testparse "C:\\"
+  FilePathGlob (FilePathRoot "A:\\") GlobDirTrailing <- testparse "A:/"
+  FilePathGlob (FilePathRoot "Z:\\") GlobDirTrailing <- testparse "z:/"
+  FilePathGlob (FilePathRoot "C:\\") GlobDirTrailing <- testparse "C:\\"
   FilePathGlob FilePathRelative (GlobFile [Literal "_:"]) <- testparse "_:"
 
   FilePathGlob FilePathRelative
@@ -68,7 +68,7 @@ testParseCases = do
     (GlobDir [Literal "foo"]
       (GlobDir [Literal "bar"] GlobDirTrailing)) <- testparse "foo/bar/"
 
-  FilePathGlob FilePathUnixRoot
+  FilePathGlob (FilePathRoot "/")
     (GlobDir [Literal "foo"]
       (GlobDir [Literal "bar"] GlobDirTrailing)) <- testparse "/foo/bar/"
 
@@ -134,16 +134,17 @@ instance Arbitrary FilePathRoot where
   arbitrary =
     frequency
       [ (3, pure FilePathRelative)
-      , (1, pure FilePathUnixRoot)
+      , (1, pure (FilePathRoot unixroot))
+      , (1, FilePathRoot <$> windrive)
       , (1, pure FilePathHomeDir)
-      , (1, FilePathWinDrive <$> choose ('A', 'Z'))
       ]
+    where
+      unixroot = "/"
+      windrive = do d <- choose ('A', 'Z'); return (d : ":\\")
 
   shrink FilePathRelative     = []
-  shrink FilePathUnixRoot     = [FilePathRelative]
+  shrink (FilePathRoot _)     = [FilePathRelative]
   shrink FilePathHomeDir      = [FilePathRelative]
-  shrink (FilePathWinDrive d) = FilePathRelative
-                              : [ FilePathWinDrive d' | d' <- shrink d ]
 
 
 instance Arbitrary FilePathGlobRel where