diff --git a/src/Options/Applicative/Builder/Extra.hs b/src/Options/Applicative/Builder/Extra.hs index fc507068be..33444033ec 100644 --- a/src/Options/Applicative/Builder/Extra.hs +++ b/src/Options/Applicative/Builder/Extra.hs @@ -2,8 +2,10 @@ module Options.Applicative.Builder.Extra (boolFlags + ,boolFlagsNoDefault ,maybeBoolFlags ,enableDisableFlags + ,enableDisableFlagsNoDefault ,extraHelpOption ,execExtraHelp) where @@ -17,6 +19,10 @@ import System.FilePath (takeBaseName) boolFlags :: Bool -> String -> String -> Mod FlagFields Bool -> Parser Bool boolFlags defaultValue = enableDisableFlags defaultValue True False +-- | Enable/disable flags for a @Bool@, without a default case (to allow chaining @<|>@s). +boolFlagsNoDefault :: String -> String -> Mod FlagFields Bool -> Parser Bool +boolFlagsNoDefault = enableDisableFlagsNoDefault True False + -- | Enable/disable flags for a @(Maybe Bool)@. maybeBoolFlags :: String -> String -> Mod FlagFields (Maybe Bool) -> Parser (Maybe Bool) maybeBoolFlags = enableDisableFlags Nothing (Just True) (Just False) @@ -24,6 +30,12 @@ maybeBoolFlags = enableDisableFlags Nothing (Just True) (Just False) -- | Enable/disable flags for any type. enableDisableFlags :: a -> a -> a -> String -> String -> Mod FlagFields a -> Parser a enableDisableFlags defaultValue enabledValue disabledValue name helpSuffix mods = + enableDisableFlagsNoDefault enabledValue disabledValue name helpSuffix mods <|> + pure defaultValue + +-- | Enable/disable flags for any type, without a default (to allow chaining @<|>@s) +enableDisableFlagsNoDefault :: a -> a -> String -> String -> Mod FlagFields a -> Parser a +enableDisableFlagsNoDefault enabledValue disabledValue name helpSuffix mods = flag' enabledValue (long name <> help ("Enable " ++ helpSuffix) <> @@ -41,8 +53,7 @@ enableDisableFlags defaultValue enabledValue disabledValue name helpSuffix mods (internal <> long ("disable-" ++ name) <> help ("Disable " ++ helpSuffix) <> - mods) <|> - pure defaultValue + mods) -- | Show an extra help option (e.g. @--docker-help@ shows help for all @--docker*@ args). -- To actually show have that help appear, use 'execExtraHelp' before executing the main parser. diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index 42f7681f47..b9c1f91655 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -26,6 +26,7 @@ import Control.Monad.Trans.Resource import Data.Function import Data.Map.Strict (Map) import qualified Data.Map as Map +import Data.Maybe (fromMaybe) import Network.HTTP.Client.Conduit (HasHttpManager) import Path.IO import Prelude hiding (FilePath, writeFile) @@ -55,7 +56,12 @@ build bopts = do menv <- getMinimalEnvOverride (mbp, locals, extraToBuild, sourceMap) <- loadSourceMap bopts - (installedMap, locallyRegistered) <- getInstalled menv profiling sourceMap + (installedMap, locallyRegistered) <- + getInstalled menv + GetInstalledOpts + { getInstalledProfiling = profiling + , getInstalledHaddock = fromMaybe (boptsHaddock bopts) (boptsDepsHaddock bopts) } + sourceMap baseConfigOpts <- mkBaseConfigOpts bopts plan <- withLoadPackage menv $ \loadPackage -> diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index d0ab9880c2..7de2c88d00 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -89,6 +89,7 @@ data Ctx = Ctx , callStack :: ![PackageName] , extraToBuild :: !(Set PackageName) , latestVersions :: !(Map PackageName Version) + , wanted :: !(Set PackageName) } instance HasStackRoot Ctx @@ -161,6 +162,7 @@ constructPlan mbp0 baseConfigOpts0 locals extraToBuild0 locallyRegistered loadPa , callStack = [] , extraToBuild = extraToBuild0 , latestVersions = latest + , wanted = wantedLocalPackages locals } toolMap = getToolMap mbp0 @@ -197,7 +199,7 @@ addFinal lp = do allDeps True -- wanted Local - (packageFlags package) + package , taskPresent = present , taskType = TTLocal lp } @@ -239,7 +241,7 @@ addDep'' name = do installPackage name ps Just (PIBoth ps installed) -> do tellExecutables name ps - needInstall <- checkNeedInstall name ps installed + needInstall <- checkNeedInstall name ps installed (wanted ctx) if needInstall then installPackage name ps else return $ Right $ ADRFound (piiLocation ps) (piiVersion ps) installed @@ -290,7 +292,7 @@ installPackage name ps = do -- An assertion to check for a recurrence of -- https://github.com/commercialhaskell/stack/issues/345 (assert (destLoc == piiLocation ps) destLoc) - (packageFlags package) + package , taskPresent = present , taskType = case ps of @@ -298,14 +300,14 @@ installPackage name ps = do PSUpstream _ loc _ -> TTUpstream package $ loc <> minLoc } -checkNeedInstall :: PackageName -> PackageSource -> Installed -> M Bool -checkNeedInstall name ps installed = assert (piiLocation ps == Local) $ do +checkNeedInstall :: PackageName -> PackageSource -> Installed -> Set PackageName -> M Bool +checkNeedInstall name ps installed wanted = assert (piiLocation ps == Local) $ do package <- psPackage name ps depsRes <- addPackageDeps package case depsRes of Left _e -> return True -- installPackage will find the error again Right (missing, present, _loc) - | Set.null missing -> checkDirtiness ps installed package present + | Set.null missing -> checkDirtiness ps installed package present wanted | otherwise -> return True addPackageDeps :: Package -> M (Either ConstructPlanException (Set PackageIdentifier, Set GhcPkgId, Location)) @@ -345,28 +347,35 @@ checkDirtiness :: PackageSource -> Installed -> Package -> Set GhcPkgId + -> Set PackageName -> M Bool -checkDirtiness ps installed package present = do +checkDirtiness ps installed package present wanted = do ctx <- ask + moldOpts <- tryGetFlagCache installed let configOpts = configureOpts (getEnvConfig ctx) (baseConfigOpts ctx) present (psWanted ps) (piiLocation ps) -- should be Local always - (packageFlags package) - configCache = ConfigCache + package + buildOpts = bcoBuildOpts (baseConfigOpts ctx) + wantConfigCache = ConfigCache { configCacheOpts = map encodeUtf8 configOpts , configCacheDeps = present , configCacheComponents = case ps of PSLocal lp -> Set.map encodeUtf8 $ lpComponents lp PSUpstream _ _ _ -> Set.empty + , configCacheHaddock = + shouldBuildHaddock buildOpts wanted (packageName package) || + -- Disabling haddocks when old config had haddocks doesn't make dirty. + maybe False configCacheHaddock moldOpts } - moldOpts <- tryGetFlagCache installed case moldOpts of Nothing -> return True - Just oldOpts -> return $ oldOpts /= configCache || psDirty ps + Just oldOpts -> return $ oldOpts /= wantConfigCache || + psDirty ps psDirty :: PackageSource -> Bool psDirty (PSLocal lp) = lpDirtyFiles lp diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 532122d993..5626682e87 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -36,6 +36,7 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import qualified Data.Map.Strict as Map import Data.Maybe +import Data.Set (Set) import qualified Data.Set as Set import Data.Streaming.Process hiding (callProcess, env) import qualified Data.Streaming.Process as Process @@ -115,7 +116,6 @@ printPlan finalAction plan = do DoNothing -> Nothing DoBenchmarks -> Just "benchmark" DoTests -> Just "test" - DoHaddock -> Just "haddock" case mfinalLabel of Nothing -> return () Just finalLabel -> do @@ -174,6 +174,7 @@ data ExecuteEnv = ExecuteEnv , eeSetupHs :: !(Path Abs File) , eeCabalPkgVer :: !Version , eeTotalWanted :: !Int + , eeWanted :: !(Set PackageName) } -- | Perform the actual plan @@ -208,6 +209,7 @@ executePlan menv bopts baseConfigOpts locals plan = do , eeSetupHs = setupHs , eeCabalPkgVer = cabalPkgVer , eeTotalWanted = length $ filter lpWanted locals + , eeWanted = wantedLocalPackages locals } unless (Map.null $ planInstallExes plan) $ do @@ -372,7 +374,6 @@ toActions runInBase ee (mbuild, mfinal) = DoNothing -> Nothing DoTests -> Just (singleTest, checkTest) DoBenchmarks -> Just (singleBench, checkBench) - DoHaddock -> Just (singleHaddock, const True) checkTest task = case taskType task of @@ -419,6 +420,8 @@ ensureConfig pkgDir ExecuteEnv {..} Task {..} announce cabal cabalfp extra = do case taskType of TTLocal lp -> Set.map encodeUtf8 $ lpComponents lp TTUpstream _ _ -> Set.empty + , configCacheHaddock = + shouldBuildHaddock eeBuildOpts eeWanted (packageIdentifierName taskProvides) } let needConfig = mOldConfigCache /= Just newConfigCache @@ -593,6 +596,16 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} = TTLocal lp -> "build" : map T.unpack (Set.toList $ lpComponents lp) TTUpstream _ _ -> ["build"] + when (shouldBuildHaddock eeBuildOpts eeWanted (packageName package) && + packageHasLibrary package && + -- Works around haddock failing on bytestring-builder since it has no modules when + -- bytestring is new enough. + packageHasExposedModules package) $ do + announce "haddock" + hscolourExists <- doesExecutableExist eeEnvOverride "hscolour" + cabal False (concat [["haddock", "--html"] + ,["--hyperlink-source" | hscolourExists]]) + withMVar eeInstallLock $ \() -> do announce "install" cabal False ["install"] @@ -720,61 +733,6 @@ singleBench ac ee task = announce "benchmarks" cabal False ["bench"] -singleHaddock :: M env m - => ActionContext - -> ExecuteEnv - -> Task - -> m () -singleHaddock ac ee task = - withSingleContext ac ee task $ \_package _cabalfp _pkgDir cabal announce _console _mlogFile -> do - announce "haddock" - hscolourExists <- doesExecutableExist (eeEnvOverride ee) "hscolour" - {- EKB TODO: doc generation for stack-doc-server - #ifndef mingw32_HOST_OS - liftIO (removeDocLinks docLoc package) - #endif - ifcOpts <- liftIO (haddockInterfaceOpts docLoc package packages) - -} - cabal False (concat [["haddock", "--html"] - ,["--hyperlink-source" | hscolourExists]]) - {- EKB TODO: doc generation for stack-doc-server - ,"--hoogle" - ,"--html-location=../$pkg-$version/" - ,"--haddock-options=" ++ intercalate " " ifcOpts ] - haddockLocs <- - liftIO (findFiles (packageDocDir package) - (\loc -> FilePath.takeExtensions (toFilePath loc) == - "." ++ haddockExtension) - (not . isHiddenDir)) - forM_ haddockLocs $ \haddockLoc -> - do let hoogleTxtPath = FilePath.replaceExtension (toFilePath haddockLoc) "txt" - hoogleDbPath = FilePath.replaceExtension hoogleTxtPath hoogleDbExtension - hoogleExists <- liftIO (doesFileExist hoogleTxtPath) - when hoogleExists - (callProcess - "hoogle" - ["convert" - ,"--haddock" - ,hoogleTxtPath - ,hoogleDbPath]) - -} - {- EKB TODO: doc generation for stack-doc-server - #ifndef mingw32_HOST_OS - case setupAction of - DoHaddock -> liftIO (createDocLinks docLoc package) - _ -> return () - #endif - - -- | Package's documentation directory. - packageDocDir :: (MonadThrow m, MonadReader env m, HasPlatform env) - => PackageIdentifier -- ^ Cabal version - -> Package - -> m (Path Abs Dir) - packageDocDir cabalPkgVer package' = do - dist <- distDirFromDir cabalPkgVer (packageDir package') - return (dist $(mkRelDir "doc/")) - --} - -- | Grab all output from the given @Handle@ and print it to stdout, stripping -- Template Haskell "Loading package" lines. Does work in a separate thread. printBuildOutput :: (MonadIO m, MonadBaseControl IO m, MonadLogger m) diff --git a/src/Stack/Build/Installed.hs b/src/Stack/Build/Installed.hs index 59a2dcdbf3..7cb71b79f9 100644 --- a/src/Stack/Build/Installed.hs +++ b/src/Stack/Build/Installed.hs @@ -6,6 +6,7 @@ module Stack.Build.Installed ( InstalledMap , Installed (..) + , GetInstalledOpts (..) , getInstalled ) where @@ -49,33 +50,41 @@ data LoadHelper = LoadHelper type InstalledMap = Map PackageName (Version, Location, Installed) -- TODO Version is now redundant and can be gleaned from Installed +-- | Options for 'getInstalled'. +data GetInstalledOpts = GetInstalledOpts + { getInstalledProfiling :: !Bool + -- ^ Require profiling libraries? + , getInstalledHaddock :: !Bool + -- ^ Require haddocks? + } + -- | Returns the new InstalledMap and all of the locally registered packages. getInstalled :: (M env m, PackageInstallInfo pii) => EnvOverride - -> Bool -- ^ profiling? + -> GetInstalledOpts -> Map PackageName pii -- ^ does not contain any installed information -> m (InstalledMap, Set GhcPkgId) -getInstalled menv profiling sourceMap = do +getInstalled menv opts sourceMap = do snapDBPath <- packageDatabaseDeps localDBPath <- packageDatabaseLocal bconfig <- asks getBuildConfig - mpcache <- - if profiling - then liftM Just $ loadProfilingCache $ configProfilingCache bconfig + mcache <- + if getInstalledProfiling opts || getInstalledHaddock opts + then liftM Just $ loadInstalledCache $ configInstalledCache bconfig else return Nothing - let loadDatabase' = loadDatabase menv mpcache sourceMap + let loadDatabase' = loadDatabase menv opts mcache sourceMap (installedLibs', localInstalled) <- loadDatabase' Nothing [] >>= loadDatabase' (Just (Snap, snapDBPath)) . fst >>= loadDatabase' (Just (Local, localDBPath)) . fst let installedLibs = M.fromList $ map lhPair installedLibs' - case mpcache of + case mcache of Nothing -> return () - Just pcache -> saveProfilingCache (configProfilingCache bconfig) pcache + Just pcache -> saveInstalledCache (configInstalledCache bconfig) pcache -- Add in the executables that are installed, making sure to only trust a -- listed installation under the right circumstances (see below) @@ -108,12 +117,13 @@ getInstalled menv profiling sourceMap = do -- location needed by the SourceMap loadDatabase :: (M env m, PackageInstallInfo pii) => EnvOverride - -> Maybe ProfilingCache -- ^ if Just, profiling is required + -> GetInstalledOpts + -> Maybe InstalledCache -- ^ if Just, profiling or haddock is required -> Map PackageName pii -- ^ to determine which installed things we should include -> Maybe (Location, Path Abs Dir) -- ^ package database, Nothing for global -> [LoadHelper] -- ^ from parent databases -> m ([LoadHelper], Set GhcPkgId) -loadDatabase menv mpcache sourceMap mdb lhs0 = do +loadDatabase menv opts mcache sourceMap mdb lhs0 = do (lhs1, gids) <- ghcPkgDump menv (fmap snd mdb) $ conduitDumpPackage =$ sink let lhs = pruneDeps @@ -124,14 +134,21 @@ loadDatabase menv mpcache sourceMap mdb lhs0 = do (lhs0 ++ lhs1) return (map (\lh -> lh { lhDeps = [] }) $ Map.elems lhs, Set.fromList gids) where - conduitCache = - case mpcache of - Just pcache -> addProfiling pcache + conduitProfilingCache = + case mcache of + Just cache | getInstalledProfiling opts -> addProfiling cache -- Just an optimization to avoid calculating the profiling -- values when they aren't necessary - Nothing -> CL.map (\dp -> dp { dpProfiling = False }) - sinkDP = conduitCache - =$ CL.mapMaybe (isAllowed mpcache sourceMap (fmap fst mdb)) + _ -> CL.map (\dp -> dp { dpProfiling = False }) + conduitHaddockCache = + case mcache of + Just cache | getInstalledHaddock opts -> addHaddock cache + -- Just an optimization to avoid calculating the haddock + -- values when they aren't necessary + _ -> CL.map (\dp -> dp { dpHaddock = False }) + sinkDP = conduitProfilingCache + =$ conduitHaddockCache + =$ CL.mapMaybe (isAllowed opts mcache sourceMap (fmap fst mdb)) =$ CL.consume sinkGIDs = CL.map dpGhcPkgId =$ CL.consume sink = getZipSink $ (,) @@ -142,14 +159,17 @@ loadDatabase menv mpcache sourceMap mdb lhs0 = do -- on the package selections made by the user. This does not perform any -- dirtiness or flag change checks. isAllowed :: PackageInstallInfo pii - => Maybe ProfilingCache + => GetInstalledOpts + -> Maybe InstalledCache -> Map PackageName pii -> Maybe Location - -> DumpPackage Bool + -> DumpPackage Bool Bool -> Maybe LoadHelper -isAllowed mpcache sourceMap mloc dp +isAllowed opts mcache sourceMap mloc dp -- Check that it can do profiling if necessary - | isJust mpcache && not (dpProfiling dp) = Nothing + | getInstalledProfiling opts && isJust mcache && not (dpProfiling dp) = Nothing + -- Check that it has haddocks if necessary + | getInstalledHaddock opts && isJust mcache && not (dpHaddock dp) = Nothing | toInclude = Just LoadHelper { lhId = gid , lhDeps = diff --git a/src/Stack/Build/Types.hs b/src/Stack/Build/Types.hs index 4ce02a5038..eb93d1f903 100644 --- a/src/Stack/Build/Types.hs +++ b/src/Stack/Build/Types.hs @@ -27,7 +27,9 @@ module Stack.Build.Types ,ConfigCache(..) ,ConstructPlanException(..) ,configureOpts - ,BadDependency(..)) + ,BadDependency(..) + ,wantedLocalPackages + ,shouldBuildHaddock) where import Control.DeepSeq @@ -54,12 +56,12 @@ import Data.Time.Clock import Distribution.System (Arch) import Distribution.Text (display) import GHC.Generics -import Path (Path, Abs, File, Dir, mkRelDir, toFilePath, ()) -import Prelude hiding (FilePath) +import Path (Path, Abs, File, Dir, mkRelDir, toFilePath, parseRelDir, ()) +import Prelude import Stack.Package import Stack.Types import System.Exit (ExitCode) -import System.FilePath (pathSeparator) +import System.FilePath (dropTrailingPathSeparator, pathSeparator) ---------------------------------------------- -- Exceptions @@ -263,6 +265,10 @@ data BuildOpts = ,boptsLibProfile :: !Bool ,boptsExeProfile :: !Bool ,boptsEnableOptimizations :: !(Maybe Bool) + ,boptsHaddock :: !Bool + -- ^ Build haddocks? + ,boptsDepsHaddock :: !(Maybe Bool) + -- ^ Build haddocks for dependencies? ,boptsFinalAction :: !FinalAction ,boptsDryrun :: !Bool ,boptsGhcOptions :: ![Text] @@ -283,7 +289,6 @@ data BuildOpts = data FinalAction = DoTests | DoBenchmarks - | DoHaddock | DoNothing deriving (Eq,Bounded,Enum,Show) @@ -333,6 +338,8 @@ data ConfigCache = ConfigCache -- ^ The components to be built. It's a bit of a hack to include this in -- here, as it's not a configure option (just a build option), but this -- is a convenient way to force compilation when the components change. + , configCacheHaddock :: !Bool + -- ^ Are haddocks to be built? } deriving (Generic,Eq,Show) instance Binary ConfigCache @@ -393,19 +400,20 @@ configureOpts :: EnvConfig -> Set GhcPkgId -- ^ dependencies -> Bool -- ^ wanted? -> Location - -> Map FlagName Bool + -> Package -> [Text] -configureOpts econfig bco deps wanted loc flags = map T.pack $ concat +configureOpts econfig bco deps wanted loc package = map T.pack $ concat [ ["--user", "--package-db=clear", "--package-db=global"] , map (("--package-db=" ++) . toFilePath) $ case loc of Snap -> [bcoSnapDB bco] Local -> [bcoSnapDB bco, bcoLocalDB bco] , depOptions , [ "--libdir=" ++ toFilePathNoTrailingSlash (installRoot $(mkRelDir "lib")) - , "--bindir=" ++ toFilePathNoTrailingSlash (installRoot bindirSuffix) - , "--datadir=" ++ toFilePathNoTrailingSlash (installRoot $(mkRelDir "share")) - , "--docdir=" ++ toFilePathNoTrailingSlash (installRoot $(mkRelDir "doc")) - ] + , "--bindir=" ++ toFilePathNoTrailingSlash (installRoot bindirSuffix) + , "--datadir=" ++ toFilePathNoTrailingSlash (installRoot $(mkRelDir "share")) + , "--docdir=" ++ toFilePathNoTrailingSlash docDir + , "--htmldir=" ++ toFilePathNoTrailingSlash docDir + , "--haddockdir=" ++ toFilePathNoTrailingSlash docDir] , ["--enable-library-profiling" | boptsLibProfile bopts || boptsExeProfile bopts] , ["--enable-executable-profiling" | boptsExeProfile bopts] , map (\(name,enabled) -> @@ -414,7 +422,7 @@ configureOpts econfig bco deps wanted loc flags = map T.pack $ concat then "" else "-") <> flagNameString name) - (Map.toList flags) + (Map.toList (packageFlags package)) -- FIXME Chris: where does this come from now? , ["--ghc-options=-O2" | gconfigOptimize gconfig] , if wanted then concatMap (\x -> ["--ghc-options", T.unpack x]) (boptsGhcOptions bopts) @@ -425,18 +433,19 @@ configureOpts econfig bco deps wanted loc flags = map T.pack $ concat where config = getConfig econfig bopts = bcoBuildOpts bco - toFilePathNoTrailingSlash = - loop . toFilePath - where - loop [] = [] - loop [c] - | c == pathSeparator = [] - | otherwise = [c] - loop (c:cs) = c : loop cs + toFilePathNoTrailingSlash = dropTrailingPathSeparator . toFilePath + docDir = + case pkgVerDir of + Nothing -> installRoot $(mkRelDir "doc") + Just dir -> installRoot $(mkRelDir "doc") dir installRoot = case loc of Snap -> bcoSnapInstallRoot bco Local -> bcoLocalInstallRoot bco + pkgVerDir = + parseRelDir (packageIdentifierString (PackageIdentifier (packageName package) + (packageVersion package)) ++ + [pathSeparator]) depOptions = map toDepOption $ Set.toList deps where @@ -461,6 +470,17 @@ configureOpts econfig bco deps wanted loc flags = map T.pack $ concat where PackageIdentifier name version = ghcPkgIdPackageIdentifier gid +-- | Get set of wanted package names from locals. +wantedLocalPackages :: [LocalPackage] -> Set PackageName +wantedLocalPackages = Set.fromList . map (packageName . lpPackage) . filter lpWanted + +-- | Determine whether we should build haddocks for a package. +shouldBuildHaddock :: BuildOpts -> Set PackageName -> PackageName -> Bool +shouldBuildHaddock bopts wanted name = + if Set.member name wanted + then boptsHaddock bopts + else fromMaybe (boptsHaddock bopts) (boptsDepsHaddock bopts) + -- | Used for storage and comparison. newtype ModTime = ModTime (Integer,Rational) deriving (Ord,Show,Generic,Eq) diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index c2882c5e75..d99ba5032d 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -120,7 +120,8 @@ data Package = ,packageTests :: !(Set Text) -- ^ names of test suites ,packageBenchmarks :: !(Set Text) -- ^ names of benchmarks ,packageExes :: !(Set Text) -- ^ names of executables - ,packageOpts :: !GetPackageOpts -- ^ Args to pass to GHC. + ,packageOpts :: !GetPackageOpts -- ^ Args to pass to GHC. + ,packageHasExposedModules :: !Bool -- ^ Does the package have exposed modules? } deriving (Show,Typeable) @@ -243,6 +244,7 @@ resolvePackage packageConfig gpkg = Package , packageExes = S.fromList $ [ T.pack (exeName b) | b <- executables pkg, buildable (buildInfo b)] , packageOpts = GetPackageOpts $ \cabalfp -> generatePkgDescOpts cabalfp pkg + , packageHasExposedModules = maybe False (not . null . exposedModules) (library pkg) } where diff --git a/src/Stack/PackageDump.hs b/src/Stack/PackageDump.hs index cdbd374f65..63d55deb0a 100644 --- a/src/Stack/PackageDump.hs +++ b/src/Stack/PackageDump.hs @@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} module Stack.PackageDump ( Line , eachSection @@ -11,11 +12,13 @@ module Stack.PackageDump , DumpPackage (..) , conduitDumpPackage , ghcPkgDump - , ProfilingCache - , newProfilingCache - , loadProfilingCache - , saveProfilingCache + , InstalledCache + , InstalledCacheEntry (..) + , newInstalledCache + , loadInstalledCache + , saveInstalledCache , addProfiling + , addHaddock , sinkMatching , pruneDeps ) where @@ -26,6 +29,7 @@ import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Logger (MonadLogger) import Control.Monad.Trans.Control +import Data.Binary (Binary) import Data.Binary.VersionTagged (taggedDecodeOrLoad, taggedEncodeFile) import Data.ByteString (ByteString) import qualified Data.ByteString as S @@ -41,15 +45,23 @@ import qualified Data.Map as Map import Data.Maybe (catMaybes) import qualified Data.Set as Set import Data.Typeable (Typeable) +import GHC.Generics (Generic) import Path import Prelude -- Fix AMP warning import Stack.GhcPkg import Stack.Types -import System.Directory (createDirectoryIfMissing, getDirectoryContents) +import System.Directory (createDirectoryIfMissing, getDirectoryContents, doesFileExist) import System.Process.Read --- | Cached information on whether a package has profiling libraries -newtype ProfilingCache = ProfilingCache (IORef (Map GhcPkgId Bool)) +-- | Cached information on whether package have profiling libraries and haddocks. +newtype InstalledCache = InstalledCache (IORef (Map GhcPkgId InstalledCacheEntry)) + +-- | Cached information on whether a package has profiling libraries and haddocks. +data InstalledCacheEntry = InstalledCacheEntry + { installedCacheProfiling :: !Bool + , installedCacheHaddock :: !Bool } + deriving (Eq, Generic) +instance Binary InstalledCacheEntry -- | Call ghc-pkg dump with appropriate flags and stream to the given @Sink@, for a single database ghcPkgDump @@ -70,20 +82,20 @@ ghcPkgDump menv mpkgDb sink = do , ["dump", "--expand-pkgroot"] ] --- | Create a new, empty @ProfilingCache@ -newProfilingCache :: MonadIO m => m ProfilingCache -newProfilingCache = liftIO $ ProfilingCache <$> newIORef Map.empty +-- | Create a new, empty @InstalledCache@ +newInstalledCache :: MonadIO m => m InstalledCache +newInstalledCache = liftIO $ InstalledCache <$> newIORef Map.empty --- | Load a @ProfilingCache@ from disk, swallowing any errors and returning an +-- | Load a @InstalledCache@ from disk, swallowing any errors and returning an -- empty cache. -loadProfilingCache :: MonadIO m => Path Abs File -> m ProfilingCache -loadProfilingCache path = do +loadInstalledCache :: MonadIO m => Path Abs File -> m InstalledCache +loadInstalledCache path = do m <- taggedDecodeOrLoad (toFilePath path) (return Map.empty) - liftIO $ fmap ProfilingCache $ newIORef m + liftIO $ fmap InstalledCache $ newIORef m --- | Save a @ProfilingCache@ to disk -saveProfilingCache :: MonadIO m => Path Abs File -> ProfilingCache -> m () -saveProfilingCache path (ProfilingCache ref) = liftIO $ do +-- | Save a @InstalledCache@ to disk +saveInstalledCache :: MonadIO m => Path Abs File -> InstalledCache -> m () +saveInstalledCache path (InstalledCache ref) = liftIO $ do createDirectoryIfMissing True $ toFilePath $ parent path readIORef ref >>= taggedEncodeFile (toFilePath path) @@ -131,10 +143,15 @@ pruneDeps getName getId getDepends chooseBest = -- Packages not mentioned in the provided @Map@ are allowed to be present too. sinkMatching :: Monad m => Bool -- ^ require profiling? + -> Bool -- ^ require haddock? -> Map PackageName Version -- ^ allowed versions - -> Consumer (DumpPackage Bool) m (Map PackageName (DumpPackage Bool)) -sinkMatching reqProfiling allowed = do - dps <- CL.filter (\dp -> isAllowed (dpGhcPkgId dp) && (not reqProfiling || dpProfiling dp)) + -> Consumer (DumpPackage Bool Bool) + m + (Map PackageName (DumpPackage Bool Bool)) +sinkMatching reqProfiling reqHaddock allowed = do + dps <- CL.filter (\dp -> isAllowed (dpGhcPkgId dp) && + (not reqProfiling || dpProfiling dp) && + (not reqHaddock || dpHaddock dp)) =$= CL.consume return $ pruneDeps (packageIdentifierName . ghcPkgIdPackageIdentifier) @@ -152,16 +169,16 @@ sinkMatching reqProfiling allowed = do -- | Add profiling information to the stream of @DumpPackage@s addProfiling :: MonadIO m - => ProfilingCache - -> Conduit (DumpPackage a) m (DumpPackage Bool) -addProfiling (ProfilingCache ref) = + => InstalledCache + -> Conduit (DumpPackage a b) m (DumpPackage Bool b) +addProfiling (InstalledCache ref) = CL.mapM go where go dp = liftIO $ do m <- readIORef ref let gid = dpGhcPkgId dp p <- case Map.lookup gid m of - Just p -> return p + Just installed -> return (installedCacheProfiling installed) Nothing | null (dpLibraries dp) -> return True Nothing -> do let loop [] = return False @@ -184,13 +201,38 @@ isProfiling content lib = where prefix = S.concat ["lib", lib, "_p"] +-- | Add haddock information to the stream of @DumpPackage@s +addHaddock :: MonadIO m + => InstalledCache + -> Conduit (DumpPackage a b) m (DumpPackage a Bool) +addHaddock (InstalledCache ref) = + CL.mapM go + where + go dp = liftIO $ do + m <- readIORef ref + let gid = dpGhcPkgId dp + h <- case Map.lookup gid m of + Just installed -> return (installedCacheHaddock installed) + Nothing | null (dpLibraries dp) -> return True + Nothing -> do + let loop [] = return False + loop (ifc:ifcs) = do + exists <- doesFileExist (S8.unpack ifc) + if exists + then return True + else loop ifcs + loop $ dpHaddockInterfaces dp + return dp { dpHaddock = h } + -- | Dump information for a single package -data DumpPackage profiling = DumpPackage +data DumpPackage profiling haddock = DumpPackage { dpGhcPkgId :: !GhcPkgId , dpLibDirs :: ![ByteString] , dpLibraries :: ![ByteString] , dpDepends :: ![GhcPkgId] + , dpHaddockInterfaces :: ![ByteString] , dpProfiling :: !profiling + , dpHaddock :: !haddock } deriving (Show, Eq, Ord) @@ -214,7 +256,7 @@ instance Show PackageDumpException where -- | Convert a stream of bytes into a stream of @DumpPackage@s conduitDumpPackage :: MonadThrow m - => Conduit ByteString m (DumpPackage ()) + => Conduit ByteString m (DumpPackage () ()) conduitDumpPackage = (=$= CL.catMaybes) $ eachSection $ do pairs <- eachPair (\k -> (k, ) <$> CL.consume) =$= CL.consume let m = Map.fromList pairs @@ -253,6 +295,7 @@ conduitDumpPackage = (=$= CL.catMaybes) $ eachSection $ do -- if a package has no modules, these won't exist let libDirs = parseM "library-dirs" libraries = parseM "hs-libraries" + haddockInterfaces = parseM "haddock-interfaces" depends <- mapM parseDepend $ parseM "depends" return $ Just DumpPackage @@ -260,7 +303,9 @@ conduitDumpPackage = (=$= CL.catMaybes) $ eachSection $ do , dpLibDirs = libDirs , dpLibraries = S8.words $ S8.unwords libraries , dpDepends = catMaybes (depends :: [Maybe GhcPkgId]) + , dpHaddockInterfaces = S8.words $ S8.unwords haddockInterfaces , dpProfiling = () + , dpHaddock = () } stripPrefixBS :: ByteString -> ByteString -> Maybe ByteString diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 41de9cd9c1..e99a4fc89d 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -559,9 +559,9 @@ configProjectWorkDir = do bc <- asks getBuildConfig return (bcRoot bc workDirRel) --- | File containing the profiling cache, see "Stack.PackageDump" -configProfilingCache :: (HasBuildConfig env, MonadReader env m) => m (Path Abs File) -configProfilingCache = liftM ( $(mkRelFile "profiling-cache.bin")) configProjectWorkDir +-- | File containing the installed cache, see "Stack.PackageDump" +configInstalledCache :: (HasBuildConfig env, MonadReader env m) => m (Path Abs File) +configInstalledCache = liftM ( $(mkRelFile "installed-cache.bin")) configProjectWorkDir -- | Relative directory for the platform identifier platformRelDir :: (MonadReader env m, HasPlatform env, MonadThrow m) => m (Path Rel Dir) diff --git a/src/main/Main.hs b/src/main/Main.hs index ab5458692c..c9a448da77 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -76,23 +76,23 @@ main = (do addCommand "build" "Build the project(s) in this directory/configuration" (buildCmd DoNothing) - buildOpts + (buildOpts False) addCommand "install" "Build executables and install to a user path" installCmd - buildOpts + (buildOpts False) addCommand "test" "Build and test the project(s) in this directory/configuration" (buildCmd DoTests) - buildOpts + (buildOpts False) addCommand "bench" "Build and benchmark the project(s) in this directory/configuration" (buildCmd DoBenchmarks) - buildOpts + (buildOpts False) addCommand "haddock" "Generate haddocks for the project(s) in this directory/configuration" - (buildCmd DoHaddock) - buildOpts + (buildCmd DoNothing) + (buildOpts True) addCommand "new" "Create a brand new project" newCmd @@ -424,10 +424,10 @@ dockerExecCmd (cmd,args) go@GlobalOpts{..} = do (return (cmd,args,lcConfig lc)) -- | Parser for build arguments. -buildOpts :: Parser BuildOpts -buildOpts = +buildOpts :: Bool -> Parser BuildOpts +buildOpts defaultHaddock = BuildOpts <$> target <*> libProfiling <*> exeProfiling <*> - optimize <*> finalAction <*> dryRun <*> ghcOpts <*> flags <*> + optimize <*> localHaddock <*> depsHaddock <*> finalAction <*> dryRun <*> ghcOpts <*> flags <*> installExes <*> preFetch <*> testArgs <*> onlySnapshot where optimize = maybeBoolFlags "optimizations" "optimizations for TARGETs and all its dependencies" idm @@ -446,6 +446,16 @@ buildOpts = "executable-profiling" "library profiling for TARGETs and all its dependencies" idm + localHaddock = + boolFlags defaultHaddock + "haddock" + "building Haddocks" + idm + depsHaddock = + maybeBoolFlags + "deps-haddock" + "building Haddocks for dependencies" + idm finalAction = pure DoNothing installExes = pure False dryRun = flag False True (long "dry-run" <> diff --git a/src/test/Stack/PackageDumpSpec.hs b/src/test/Stack/PackageDumpSpec.hs index d1f1cf3375..2e36587f4d 100644 --- a/src/test/Stack/PackageDumpSpec.hs +++ b/src/test/Stack/PackageDumpSpec.hs @@ -76,7 +76,9 @@ spec = do , dpLibDirs = ["/opt/ghc/7.8.4/lib/ghc-7.8.4/haskell2010-1.1.2.0"] , dpDepends = depends , dpLibraries = ["HShaskell2010-1.1.2.0"] + , dpHaddockInterfaces = ["/opt/ghc/7.8.4/share/doc/ghc/html/libraries/haskell2010-1.1.2.0/haskell2010.haddock"] , dpProfiling = () + , dpHaddock = () } it "ghc 7.10" $ do @@ -104,28 +106,32 @@ spec = do haskell2010 `shouldBe` DumpPackage { dpGhcPkgId = ghcPkgId , dpLibDirs = ["/opt/ghc/7.10.1/lib/ghc-7.10.1/ghc_EMlWrQ42XY0BNVbSrKixqY"] + , dpHaddockInterfaces = ["/opt/ghc/7.10.1/share/doc/ghc/html/libraries/ghc-7.10.1/ghc.haddock"] , dpDepends = depends , dpLibraries = ["HSghc-7.10.1-EMlWrQ42XY0BNVbSrKixqY"] , dpProfiling = () + , dpHaddock = () } - it "ghcPkgDump + addProfiling" $ (id :: IO () -> IO ()) $ runNoLoggingT $ do + it "ghcPkgDump + addProfiling + addHaddock" $ (id :: IO () -> IO ()) $ runNoLoggingT $ do menv' <- getEnvOverride buildPlatform menv <- mkEnvOverride buildPlatform $ Map.delete "GHC_PACKAGE_PATH" $ unEnvOverride menv' - pcache <- newProfilingCache + icache <- newInstalledCache ghcPkgDump menv Nothing $ conduitDumpPackage - =$ addProfiling pcache + =$ addProfiling icache + =$ addHaddock icache =$ CL.sinkNull it "sinkMatching" $ do menv' <- getEnvOverride buildPlatform menv <- mkEnvOverride buildPlatform $ Map.delete "GHC_PACKAGE_PATH" $ unEnvOverride menv' - pcache <- newProfilingCache + icache <- newInstalledCache m <- runNoLoggingT $ ghcPkgDump menv Nothing $ conduitDumpPackage - =$ addProfiling pcache - =$ sinkMatching False (Map.singleton $(mkPackageName "transformers") $(mkVersion "0.0.0.0.0.0.1")) + =$ addProfiling icache + =$ addHaddock icache + =$ sinkMatching False False (Map.singleton $(mkPackageName "transformers") $(mkVersion "0.0.0.0.0.0.1")) case Map.lookup $(mkPackageName "base") m of Nothing -> error "base not present" Just _ -> return ()