1{-# LANGUAGE NoImplicitPrelude #-} 2{-# LANGUAGE ConstraintKinds #-} 3{-# LANGUAGE TupleSections #-} 4{-# LANGUAGE FlexibleContexts #-} 5{-# LANGUAGE OverloadedStrings #-} 6 7module Stack.Dot (dot 8 ,listDependencies 9 ,DotOpts(..) 10 ,DotPayload(..) 11 ,ListDepsOpts(..) 12 ,ListDepsFormat(..) 13 ,ListDepsFormatOpts(..) 14 ,resolveDependencies 15 ,printGraph 16 ,pruneGraph 17 ) where 18 19import Data.Aeson 20import qualified Data.ByteString.Lazy.Char8 as LBC8 21import qualified Data.Foldable as F 22import qualified Data.Sequence as Seq 23import qualified Data.Set as Set 24import qualified Data.Map as Map 25import qualified Data.Text as Text 26import qualified Data.Text.IO as Text 27import qualified Data.Traversable as T 28import Distribution.Text (display) 29import qualified Distribution.PackageDescription as PD 30import qualified Distribution.SPDX.License as SPDX 31import Distribution.License (License(BSD3), licenseFromSPDX) 32import Distribution.Types.PackageName (mkPackageName) 33import qualified Path 34import RIO.PrettyPrint (HasTerm (..), HasStylesUpdate (..)) 35import RIO.Process (HasProcessContext (..)) 36import Stack.Build (loadPackage) 37import Stack.Build.Installed (getInstalled, toInstallMap) 38import Stack.Build.Source 39import Stack.Constants 40import Stack.Package 41import Stack.Prelude hiding (Display (..), pkgName, loadPackage) 42import qualified Stack.Prelude (pkgName) 43import Stack.Runners 44import Stack.SourceMap 45import Stack.Types.Build 46import Stack.Types.Compiler (wantedToActual) 47import Stack.Types.Config 48import Stack.Types.GhcPkgId 49import Stack.Types.SourceMap 50import Stack.Build.Target(NeedTargets(..), parseTargets) 51 52-- | Options record for @stack dot@ 53data DotOpts = DotOpts 54 { dotIncludeExternal :: !Bool 55 -- ^ Include external dependencies 56 , dotIncludeBase :: !Bool 57 -- ^ Include dependencies on base 58 , dotDependencyDepth :: !(Maybe Int) 59 -- ^ Limit the depth of dependency resolution to (Just n) or continue until fixpoint 60 , dotPrune :: !(Set PackageName) 61 -- ^ Package names to prune from the graph 62 , dotTargets :: [Text] 63 -- ^ stack TARGETs to trace dependencies for 64 , dotFlags :: !(Map ApplyCLIFlag (Map FlagName Bool)) 65 -- ^ Flags to apply when calculating dependencies 66 , dotTestTargets :: Bool 67 -- ^ Like the "--test" flag for build, affects the meaning of 'dotTargets'. 68 , dotBenchTargets :: Bool 69 -- ^ Like the "--bench" flag for build, affects the meaning of 'dotTargets'. 70 , dotGlobalHints :: Bool 71 -- ^ Use global hints instead of relying on an actual GHC installation. 72 } 73 74data ListDepsFormatOpts = ListDepsFormatOpts { listDepsSep :: !Text 75 -- ^ Separator between the package name and details. 76 , listDepsLicense :: !Bool 77 -- ^ Print dependency licenses instead of versions. 78 } 79 80data ListDepsFormat = ListDepsText ListDepsFormatOpts 81 | ListDepsTree ListDepsFormatOpts 82 | ListDepsJSON 83 84data ListDepsOpts = ListDepsOpts 85 { listDepsFormat :: !ListDepsFormat 86 -- ^ Format of printing dependencies 87 , listDepsDotOpts :: !DotOpts 88 -- ^ The normal dot options. 89 } 90 91-- | Visualize the project's dependencies as a graphviz graph 92dot :: DotOpts -> RIO Runner () 93dot dotOpts = do 94 (localNames, prunedGraph) <- createPrunedDependencyGraph dotOpts 95 printGraph dotOpts localNames prunedGraph 96 97-- | Information about a package in the dependency graph, when available. 98data DotPayload = DotPayload 99 { payloadVersion :: Maybe Version 100 -- ^ The package version. 101 , payloadLicense :: Maybe (Either SPDX.License License) 102 -- ^ The license the package was released under. 103 , payloadLocation :: Maybe PackageLocation 104 -- ^ The location of the package. 105 } deriving (Eq, Show) 106 107-- | Create the dependency graph and also prune it as specified in the dot 108-- options. Returns a set of local names and and a map from package names to 109-- dependencies. 110createPrunedDependencyGraph :: DotOpts 111 -> RIO Runner 112 (Set PackageName, 113 Map PackageName (Set PackageName, DotPayload)) 114createPrunedDependencyGraph dotOpts = withDotConfig dotOpts $ do 115 localNames <- view $ buildConfigL.to (Map.keysSet . smwProject . bcSMWanted) 116 logDebug "Creating dependency graph" 117 resultGraph <- createDependencyGraph dotOpts 118 let pkgsToPrune = if dotIncludeBase dotOpts 119 then dotPrune dotOpts 120 else Set.insert "base" (dotPrune dotOpts) 121 prunedGraph = pruneGraph localNames pkgsToPrune resultGraph 122 logDebug "Returning prouned dependency graph" 123 return (localNames, prunedGraph) 124 125-- | Create the dependency graph, the result is a map from a package 126-- name to a tuple of dependencies and payload if available. This 127-- function mainly gathers the required arguments for 128-- @resolveDependencies@. 129createDependencyGraph 130 :: DotOpts 131 -> RIO DotConfig (Map PackageName (Set PackageName, DotPayload)) 132createDependencyGraph dotOpts = do 133 sourceMap <- view sourceMapL 134 locals <- for (toList $ smProject sourceMap) loadLocalPackage 135 let graph = Map.fromList $ projectPackageDependencies dotOpts (filter lpWanted locals) 136 globalDump <- view $ to dcGlobalDump 137 -- TODO: Can there be multiple entries for wired-in-packages? If so, 138 -- this will choose one arbitrarily.. 139 let globalDumpMap = Map.fromList $ map (\dp -> (Stack.Prelude.pkgName (dpPackageIdent dp), dp)) globalDump 140 globalIdMap = Map.fromList $ map (\dp -> (dpGhcPkgId dp, dpPackageIdent dp)) globalDump 141 let depLoader = createDepLoader sourceMap globalDumpMap globalIdMap loadPackageDeps 142 loadPackageDeps name version loc flags ghcOptions cabalConfigOpts 143 -- Skip packages that can't be loaded - see 144 -- https://github.com/commercialhaskell/stack/issues/2967 145 | name `elem` [mkPackageName "rts", mkPackageName "ghc"] = 146 return (Set.empty, DotPayload (Just version) (Just $ Right BSD3) Nothing) 147 | otherwise = 148 fmap (packageAllDeps &&& makePayload loc) (loadPackage loc flags ghcOptions cabalConfigOpts) 149 resolveDependencies (dotDependencyDepth dotOpts) graph depLoader 150 where makePayload loc pkg = DotPayload (Just $ packageVersion pkg) (Just $ packageLicense pkg) (Just $ PLImmutable loc) 151 152listDependencies 153 :: ListDepsOpts 154 -> RIO Runner () 155listDependencies opts = do 156 let dotOpts = listDepsDotOpts opts 157 (pkgs, resultGraph) <- createPrunedDependencyGraph dotOpts 158 liftIO $ case listDepsFormat opts of 159 ListDepsTree treeOpts -> Text.putStrLn "Packages" >> printTree treeOpts dotOpts 0 [] (treeRoots opts pkgs) resultGraph 160 ListDepsJSON -> printJSON pkgs resultGraph 161 ListDepsText textOpts -> void (Map.traverseWithKey go (snd <$> resultGraph)) 162 where go name payload = Text.putStrLn $ listDepsLine textOpts name payload 163 164data DependencyTree = DependencyTree (Set PackageName) (Map PackageName (Set PackageName, DotPayload)) 165 166instance ToJSON DependencyTree where 167 toJSON (DependencyTree _ dependencyMap) = 168 toJSON $ foldToList dependencyToJSON dependencyMap 169 170foldToList :: (k -> a -> b) -> Map k a -> [b] 171foldToList f = Map.foldrWithKey (\k a bs -> bs ++ [f k a]) [] 172 173dependencyToJSON :: PackageName -> (Set PackageName, DotPayload) -> Value 174dependencyToJSON pkg (deps, payload) = let fieldsAlwaysPresent = [ "name" .= packageNameString pkg 175 , "license" .= licenseText payload 176 , "version" .= versionText payload 177 , "dependencies" .= Set.map packageNameString deps 178 ] 179 loc = catMaybes [("location" .=) . pkgLocToJSON <$> payloadLocation payload] 180 in object $ fieldsAlwaysPresent ++ loc 181 182pkgLocToJSON :: PackageLocation -> Value 183pkgLocToJSON (PLMutable (ResolvedPath _ dir)) = object [ "type" .= ("project package" :: Text) 184 , "url" .= ("file://" ++ Path.toFilePath dir)] 185pkgLocToJSON (PLImmutable (PLIHackage pkgid _ _)) = object [ "type" .= ("hackage" :: Text) 186 , "url" .= ("https://hackage.haskell.org/package/" ++ display pkgid)] 187pkgLocToJSON (PLImmutable (PLIArchive archive _)) = let url = case archiveLocation archive of 188 ALUrl u -> u 189 ALFilePath (ResolvedPath _ path) -> Text.pack $ "file://" ++ Path.toFilePath path 190 in object [ "type" .= ("archive" :: Text) 191 , "url" .= url 192 , "sha256" .= archiveHash archive 193 , "size" .= archiveSize archive ] 194pkgLocToJSON (PLImmutable (PLIRepo repo _)) = object [ "type" .= case repoType repo of 195 RepoGit -> "git" :: Text 196 RepoHg -> "hg" :: Text 197 , "url" .= repoUrl repo 198 , "commit" .= repoCommit repo 199 , "subdir" .= repoSubdir repo 200 ] 201 202printJSON :: Set PackageName 203 -> Map PackageName (Set PackageName, DotPayload) 204 -> IO () 205printJSON pkgs dependencyMap = LBC8.putStrLn $ encode $ DependencyTree pkgs dependencyMap 206 207treeRoots :: ListDepsOpts -> Set PackageName -> Set PackageName 208treeRoots opts projectPackages' = 209 let targets = dotTargets $ listDepsDotOpts opts 210 in if null targets 211 then projectPackages' 212 else Set.fromList $ map (mkPackageName . Text.unpack) targets 213 214printTree :: ListDepsFormatOpts 215 -> DotOpts 216 -> Int 217 -> [Int] 218 -> Set PackageName 219 -> Map PackageName (Set PackageName, DotPayload) 220 -> IO () 221printTree opts dotOpts depth remainingDepsCounts packages dependencyMap = 222 F.sequence_ $ Seq.mapWithIndex go (toSeq packages) 223 where 224 toSeq = Seq.fromList . Set.toList 225 go index name = let newDepsCounts = remainingDepsCounts ++ [Set.size packages - index - 1] 226 in 227 case Map.lookup name dependencyMap of 228 Just (deps, payload) -> do 229 printTreeNode opts dotOpts depth newDepsCounts deps payload name 230 if Just depth == dotDependencyDepth dotOpts 231 then return () 232 else printTree opts dotOpts (depth + 1) newDepsCounts deps dependencyMap 233 -- TODO: Define this behaviour, maybe return an error? 234 Nothing -> return () 235 236printTreeNode :: ListDepsFormatOpts 237 -> DotOpts 238 -> Int 239 -> [Int] 240 -> Set PackageName 241 -> DotPayload 242 -> PackageName 243 -> IO () 244printTreeNode opts dotOpts depth remainingDepsCounts deps payload name = 245 let remainingDepth = fromMaybe 999 (dotDependencyDepth dotOpts) - depth 246 hasDeps = not $ null deps 247 in Text.putStrLn $ treeNodePrefix "" remainingDepsCounts hasDeps remainingDepth <> " " <> listDepsLine opts name payload 248 249treeNodePrefix :: Text -> [Int] -> Bool -> Int -> Text 250treeNodePrefix t [] _ _ = t 251treeNodePrefix t [0] True 0 = t <> "└──" 252treeNodePrefix t [_] True 0 = t <> "├──" 253treeNodePrefix t [0] True _ = t <> "└─┬" 254treeNodePrefix t [_] True _ = t <> "├─┬" 255treeNodePrefix t [0] False _ = t <> "└──" 256treeNodePrefix t [_] False _ = t <> "├──" 257treeNodePrefix t (0:ns) d remainingDepth = treeNodePrefix (t <> " ") ns d remainingDepth 258treeNodePrefix t (_:ns) d remainingDepth = treeNodePrefix (t <> "│ ") ns d remainingDepth 259 260listDepsLine :: ListDepsFormatOpts -> PackageName -> DotPayload -> Text 261listDepsLine opts name payload = Text.pack (packageNameString name) <> listDepsSep opts <> payloadText opts payload 262 263payloadText :: ListDepsFormatOpts -> DotPayload -> Text 264payloadText opts payload = 265 if listDepsLicense opts 266 then licenseText payload 267 else versionText payload 268 269licenseText :: DotPayload -> Text 270licenseText payload = maybe "<unknown>" (Text.pack . display . either licenseFromSPDX id) (payloadLicense payload) 271 272versionText :: DotPayload -> Text 273versionText payload = maybe "<unknown>" (Text.pack . display) (payloadVersion payload) 274 275-- | @pruneGraph dontPrune toPrune graph@ prunes all packages in 276-- @graph@ with a name in @toPrune@ and removes resulting orphans 277-- unless they are in @dontPrune@ 278pruneGraph :: (F.Foldable f, F.Foldable g, Eq a) 279 => f PackageName 280 -> g PackageName 281 -> Map PackageName (Set PackageName, a) 282 -> Map PackageName (Set PackageName, a) 283pruneGraph dontPrune names = 284 pruneUnreachable dontPrune . Map.mapMaybeWithKey (\pkg (pkgDeps,x) -> 285 if pkg `F.elem` names 286 then Nothing 287 else let filtered = Set.filter (\n -> n `F.notElem` names) pkgDeps 288 in if Set.null filtered && not (Set.null pkgDeps) 289 then Nothing 290 else Just (filtered,x)) 291 292-- | Make sure that all unreachable nodes (orphans) are pruned 293pruneUnreachable :: (Eq a, F.Foldable f) 294 => f PackageName 295 -> Map PackageName (Set PackageName, a) 296 -> Map PackageName (Set PackageName, a) 297pruneUnreachable dontPrune = fixpoint prune 298 where fixpoint :: Eq a => (a -> a) -> a -> a 299 fixpoint f v = if f v == v then v else fixpoint f (f v) 300 prune graph' = Map.filterWithKey (\k _ -> reachable k) graph' 301 where reachable k = k `F.elem` dontPrune || k `Set.member` reachables 302 reachables = F.fold (fst <$> graph') 303 304 305-- | Resolve the dependency graph up to (Just depth) or until fixpoint is reached 306resolveDependencies :: (Applicative m, Monad m) 307 => Maybe Int 308 -> Map PackageName (Set PackageName, DotPayload) 309 -> (PackageName -> m (Set PackageName, DotPayload)) 310 -> m (Map PackageName (Set PackageName, DotPayload)) 311resolveDependencies (Just 0) graph _ = return graph 312resolveDependencies limit graph loadPackageDeps = do 313 let values = Set.unions (fst <$> Map.elems graph) 314 keys = Map.keysSet graph 315 next = Set.difference values keys 316 if Set.null next 317 then return graph 318 else do 319 x <- T.traverse (\name -> (name,) <$> loadPackageDeps name) (F.toList next) 320 resolveDependencies (subtract 1 <$> limit) 321 (Map.unionWith unifier graph (Map.fromList x)) 322 loadPackageDeps 323 where unifier (pkgs1,v1) (pkgs2,_) = (Set.union pkgs1 pkgs2, v1) 324 325-- | Given a SourceMap and a dependency loader, load the set of dependencies for a package 326createDepLoader :: SourceMap 327 -> Map PackageName DumpPackage 328 -> Map GhcPkgId PackageIdentifier 329 -> (PackageName -> Version -> PackageLocationImmutable -> 330 Map FlagName Bool -> [Text] -> [Text] -> RIO DotConfig (Set PackageName, DotPayload)) 331 -> PackageName 332 -> RIO DotConfig (Set PackageName, DotPayload) 333createDepLoader sourceMap globalDumpMap globalIdMap loadPackageDeps pkgName = do 334 fromMaybe noDepsErr 335 (projectPackageDeps <|> dependencyDeps <|> globalDeps) 336 where 337 projectPackageDeps = 338 loadDeps <$> Map.lookup pkgName (smProject sourceMap) 339 where 340 loadDeps pp = do 341 pkg <- loadCommonPackage (ppCommon pp) 342 pure (packageAllDeps pkg, payloadFromLocal pkg Nothing) 343 344 dependencyDeps = 345 loadDeps <$> Map.lookup pkgName (smDeps sourceMap) 346 where 347 loadDeps DepPackage{dpLocation=PLMutable dir} = do 348 pp <- mkProjectPackage YesPrintWarnings dir False 349 pkg <- loadCommonPackage (ppCommon pp) 350 pure (packageAllDeps pkg, payloadFromLocal pkg (Just $ PLMutable dir)) 351 352 loadDeps dp@DepPackage{dpLocation=PLImmutable loc} = do 353 let common = dpCommon dp 354 gpd <- liftIO $ cpGPD common 355 let PackageIdentifier name version = PD.package $ PD.packageDescription gpd 356 flags = cpFlags common 357 ghcOptions = cpGhcOptions common 358 cabalConfigOpts = cpCabalConfigOpts common 359 assert (pkgName == name) (loadPackageDeps pkgName version loc flags ghcOptions cabalConfigOpts) 360 361 -- If package is a global package, use info from ghc-pkg (#4324, #3084) 362 globalDeps = 363 pure . getDepsFromDump <$> Map.lookup pkgName globalDumpMap 364 where 365 getDepsFromDump dump = 366 (Set.fromList deps, payloadFromDump dump) 367 where 368 deps = map ghcIdToPackageName (dpDepends dump) 369 ghcIdToPackageName depId = 370 let errText = "Invariant violated: Expected to find " 371 in maybe (error (errText ++ ghcPkgIdString depId ++ " in global DB")) 372 Stack.Prelude.pkgName 373 (Map.lookup depId globalIdMap) 374 375 noDepsErr = error ("Invariant violated: The '" ++ packageNameString pkgName 376 ++ "' package was not found in any of the dependency sources") 377 378 payloadFromLocal pkg loc = DotPayload (Just $ packageVersion pkg) (Just $ packageLicense pkg) loc 379 payloadFromDump dp = DotPayload (Just $ pkgVersion $ dpPackageIdent dp) (Right <$> dpLicense dp) Nothing 380 381-- | Resolve the direct (depth 0) external dependencies of the given local packages (assumed to come from project packages) 382projectPackageDependencies :: DotOpts -> [LocalPackage] -> [(PackageName, (Set PackageName, DotPayload))] 383projectPackageDependencies dotOpts locals = 384 map (\lp -> let pkg = localPackageToPackage lp 385 pkgDir = Path.parent $ lpCabalFile lp 386 loc = PLMutable $ ResolvedPath (RelFilePath "N/A") pkgDir 387 in (packageName pkg, (deps pkg, lpPayload pkg loc))) 388 locals 389 where deps pkg = 390 if dotIncludeExternal dotOpts 391 then Set.delete (packageName pkg) (packageAllDeps pkg) 392 else Set.intersection localNames (packageAllDeps pkg) 393 localNames = Set.fromList $ map (packageName . lpPackage) locals 394 lpPayload pkg loc = DotPayload (Just $ packageVersion pkg) (Just $ packageLicense pkg) (Just loc) 395 396-- | Print a graphviz graph of the edges in the Map and highlight the given local packages 397printGraph :: (Applicative m, MonadIO m) 398 => DotOpts 399 -> Set PackageName -- ^ all locals 400 -> Map PackageName (Set PackageName, DotPayload) 401 -> m () 402printGraph dotOpts locals graph = do 403 liftIO $ Text.putStrLn "strict digraph deps {" 404 printLocalNodes dotOpts filteredLocals 405 printLeaves graph 406 void (Map.traverseWithKey printEdges (fst <$> graph)) 407 liftIO $ Text.putStrLn "}" 408 where filteredLocals = Set.filter (\local' -> 409 local' `Set.notMember` dotPrune dotOpts) locals 410 411-- | Print the local nodes with a different style depending on options 412printLocalNodes :: (F.Foldable t, MonadIO m) 413 => DotOpts 414 -> t PackageName 415 -> m () 416printLocalNodes dotOpts locals = liftIO $ Text.putStrLn (Text.intercalate "\n" lpNodes) 417 where applyStyle :: Text -> Text 418 applyStyle n = if dotIncludeExternal dotOpts 419 then n <> " [style=dashed];" 420 else n <> " [style=solid];" 421 lpNodes :: [Text] 422 lpNodes = map (applyStyle . nodeName) (F.toList locals) 423 424-- | Print nodes without dependencies 425printLeaves :: MonadIO m 426 => Map PackageName (Set PackageName, DotPayload) 427 -> m () 428printLeaves = F.mapM_ printLeaf . Map.keysSet . Map.filter Set.null . fmap fst 429 430-- | @printDedges p ps@ prints an edge from p to every ps 431printEdges :: MonadIO m => PackageName -> Set PackageName -> m () 432printEdges package deps = F.forM_ deps (printEdge package) 433 434-- | Print an edge between the two package names 435printEdge :: MonadIO m => PackageName -> PackageName -> m () 436printEdge from to' = liftIO $ Text.putStrLn (Text.concat [ nodeName from, " -> ", nodeName to', ";"]) 437 438-- | Convert a package name to a graph node name. 439nodeName :: PackageName -> Text 440nodeName name = "\"" <> Text.pack (packageNameString name) <> "\"" 441 442-- | Print a node with no dependencies 443printLeaf :: MonadIO m => PackageName -> m () 444printLeaf package = liftIO . Text.putStrLn . Text.concat $ 445 if isWiredIn package 446 then ["{rank=max; ", nodeName package, " [shape=box]; };"] 447 else ["{rank=max; ", nodeName package, "; };"] 448 449-- | Check if the package is wired in (shipped with) ghc 450isWiredIn :: PackageName -> Bool 451isWiredIn = (`Set.member` wiredInPackages) 452 453localPackageToPackage :: LocalPackage -> Package 454localPackageToPackage lp = 455 fromMaybe (lpPackage lp) (lpTestBench lp) 456 457-- Plumbing for --test and --bench flags 458withDotConfig 459 :: DotOpts 460 -> RIO DotConfig a 461 -> RIO Runner a 462withDotConfig opts inner = 463 local (over globalOptsL modifyGO) $ 464 if dotGlobalHints opts 465 then withConfig NoReexec $ withBuildConfig withGlobalHints 466 else withConfig YesReexec withReal 467 where 468 withGlobalHints = do 469 bconfig <- view buildConfigL 470 globals <- globalsFromHints $ smwCompiler $ bcSMWanted bconfig 471 fakeGhcPkgId <- parseGhcPkgId "ignored" 472 actual <- either throwIO pure $ 473 wantedToActual $ smwCompiler $ 474 bcSMWanted bconfig 475 let smActual = SMActual 476 { smaCompiler = actual 477 , smaProject = smwProject $ bcSMWanted bconfig 478 , smaDeps = smwDeps $ bcSMWanted bconfig 479 , smaGlobal = Map.mapWithKey toDump globals 480 } 481 toDump :: PackageName -> Version -> DumpPackage 482 toDump name version = DumpPackage 483 { dpGhcPkgId = fakeGhcPkgId 484 , dpPackageIdent = PackageIdentifier name version 485 , dpParentLibIdent = Nothing 486 , dpLicense = Nothing 487 , dpLibDirs = [] 488 , dpLibraries = [] 489 , dpHasExposedModules = True 490 , dpExposedModules = mempty 491 , dpDepends = [] 492 , dpHaddockInterfaces = [] 493 , dpHaddockHtml = Nothing 494 , dpIsExposed = True 495 } 496 actualPkgs = Map.keysSet (smaDeps smActual) <> 497 Map.keysSet (smaProject smActual) 498 prunedActual = smActual { smaGlobal = pruneGlobals (smaGlobal smActual) actualPkgs } 499 targets <- parseTargets NeedTargets False boptsCLI prunedActual 500 logDebug "Loading source map" 501 sourceMap <- loadSourceMap targets boptsCLI smActual 502 let dc = DotConfig 503 { dcBuildConfig = bconfig 504 , dcSourceMap = sourceMap 505 , dcGlobalDump = toList $ smaGlobal smActual 506 } 507 logDebug "DotConfig fully loaded" 508 runRIO dc inner 509 510 withReal = withEnvConfig NeedTargets boptsCLI $ do 511 envConfig <- ask 512 let sourceMap = envConfigSourceMap envConfig 513 installMap <- toInstallMap sourceMap 514 (_, globalDump, _, _) <- getInstalled installMap 515 let dc = DotConfig 516 { dcBuildConfig = envConfigBuildConfig envConfig 517 , dcSourceMap = sourceMap 518 , dcGlobalDump = globalDump 519 } 520 runRIO dc inner 521 522 boptsCLI = defaultBuildOptsCLI 523 { boptsCLITargets = dotTargets opts 524 , boptsCLIFlags = dotFlags opts 525 } 526 modifyGO = 527 (if dotTestTargets opts then set (globalOptsBuildOptsMonoidL.buildOptsMonoidTestsL) (Just True) else id) . 528 (if dotBenchTargets opts then set (globalOptsBuildOptsMonoidL.buildOptsMonoidBenchmarksL) (Just True) else id) 529 530data DotConfig = DotConfig 531 { dcBuildConfig :: !BuildConfig 532 , dcSourceMap :: !SourceMap 533 , dcGlobalDump :: ![DumpPackage] 534 } 535instance HasLogFunc DotConfig where 536 logFuncL = runnerL.logFuncL 537instance HasPantryConfig DotConfig where 538 pantryConfigL = configL.pantryConfigL 539instance HasTerm DotConfig where 540 useColorL = runnerL.useColorL 541 termWidthL = runnerL.termWidthL 542instance HasStylesUpdate DotConfig where 543 stylesUpdateL = runnerL.stylesUpdateL 544instance HasGHCVariant DotConfig 545instance HasPlatform DotConfig 546instance HasRunner DotConfig where 547 runnerL = configL.runnerL 548instance HasProcessContext DotConfig where 549 processContextL = runnerL.processContextL 550instance HasConfig DotConfig 551instance HasBuildConfig DotConfig where 552 buildConfigL = lens dcBuildConfig (\x y -> x { dcBuildConfig = y }) 553instance HasSourceMap DotConfig where 554 sourceMapL = lens dcSourceMap (\x y -> x { dcSourceMap = y }) 555