Skip to content

Commit 36e5680

Browse files
mpilgremmpilgrem
committed
Add explicit imports
Also some reformatting
1 parent 016a944 commit 36e5680

File tree

1 file changed

+97
-74
lines changed

1 file changed

+97
-74
lines changed

‎src/Stack/Dot.hs

Lines changed: 97 additions & 74 deletions
Original file line numberDiff line numberDiff line change
@@ -14,7 +14,7 @@ module Stack.Dot
1414
, pruneGraph
1515
) where
1616

17-
import Data.Aeson
17+
import Data.Aeson ( ToJSON (..), Value, (.=), encode, object )
1818
import qualified Data.ByteString.Lazy.Char8 as LBC8
1919
import qualified Data.Foldable as F
2020
import qualified Data.Sequence as Seq
@@ -28,19 +28,23 @@ import qualified Distribution.PackageDescription as PD
2828
import qualified Distribution.SPDX.License as SPDX
2929
import Distribution.Text ( display )
3030
import Distribution.Types.PackageName ( mkPackageName )
31-
import qualified Path
31+
import Path ( parent )
3232
import RIO.Process ( HasProcessContext (..) )
3333
import Stack.Build ( loadPackage )
3434
import Stack.Build.Installed ( getInstalled, toInstallMap )
3535
import Stack.Build.Source
36+
( loadCommonPackage, loadLocalPackage, loadSourceMap )
3637
import Stack.Build.Target( NeedTargets (..), parseTargets )
37-
import Stack.Constants
38-
import Stack.Package
38+
import Stack.Constants ( wiredInPackages )
39+
import Stack.Package ( Package (..) )
3940
import Stack.Prelude hiding ( Display (..), pkgName, loadPackage )
4041
import qualified Stack.Prelude ( pkgName )
4142
import Stack.Runners
43+
( ShouldReexec (..), withBuildConfig, withConfig
44+
, withEnvConfig
45+
)
4246
import Stack.SourceMap
43-
import Stack.Types.Build
47+
( globalsFromHints, mkProjectPackage, pruneGlobals )
4448
import Stack.Types.BuildConfig
4549
( BuildConfig (..), HasBuildConfig (..) )
4650
import Stack.Types.BuildOpts
@@ -53,10 +57,15 @@ import Stack.Types.DumpPackage ( DumpPackage (..) )
5357
import Stack.Types.EnvConfig ( EnvConfig (..), HasSourceMap (..) )
5458
import Stack.Types.GHCVariant ( HasGHCVariant (..) )
5559
import Stack.Types.GhcPkgId
60+
( GhcPkgId, ghcPkgIdString, parseGhcPkgId )
5661
import Stack.Types.GlobalOpts ( globalOptsBuildOptsMonoidL )
62+
import Stack.Types.Package ( LocalPackage (..) )
5763
import Stack.Types.Platform ( HasPlatform (..) )
5864
import Stack.Types.Runner ( HasRunner (..), Runner, globalOptsL )
5965
import Stack.Types.SourceMap
66+
( CommonPackage (..), DepPackage (..), ProjectPackage (..)
67+
, SMActual (..), SMWanted (..), SourceMap (..)
68+
)
6069

6170
-- | Type representing exceptions thrown by functions exported by the
6271
-- "Stack.Dot" module.
@@ -80,43 +89,44 @@ instance Exception DotException where
8089
-- | Options record for @stack dot@
8190
data DotOpts = DotOpts
8291
{ dotIncludeExternal :: !Bool
83-
-- ^ Include external dependencies
92+
-- ^ Include external dependencies
8493
, dotIncludeBase :: !Bool
85-
-- ^ Include dependencies on base
94+
-- ^ Include dependencies on base
8695
, dotDependencyDepth :: !(Maybe Int)
87-
-- ^ Limit the depth of dependency resolution to (Just n) or continue until
88-
-- fixpoint
96+
-- ^ Limit the depth of dependency resolution to (Just n) or continue until
97+
-- fixpoint
8998
, dotPrune :: !(Set PackageName)
90-
-- ^ Package names to prune from the graph
99+
-- ^ Package names to prune from the graph
91100
, dotTargets :: [Text]
92-
-- ^ Stack TARGETs to trace dependencies for
101+
-- ^ Stack TARGETs to trace dependencies for
93102
, dotFlags :: !(Map ApplyCLIFlag (Map FlagName Bool))
94-
-- ^ Flags to apply when calculating dependencies
103+
-- ^ Flags to apply when calculating dependencies
95104
, dotTestTargets :: Bool
96-
-- ^ Like the "--test" flag for build, affects the meaning of 'dotTargets'.
105+
-- ^ Like the "--test" flag for build, affects the meaning of 'dotTargets'.
97106
, dotBenchTargets :: Bool
98-
-- ^ Like the "--bench" flag for build, affects the meaning of 'dotTargets'.
107+
-- ^ Like the "--bench" flag for build, affects the meaning of 'dotTargets'.
99108
, dotGlobalHints :: Bool
100-
-- ^ Use global hints instead of relying on an actual GHC installation.
109+
-- ^ Use global hints instead of relying on an actual GHC installation.
101110
}
102111

103112
data ListDepsFormatOpts = ListDepsFormatOpts
104113
{ listDepsSep :: !Text
105-
-- ^ Separator between the package name and details.
114+
-- ^ Separator between the package name and details.
106115
, listDepsLicense :: !Bool
107-
-- ^ Print dependency licenses instead of versions.
116+
-- ^ Print dependency licenses instead of versions.
108117
}
109118

110-
data ListDepsFormat = ListDepsText ListDepsFormatOpts
111-
| ListDepsTree ListDepsFormatOpts
112-
| ListDepsJSON
113-
| ListDepsConstraints
119+
data ListDepsFormat
120+
= ListDepsText ListDepsFormatOpts
121+
| ListDepsTree ListDepsFormatOpts
122+
| ListDepsJSON
123+
| ListDepsConstraints
114124

115125
data ListDepsOpts = ListDepsOpts
116126
{ listDepsFormat :: !ListDepsFormat
117-
-- ^ Format of printing dependencies
127+
-- ^ Format of printing dependencies
118128
, listDepsDotOpts :: !DotOpts
119-
-- ^ The normal dot options.
129+
-- ^ The normal dot options.
120130
}
121131

122132
-- | Visualize the project's dependencies as a graphviz graph
@@ -128,11 +138,11 @@ dot dotOpts = do
128138
-- | Information about a package in the dependency graph, when available.
129139
data DotPayload = DotPayload
130140
{ payloadVersion :: Maybe Version
131-
-- ^ The package version.
141+
-- ^ The package version.
132142
, payloadLicense :: Maybe (Either SPDX.License License)
133-
-- ^ The license the package was released under.
143+
-- ^ The license the package was released under.
134144
, payloadLocation :: Maybe PackageLocation
135-
-- ^ The location of the package.
145+
-- ^ The location of the package.
136146
}
137147
deriving (Eq, Show)
138148

@@ -232,7 +242,7 @@ dependencyToJSON pkg (deps, payload) =
232242
pkgLocToJSON :: PackageLocation -> Value
233243
pkgLocToJSON (PLMutable (ResolvedPath _ dir)) = object
234244
[ "type" .= ("project package" :: Text)
235-
, "url" .= ("file://" ++ Path.toFilePath dir)
245+
, "url" .= ("file://" ++ toFilePath dir)
236246
]
237247
pkgLocToJSON (PLImmutable (PLIHackage pkgid _ _)) = object
238248
[ "type" .= ("hackage" :: Text)
@@ -242,7 +252,7 @@ pkgLocToJSON (PLImmutable (PLIArchive archive _)) =
242252
let url = case archiveLocation archive of
243253
ALUrl u -> u
244254
ALFilePath (ResolvedPath _ path) ->
245-
Text.pack $ "file://" ++ Path.toFilePath path
255+
Text.pack $ "file://" ++ toFilePath path
246256
in object
247257
[ "type" .= ("archive" :: Text)
248258
, "url" .= url
@@ -258,9 +268,10 @@ pkgLocToJSON (PLImmutable (PLIRepo repo _)) = object
258268
, "subdir" .= repoSubdir repo
259269
]
260270

261-
printJSON :: Set PackageName
262-
-> Map PackageName (Set PackageName, DotPayload)
263-
-> IO ()
271+
printJSON ::
272+
Set PackageName
273+
-> Map PackageName (Set PackageName, DotPayload)
274+
-> IO ()
264275
printJSON pkgs dependencyMap =
265276
LBC8.putStrLn $ encode $ DependencyTree pkgs dependencyMap
266277

@@ -271,13 +282,14 @@ treeRoots opts projectPackages' =
271282
then projectPackages'
272283
else Set.fromList $ map (mkPackageName . Text.unpack) targets
273284

274-
printTree :: ListDepsFormatOpts
275-
-> DotOpts
276-
-> Int
277-
-> [Int]
278-
-> Set PackageName
279-
-> Map PackageName (Set PackageName, DotPayload)
280-
-> IO ()
285+
printTree ::
286+
ListDepsFormatOpts
287+
-> DotOpts
288+
-> Int
289+
-> [Int]
290+
-> Set PackageName
291+
-> Map PackageName (Set PackageName, DotPayload)
292+
-> IO ()
281293
printTree opts dotOpts depth remainingDepsCounts packages dependencyMap =
282294
F.sequence_ $ Seq.mapWithIndex go (toSeq packages)
283295
where
@@ -294,14 +306,15 @@ printTree opts dotOpts depth remainingDepsCounts packages dependencyMap =
294306
-- TODO: Define this behaviour, maybe pure an error?
295307
Nothing -> pure ()
296308

297-
printTreeNode :: ListDepsFormatOpts
298-
-> DotOpts
299-
-> Int
300-
-> [Int]
301-
-> Set PackageName
302-
-> DotPayload
303-
-> PackageName
304-
-> IO ()
309+
printTreeNode ::
310+
ListDepsFormatOpts
311+
-> DotOpts
312+
-> Int
313+
-> [Int]
314+
-> Set PackageName
315+
-> DotPayload
316+
-> PackageName
317+
-> IO ()
305318
printTreeNode opts dotOpts depth remainingDepsCounts deps payload name =
306319
let remainingDepth = fromMaybe 999 (dotDependencyDepth dotOpts) - depth
307320
hasDeps = not $ null deps
@@ -343,11 +356,12 @@ versionText payload =
343356
-- | @pruneGraph dontPrune toPrune graph@ prunes all packages in
344357
-- @graph@ with a name in @toPrune@ and removes resulting orphans
345358
-- unless they are in @dontPrune@
346-
pruneGraph :: (F.Foldable f, F.Foldable g, Eq a)
347-
=> f PackageName
348-
-> g PackageName
349-
-> Map PackageName (Set PackageName, a)
350-
-> Map PackageName (Set PackageName, a)
359+
pruneGraph ::
360+
(F.Foldable f, F.Foldable g, Eq a)
361+
=> f PackageName
362+
-> g PackageName
363+
-> Map PackageName (Set PackageName, a)
364+
-> Map PackageName (Set PackageName, a)
351365
pruneGraph dontPrune names =
352366
pruneUnreachable dontPrune . Map.mapMaybeWithKey (\pkg (pkgDeps,x) ->
353367
if pkg `F.elem` names
@@ -358,10 +372,11 @@ pruneGraph dontPrune names =
358372
else Just (filtered,x))
359373

360374
-- | Make sure that all unreachable nodes (orphans) are pruned
361-
pruneUnreachable :: (Eq a, F.Foldable f)
362-
=> f PackageName
363-
-> Map PackageName (Set PackageName, a)
364-
-> Map PackageName (Set PackageName, a)
375+
pruneUnreachable ::
376+
(Eq a, F.Foldable f)
377+
=> f PackageName
378+
-> Map PackageName (Set PackageName, a)
379+
-> Map PackageName (Set PackageName, a)
365380
pruneUnreachable dontPrune = fixpoint prune
366381
where
367382
fixpoint :: Eq a => (a -> a) -> a -> a
@@ -400,9 +415,14 @@ createDepLoader ::
400415
SourceMap
401416
-> Map PackageName DumpPackage
402417
-> Map GhcPkgId PackageIdentifier
403-
-> (PackageName -> Version -> PackageLocationImmutable ->
404-
Map FlagName Bool -> [Text] -> [Text] ->
405-
RIO DotConfig (Set PackageName, DotPayload))
418+
-> ( PackageName
419+
-> Version
420+
-> PackageLocationImmutable
421+
-> Map FlagName Bool
422+
-> [Text]
423+
-> [Text]
424+
-> RIO DotConfig (Set PackageName, DotPayload)
425+
)
406426
-> PackageName
407427
-> RIO DotConfig (Set PackageName, DotPayload)
408428
createDepLoader sourceMap globalDumpMap globalIdMap loadPackageDeps pkgName =
@@ -462,7 +482,7 @@ projectPackageDependencies ::
462482
-> [(PackageName, (Set PackageName, DotPayload))]
463483
projectPackageDependencies dotOpts locals =
464484
map (\lp -> let pkg = localPackageToPackage lp
465-
pkgDir = Path.parent $ lpCabalFile lp
485+
pkgDir = parent $ lpCabalFile lp
466486
loc = PLMutable $ ResolvedPath (RelFilePath "N/A") pkgDir
467487
in (packageName pkg, (deps pkg, lpPayload pkg loc)))
468488
locals
@@ -478,11 +498,12 @@ projectPackageDependencies dotOpts locals =
478498

479499
-- | Print a graphviz graph of the edges in the Map and highlight the given
480500
-- local packages
481-
printGraph :: (Applicative m, MonadIO m)
482-
=> DotOpts
483-
-> Set PackageName -- ^ all locals
484-
-> Map PackageName (Set PackageName, DotPayload)
485-
-> m ()
501+
printGraph ::
502+
(Applicative m, MonadIO m)
503+
=> DotOpts
504+
-> Set PackageName -- ^ all locals
505+
-> Map PackageName (Set PackageName, DotPayload)
506+
-> m ()
486507
printGraph dotOpts locals graph = do
487508
liftIO $ Text.putStrLn "strict digraph deps {"
488509
printLocalNodes dotOpts filteredLocals
@@ -494,10 +515,11 @@ printGraph dotOpts locals graph = do
494515
Set.filter (\local' -> local' `Set.notMember` dotPrune dotOpts) locals
495516

496517
-- | Print the local nodes with a different style depending on options
497-
printLocalNodes :: (F.Foldable t, MonadIO m)
498-
=> DotOpts
499-
-> t PackageName
500-
-> m ()
518+
printLocalNodes ::
519+
(F.Foldable t, MonadIO m)
520+
=> DotOpts
521+
-> t PackageName
522+
-> m ()
501523
printLocalNodes dotOpts locals =
502524
liftIO $ Text.putStrLn (Text.intercalate "\n" lpNodes)
503525
where
@@ -509,9 +531,10 @@ printLocalNodes dotOpts locals =
509531
lpNodes = map (applyStyle . nodeName) (F.toList locals)
510532

511533
-- | Print nodes without dependencies
512-
printLeaves :: MonadIO m
513-
=> Map PackageName (Set PackageName, DotPayload)
514-
-> m ()
534+
printLeaves ::
535+
MonadIO m
536+
=> Map PackageName (Set PackageName, DotPayload)
537+
-> m ()
515538
printLeaves = F.mapM_ printLeaf . Map.keysSet . Map.filter Set.null . fmap fst
516539

517540
-- | @printDedges p ps@ prints an edge from p to every ps
@@ -547,9 +570,9 @@ localPackageToPackage lp =
547570

548571
-- Plumbing for --test and --bench flags
549572
withDotConfig ::
550-
DotOpts
551-
-> RIO DotConfig a
552-
-> RIO Runner a
573+
DotOpts
574+
-> RIO DotConfig a
575+
-> RIO Runner a
553576
withDotConfig opts inner =
554577
local (over globalOptsL modifyGO) $
555578
if dotGlobalHints opts

0 commit comments

Comments
 (0)