1{-# LANGUAGE NoImplicitPrelude #-} 2{-# LANGUAGE FlexibleContexts #-} 3{-# LANGUAGE MultiParamTypeClasses #-} 4{-# LANGUAGE OverloadedStrings #-} 5{-# LANGUAGE RecordWildCards #-} 6{-# LANGUAGE ScopedTypeVariables #-} 7{-# LANGUAGE ConstraintKinds #-} 8-- Load information on package sources 9module Stack.Build.Source 10 ( projectLocalPackages 11 , localDependencies 12 , loadCommonPackage 13 , loadLocalPackage 14 , loadSourceMap 15 , getLocalFlags 16 , addUnlistedToBuildCache 17 , hashSourceMapData 18 ) where 19 20import Stack.Prelude 21import qualified Pantry.SHA256 as SHA256 22import Data.ByteString.Builder (toLazyByteString) 23import Conduit (ZipSink (..), withSourceFile) 24import qualified Distribution.PackageDescription as C 25import Data.List 26import qualified Data.Map as Map 27import qualified Data.Map.Strict as M 28import qualified Data.Set as Set 29import Stack.Build.Cache 30import Stack.Build.Haddock (shouldHaddockDeps) 31import Stack.Build.Target 32import Stack.Package 33import Stack.SourceMap 34import Stack.Types.Build 35import Stack.Types.Config 36import Stack.Types.NamedComponent 37import Stack.Types.Package 38import Stack.Types.SourceMap 39import System.FilePath (takeFileName) 40import System.IO.Error (isDoesNotExistError) 41 42-- | loads and returns project packages 43projectLocalPackages :: HasEnvConfig env 44 => RIO env [LocalPackage] 45projectLocalPackages = do 46 sm <- view $ envConfigL.to envConfigSourceMap 47 for (toList $ smProject sm) loadLocalPackage 48 49-- | loads all local dependencies - project packages and local extra-deps 50localDependencies :: HasEnvConfig env => RIO env [LocalPackage] 51localDependencies = do 52 bopts <- view $ configL.to configBuild 53 sourceMap <- view $ envConfigL . to envConfigSourceMap 54 forMaybeM (Map.elems $ smDeps sourceMap) $ \dp -> 55 case dpLocation dp of 56 PLMutable dir -> do 57 pp <- mkProjectPackage YesPrintWarnings dir (shouldHaddockDeps bopts) 58 Just <$> loadLocalPackage pp 59 _ -> return Nothing 60 61-- | Given the parsed targets and build command line options constructs 62-- a source map 63loadSourceMap :: HasBuildConfig env 64 => SMTargets 65 -> BuildOptsCLI 66 -> SMActual DumpedGlobalPackage 67 -> RIO env SourceMap 68loadSourceMap smt boptsCli sma = do 69 bconfig <- view buildConfigL 70 let compiler = smaCompiler sma 71 project = M.map applyOptsFlagsPP $ smaProject sma 72 bopts = configBuild (bcConfig bconfig) 73 applyOptsFlagsPP p@ProjectPackage{ppCommon = c} = 74 p{ppCommon = applyOptsFlags (M.member (cpName c) (smtTargets smt)) True c} 75 deps0 = smtDeps smt <> smaDeps sma 76 deps = M.map applyOptsFlagsDep deps0 77 applyOptsFlagsDep d@DepPackage{dpCommon = c} = 78 d{dpCommon = applyOptsFlags (M.member (cpName c) (smtDeps smt)) False c} 79 applyOptsFlags isTarget isProjectPackage common = 80 let name = cpName common 81 flags = getLocalFlags boptsCli name 82 ghcOptions = 83 generalGhcOptions bconfig boptsCli isTarget isProjectPackage 84 cabalConfigOpts = 85 loadCabalConfigOpts bconfig (cpName common) isTarget isProjectPackage 86 in common 87 { cpFlags = 88 if M.null flags 89 then cpFlags common 90 else flags 91 , cpGhcOptions = 92 ghcOptions ++ cpGhcOptions common 93 , cpCabalConfigOpts = 94 cabalConfigOpts ++ cpCabalConfigOpts common 95 , cpHaddocks = 96 if isTarget 97 then boptsHaddock bopts 98 else shouldHaddockDeps bopts 99 } 100 packageCliFlags = Map.fromList $ 101 mapMaybe maybeProjectFlags $ 102 Map.toList (boptsCLIFlags boptsCli) 103 maybeProjectFlags (ACFByName name, fs) = Just (name, fs) 104 maybeProjectFlags _ = Nothing 105 globals = pruneGlobals (smaGlobal sma) (Map.keysSet deps) 106 logDebug "Checking flags" 107 checkFlagsUsedThrowing packageCliFlags FSCommandLine project deps 108 logDebug "SourceMap constructed" 109 return 110 SourceMap 111 { smTargets = smt 112 , smCompiler = compiler 113 , smProject = project 114 , smDeps = deps 115 , smGlobal = globals 116 } 117 118-- | Get a 'SourceMapHash' for a given 'SourceMap' 119-- 120-- Basic rules: 121-- 122-- * If someone modifies a GHC installation in any way after Stack 123-- looks at it, they voided the warranty. This includes installing a 124-- brand new build to the same directory, or registering new 125-- packages to the global database. 126-- 127-- * We should include everything in the hash that would relate to 128-- immutable packages and identifying the compiler itself. Mutable 129-- packages (both project packages and dependencies) will never make 130-- it into the snapshot database, and can be ignored. 131-- 132-- * Target information is only relevant insofar as it effects the 133-- dependency map. The actual current targets for this build are 134-- irrelevant to the cache mechanism, and can be ignored. 135-- 136-- * Make sure things like profiling and haddocks are included in the hash 137-- 138hashSourceMapData 139 :: (HasBuildConfig env, HasCompiler env) 140 => BuildOptsCLI 141 -> SourceMap 142 -> RIO env SourceMapHash 143hashSourceMapData boptsCli sm = do 144 compilerPath <- getUtf8Builder . fromString . toFilePath <$> getCompilerPath 145 compilerInfo <- getCompilerInfo 146 immDeps <- forM (Map.elems (smDeps sm)) depPackageHashableContent 147 bc <- view buildConfigL 148 let -- extra bytestring specifying GHC options supposed to be applied to 149 -- GHC boot packages so we'll have differrent hashes when bare 150 -- resolver 'ghc-X.Y.Z' is used, no extra-deps and e.g. user wants builds 151 -- with profiling or without 152 bootGhcOpts = map display (generalGhcOptions bc boptsCli False False) 153 hashedContent = toLazyByteString $ compilerPath <> compilerInfo <> 154 getUtf8Builder (mconcat bootGhcOpts) <> mconcat immDeps 155 return $ SourceMapHash (SHA256.hashLazyBytes hashedContent) 156 157depPackageHashableContent :: (HasConfig env) => DepPackage -> RIO env Builder 158depPackageHashableContent DepPackage {..} = do 159 case dpLocation of 160 PLMutable _ -> return "" 161 PLImmutable pli -> do 162 let flagToBs (f, enabled) = 163 if enabled 164 then "" 165 else "-" <> fromString (C.unFlagName f) 166 flags = map flagToBs $ Map.toList (cpFlags dpCommon) 167 ghcOptions = map display (cpGhcOptions dpCommon) 168 cabalConfigOpts = map display (cpCabalConfigOpts dpCommon) 169 haddocks = if cpHaddocks dpCommon then "haddocks" else "" 170 hash = immutableLocSha pli 171 return $ hash <> haddocks <> getUtf8Builder (mconcat flags) <> 172 getUtf8Builder (mconcat ghcOptions) <> 173 getUtf8Builder (mconcat cabalConfigOpts) 174 175-- | All flags for a local package. 176getLocalFlags 177 :: BuildOptsCLI 178 -> PackageName 179 -> Map FlagName Bool 180getLocalFlags boptsCli name = Map.unions 181 [ Map.findWithDefault Map.empty (ACFByName name) cliFlags 182 , Map.findWithDefault Map.empty ACFAllProjectPackages cliFlags 183 ] 184 where 185 cliFlags = boptsCLIFlags boptsCli 186 187-- | Get the options to pass to @./Setup.hs configure@ 188loadCabalConfigOpts :: BuildConfig -> PackageName -> Bool -> Bool -> [Text] 189loadCabalConfigOpts bconfig name isTarget isLocal = concat 190 [ Map.findWithDefault [] CCKEverything (configCabalConfigOpts config) 191 , if isLocal 192 then Map.findWithDefault [] CCKLocals (configCabalConfigOpts config) 193 else [] 194 , if isTarget 195 then Map.findWithDefault [] CCKTargets (configCabalConfigOpts config) 196 else [] 197 , Map.findWithDefault [] (CCKPackage name) (configCabalConfigOpts config) 198 ] 199 where 200 config = view configL bconfig 201 202-- | Get the configured options to pass from GHC, based on the build 203-- configuration and commandline. 204generalGhcOptions :: BuildConfig -> BuildOptsCLI -> Bool -> Bool -> [Text] 205generalGhcOptions bconfig boptsCli isTarget isLocal = concat 206 [ Map.findWithDefault [] AGOEverything (configGhcOptionsByCat config) 207 , if isLocal 208 then Map.findWithDefault [] AGOLocals (configGhcOptionsByCat config) 209 else [] 210 , if isTarget 211 then Map.findWithDefault [] AGOTargets (configGhcOptionsByCat config) 212 else [] 213 , concat [["-fhpc"] | isLocal && toCoverage (boptsTestOpts bopts)] 214 , if boptsLibProfile bopts || boptsExeProfile bopts 215 then ["-fprof-auto","-fprof-cafs"] 216 else [] 217 , if not $ boptsLibStrip bopts || boptsExeStrip bopts 218 then ["-g"] 219 else [] 220 , if includeExtraOptions 221 then boptsCLIGhcOptions boptsCli 222 else [] 223 ] 224 where 225 bopts = configBuild config 226 config = view configL bconfig 227 includeExtraOptions = 228 case configApplyGhcOptions config of 229 AGOTargets -> isTarget 230 AGOLocals -> isLocal 231 AGOEverything -> True 232 233splitComponents :: [NamedComponent] 234 -> (Set Text, Set Text, Set Text) 235splitComponents = 236 go id id id 237 where 238 go a b c [] = (Set.fromList $ a [], Set.fromList $ b [], Set.fromList $ c []) 239 go a b c (CLib:xs) = go a b c xs 240 go a b c (CInternalLib x:xs) = go (a . (x:)) b c xs 241 go a b c (CExe x:xs) = go (a . (x:)) b c xs 242 go a b c (CTest x:xs) = go a (b . (x:)) c xs 243 go a b c (CBench x:xs) = go a b (c . (x:)) xs 244 245loadCommonPackage :: 246 forall env. (HasBuildConfig env, HasSourceMap env) 247 => CommonPackage 248 -> RIO env Package 249loadCommonPackage common = do 250 config <- getPackageConfig (cpFlags common) (cpGhcOptions common) (cpCabalConfigOpts common) 251 gpkg <- liftIO $ cpGPD common 252 return $ resolvePackage config gpkg 253 254-- | Upgrade the initial project package info to a full-blown @LocalPackage@ 255-- based on the selected components 256loadLocalPackage :: 257 forall env. (HasBuildConfig env, HasSourceMap env) 258 => ProjectPackage 259 -> RIO env LocalPackage 260loadLocalPackage pp = do 261 sm <- view sourceMapL 262 let common = ppCommon pp 263 bopts <- view buildOptsL 264 mcurator <- view $ buildConfigL.to bcCurator 265 config <- getPackageConfig (cpFlags common) (cpGhcOptions common) (cpCabalConfigOpts common) 266 gpkg <- ppGPD pp 267 let name = cpName common 268 mtarget = M.lookup name (smtTargets $ smTargets sm) 269 (exeCandidates, testCandidates, benchCandidates) = 270 case mtarget of 271 Just (TargetComps comps) -> splitComponents $ Set.toList comps 272 Just (TargetAll _packageType) -> 273 ( packageExes pkg 274 , if boptsTests bopts && maybe True (Set.notMember name . curatorSkipTest) mcurator 275 then Map.keysSet (packageTests pkg) 276 else Set.empty 277 , if boptsBenchmarks bopts && maybe True (Set.notMember name . curatorSkipBenchmark) mcurator 278 then packageBenchmarks pkg 279 else Set.empty 280 ) 281 Nothing -> mempty 282 283 -- See https://github.com/commercialhaskell/stack/issues/2862 284 isWanted = case mtarget of 285 Nothing -> False 286 -- FIXME: When issue #1406 ("stack 0.1.8 lost ability to 287 -- build individual executables or library") is resolved, 288 -- 'hasLibrary' is only relevant if the library is 289 -- part of the target spec. 290 Just _ -> 291 let hasLibrary = 292 case packageLibraries pkg of 293 NoLibraries -> False 294 HasLibraries _ -> True 295 in hasLibrary 296 || not (Set.null nonLibComponents) 297 || not (Set.null $ packageInternalLibraries pkg) 298 299 filterSkippedComponents = Set.filter (not . (`elem` boptsSkipComponents bopts)) 300 301 (exes, tests, benches) = (filterSkippedComponents exeCandidates, 302 filterSkippedComponents testCandidates, 303 filterSkippedComponents benchCandidates) 304 305 nonLibComponents = toComponents exes tests benches 306 307 toComponents e t b = Set.unions 308 [ Set.map CExe e 309 , Set.map CTest t 310 , Set.map CBench b 311 ] 312 313 btconfig = config 314 { packageConfigEnableTests = not $ Set.null tests 315 , packageConfigEnableBenchmarks = not $ Set.null benches 316 } 317 testconfig = config 318 { packageConfigEnableTests = True 319 , packageConfigEnableBenchmarks = False 320 } 321 benchconfig = config 322 { packageConfigEnableTests = False 323 , packageConfigEnableBenchmarks = True 324 } 325 326 -- We resolve the package in 4 different configurations: 327 -- 328 -- - pkg doesn't have tests or benchmarks enabled. 329 -- 330 -- - btpkg has them enabled if they are present. 331 -- 332 -- - testpkg has tests enabled, but not benchmarks. 333 -- 334 -- - benchpkg has benchmarks enablde, but not tests. 335 -- 336 -- The latter two configurations are used to compute the deps 337 -- when --enable-benchmarks or --enable-tests are configured. 338 -- This allows us to do an optimization where these are passed 339 -- if the deps are present. This can avoid doing later 340 -- unnecessary reconfigures. 341 pkg = resolvePackage config gpkg 342 btpkg 343 | Set.null tests && Set.null benches = Nothing 344 | otherwise = Just (resolvePackage btconfig gpkg) 345 testpkg = resolvePackage testconfig gpkg 346 benchpkg = resolvePackage benchconfig gpkg 347 348 componentFiles <- memoizeRefWith $ fst <$> getPackageFilesForTargets pkg (ppCabalFP pp) nonLibComponents 349 350 checkCacheResults <- memoizeRefWith $ do 351 componentFiles' <- runMemoizedWith componentFiles 352 forM (Map.toList componentFiles') $ \(component, files) -> do 353 mbuildCache <- tryGetBuildCache (ppRoot pp) component 354 checkCacheResult <- checkBuildCache 355 (fromMaybe Map.empty mbuildCache) 356 (Set.toList files) 357 return (component, checkCacheResult) 358 359 let dirtyFiles = do 360 checkCacheResults' <- checkCacheResults 361 let allDirtyFiles = Set.unions $ map (\(_, (x, _)) -> x) checkCacheResults' 362 pure $ 363 if not (Set.null allDirtyFiles) 364 then let tryStripPrefix y = 365 fromMaybe y (stripPrefix (toFilePath $ ppRoot pp) y) 366 in Just $ Set.map tryStripPrefix allDirtyFiles 367 else Nothing 368 newBuildCaches = 369 M.fromList . map (\(c, (_, cache)) -> (c, cache)) 370 <$> checkCacheResults 371 372 return LocalPackage 373 { lpPackage = pkg 374 , lpTestDeps = dvVersionRange <$> packageDeps testpkg 375 , lpBenchDeps = dvVersionRange <$> packageDeps benchpkg 376 , lpTestBench = btpkg 377 , lpComponentFiles = componentFiles 378 , lpBuildHaddocks = cpHaddocks (ppCommon pp) 379 , lpForceDirty = boptsForceDirty bopts 380 , lpDirtyFiles = dirtyFiles 381 , lpNewBuildCaches = newBuildCaches 382 , lpCabalFile = ppCabalFP pp 383 , lpWanted = isWanted 384 , lpComponents = nonLibComponents 385 -- TODO: refactor this so that it's easier to be sure that these 386 -- components are indeed unbuildable. 387 -- 388 -- The reasoning here is that if the STLocalComps specification 389 -- made it through component parsing, but the components aren't 390 -- present, then they must not be buildable. 391 , lpUnbuildable = toComponents 392 (exes `Set.difference` packageExes pkg) 393 (tests `Set.difference` Map.keysSet (packageTests pkg)) 394 (benches `Set.difference` packageBenchmarks pkg) 395 } 396 397-- | Compare the current filesystem state to the cached information, and 398-- determine (1) if the files are dirty, and (2) the new cache values. 399checkBuildCache :: forall m. (MonadIO m) 400 => Map FilePath FileCacheInfo -- ^ old cache 401 -> [Path Abs File] -- ^ files in package 402 -> m (Set FilePath, Map FilePath FileCacheInfo) 403checkBuildCache oldCache files = do 404 fileTimes <- liftM Map.fromList $ forM files $ \fp -> do 405 mdigest <- liftIO (getFileDigestMaybe (toFilePath fp)) 406 return (toFilePath fp, mdigest) 407 liftM (mconcat . Map.elems) $ sequence $ 408 Map.mergeWithKey 409 (\fp mdigest fci -> Just (go fp mdigest (Just fci))) 410 (Map.mapWithKey (\fp mdigest -> go fp mdigest Nothing)) 411 (Map.mapWithKey (\fp fci -> go fp Nothing (Just fci))) 412 fileTimes 413 oldCache 414 where 415 go :: FilePath -> Maybe SHA256 -> Maybe FileCacheInfo -> m (Set FilePath, Map FilePath FileCacheInfo) 416 -- Filter out the cabal_macros file to avoid spurious recompilations 417 go fp _ _ | takeFileName fp == "cabal_macros.h" = return (Set.empty, Map.empty) 418 -- Common case where it's in the cache and on the filesystem. 419 go fp (Just digest') (Just fci) 420 | fciHash fci == digest' = return (Set.empty, Map.singleton fp fci) 421 | otherwise = return (Set.singleton fp, Map.singleton fp $ FileCacheInfo digest') 422 -- Missing file. Add it to dirty files, but no FileCacheInfo. 423 go fp Nothing _ = return (Set.singleton fp, Map.empty) 424 -- Missing cache. Add it to dirty files and compute FileCacheInfo. 425 go fp (Just digest') Nothing = 426 return (Set.singleton fp, Map.singleton fp $ FileCacheInfo digest') 427 428-- | Returns entries to add to the build cache for any newly found unlisted modules 429addUnlistedToBuildCache 430 :: HasEnvConfig env 431 => Package 432 -> Path Abs File 433 -> Set NamedComponent 434 -> Map NamedComponent (Map FilePath a) 435 -> RIO env (Map NamedComponent [Map FilePath FileCacheInfo], [PackageWarning]) 436addUnlistedToBuildCache pkg cabalFP nonLibComponents buildCaches = do 437 (componentFiles, warnings) <- getPackageFilesForTargets pkg cabalFP nonLibComponents 438 results <- forM (M.toList componentFiles) $ \(component, files) -> do 439 let buildCache = M.findWithDefault M.empty component buildCaches 440 newFiles = 441 Set.toList $ 442 Set.map toFilePath files `Set.difference` Map.keysSet buildCache 443 addBuildCache <- mapM addFileToCache newFiles 444 return ((component, addBuildCache), warnings) 445 return (M.fromList (map fst results), concatMap snd results) 446 where 447 addFileToCache fp = do 448 mdigest <- getFileDigestMaybe fp 449 case mdigest of 450 Nothing -> return Map.empty 451 Just digest' -> return . Map.singleton fp $ FileCacheInfo digest' 452 453-- | Gets list of Paths for files relevant to a set of components in a package. 454-- Note that the library component, if any, is always automatically added to the 455-- set of components. 456getPackageFilesForTargets 457 :: HasEnvConfig env 458 => Package 459 -> Path Abs File 460 -> Set NamedComponent 461 -> RIO env (Map NamedComponent (Set (Path Abs File)), [PackageWarning]) 462getPackageFilesForTargets pkg cabalFP nonLibComponents = do 463 (components',compFiles,otherFiles,warnings) <- 464 getPackageFiles (packageFiles pkg) cabalFP 465 let necessaryComponents = Set.insert CLib $ Set.filter isCInternalLib (M.keysSet components') 466 components = necessaryComponents `Set.union` nonLibComponents 467 componentsFiles = 468 M.map (\files -> Set.union otherFiles (Set.map dotCabalGetPath $ Set.fromList files)) $ 469 M.filterWithKey (\component _ -> component `elem` components) compFiles 470 return (componentsFiles, warnings) 471 472-- | Get file digest, if it exists 473getFileDigestMaybe :: MonadIO m => FilePath -> m (Maybe SHA256) 474getFileDigestMaybe fp = do 475 liftIO 476 (catch 477 (liftM Just . withSourceFile fp $ getDigest) 478 (\e -> 479 if isDoesNotExistError e 480 then return Nothing 481 else throwM e)) 482 where 483 getDigest src = runConduit $ src .| getZipSink (ZipSink SHA256.sinkHash) 484 485-- | Get 'PackageConfig' for package given its name. 486getPackageConfig 487 :: (HasBuildConfig env, HasSourceMap env) 488 => Map FlagName Bool 489 -> [Text] -- ^ GHC options 490 -> [Text] -- ^ cabal config opts 491 -> RIO env PackageConfig 492getPackageConfig flags ghcOptions cabalConfigOpts = do 493 platform <- view platformL 494 compilerVersion <- view actualCompilerVersionL 495 return PackageConfig 496 { packageConfigEnableTests = False 497 , packageConfigEnableBenchmarks = False 498 , packageConfigFlags = flags 499 , packageConfigGhcOptions = ghcOptions 500 , packageConfigCabalConfigOpts = cabalConfigOpts 501 , packageConfigCompilerVersion = compilerVersion 502 , packageConfigPlatform = platform 503 } 504