diff --git a/cabal-install/Distribution/Client/ProjectConfig.hs b/cabal-install/Distribution/Client/ProjectConfig.hs index e00d76250b4..2a772b78d1b 100644 --- a/cabal-install/Distribution/Client/ProjectConfig.hs +++ b/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 diff --git a/cabal-install/Distribution/Client/ProjectPlanning.hs b/cabal-install/Distribution/Client/ProjectPlanning.hs index a1261b57193..4ce9c484ad4 100644 --- a/cabal-install/Distribution/Client/ProjectPlanning.hs +++ b/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 diff --git a/cabal-install/Distribution/Client/RebuildMonad.hs b/cabal-install/Distribution/Client/RebuildMonad.hs index bef1ec59650..f3ef1c107aa 100644 --- a/cabal-install/Distribution/Client/RebuildMonad.hs +++ b/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,7 +62,7 @@ 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 @@ -68,16 +70,23 @@ newtype Rebuild a = Rebuild (StateT [MonitorFilePath] IO a) -- 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 monitrs 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