diff --git a/cabal-install/Distribution/Client/ProjectBuilding.hs b/cabal-install/Distribution/Client/ProjectBuilding.hs index 051bab7f1f2..0f3ae1b64a2 100644 --- a/cabal-install/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/Distribution/Client/ProjectBuilding.hs @@ -56,12 +56,15 @@ import Distribution.Client.FetchUtils import Distribution.Client.GlobalFlags (RepoContext) import qualified Distribution.Client.Tar as Tar import Distribution.Client.Setup (filterConfigureFlags) +import Distribution.Client.SourceFiles import Distribution.Client.SrcDist (allPackageSourceFiles) import Distribution.Client.Utils (removeExistingFile) import Distribution.Package hiding (InstalledPackageId, installedPackageId) +import qualified Distribution.PackageDescription as PD import Distribution.InstalledPackageInfo (InstalledPackageInfo) import qualified Distribution.InstalledPackageInfo as Installed +import Distribution.Types.BuildType import Distribution.Simple.Program import qualified Distribution.Simple.Setup as Cabal import Distribution.Simple.Command (CommandUI) @@ -85,7 +88,6 @@ import qualified Data.ByteString.Lazy as LBS import Control.Monad import Control.Exception -import Data.List import Data.Maybe import System.FilePath @@ -452,15 +454,14 @@ updatePackageBuildFileMonitor :: PackageFileMonitor -> MonitorTimestamp -> ElaboratedConfiguredPackage -> BuildStatusRebuild - -> [FilePath] + -> [MonitorFilePath] -> BuildResultMisc -> IO () updatePackageBuildFileMonitor PackageFileMonitor{pkgFileMonitorBuild} srcdir timestamp pkg pkgBuildStatus - allSrcFiles buildResult = + monitors buildResult = updateFileMonitor pkgFileMonitorBuild srcdir (Just timestamp) - (map monitorFileHashed allSrcFiles) - buildComponents' buildResult + monitors buildComponents' buildResult where (_pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg @@ -1041,29 +1042,35 @@ buildInplaceUnpackedPackage verbosity annotateFailureNoLog BuildFailed $ setup buildCommand buildFlags buildArgs - --TODO: [required eventually] this doesn't track file - --non-existence, so we could fail to rebuild if someone - --adds a new file which changes behavior. - allSrcFiles <- - let trySdist = allPackageSourceFiles verbosity scriptOptions srcdir - -- This is just a hack, to get semi-reasonable file - -- listings for the monitor - tryFallback = do - warn verbosity $ - "Couldn't use sdist to compute source files; falling " ++ - "back on recursive file scan." - filter (not . ("dist" `isPrefixOf`)) - `fmap` getDirectoryContentsRecursive srcdir - in if elabSetupScriptCliVersion pkg >= mkVersion [1,17] - then do r <- trySdist - if null r - then tryFallback - else return r - else tryFallback + let listSimple = + execRebuild srcdir (needElaboratedConfiguredPackage pkg) + listSdist = + fmap (map monitorFileHashed) $ + allPackageSourceFiles verbosity scriptOptions srcdir + ifNullThen m m' = do xs <- m + if null xs then m' else return xs + monitors <- case PD.buildType (elabPkgDescription pkg) of + Just Simple -> listSimple + -- If a Custom setup was used, AND the Cabal is recent + -- enough to have sdist --list-sources, use that to + -- determine the files that we need to track. This can + -- cause unnecessary rebuilding (for example, if README + -- is edited, we will try to rebuild) but there isn't + -- a more accurate Custom interface we can use to get + -- this info. We prefer not to use listSimple here + -- as it can miss extra source files that are considered + -- by the Custom setup. + _ | elabSetupScriptCliVersion pkg >= mkVersion [1,17] + -- However, sometimes sdist --list-sources will fail + -- and return an empty list. In that case, fall + -- back on the (inaccurate) simple tracking. + -> listSdist `ifNullThen` listSimple + | otherwise + -> listSimple updatePackageBuildFileMonitor packageFileMonitor srcdir timestamp pkg buildStatus - allSrcFiles buildResult + monitors buildResult -- PURPOSELY omitted: no copy! diff --git a/cabal-install/Distribution/Client/RebuildMonad.hs b/cabal-install/Distribution/Client/RebuildMonad.hs index a394d9cb00d..24fe1a38a18 100644 --- a/cabal-install/Distribution/Client/RebuildMonad.hs +++ b/cabal-install/Distribution/Client/RebuildMonad.hs @@ -12,6 +12,7 @@ module Distribution.Client.RebuildMonad ( -- * Rebuild monad Rebuild, runRebuild, + execRebuild, askRoot, -- * Setting up file monitoring @@ -44,6 +45,12 @@ module Distribution.Client.RebuildMonad ( getDirectoryContentsMonitored, createDirectoryMonitored, monitorDirectoryStatus, + doesFileExistMonitored, + need, + needIfExists, + findFileWithExtensionMonitored, + findFirstFileMonitored, + findFileMonitored, ) where import Prelude () @@ -58,7 +65,7 @@ import Distribution.Verbosity (Verbosity) import Control.Monad.State as State import Control.Monad.Reader as Reader -import System.FilePath (takeFileName) +import System.FilePath import System.Directory @@ -88,6 +95,10 @@ unRebuild rootDir (Rebuild action) = runStateT (runReaderT action rootDir) [] runRebuild :: FilePath -> Rebuild a -> IO a runRebuild rootDir (Rebuild action) = evalStateT (runReaderT action rootDir) [] +-- | Run a 'Rebuild' IO action. +execRebuild :: FilePath -> Rebuild a -> IO [MonitorFilePath] +execRebuild rootDir (Rebuild action) = execStateT (runReaderT action rootDir) [] + -- | The root that relative paths are interpreted as being relative to. askRoot :: Rebuild FilePath askRoot = Rebuild Reader.ask @@ -166,3 +177,58 @@ monitorDirectoryStatus dir = do then monitorDirectory dir else monitorNonExistentDirectory dir] +doesFileExistMonitored :: FilePath -> Rebuild Bool +doesFileExistMonitored f = do + root <- askRoot + exists <- liftIO $ doesFileExist (root f) + -- TODO: If the file exists, should we really monitor the entire + -- file?! + monitorFiles [if exists + then monitorFileHashed f + else monitorNonExistentFile f] + return exists + +-- | Monitor a single file +need :: FilePath -> Rebuild () +need f = monitorFiles [monitorFileHashed f] + +-- | Monitor a file if it exists; otherwise check for when it +-- gets created. This is a bit better for recompilation avoidance +-- because sometimes users give bad package metadata, and we don't +-- want to repeatedly rebuild in this case (which we would if we +-- need'ed a non-existent file). +needIfExists :: FilePath -> Rebuild () +needIfExists f = do + root <- askRoot + exists <- liftIO $ doesFileExist (root f) + monitorFiles [if exists + then monitorFileHashed f + else monitorNonExistentFile f] + +-- | Like 'findFileWithExtension', but in the 'Rebuild' monad. +findFileWithExtensionMonitored + :: [String] + -> [FilePath] + -> FilePath + -> Rebuild (Maybe FilePath) +findFileWithExtensionMonitored extensions searchPath baseName = + findFirstFileMonitored id + [ path baseName <.> ext + | path <- nub searchPath + , ext <- nub extensions ] + +-- | Like 'findFirstFile', but in the 'Rebuild' monad. +findFirstFileMonitored :: (a -> FilePath) -> [a] -> Rebuild (Maybe a) +findFirstFileMonitored file = findFirst + where findFirst [] = return Nothing + findFirst (x:xs) = do exists <- doesFileExistMonitored (file x) + if exists + then return (Just x) + else findFirst xs + +-- | Like 'findFile', but in the 'Rebuild' monad. +findFileMonitored :: [FilePath] -> FilePath -> Rebuild (Maybe FilePath) +findFileMonitored searchPath fileName = + findFirstFileMonitored id + [ path fileName + | path <- nub searchPath] diff --git a/cabal-install/Distribution/Client/SourceFiles.hs b/cabal-install/Distribution/Client/SourceFiles.hs new file mode 100644 index 00000000000..10284ad2a86 --- /dev/null +++ b/cabal-install/Distribution/Client/SourceFiles.hs @@ -0,0 +1,160 @@ +-- | Contains an @sdist@ like function which computes the source files +-- that we should track to determine if a rebuild is necessary. +-- Unlike @sdist@, we can operate directly on the true +-- 'PackageDescription' (not flattened). +-- +-- The naming convention, roughly, is that to declare we need the +-- source for some type T, you use the function needT; some functions +-- need auxiliary information. +-- +-- We can only use this code for non-Custom scripts; Custom scripts +-- may have arbitrary extra dependencies (esp. new preprocessors) which +-- we cannot "see" easily. +module Distribution.Client.SourceFiles (needElaboratedConfiguredPackage) where + +import Distribution.Client.ProjectPlanning.Types +import Distribution.Client.RebuildMonad + +import Distribution.Solver.Types.OptionalStanza + +import Distribution.Simple.PreProcess + +import Distribution.Types.PackageDescription +import Distribution.Types.Component +import Distribution.Types.ComponentRequestedSpec +import Distribution.Types.Library +import Distribution.Types.Executable +import Distribution.Types.Benchmark +import Distribution.Types.BenchmarkInterface +import Distribution.Types.TestSuite +import Distribution.Types.TestSuiteInterface +import Distribution.Types.BuildInfo + +import Distribution.ModuleName + +import Prelude () +import Distribution.Client.Compat.Prelude + +import System.FilePath +import Control.Monad +import qualified Data.Set as Set + +needElaboratedConfiguredPackage :: ElaboratedConfiguredPackage -> Rebuild () +needElaboratedConfiguredPackage elab = + case elabPkgOrComp elab of + ElabComponent ecomp -> needElaboratedComponent elab ecomp + ElabPackage epkg -> needElaboratedPackage elab epkg + +needElaboratedPackage :: ElaboratedConfiguredPackage -> ElaboratedPackage -> Rebuild () +needElaboratedPackage elab epkg = + mapM_ (needComponent pkg_descr) (enabledComponents pkg_descr enabled) + where + pkg_descr = elabPkgDescription elab + enabled_stanzas = pkgStanzasEnabled epkg + -- TODO: turn this into a helper function somewhere + enabled = + ComponentRequestedSpec { + testsRequested = TestStanzas `Set.member` enabled_stanzas, + benchmarksRequested = BenchStanzas `Set.member` enabled_stanzas + } + +needElaboratedComponent :: ElaboratedConfiguredPackage -> ElaboratedComponent -> Rebuild () +needElaboratedComponent elab ecomp = + case mb_comp of + Nothing -> needSetup + Just comp -> needComponent pkg_descr comp + where + pkg_descr = elabPkgDescription elab + mb_comp = fmap (getComponent pkg_descr) (compComponentName ecomp) + +needComponent :: PackageDescription -> Component -> Rebuild () +needComponent pkg_descr comp = + case comp of + CLib lib -> needLibrary pkg_descr lib + CExe exe -> needExecutable pkg_descr exe + CTest test -> needTestSuite pkg_descr test + CBench bench -> needBenchmark pkg_descr bench + +needSetup :: Rebuild () +needSetup = findFirstFileMonitored id ["Setup.hs", "Setup.lhs"] >> return () + +needLibrary :: PackageDescription -> Library -> Rebuild () +needLibrary pkg_descr (Library { exposedModules = modules + , signatures = sigs + , libBuildInfo = bi }) + = needBuildInfo pkg_descr bi (modules ++ sigs) + +needExecutable :: PackageDescription -> Executable -> Rebuild () +needExecutable pkg_descr (Executable { modulePath = mainPath + , buildInfo = bi }) + = do needBuildInfo pkg_descr bi [] + needMainFile bi mainPath + +needTestSuite :: PackageDescription -> TestSuite -> Rebuild () +needTestSuite pkg_descr t + = case testInterface t of + TestSuiteExeV10 _ mainPath -> do + needBuildInfo pkg_descr bi [] + needMainFile bi mainPath + TestSuiteLibV09 _ m -> + needBuildInfo pkg_descr bi [m] + TestSuiteUnsupported _ -> return () -- soft fail + where + bi = testBuildInfo t + +needMainFile :: BuildInfo -> FilePath -> Rebuild () +needMainFile bi mainPath = do + -- The matter here is subtle. It might *seem* that we + -- should just search for mainPath, but as per + -- b61cb051f63ed5869b8f4a6af996ff7e833e4b39 'main-is' + -- will actually be the source file AFTER preprocessing, + -- whereas we need to get the file *prior* to preprocessing. + ppFile <- findFileWithExtensionMonitored + (ppSuffixes knownSuffixHandlers) + (hsSourceDirs bi) + (dropExtension mainPath) + case ppFile of + -- But check the original path in the end, because + -- maybe it's a non-preprocessed file with a non-traditional + -- extension. + Nothing -> findFileMonitored (hsSourceDirs bi) mainPath + >>= maybe (return ()) need + Just pp -> need pp + +needBenchmark :: PackageDescription -> Benchmark -> Rebuild () +needBenchmark pkg_descr bm + = case benchmarkInterface bm of + BenchmarkExeV10 _ mainPath -> do + needBuildInfo pkg_descr bi [] + needMainFile bi mainPath + BenchmarkUnsupported _ -> return () -- soft fail + where + bi = benchmarkBuildInfo bm + +needBuildInfo :: PackageDescription -> BuildInfo -> [ModuleName] -> Rebuild () +needBuildInfo pkg_descr bi modules = do + -- NB: These are separate because there may be both A.hs and + -- A.hs-boot; need to track both. + findNeededModules ["hs", "lhs", "hsig", "lhsig"] + findNeededModules ["hs-boot", "lhs-boot"] + mapM_ needIfExists (cSources bi ++ jsSources bi) + -- A MASSIVE HACK to (1) make sure we rebuild when header + -- files change, but (2) not have to rebuild when anything + -- in extra-src-files changes (most of these won't affect + -- compilation). It would be even better if we knew on a + -- per-component basis which headers would be used but that + -- seems to be too difficult. + mapM_ needIfExists (filter ((==".h").takeExtension) (extraSrcFiles pkg_descr)) + forM_ (installIncludes bi) $ \f -> + findFileMonitored ("." : includeDirs bi) f + >>= maybe (return ()) need + where + findNeededModules exts = + mapM_ (findNeededModule exts) + (modules ++ otherModules bi) + findNeededModule exts m = + findFileWithExtensionMonitored + (ppSuffixes knownSuffixHandlers ++ exts) + (hsSourceDirs bi) + (toFilePath m) + >>= maybe (return ()) need diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index a066e8a6780..319a7fb6439 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -324,6 +324,7 @@ executable cabal Distribution.Client.SrcDist Distribution.Client.SolverInstallPlan Distribution.Client.SolverPlanIndex + Distribution.Client.SourceFiles Distribution.Client.Tar Distribution.Client.Targets Distribution.Client.Types