From 11e02a8f9cddb6c24ee74648433e8706f25169a6 Mon Sep 17 00:00:00 2001 From: Emanuel Borsboom Date: Sat, 19 Sep 2015 17:39:31 -0700 Subject: [PATCH] Unlisted dependencies no longer trigger extraneous second build (#838) --- ChangeLog.md | 1 + src/Stack/Build/Execute.hs | 18 ++++++- src/Stack/Build/Source.hs | 96 +++++++++++++++++++++++---------- src/Stack/Package.hs | 108 +++++++++++++++++-------------------- src/Stack/Types/Package.hs | 28 +++++++++- 5 files changed, 162 insertions(+), 89 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 0a8755b8d6..ed0ae5cb63 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -33,6 +33,7 @@ Bug fixes: * Support for spaces in Haddock interface files [fpco/minghc#85](https://github.com/fpco/minghc/issues/85) * Temporarily building against a "shadowing" local package? [#992](https://github.com/commercialhaskell/stack/issues/992) * Fix Setup.exe name for --upgrade-cabal on Windows [#1002](https://github.com/commercialhaskell/stack/issues/1002) +* Unlisted dependencies no longer trigger extraneous second build [#838](https://github.com/commercialhaskell/stack/issues/838) ## 0.1.4.1 diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 29f06d733e..8b52953bc5 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -52,6 +52,7 @@ import qualified Data.Streaming.Process as Process import Data.Traversable (forM) import Data.Text (Text) import qualified Data.Text as T +import Data.Time.Clock (getCurrentTime) import Data.Word8 (_colon) import Distribution.System (OS (Windows), Platform (Platform)) @@ -928,6 +929,7 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in () <- announce "build" config <- asks getConfig extraOpts <- extraBuildOptions eeBuildOpts + preBuildTime <- modTime <$> liftIO getCurrentTime cabal (console && configHideTHLoading config) $ (case taskType of TTLocal lp -> concat @@ -947,12 +949,26 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in ] TTUpstream _ _ -> ["build"]) ++ extraOpts + case taskType of + TTLocal lp -> do + (addBuildCache,warnings) <- + addUnlistedToBuildCache + preBuildTime + (lpPackage lp) + (lpCabalFile lp) + (lpNewBuildCache lp) + mapM_ ($logWarn . ("Warning: " <>) . T.pack . show) warnings + unless (null addBuildCache) $ + writeBuildCache pkgDir $ + Map.unions (lpNewBuildCache lp : addBuildCache) + TTUpstream _ _ -> return () + when (doHaddock package) $ do announce "haddock" hscolourExists <- doesExecutableExist eeEnvOverride "HsColour" unless hscolourExists $ $logWarn ("Warning: haddock not generating hyperlinked sources because 'HsColour' not\n" <> - "found on PATH (use 'stack build hscolour --copy-bins' to install).") + "found on PATH (use 'stack install hscolour' to install).") cabal False (concat [["haddock", "--html", "--hoogle", "--html-location=../$pkg-$version/"] ,["--hyperlink-source" | hscolourExists] ,["--ghcjs" | wc == Ghcjs]]) diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index 3b1a5b6424..91f1853a10 100644 --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -14,6 +14,7 @@ module Stack.Build.Source , getLocalPackageViews , loadLocalPackage , parseTargetsFromBuildOpts + , addUnlistedToBuildCache ) where @@ -334,10 +335,7 @@ loadLocalPackage bopts targets (name, (lpv, gpkg)) = do testpkg = resolvePackage testconfig gpkg benchpkg = resolvePackage benchconfig gpkg mbuildCache <- tryGetBuildCache $ lpvRoot lpv - (_,compFiles,cabalFiles) <- getPackageFiles (packageFiles pkg) (lpvCabalFP lpv) - let files = - Set.map dotCabalGetPath (mconcat (M.elems compFiles)) <> - cabalFiles + (files,_) <- getPackageFilesSimple pkg (lpvCabalFP lpv) (isDirty, newBuildCache) <- checkBuildCache (fromMaybe Map.empty mbuildCache) (map toFilePath $ Set.toList files) @@ -480,27 +478,69 @@ checkBuildCache oldCache files = liftIO $ do return (True, newFci) return (Any isDirty, Map.singleton fp newFci) - getModTimeMaybe fp = - liftIO - (catch - (liftM - (Just . modTime) - (getModificationTime fp)) - (\e -> - if isDoesNotExistError e - then return Nothing - else throwM e)) - - calcFci modTime' fp = - withBinaryFile fp ReadMode $ \h -> do - (size, digest) <- CB.sourceHandle h $$ getZipSink - ((,) - <$> ZipSink (CL.fold - (\x y -> x + fromIntegral (S.length y)) - 0) - <*> ZipSink sinkHash) - return FileCacheInfo - { fciModTime = modTime' - , fciSize = size - , fciHash = toBytes (digest :: Digest SHA256) - } +-- | Returns entries to add to the build cache for any newly found unlisted modules +addUnlistedToBuildCache + :: (MonadIO m, MonadReader env m, MonadCatch m, MonadLogger m, HasEnvConfig env) + => ModTime + -> Package + -> Path Abs File + -> Map FilePath a + -> m ([Map FilePath FileCacheInfo], [PackageWarning]) +addUnlistedToBuildCache preBuildTime pkg cabalFP buildCache = do + (files,warnings) <- getPackageFilesSimple pkg cabalFP + let newFiles = + Set.toList $ + Set.map toFilePath files `Set.difference` Map.keysSet buildCache + addBuildCache <- mapM addFileToCache newFiles + return (addBuildCache, warnings) + where + addFileToCache fp = do + mmodTime <- getModTimeMaybe fp + case mmodTime of + Nothing -> return Map.empty + Just modTime' -> + if modTime' < preBuildTime + then do + newFci <- calcFci modTime' fp + return (Map.singleton fp newFci) + else return Map.empty + +-- | Gets list of Paths for files in a package +getPackageFilesSimple + :: (MonadIO m, MonadReader env m, MonadCatch m, MonadLogger m, HasEnvConfig env) + => Package -> Path Abs File -> m (Set (Path Abs File), [PackageWarning]) +getPackageFilesSimple pkg cabalFP = do + (_,compFiles,cabalFiles,warnings) <- + getPackageFiles (packageFiles pkg) cabalFP + return + ( Set.map dotCabalGetPath (mconcat (M.elems compFiles)) <> cabalFiles + , warnings) + +-- | Get file modification time, if it exists. +getModTimeMaybe :: MonadIO m => FilePath -> m (Maybe ModTime) +getModTimeMaybe fp = + liftIO + (catch + (liftM + (Just . modTime) + (getModificationTime fp)) + (\e -> + if isDoesNotExistError e + then return Nothing + else throwM e)) + +-- | Create FileCacheInfo for a file. +calcFci :: MonadIO m => ModTime -> FilePath -> m FileCacheInfo +calcFci modTime' fp = liftIO $ + withBinaryFile fp ReadMode $ \h -> do + (size, digest) <- CB.sourceHandle h $$ getZipSink + ((,) + <$> ZipSink (CL.fold + (\x y -> x + fromIntegral (S.length y)) + 0) + <*> ZipSink sinkHash) + return FileCacheInfo + { fciModTime = modTime' + , fciSize = size + , fciHash = toBytes (digest :: Digest SHA256) + } diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index 7ca1e67e89..db7ab6a58d 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -195,7 +195,7 @@ resolvePackage packageConfig gpkg = , buildable (buildInfo b)] , packageOpts = GetPackageOpts $ \sourceMap locals cabalfp -> - do (componentsModules,componentFiles,_) <- getPackageFiles pkgFiles cabalfp + do (componentsModules,componentFiles,_,_) <- getPackageFiles pkgFiles cabalfp (componentsOpts,generalOpts) <- generatePkgDescOpts sourceMap locals cabalfp pkg componentFiles return (componentsModules,componentFiles,componentsOpts,generalOpts) @@ -211,11 +211,11 @@ resolvePackage packageConfig gpkg = pkgFiles = GetPackageFiles $ \cabalfp -> do distDir <- distDirFromDir (parent cabalfp) - (componentModules,componentFiles,cabalFiles) <- + (componentModules,componentFiles,cabalFiles,warnings) <- runReaderT (packageDescModulesAndFiles pkg) (cabalfp, buildDir distDir) - return ( componentModules, componentFiles, cabalFiles) + return (componentModules, componentFiles, cabalFiles, warnings) pkgId = package (packageDescription gpkg) name = fromCabalPackageName (pkgName pkgId) pkg = resolvePackageDescription packageConfig gpkg @@ -454,44 +454,45 @@ allBuildInfo' pkg_descr = [ bi | Just lib <- [library pkg_descr] packageDescModulesAndFiles :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m, MonadCatch m) => PackageDescription - -> m (Map NamedComponent (Set ModuleName), Map NamedComponent (Set DotCabalPath), Set (Path Abs File)) + -> m (Map NamedComponent (Set ModuleName), Map NamedComponent (Set DotCabalPath), Set (Path Abs File), [PackageWarning]) packageDescModulesAndFiles pkg = do - (libraryMods,libDotCabalFiles) <- + (libraryMods,libDotCabalFiles,libWarnings) <- maybe - (return (M.empty, M.empty)) + (return (M.empty, M.empty, [])) (asModuleAndFileMap libComponent libraryFiles) (library pkg) - (executableMods,exeDotCabalFiles) <- + (executableMods,exeDotCabalFiles,exeWarnings) <- liftM - foldPairs + foldTuples (mapM (asModuleAndFileMap exeComponent executableFiles) (executables pkg)) - (testMods,testDotCabalFiles) <- + (testMods,testDotCabalFiles,testWarnings) <- liftM - foldPairs + foldTuples (mapM (asModuleAndFileMap testComponent testFiles) (testSuites pkg)) - (benchModules,benchDotCabalPaths) <- + (benchModules,benchDotCabalPaths,benchWarnings) <- liftM - foldPairs + foldTuples (mapM (asModuleAndFileMap benchComponent benchmarkFiles) (benchmarks pkg)) - dfiles <- resolveGlobFiles (map (dataDir pkg FilePath.) (dataFiles pkg)) + (dfiles) <- resolveGlobFiles (map (dataDir pkg FilePath.) (dataFiles pkg)) let modules = libraryMods <> executableMods <> testMods <> benchModules files = libDotCabalFiles <> exeDotCabalFiles <> testDotCabalFiles <> benchDotCabalPaths - return (modules, files, dfiles) + warnings = libWarnings <> exeWarnings <> testWarnings <> benchWarnings + return (modules, files, dfiles, warnings) where libComponent = const CLib exeComponent = CExe . T.pack . exeName testComponent = CTest . T.pack . testName benchComponent = CBench . T.pack . benchmarkName asModuleAndFileMap label f lib = do - (a,b) <- f lib - return (M.singleton (label lib) a, M.singleton (label lib) b) - foldPairs = foldl' (<>) (M.empty, M.empty) + (a,b,c) <- f lib + return (M.singleton (label lib) a, M.singleton (label lib) b, c) + foldTuples = foldl' (<>) (M.empty, M.empty, []) -- | Resolve globbing of files (e.g. data files) to absolute paths. resolveGlobFiles :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File, Path Abs Dir) m,MonadCatch m) @@ -556,19 +557,20 @@ matchDirFileGlob_ dir filepath = case parseFileGlob filepath of matches -> return matches -- | Get all files referenced by the benchmark. -benchmarkFiles :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m) - => Benchmark -> m (Set ModuleName,Set DotCabalPath) +benchmarkFiles + :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m) + => Benchmark -> m (Set ModuleName, Set DotCabalPath, [PackageWarning]) benchmarkFiles bench = do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) dir <- asks (parent . fst) - (modules,files) <- + (modules,files,warnings) <- resolveFilesAndDeps (Just $ benchmarkName bench) (dirs ++ [dir]) (bnames <> exposed) haskellModuleExts cfiles <- buildOtherSources build - return (modules, files <> cfiles) + return (modules, files <> cfiles, warnings) where exposed = case benchmarkInterface bench of @@ -581,18 +583,18 @@ benchmarkFiles bench = do testFiles :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m) => TestSuite - -> m (Set ModuleName, Set DotCabalPath) + -> m (Set ModuleName, Set DotCabalPath, [PackageWarning]) testFiles test = do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) dir <- asks (parent . fst) - (modules,files) <- + (modules,files,warnings) <- resolveFilesAndDeps (Just $ testName test) (dirs ++ [dir]) (bnames <> exposed) haskellModuleExts cfiles <- buildOtherSources build - return (modules, files <> cfiles) + return (modules, files <> cfiles, warnings) where exposed = case testInterface test of @@ -606,11 +608,11 @@ testFiles test = do executableFiles :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m) => Executable - -> m (Set ModuleName, Set DotCabalPath) + -> m (Set ModuleName, Set DotCabalPath, [PackageWarning]) executableFiles exe = do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) dir <- asks (parent . fst) - (modules,files) <- + (modules,files,warnings) <- resolveFilesAndDeps (Just $ exeName exe) (dirs ++ [dir]) @@ -618,24 +620,25 @@ executableFiles exe = do [DotCabalMain (modulePath exe)]) haskellModuleExts cfiles <- buildOtherSources build - return (modules, files <> cfiles) + return (modules, files <> cfiles, warnings) where build = buildInfo exe -- | Get all files referenced by the library. -libraryFiles :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File, Path Abs Dir) m) - => Library -> m (Set ModuleName,Set DotCabalPath) +libraryFiles + :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m) + => Library -> m (Set ModuleName, Set DotCabalPath, [PackageWarning]) libraryFiles lib = do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) dir <- asks (parent . fst) - (modules,files) <- + (modules,files,warnings) <- resolveFilesAndDeps Nothing (dirs ++ [dir]) (names <> exposed) haskellModuleExts cfiles <- buildOtherSources build - return (modules, files <> cfiles) + return (modules, files <> cfiles, warnings) where names = concat [bnames, exposed] exposed = map DotCabalModule (exposedModules lib) @@ -796,11 +799,11 @@ resolveFilesAndDeps -> [Path Abs Dir] -- ^ Directories to look in. -> [DotCabalDescriptor] -- ^ Base names. -> [Text] -- ^ Extentions. - -> m (Set ModuleName,Set DotCabalPath) + -> m (Set ModuleName,Set DotCabalPath,[PackageWarning]) resolveFilesAndDeps component dirs names0 exts = do (dotCabalPaths,foundModules) <- loop names0 S.empty - warnUnlisted component (mapMaybe dotCabalModule names0) foundModules - return (foundModules, dotCabalPaths) + warnings <- warnUnlisted foundModules + return (foundModules, dotCabalPaths, warnings) where loop [] doneModules = return (S.empty, doneModules) loop names doneModules0 = do @@ -821,31 +824,18 @@ resolveFilesAndDeps component dirs names0 exts = do (resolvedFiles <> map DotCabalFilePath thDepFiles)) resolvedFiles' , doneModules'') - --- | Warn about modules which are used but not listed in the cabal --- file. -warnUnlisted - :: (MonadLogger m, MonadReader (Path Abs File, void) m) - => Maybe String -> [ModuleName] -> Set ModuleName -> m () -warnUnlisted component names0 foundModules = do - cabalfp <- asks fst - unless (S.null unlistedModules) $ - $(logWarn) $ - T.pack $ - "Warning: " ++ - (if S.size unlistedModules == 1 - then "module" - else "modules") ++ - " not listed in " ++ - toFilePath (filename cabalfp) ++ - (case component of - Nothing -> " for library" - Just c -> " for '" ++ c ++ "'") ++ - " component (add to other-modules):\n " ++ - intercalate "\n " (map display (S.toList unlistedModules)) - where - unlistedModules = - foundModules `S.difference` (S.fromList names0) + warnUnlisted foundModules = do + let unlistedModules = + foundModules `S.difference` + (S.fromList $ mapMaybe dotCabalModule names0) + cabalfp <- asks fst + return $ + if S.null unlistedModules + then [] + else [ UnlistedModulesWarning + cabalfp + component + (S.toList unlistedModules)] -- | Get the dependencies of a Haskell module file. getDependencies diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs index a52b26e7da..0f557401e4 100644 --- a/src/Stack/Types/Package.hs +++ b/src/Stack/Types/Package.hs @@ -29,6 +29,7 @@ import Distribution.InstalledPackageInfo (PError) import Distribution.ModuleName (ModuleName) import Distribution.Package hiding (Package,PackageName,packageName,packageVersion,PackageIdentifier) import Distribution.System (Platform (..)) +import Distribution.Text (display) import GHC.Generics import Path as FL import Prelude @@ -118,11 +119,36 @@ newtype GetPackageFiles = GetPackageFiles => Path Abs File -> m (Map NamedComponent (Set ModuleName) ,Map NamedComponent (Set DotCabalPath) - ,Set (Path Abs File)) + ,Set (Path Abs File) + ,[PackageWarning]) } instance Show GetPackageFiles where show _ = "" +-- | Warning generated when reading a package +data PackageWarning + = UnlistedModulesWarning (Path Abs File) (Maybe String) [ModuleName] + -- ^ Modules found that are not listed in cabal file +instance Show PackageWarning where + show (UnlistedModulesWarning cabalfp component [unlistedModule]) = + concat + [ "module not listed in " + , toFilePath (filename cabalfp) + , (case component of + Nothing -> " for library" + Just c -> " for '" ++ c ++ "'") + , " component (add to other-modules): " + , display unlistedModule] + show (UnlistedModulesWarning cabalfp component unlistedModules) = + concat + [ "modules not listed in " + , toFilePath (filename cabalfp) + , (case component of + Nothing -> " for library" + Just c -> " for '" ++ c ++ "'") + , " component (add to other-modules):\n " + , intercalate "\n " (map display unlistedModules)] + -- | Package build configuration data PackageConfig = PackageConfig {packageConfigEnableTests :: !Bool -- ^ Are tests enabled?