1{-# LANGUAGE NoImplicitPrelude #-} 2{-# LANGUAGE ConstraintKinds #-} 3{-# LANGUAGE DataKinds #-} 4{-# LANGUAGE DeriveDataTypeable #-} 5{-# LANGUAGE FlexibleContexts #-} 6{-# LANGUAGE GADTs #-} 7{-# LANGUAGE OverloadedStrings #-} 8{-# LANGUAGE ScopedTypeVariables #-} 9 10-- | Resolving a build plan for a set of packages in a given Stackage 11-- snapshot. 12 13module Stack.BuildPlan 14 ( BuildPlanException (..) 15 , BuildPlanCheck (..) 16 , checkSnapBuildPlan 17 , DepError(..) 18 , DepErrors 19 , removeSrcPkgDefaultFlags 20 , selectBestSnapshot 21 , showItems 22 ) where 23 24import Stack.Prelude hiding (Display (..)) 25import qualified Data.Foldable as F 26import qualified Data.Set as Set 27import Data.List (intercalate) 28import qualified Data.List.NonEmpty as NonEmpty 29import qualified Data.Map as Map 30import qualified Data.Text as T 31import qualified Distribution.Package as C 32import Distribution.PackageDescription (GenericPackageDescription, 33 flagDefault, flagManual, 34 flagName, genPackageFlags) 35import qualified Distribution.PackageDescription as C 36import Distribution.System (Platform) 37import Distribution.Text (display) 38import Distribution.Types.UnqualComponentName (unUnqualComponentName) 39import qualified Distribution.Version as C 40import qualified RIO 41import Stack.Constants 42import Stack.Package 43import Stack.SourceMap 44import Stack.Types.SourceMap 45import Stack.Types.Version 46import Stack.Types.Config 47import Stack.Types.Compiler 48 49data BuildPlanException 50 = UnknownPackages 51 (Path Abs File) -- stack.yaml file 52 (Map PackageName (Maybe Version, Set PackageName)) -- truly unknown 53 (Map PackageName (Set PackageIdentifier)) -- shadowed 54 | SnapshotNotFound SnapName 55 | NeitherCompilerOrResolverSpecified T.Text 56 deriving (Typeable) 57instance Exception BuildPlanException 58instance Show BuildPlanException where 59 show (SnapshotNotFound snapName) = unlines 60 [ "SnapshotNotFound " ++ snapName' 61 , "Non existing resolver: " ++ snapName' ++ "." 62 , "For a complete list of available snapshots see https://www.stackage.org/snapshots" 63 ] 64 where snapName' = show snapName 65 show (UnknownPackages stackYaml unknown shadowed) = 66 unlines $ unknown' ++ shadowed' 67 where 68 unknown' :: [String] 69 unknown' 70 | Map.null unknown = [] 71 | otherwise = concat 72 [ ["The following packages do not exist in the build plan:"] 73 , map go (Map.toList unknown) 74 , case mapMaybe goRecommend $ Map.toList unknown of 75 [] -> [] 76 rec -> 77 ("Recommended action: modify the extra-deps field of " ++ 78 toFilePath stackYaml ++ 79 " to include the following:") 80 : (rec 81 ++ ["Note: further dependencies may need to be added"]) 82 , case mapMaybe getNoKnown $ Map.toList unknown of 83 [] -> [] 84 noKnown -> 85 [ "There are no known versions of the following packages:" 86 , intercalate ", " $ map packageNameString noKnown 87 ] 88 ] 89 where 90 go (dep, (_, users)) | Set.null users = packageNameString dep 91 go (dep, (_, users)) = concat 92 [ packageNameString dep 93 , " (used by " 94 , intercalate ", " $ map packageNameString $ Set.toList users 95 , ")" 96 ] 97 98 goRecommend (name, (Just version, _)) = 99 Just $ "- " ++ packageIdentifierString (PackageIdentifier name version) 100 goRecommend (_, (Nothing, _)) = Nothing 101 102 getNoKnown (name, (Nothing, _)) = Just name 103 getNoKnown (_, (Just _, _)) = Nothing 104 105 shadowed' :: [String] 106 shadowed' 107 | Map.null shadowed = [] 108 | otherwise = concat 109 [ ["The following packages are shadowed by local packages:"] 110 , map go (Map.toList shadowed) 111 , ["Recommended action: modify the extra-deps field of " ++ 112 toFilePath stackYaml ++ 113 " to include the following:"] 114 , extraDeps 115 , ["Note: further dependencies may need to be added"] 116 ] 117 where 118 go (dep, users) | Set.null users = packageNameString dep ++ " (internal stack error: this should never be null)" 119 go (dep, users) = concat 120 [ packageNameString dep 121 , " (used by " 122 , intercalate ", " 123 $ map (packageNameString . pkgName) 124 $ Set.toList users 125 , ")" 126 ] 127 128 extraDeps = map (\ident -> "- " ++ packageIdentifierString ident) 129 $ Set.toList 130 $ Set.unions 131 $ Map.elems shadowed 132 show (NeitherCompilerOrResolverSpecified url) = 133 "Failed to load custom snapshot at " ++ 134 T.unpack url ++ 135 ", because no 'compiler' or 'resolver' is specified." 136 137gpdPackages :: [GenericPackageDescription] -> Map PackageName Version 138gpdPackages = Map.fromList . map (toPair . C.package . C.packageDescription) 139 where 140 toPair (C.PackageIdentifier name version) = (name, version) 141 142gpdPackageDeps 143 :: GenericPackageDescription 144 -> ActualCompiler 145 -> Platform 146 -> Map FlagName Bool 147 -> Map PackageName VersionRange 148gpdPackageDeps gpd ac platform flags = 149 Map.filterWithKey (const . not . isLocalLibrary) (packageDependencies pkgConfig pkgDesc) 150 where 151 isLocalLibrary name' = name' == name || name' `Set.member` subs 152 153 name = gpdPackageName gpd 154 subs = Set.fromList 155 $ map (C.mkPackageName . unUnqualComponentName . fst) 156 $ C.condSubLibraries gpd 157 158 -- Since tests and benchmarks are both enabled, doesn't matter 159 -- if we choose modified or unmodified 160 pkgDesc = pdpModifiedBuildable $ resolvePackageDescription pkgConfig gpd 161 pkgConfig = PackageConfig 162 { packageConfigEnableTests = True 163 , packageConfigEnableBenchmarks = True 164 , packageConfigFlags = flags 165 , packageConfigGhcOptions = [] 166 , packageConfigCabalConfigOpts = [] 167 , packageConfigCompilerVersion = ac 168 , packageConfigPlatform = platform 169 } 170 171-- Remove any src package flags having default values 172-- Remove any package entries with no flags set 173removeSrcPkgDefaultFlags :: [C.GenericPackageDescription] 174 -> Map PackageName (Map FlagName Bool) 175 -> Map PackageName (Map FlagName Bool) 176removeSrcPkgDefaultFlags gpds flags = 177 let defaults = Map.unions (map gpdDefaultFlags gpds) 178 flags' = Map.differenceWith removeSame flags defaults 179 in Map.filter (not . Map.null) flags' 180 where 181 removeSame f1 f2 = 182 let diff v v' = if v == v' then Nothing else Just v 183 in Just $ Map.differenceWith diff f1 f2 184 185 gpdDefaultFlags gpd = 186 let tuples = map getDefault (C.genPackageFlags gpd) 187 in Map.singleton (gpdPackageName gpd) (Map.fromList tuples) 188 189 getDefault f 190 | C.flagDefault f = (C.flagName f, True) 191 | otherwise = (C.flagName f, False) 192 193-- | Find the set of @FlagName@s necessary to get the given 194-- @GenericPackageDescription@ to compile against the given @BuildPlan@. Will 195-- only modify non-manual flags, and will prefer default values for flags. 196-- Returns the plan which produces least number of dep errors 197selectPackageBuildPlan 198 :: Platform 199 -> ActualCompiler 200 -> Map PackageName Version 201 -> GenericPackageDescription 202 -> (Map PackageName (Map FlagName Bool), DepErrors) 203selectPackageBuildPlan platform compiler pool gpd = 204 (selectPlan . limitSearchSpace . NonEmpty.map makePlan) flagCombinations 205 where 206 selectPlan :: NonEmpty (a, DepErrors) -> (a, DepErrors) 207 selectPlan = F.foldr1 fewerErrors 208 where 209 fewerErrors p1 p2 210 | nErrors p1 == 0 = p1 211 | nErrors p1 <= nErrors p2 = p1 212 | otherwise = p2 213 where nErrors = Map.size . snd 214 215 -- Avoid exponential complexity in flag combinations making us sad pandas. 216 -- See: https://github.com/commercialhaskell/stack/issues/543 217 limitSearchSpace :: NonEmpty a -> NonEmpty a 218 limitSearchSpace (x :| xs) = x :| take (maxFlagCombinations - 1) xs 219 where maxFlagCombinations = 128 220 221 makePlan :: [(FlagName, Bool)] -> (Map PackageName (Map FlagName Bool), DepErrors) 222 makePlan flags = checkPackageBuildPlan platform compiler pool (Map.fromList flags) gpd 223 224 flagCombinations :: NonEmpty [(FlagName, Bool)] 225 flagCombinations = mapM getOptions (genPackageFlags gpd) 226 where 227 getOptions :: C.Flag -> NonEmpty (FlagName, Bool) 228 getOptions f 229 | flagManual f = (fname, flagDefault f) :| [] 230 | flagDefault f = (fname, True) :| [(fname, False)] 231 | otherwise = (fname, False) :| [(fname, True)] 232 where fname = flagName f 233 234-- | Check whether with the given set of flags a package's dependency 235-- constraints can be satisfied against a given build plan or pool of packages. 236checkPackageBuildPlan 237 :: Platform 238 -> ActualCompiler 239 -> Map PackageName Version 240 -> Map FlagName Bool 241 -> GenericPackageDescription 242 -> (Map PackageName (Map FlagName Bool), DepErrors) 243checkPackageBuildPlan platform compiler pool flags gpd = 244 (Map.singleton pkg flags, errs) 245 where 246 pkg = gpdPackageName gpd 247 errs = checkPackageDeps pkg constraints pool 248 constraints = gpdPackageDeps gpd compiler platform flags 249 250-- | Checks if the given package dependencies can be satisfied by the given set 251-- of packages. Will fail if a package is either missing or has a version 252-- outside of the version range. 253checkPackageDeps 254 :: PackageName -- ^ package using dependencies, for constructing DepErrors 255 -> Map PackageName VersionRange -- ^ dependency constraints 256 -> Map PackageName Version -- ^ Available package pool or index 257 -> DepErrors 258checkPackageDeps myName deps packages = 259 Map.unionsWith combineDepError $ map go $ Map.toList deps 260 where 261 go :: (PackageName, VersionRange) -> DepErrors 262 go (name, range) = 263 case Map.lookup name packages of 264 Nothing -> Map.singleton name DepError 265 { deVersion = Nothing 266 , deNeededBy = Map.singleton myName range 267 } 268 Just v 269 | withinRange v range -> Map.empty 270 | otherwise -> Map.singleton name DepError 271 { deVersion = Just v 272 , deNeededBy = Map.singleton myName range 273 } 274 275type DepErrors = Map PackageName DepError 276data DepError = DepError 277 { deVersion :: !(Maybe Version) 278 , deNeededBy :: !(Map PackageName VersionRange) 279 } deriving Show 280 281-- | Combine two 'DepError's for the same 'Version'. 282combineDepError :: DepError -> DepError -> DepError 283combineDepError (DepError a x) (DepError b y) = 284 assert (a == b) $ DepError a (Map.unionWith C.intersectVersionRanges x y) 285 286-- | Given a bundle of packages (a list of @GenericPackageDescriptions@'s) to 287-- build and an available package pool (snapshot) check whether the bundle's 288-- dependencies can be satisfied. If flags is passed as Nothing flag settings 289-- will be chosen automatically. 290checkBundleBuildPlan 291 :: Platform 292 -> ActualCompiler 293 -> Map PackageName Version 294 -> Maybe (Map PackageName (Map FlagName Bool)) 295 -> [GenericPackageDescription] 296 -> (Map PackageName (Map FlagName Bool), DepErrors) 297checkBundleBuildPlan platform compiler pool flags gpds = 298 (Map.unionsWith dupError (map fst plans) 299 , Map.unionsWith combineDepError (map snd plans)) 300 301 where 302 plans = map (pkgPlan flags) gpds 303 pkgPlan Nothing gpd = 304 selectPackageBuildPlan platform compiler pool' gpd 305 pkgPlan (Just f) gpd = 306 checkPackageBuildPlan platform compiler pool' (flags' f gpd) gpd 307 flags' f gpd = fromMaybe Map.empty (Map.lookup (gpdPackageName gpd) f) 308 pool' = Map.union (gpdPackages gpds) pool 309 310 dupError _ _ = error "Bug: Duplicate packages are not expected here" 311 312data BuildPlanCheck = 313 BuildPlanCheckOk (Map PackageName (Map FlagName Bool)) 314 | BuildPlanCheckPartial (Map PackageName (Map FlagName Bool)) DepErrors 315 | BuildPlanCheckFail (Map PackageName (Map FlagName Bool)) DepErrors 316 ActualCompiler 317 318-- | Compare 'BuildPlanCheck', where GT means a better plan. 319compareBuildPlanCheck :: BuildPlanCheck -> BuildPlanCheck -> Ordering 320compareBuildPlanCheck (BuildPlanCheckPartial _ e1) (BuildPlanCheckPartial _ e2) = 321 -- Note: order of comparison flipped, since it's better to have fewer errors. 322 compare (Map.size e2) (Map.size e1) 323compareBuildPlanCheck (BuildPlanCheckFail _ e1 _) (BuildPlanCheckFail _ e2 _) = 324 let numUserPkgs e = Map.size $ Map.unions (Map.elems (fmap deNeededBy e)) 325 in compare (numUserPkgs e2) (numUserPkgs e1) 326compareBuildPlanCheck BuildPlanCheckOk{} BuildPlanCheckOk{} = EQ 327compareBuildPlanCheck BuildPlanCheckOk{} BuildPlanCheckPartial{} = GT 328compareBuildPlanCheck BuildPlanCheckOk{} BuildPlanCheckFail{} = GT 329compareBuildPlanCheck BuildPlanCheckPartial{} BuildPlanCheckFail{} = GT 330compareBuildPlanCheck _ _ = LT 331 332instance Show BuildPlanCheck where 333 show BuildPlanCheckOk {} = "" 334 show (BuildPlanCheckPartial f e) = T.unpack $ showDepErrors f e 335 show (BuildPlanCheckFail f e c) = T.unpack $ showCompilerErrors f e c 336 337-- | Check a set of 'GenericPackageDescription's and a set of flags against a 338-- given snapshot. Returns how well the snapshot satisfies the dependencies of 339-- the packages. 340checkSnapBuildPlan 341 :: (HasConfig env, HasGHCVariant env) 342 => [ResolvedPath Dir] 343 -> Maybe (Map PackageName (Map FlagName Bool)) 344 -> SnapshotCandidate env 345 -> RIO env BuildPlanCheck 346checkSnapBuildPlan pkgDirs flags snapCandidate = do 347 platform <- view platformL 348 sma <- snapCandidate pkgDirs 349 gpds <- liftIO $ forM (Map.elems $ smaProject sma) (cpGPD . ppCommon) 350 351 let 352 compiler = smaCompiler sma 353 globalVersion (GlobalPackageVersion v) = v 354 depVersion dep | PLImmutable loc <- dpLocation dep = 355 Just $ packageLocationVersion loc 356 | otherwise = 357 Nothing 358 snapPkgs = Map.union 359 (Map.mapMaybe depVersion $ smaDeps sma) 360 (Map.map globalVersion $ smaGlobal sma) 361 (f, errs) = checkBundleBuildPlan platform compiler snapPkgs flags gpds 362 cerrs = compilerErrors compiler errs 363 364 if Map.null errs then 365 return $ BuildPlanCheckOk f 366 else if Map.null cerrs then do 367 return $ BuildPlanCheckPartial f errs 368 else 369 return $ BuildPlanCheckFail f cerrs compiler 370 where 371 compilerErrors compiler errs 372 | whichCompiler compiler == Ghc = ghcErrors errs 373 | otherwise = Map.empty 374 375 isGhcWiredIn p _ = p `Set.member` wiredInPackages 376 ghcErrors = Map.filterWithKey isGhcWiredIn 377 378-- | Find a snapshot and set of flags that is compatible with and matches as 379-- best as possible with the given 'GenericPackageDescription's. 380selectBestSnapshot 381 :: (HasConfig env, HasGHCVariant env) 382 => [ResolvedPath Dir] 383 -> NonEmpty SnapName 384 -> RIO env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck) 385selectBestSnapshot pkgDirs snaps = do 386 logInfo $ "Selecting the best among " 387 <> displayShow (NonEmpty.length snaps) 388 <> " snapshots...\n" 389 F.foldr1 go (NonEmpty.map (getResult <=< snapshotLocation) snaps) 390 where 391 go mold mnew = do 392 old@(_snap, _loc, bpc) <- mold 393 case bpc of 394 BuildPlanCheckOk {} -> return old 395 _ -> fmap (betterSnap old) mnew 396 397 getResult loc = do 398 candidate <- loadProjectSnapshotCandidate loc NoPrintWarnings False 399 result <- checkSnapBuildPlan pkgDirs Nothing candidate 400 reportResult result loc 401 return (candidate, loc, result) 402 403 betterSnap (s1, l1, r1) (s2, l2, r2) 404 | compareBuildPlanCheck r1 r2 /= LT = (s1, l1, r1) 405 | otherwise = (s2, l2, r2) 406 407 reportResult BuildPlanCheckOk {} loc = do 408 logInfo $ "* Matches " <> RIO.display loc 409 logInfo "" 410 411 reportResult r@BuildPlanCheckPartial {} loc = do 412 logWarn $ "* Partially matches " <> RIO.display loc 413 logWarn $ RIO.display $ indent $ T.pack $ show r 414 415 reportResult r@BuildPlanCheckFail {} loc = do 416 logWarn $ "* Rejected " <> RIO.display loc 417 logWarn $ RIO.display $ indent $ T.pack $ show r 418 419 indent t = T.unlines $ fmap (" " <>) (T.lines t) 420 421showItems :: [String] -> Text 422showItems items = T.concat (map formatItem items) 423 where 424 formatItem item = T.concat 425 [ " - " 426 , T.pack item 427 , "\n" 428 ] 429 430showPackageFlags :: PackageName -> Map FlagName Bool -> Text 431showPackageFlags pkg fl = 432 if not $ Map.null fl then 433 T.concat 434 [ " - " 435 , T.pack $ packageNameString pkg 436 , ": " 437 , T.pack $ intercalate ", " 438 $ map formatFlags (Map.toList fl) 439 , "\n" 440 ] 441 else "" 442 where 443 formatFlags (f, v) = show f ++ " = " ++ show v 444 445showMapPackages :: Map PackageName a -> Text 446showMapPackages mp = showItems $ map packageNameString $ Map.keys mp 447 448showCompilerErrors 449 :: Map PackageName (Map FlagName Bool) 450 -> DepErrors 451 -> ActualCompiler 452 -> Text 453showCompilerErrors flags errs compiler = 454 T.concat 455 [ compilerVersionText compiler 456 , " cannot be used for these packages:\n" 457 , showMapPackages $ Map.unions (Map.elems (fmap deNeededBy errs)) 458 , showDepErrors flags errs -- TODO only in debug mode 459 ] 460 461showDepErrors :: Map PackageName (Map FlagName Bool) -> DepErrors -> Text 462showDepErrors flags errs = 463 T.concat 464 [ T.concat $ map formatError (Map.toList errs) 465 , if T.null flagVals then "" 466 else "Using package flags:\n" <> flagVals 467 ] 468 where 469 formatError (depName, DepError mversion neededBy) = T.concat 470 [ showDepVersion depName mversion 471 , T.concat (map showRequirement (Map.toList neededBy)) 472 ] 473 474 showDepVersion depName mversion = T.concat 475 [ T.pack $ packageNameString depName 476 , case mversion of 477 Nothing -> " not found" 478 Just version -> T.concat 479 [ " version " 480 , T.pack $ versionString version 481 , " found" 482 ] 483 , "\n" 484 ] 485 486 showRequirement (user, range) = T.concat 487 [ " - " 488 , T.pack $ packageNameString user 489 , " requires " 490 , T.pack $ display range 491 , "\n" 492 ] 493 494 flagVals = T.concat (map showFlags userPkgs) 495 userPkgs = Map.keys $ Map.unions (Map.elems (fmap deNeededBy errs)) 496 showFlags pkg = maybe "" (showPackageFlags pkg) (Map.lookup pkg flags) 497