Refactor the Rebuild monad to keep file root in Reader env

Fixes haskell#3323 and haskell#3324, ensuring we monitor the project Cabal files.
Original fix by Edward Z. Yang. The approach in this patch is to fix an
underlying problem. Subsequent patches use a more consistent approach to
the monitoring as suggested by Edward.

The motivating example is:

  matches <- matchFileGlob dirname glob

where matchFileGlob is defined in the RebuildMonad module as

matchFileGlob root glob = do
    monitorFiles [monitorFileGlob glob]
    liftIO $ Glob.matchFileGlob root glob

This usage is wrong because the root used to match the glob is not the
same as the root that will be used later when checking the file monitor
for changes. You can see this is suspicious because the declaration of
the monitor does not take an root dir paramater but the immediate
matching does. That's because the root for the monitors is specified
when we do the rerunIfChanged to check the monitor.

So the only correct usage involves passing in the correct root. This is
a ripe source of bugs. So this refactoring moves the root into the
Rebuild monad directly, so the example becomes:

  matches <- matchFileGlob glob

The root is implicit, so you can't accidentally pick a different root
for the immediate match vs the later monitor check. Of course the root
still matters, but if you get that wrong you'll notice immediately
because you will not get the match results you were expecting.

So the root is now passed in with runRebuild, not with rerunIfChanged.

Also change the incorrect use of matchFileGlob. This use case now
relies on the adjusted representation of glob roots, using
FilePath.splitDrive to obtain the root (if any).

(cherry picked from commit bba5a81)

cabal-install/Distribution/Client/ProjectConfig.hs

@@ -591,7 +591,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 
@@ -629,13 +629,13 @@ findProjectPackages projectRootDir ProjectConfig{..} = do
       case () of
         _ | isDir
          -> do let dirname = filename -- now we know its a dir
-               matches <- matchFileGlob dirname globStarDotCabal
+               matches <- matchFileGlob (globStarDotCabal pkglocstr)
                case matches of
                  [match]
                      -> return (Right (ProjectPackageLocalDirectory
                                          dirname cabalFile))
                    where
-                     cabalFile = dirname </> match
+                     cabalFile = projectRootDir </> match
                  []  -> return (Left (BadLocDirNoCabalFile pkglocstr))
                  _   -> return (Left (BadLocDirManyCabalFiles pkglocstr))
 
@@ -656,9 +656,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

cabal-install/Distribution/Client/ProjectPlanning.hs

@@ -222,19 +222,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
@@ -324,7 +324,7 @@ rebuildInstallPlan verbosity
                              }
                            } = do
         progsearchpath <- liftIO $ getSystemSearchPath
-        rerunIfChanged verbosity projectRootDir fileMonitorCompiler
+        rerunIfChanged verbosity fileMonitorCompiler
                        (hcFlavor, hcPath, hcPkg, progsearchpath,
                         packageConfigProgramPaths,
                         packageConfigProgramArgs,
@@ -402,7 +402,7 @@ rebuildInstallPlan verbosity
                    }
                    (compiler, platform, progdb)
                    localPackages =
-        rerunIfChanged verbosity projectRootDir fileMonitorSolverPlan
+        rerunIfChanged verbosity fileMonitorSolverPlan
                        (solverSettings, cabalPackageCacheDirectory,
                         localPackages, localPackagesEnabledStanzas,
                         compiler, platform, programsDbSignature progdb) $ do
@@ -476,7 +476,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,
@@ -52,6 +53,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 +62,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 +99,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 +117,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 +137,9 @@ rerunIfChanged verbosity rootDir monitor key action = do
 -- Since this operates in the 'Rebuild' monad, it also monitors the given glob
 -- for changes.
 --
-matchFileGlob :: FilePath -> FilePathGlob -> Rebuild [FilePath]
-matchFileGlob root glob = do
+matchFileGlob :: FilePathGlob -> Rebuild [FilePath]
+matchFileGlob glob = do
+    root <- askRoot
     monitorFiles [monitorFileGlob glob]
     liftIO $ Glob.matchFileGlob root glob