Skip to content

Commit bf086c6

Browse files
mboesmboes
committed
Merge pull request #437 from markus1189/dot-command
Add --external flag to `stack dot`
2 parents 94e3181 + 6b4ebf9 commit bf086c6

File tree

5 files changed

+277
-44
lines changed

5 files changed

+277
-44
lines changed

‎src/Stack/Build.hs

+9-2
Original file line numberDiff line numberDiff line change
@@ -14,7 +14,8 @@
1414

1515
module Stack.Build
1616
(build
17-
,clean)
17+
,clean
18+
,withLoadPackage)
1819
where
1920

2021
import Control.Monad
@@ -101,7 +102,13 @@ mkBaseConfigOpts bopts = do
101102
}
102103

103104
-- | Provide a function for loading package information from the package index
104-
withLoadPackage :: M env m
105+
withLoadPackage :: ( MonadIO m
106+
, HasHttpManager env
107+
, MonadReader env m
108+
, MonadBaseControl IO m
109+
, MonadCatch m
110+
, MonadLogger m
111+
, HasEnvConfig env)
105112
=> EnvOverride
106113
-> ((PackageName -> Version -> Map FlagName Bool -> IO Package) -> m a)
107114
-> m a

‎src/Stack/Dot.hs

+171-39
Original file line numberDiff line numberDiff line change
@@ -1,53 +1,185 @@
1-
{-# LANGUAGE OverloadedStrings #-}
2-
{-# LANGUAGE RecordWildCards #-}
31
{-# LANGUAGE TemplateHaskell #-}
4-
module Stack.Dot where
5-
2+
{-# LANGUAGE TupleSections #-}
3+
{-# LANGUAGE FlexibleContexts #-}
4+
{-# LANGUAGE OverloadedStrings #-}
5+
module Stack.Dot (dot
6+
,DotOpts(..)
7+
,dotOptsParser
8+
,resolveDependencies
9+
,printGraph
10+
) where
611

7-
import Control.Monad (when)
12+
import Control.Monad (void)
813
import Control.Monad.Catch (MonadCatch)
9-
import Control.Monad.IO.Class (MonadIO)
14+
import Control.Monad.IO.Class
1015
import Control.Monad.Logger (MonadLogger, logInfo)
1116
import Control.Monad.Reader (MonadReader)
17+
import Control.Monad.Trans.Control (MonadBaseControl)
1218
import qualified Data.Foldable as F
13-
import Data.Monoid ((<>))
19+
import qualified Data.HashSet as HashSet
20+
import Data.Map (Map)
1421
import qualified Data.Map as Map
22+
import Data.Monoid ((<>))
23+
import Data.Set (Set)
1524
import qualified Data.Set as Set
16-
import qualified Data.Text as T
25+
import Data.Text (Text)
26+
import qualified Data.Text as Text
27+
import qualified Data.Traversable as T
28+
import Network.HTTP.Client.Conduit (HasHttpManager)
29+
import Options.Applicative
30+
import Options.Applicative.Builder.Extra (boolFlags)
31+
import Stack.Build (withLoadPackage)
1732
import Stack.Build.Source
1833
import Stack.Build.Types
34+
import Stack.Constants
1935
import Stack.Package
2036
import Stack.Types
2137

38+
-- | Options record for `stack dot`
39+
data DotOpts = DotOpts
40+
{ dotIncludeExternal :: Bool
41+
-- ^ Include external dependencies
42+
, dotIncludeBase :: Bool
43+
-- ^ Include dependencies on base
44+
, dotDependencyDepth :: Maybe Int
45+
-- ^ Limit the depth of dependency resolution to (Just n) or continue until fixpoint
46+
}
47+
48+
-- | Parser for arguments to `stack dot`
49+
dotOptsParser :: Parser DotOpts
50+
dotOptsParser = DotOpts <$> includeExternal <*> includeBase <*> depthLimit
51+
where includeExternal = boolFlags False
52+
"external"
53+
"inclusion of external dependencies"
54+
idm
55+
includeBase = boolFlags True
56+
"include-base"
57+
"inclusion of dependencies on base"
58+
idm
59+
depthLimit =
60+
optional (option auto
61+
(long "depth" <>
62+
metavar "DEPTH" <>
63+
help ("Limit the depth of dependency resolution " <>
64+
"(Default: No limit)")))
65+
66+
-- | Visualize the project's dependencies as a graphviz graph
67+
dot :: (HasEnvConfig env
68+
,HasHttpManager env
69+
,MonadBaseControl IO m
70+
,MonadCatch m
71+
,MonadIO m
72+
,MonadLogger m
73+
,MonadReader env m
74+
)
75+
=> DotOpts
76+
-> m ()
77+
dot dotOpts = do
78+
(locals,_,_) <- loadLocals defaultBuildOpts Map.empty
79+
(_,_,_,sourceMap) <- loadSourceMap defaultBuildOpts
80+
let graph = Map.fromList (localDependencies dotOpts locals)
81+
menv <- getMinimalEnvOverride
82+
resultGraph <- withLoadPackage menv (\loader -> do
83+
let depLoader = createDepLoader sourceMap (fmap3 packageAllDeps loader)
84+
liftIO $ resolveDependencies (dotDependencyDepth dotOpts) graph depLoader)
85+
printGraph dotOpts locals (if dotIncludeBase dotOpts
86+
then resultGraph
87+
else filterOutDepsOnBase resultGraph)
88+
where filterOutDepsOnBase = Map.filterWithKey (\k _ -> show k /= "base") .
89+
fmap (Set.filter ((/= "base") . show))
90+
-- fmap a function over the result of a function with 3 arguments
91+
fmap3 :: Functor f => (d -> e) -> (a -> b -> c -> f d) -> (a -> b -> c -> f e)
92+
fmap3 f g a b c = f <$> g a b c
93+
94+
-- | Resolve the dependency graph up to (Just depth) or until fixpoint is reached
95+
resolveDependencies :: (Applicative m, Monad m)
96+
=> Maybe Int
97+
-> Map PackageName (Set PackageName)
98+
-> (PackageName -> m (Set PackageName))
99+
-> m (Map PackageName (Set PackageName))
100+
resolveDependencies (Just 0) graph _ = return graph
101+
resolveDependencies limit graph loadPackageDeps = do
102+
let values = Set.unions (Map.elems graph)
103+
keys = Map.keysSet graph
104+
next = Set.difference values keys
105+
if Set.null next
106+
then return graph
107+
else do
108+
x <- T.traverse (\name -> (name,) <$> loadPackageDeps name) (F.toList next)
109+
resolveDependencies (subtract 1 <$> limit)
110+
(Map.unionWith Set.union graph (Map.fromList x))
111+
loadPackageDeps
112+
113+
-- | Given a SourceMap and a dependency loader, load the set of dependencies for a package
114+
createDepLoader :: Applicative m
115+
=> Map PackageName PackageSource
116+
-> (PackageName -> Version -> Map FlagName Bool -> m (Set PackageName))
117+
-> PackageName
118+
-> m (Set PackageName)
119+
createDepLoader sourceMap loadPackageDeps pkgName =
120+
case Map.lookup pkgName sourceMap of
121+
Just (PSLocal lp) -> pure (packageAllDeps (lpPackage lp))
122+
Just (PSUpstream version _ flags) -> loadPackageDeps pkgName version flags
123+
Nothing -> pure Set.empty
124+
125+
-- | Resolve the direct (depth 0) external dependencies of the given local packages
126+
localDependencies :: DotOpts -> [LocalPackage] -> [(PackageName,Set PackageName)]
127+
localDependencies dotOpts locals = map (\lp -> (packageName (lpPackage lp), deps lp)) locals
128+
where deps lp = if dotIncludeExternal dotOpts
129+
then Set.delete (lpName lp) (packageAllDeps (lpPackage lp))
130+
else Set.intersection localNames (packageAllDeps (lpPackage lp))
131+
lpName lp = packageName (lpPackage lp)
132+
localNames = Set.fromList $ map (packageName . lpPackage) locals
133+
134+
-- | Print a graphviz graph of the edges in the Map and highlight the given local packages
135+
printGraph :: (Applicative m, MonadLogger m)
136+
=> DotOpts
137+
-> [LocalPackage]
138+
-> Map PackageName (Set PackageName)
139+
-> m ()
140+
printGraph dotOpts locals graph = do
141+
$logInfo "strict digraph deps {"
142+
printLocalNodes dotOpts locals
143+
printLeaves graph
144+
void (Map.traverseWithKey printEdges graph)
145+
$logInfo "}"
146+
147+
-- | Print the local nodes with a different style depending on options
148+
printLocalNodes :: (F.Foldable t, MonadLogger m)
149+
=> DotOpts
150+
-> t LocalPackage
151+
-> m ()
152+
printLocalNodes dotOpts locals = $logInfo (Text.intercalate "\n" lpNodes)
153+
where applyStyle :: Text -> Text
154+
applyStyle n = if dotIncludeExternal dotOpts
155+
then n <> " [style=dashed];"
156+
else n <> " [style=solid];"
157+
lpNodes :: [Text]
158+
lpNodes = map (applyStyle . nodeName . packageName . lpPackage) (F.toList locals)
159+
160+
-- | Print nodes without dependencies
161+
printLeaves :: (Applicative m, MonadLogger m) => Map PackageName (Set PackageName) -> m ()
162+
printLeaves = F.traverse_ printLeaf . Map.keysSet . Map.filter Set.null
163+
164+
-- | `printDedges p ps` prints an edge from p to every ps
165+
printEdges :: (Applicative m, MonadLogger m) => PackageName -> Set PackageName -> m ()
166+
printEdges package deps = F.for_ deps (printEdge package)
167+
168+
-- | Print an edge between the two package names
169+
printEdge :: MonadLogger m => PackageName -> PackageName -> m ()
170+
printEdge from to = $logInfo (Text.concat [ nodeName from, " -> ", nodeName to, ";"])
171+
22172
-- | Convert a package name to a graph node name.
23-
nodeName :: PackageName -> T.Text
24-
nodeName name = "\"" <> T.pack (packageNameString name) <> "\""
25-
26-
dot :: (MonadReader env m, HasBuildConfig env, MonadIO m, MonadLogger m, MonadCatch m,HasEnvConfig env)
27-
=> m ()
28-
dot = do
29-
(locals, _names, _idents) <- loadLocals
30-
defaultBuildOpts
31-
Map.empty
32-
let localNames = Set.fromList $ map (packageName . lpPackage) locals
33-
34-
$logInfo "digraph deps {"
35-
$logInfo "splines=polyline;"
36-
37-
F.forM_ locals $ \lp -> do
38-
let deps = Set.intersection localNames $ packageAllDeps $ lpPackage lp
39-
F.forM_ deps $ \dep ->
40-
$logInfo $ T.concat
41-
[ nodeName $ packageName $ lpPackage lp
42-
, " -> "
43-
, nodeName dep
44-
, ";"
45-
]
46-
when (Set.null deps) $
47-
$logInfo $ T.concat
48-
[ "{rank=max; "
49-
, nodeName $ packageName $ lpPackage lp
50-
, "}"
51-
]
52-
53-
$logInfo "}"
173+
nodeName :: PackageName -> Text
174+
nodeName name = "\"" <> Text.pack (packageNameString name) <> "\""
175+
176+
-- | Print a node with no dependencies
177+
printLeaf :: MonadLogger m => PackageName -> m ()
178+
printLeaf package = $logInfo . Text.concat $
179+
if isWiredIn package
180+
then ["{rank=max; ", nodeName package, " [shape=box]; };"]
181+
else ["{rank=max; ", nodeName package, "; };"]
182+
183+
-- | Check if the package is wired in (shipped with) ghc
184+
isWiredIn :: PackageName -> Bool
185+
isWiredIn = (`HashSet.member` wiredInPackages)

‎src/main/Main.hs

+3-3
Original file line numberDiff line numberDiff line change
@@ -165,7 +165,7 @@ main = withInterpreterArgs stackProgName $ \args isInterpreter ->
165165
addCommand "dot"
166166
"Visualize your project's dependency graph using Graphviz dot"
167167
dotCmd
168-
(pure ())
168+
dotOptsParser
169169
addCommand "exec"
170170
"Execute a command"
171171
execCmd
@@ -892,5 +892,5 @@ solverOptsParser = boolFlags False
892892
idm
893893

894894
-- | Visualize dependencies
895-
dotCmd :: () -> GlobalOpts -> IO ()
896-
dotCmd () go = withBuildConfig go ThrowException dot
895+
dotCmd :: DotOpts -> GlobalOpts -> IO ()
896+
dotCmd dotOpts go = withBuildConfig go ThrowException (dot dotOpts)

‎src/test/Stack/DotSpec.hs

+92
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,92 @@
1+
{-# LANGUAGE OverloadedStrings #-}
2+
-- | Test suite for Stack.Dot
3+
module Stack.DotSpec where
4+
5+
import Data.ByteString.Char8 (ByteString)
6+
import Data.Functor.Identity
7+
import qualified Data.Map as Map
8+
import Data.Maybe (fromMaybe)
9+
import Data.Set (Set)
10+
import qualified Data.Set as Set
11+
import Options.Applicative (execParserPure,idm,prefs,info,getParseResult)
12+
import Stack.Types
13+
import Test.Hspec
14+
15+
import Stack.Dot
16+
17+
spec :: Spec
18+
spec = do
19+
let graph =
20+
Map.mapKeys pkgName
21+
. fmap (Set.map pkgName)
22+
. Map.fromList $ [("one",Set.fromList ["base","free"])
23+
,("two",Set.fromList ["base","free","mtl","transformers","one"])
24+
]
25+
describe "Stack.Dot" $ do
26+
it "does nothing if depth is 0" $
27+
resolveDependencies (Just 0) graph stubLoader `shouldBe` return graph
28+
29+
it "with depth 1, more dependencies are resolved" $ do
30+
let graph' = Map.insert (pkgName "cycle") (Set.singleton (pkgName "cycle")) graph
31+
resultGraph = runIdentity (resolveDependencies (Just 0) graph stubLoader)
32+
resultGraph' = runIdentity (resolveDependencies (Just 1) graph' stubLoader)
33+
Map.size resultGraph < Map.size resultGraph' `shouldBe` True
34+
35+
it "cycles are ignored" $ do
36+
let graph' = Map.insert (pkgName "cycle") (Set.singleton (pkgName "cycle")) graph
37+
resultGraph = resolveDependencies Nothing graph stubLoader
38+
resultGraph' = resolveDependencies Nothing graph' stubLoader
39+
fmap Map.size resultGraph' `shouldBe` fmap ((+1) . Map.size) resultGraph
40+
41+
where graphElem e graph = Set.member e . Set.unions . Map.elems $ graph
42+
43+
{- Helper functions below -}
44+
45+
-- Unsafe internal helper to create a package name
46+
pkgName :: ByteString -> PackageName
47+
pkgName = fromMaybe failure . parsePackageName
48+
where
49+
failure = (error "Internal error during package name creation in DotSpec.pkgName")
50+
51+
-- Stub, simulates the function to load package dependecies
52+
stubLoader :: PackageName -> Identity (Set PackageName)
53+
stubLoader name = return . Set.fromList . map pkgName $ case show name of
54+
"StateVar" -> ["stm","transformers"]
55+
"array" -> []
56+
"bifunctors" -> ["semigroupoids","semigroups","tagged"]
57+
"binary" -> ["array","bytestring","containers"]
58+
"bytestring" -> ["deepseq","ghc-prim","integer-gmp"]
59+
"comonad" -> ["containers","contravariant","distributive"
60+
,"semigroups","tagged","transformers","transformers-compat"
61+
]
62+
"cont" -> ["StateVar","semigroups","transformers","transformers-compat","void"]
63+
"containers" -> ["array","deepseq","ghc-prim"]
64+
"deepseq" -> ["array"]
65+
"distributive" -> ["ghc-prim","tagged","transformers","transformers-compat"]
66+
"free" -> ["bifunctors","comonad","distributive","mtl"
67+
,"prelude-extras","profunctors","semigroupoids"
68+
,"semigroups","template-haskell","transformers"
69+
]
70+
"ghc" -> []
71+
"hashable" -> ["bytestring","ghc-prim","integer-gmp","text"]
72+
"integer" -> []
73+
"mtl" -> ["transformers"]
74+
"nats" -> []
75+
"one" -> ["free"]
76+
"prelude" -> []
77+
"profunctors" -> ["comonad","distributive","semigroupoids","tagged","transformers"]
78+
"semigroupoids" -> ["comonad","containers","contravariant","distributive"
79+
,"semigroups","transformers","transformers-compat"
80+
]
81+
"semigroups" -> ["bytestring","containers","deepseq","hashable"
82+
,"nats","text","unordered-containers"
83+
]
84+
"stm" -> ["array"]
85+
"tagged" -> ["template-haskell"]
86+
"template" -> []
87+
"text" -> ["array","binary","bytestring","deepseq","ghc-prim","integer-gmp"]
88+
"transformers" -> []
89+
"two" -> ["free","mtl","one","transformers"]
90+
"unordered" -> ["deepseq","hashable"]
91+
"void" -> ["ghc-prim","hashable","semigroups"]
92+
_ -> []

‎stack.cabal

+2
Original file line numberDiff line numberDiff line change
@@ -226,6 +226,8 @@ test-suite stack-test
226226
, resourcet
227227
, Cabal
228228
, text
229+
, optparse-applicative
230+
, bytestring
229231
default-language: Haskell2010
230232

231233
test-suite stack-integration-test

0 commit comments

Comments
 (0)