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