diff --git a/cabal-install/Distribution/Client/FileMonitor.hs b/cabal-install/Distribution/Client/FileMonitor.hs index 7a1abb3bf79..15cca4a4513 100644 --- a/cabal-install/Distribution/Client/FileMonitor.hs +++ b/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@. diff --git a/cabal-install/Distribution/Client/Glob.hs b/cabal-install/Distribution/Client/Glob.hs index e48a0c366af..78d4d8d993e 100644 --- a/cabal-install/Distribution/Client/Glob.hs +++ b/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 diff --git a/cabal-install/Distribution/Client/ProjectConfig.hs b/cabal-install/Distribution/Client/ProjectConfig.hs index e00d76250b4..6cdc2bd8e41 100644 --- a/cabal-install/Distribution/Client/ProjectConfig.hs +++ b/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 _ = 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..fbd22488915 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, @@ -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,7 +63,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 +71,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 +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 diff --git a/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/cabal.project b/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/cabal.project index c366c4702ad..f2bd0e70747 100644 --- a/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/cabal.project +++ b/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 diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Glob.hs b/cabal-install/tests/UnitTests/Distribution/Client/Glob.hs index 9d18700abd6..592d795b427 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Glob.hs +++ b/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