graphmod 1.2.9 → 1.3
raw patch · 4 files changed
+305/−156 lines, 4 filesdep ~haskell-lexer
Dependency ranges changed: haskell-lexer
Files
- CHANGELOG.md +54/−0
- graphmod.cabal +3/−2
- src/Main.hs +245/−154
- src/Trie.hs +3/−0
+ CHANGELOG.md view
@@ -0,0 +1,54 @@+* Version 1.3+ - Corrects collapsing logic.+ - Change node coloring in clusters:+ * Clusters are displayed with various shades of gray+ * Nodes in a cluster are all the same color+ - Change to clustering logic: by default, a module that has the same+ name as a cluster will be rendered inside the cluster. One can tell+ that the module is different because it will still have the color of+ modules from the cluster "above". Also, the module has a border to+ empahsize the difference.+ This behavior may be disabled using `--no-module-in-cluster`++* Version 1.2.9+ - Support for Cabal: if we find a cabal file, we add all modules in it+ - Render `{-# SOURCE #-}` imports specially.++* Version 1.2.7+ Correct the prunning logic.++* Version 1.2.6++ Add support for parsing GHC's `.import` files. These may be produced+ by running GHC with `-ddump-minimal-imports`++* Version 1.2.5++ Add support for pruning the dependecy graph.++* Version 1.2.3++ [Collapse Modules]+ The flag `--collapse-module` (`-C` for short) adds a new mode of collapsing+ multiples nodes into a single one. This is similar to `--collapse` except+ that the parameter can refer either to a module name, or to a module prefix.+ So, for example, `--collapse-module=A.B` will use a single node for the+ module A.B (if there is one), as well as for any module that starts with+ the prefix A.B (e.g., A.B.C).++ "Collapsed" nodes are represented with a box.++ Collapsed nodes corresponding to modules have a border, while ones which+ correspond to just a prefix do not have a border.+++ [Color Schemes]+ The flag `--colors` (`-s` for short) enables users to choose from+ a set of predefined color schemes.+++* Version 1.2.2++ [Show Version]+ The flag `--version` (`-v` for short) shows graphmod's version.+
graphmod.cabal view
@@ -1,5 +1,5 @@ name: graphmod-version: 1.2.9+version: 1.3 license: BSD3 license-file: LICENSE author: Iavor S. Diatchki@@ -13,12 +13,13 @@ category: Development tested-with: GHC==7.10.3, GHC==7.8.4+extra-source-files: CHANGELOG.md executable graphmod main-is: Main.hs other-modules: Utils, Trie, Paths_graphmod, CabalSupport build-depends: base < 5, directory, filepath, dotgen >= 0.2 && < 0.5,- haskell-lexer, containers, Cabal+ haskell-lexer >= 1.0.1, containers, Cabal hs-source-dirs: src ghc-options: -Wall -O2
src/Main.hs view
@@ -1,18 +1,16 @@ import Utils import qualified Trie import CabalSupport(parseCabalFile,Unit(..))- import Text.Dot -import Control.Monad(when,forM_,(<=<),mplus,msum,guard)+import Control.Monad(when,forM_,msum,guard,unless) import Control.Monad.Fix(mfix) import Control.Exception(catch,SomeException(..))-import Data.List(intersperse,partition)-import Data.Maybe(mapMaybe,isJust,fromMaybe,listToMaybe)+import Data.List(intersperse,transpose)+import Data.Maybe(isJust,fromMaybe,listToMaybe) import qualified Data.IntMap as IMap import qualified Data.Map as Map import qualified Data.IntSet as ISet-import qualified Data.Set as Set import System.Environment(getArgs) import System.IO(hPutStrLn,stderr) import System.FilePath@@ -34,8 +32,7 @@ do (incs,inps) <- fromCabal (use_cabal opts) g <- graph (foldr add_inc (add_current opts) incs) (inps ++ map to_input ms)- putStr (make_dot (graph_size opts) (color_scheme opts)- (use_clusters opts) g)+ putStr (make_dot opts g) where opts = foldr ($) default_opts fs _ -> hPutStrLn stderr $@@ -53,95 +50,126 @@ --- type Nodes = Trie.Trie String [(String,Int)]-type NodesC = Trie.Trie String [((NodeT,String),Int)]+type Nodes = Trie.Trie String [((NodeT,String),Int)] -- Maps a path to: ((node, label), nodeId) -type Edges = IMap.IntMap ISet.IntSet-type FinalEdges = IMap.IntMap (Set.Set (Int,ImpType))-+type Edges = IMap.IntMap ISet.IntSet data NodeT = ModuleNode- | CollapsedNode Bool NodesC++ | ModuleInItsCluster+ -- ^ A module that has been relocated to its cluster++ | Redirect+ -- ^ This is not rendered. It is there to support replacing+ -- one node with another (e.g., when collapsing)++ | Deleted+ -- ^ This is not rendered, and edges to/from it are also+ -- not rendered.++ | CollapsedNode Bool -- ^ indicates if it contains module too.- -- Also includes the collapsed tree, so we know whether to- -- draw edges "into" the collapsed node or not. deriving (Show,Eq,Ord) -graph :: Opts -> [Input] -> IO (FinalEdges, NodesC)-graph opts inputs = fmap maybePrune $ mfix $ \ ~(_,_,mods) ->+data AllEdges = AllEdges+ { normalEdges :: Edges+ , sourceEdges :: Edges+ }++noEdges :: AllEdges+noEdges = AllEdges { normalEdges = IMap.empty+ , sourceEdges = IMap.empty+ }++graph :: Opts -> [Input] -> IO (AllEdges, Nodes)+graph opts inputs = fmap maybePrune $ mfix $ \ ~(_,mods) -> -- NOTE: 'mods' is the final value of 'done' in the funciton 'loop'. - let nodeFor x = lookupNode x mods -- Recursion happens here!+ let nodeFor x = lookupMod x mods -- Recursion happens here! - loop :: NodesC ->- Edges {- normal edges -} ->- Edges {- SOURCE (i.e., back) edges -} ->- Int {- size -} ->- [Input] {- root files/modules -} ->- IO (Edges {- normal-}, Edges {- SOURCES -}, NodesC)+ loop :: Nodes ->+ AllEdges {- all kinds of edges -} ->+ Int {- size -} ->+ [Input] {- root files/modules -} ->+ IO (AllEdges, Nodes) - loop done es bes _ [] =- return (es, bes, collapseAll done (collapse_quals opts))+ loop done es _ [] =+ return (es, collapseAll opts done (collapse_quals opts)) - loop done es bes size (Module m : todo)- | ignore done m = loop done es bes size todo+ loop done es size (Module m : todo)+ | ignore done m = loop done es size todo | otherwise = do fs <- modToFile (inc_dirs opts) m case fs of [] -> do warn opts (notFoundMsg m) if with_missing opts- then add done es bes size m [] todo- else loop done es bes size todo+ then add done es size m [] todo+ else loop done es size todo f : gs -> do when (not (null gs)) (warn opts (ambigMsg m fs)) (x,imps) <- parseFile f- add done es bes size x imps todo+ add done es size x imps todo - loop done es bes size (File f : todo) =+ loop done es size (File f : todo) = do (m,is) <- parseFile f if ignore done m- then loop done es bes size todo- else add done es bes size m is todo+ then loop done es size todo+ else add done es size m is todo - add done es bes size m imps ms =- let (sourceImps,normalImps) = partition ((== SourceImp) . impType) imps- srcMods = map impMod sourceImps- nrmMods = map impMod normalImps+ add done es size m imps ms = size1 `seq` loop done1 es1 size1 ms1+ where+ es1 = case nodeFor m of+ Just src -> foldr (addEdge src) es imps+ Nothing -> es+ size1 = size + 1+ ms1 = map (Module . impMod) imps ++ ms+ done1 = insMod m size done - ms1 = map Module (srcMods ++ nrmMods) ++ ms - normIds = ISet.fromList (mapMaybe nodeFor nrmMods)- srcIds = ISet.fromList (mapMaybe nodeFor srcMods)+ addEdge nFrom i aes =+ case nodeFor (impMod i) of+ Nothing -> aes+ Just nTo ->+ case impType i of+ SourceImp ->+ aes { sourceEdges = insSet nFrom nTo (sourceEdges aes) }+ NormalImp ->+ aes { normalEdges = insSet nFrom nTo (normalEdges aes) } - size1 = 1 + size - (es1,bes1) = case nodeFor m of- Just n -> ( IMap.insertWith ISet.union n normIds es- , IMap.insertWith ISet.union n srcIds bes- )- Nothing -> (es,bes)- in size1 `seq` loop (insMod m size done) es1 bes1 size1 ms1+ in loop Trie.empty noEdges 0 inputs - insMod (q,m) n t = Trie.insert q (\xs -> ((ModuleNode,m),n)- : fromMaybe [] xs) t- lookupMod (q,m) = lookup (ModuleNode,m) <=< Trie.lookup q- ignore done m = isIgnored (ignore_mods opts) m+ where+ maybePrune (es,ns)+ | prune_edges opts = (es { normalEdges = pruneEdges (normalEdges es) }, ns)+ | otherwise = (es,ns)++ ignore done m = isIgnored (ignore_mods opts) m || isJust (lookupMod m done) - in loop Trie.empty IMap.empty IMap.empty 0 inputs - where- jn xs ys = IMap.unionWith Set.union (fmap (cvt SourceImp) xs)- (fmap (cvt NormalImp) ys)- cvt t xs = Set.fromList [ (x, t) | x <- ISet.toList xs ] - maybePrune (es,bes,ns)- | prune_edges opts = (jn bes (pruneEdges es), ns)- | otherwise = (jn bes es,ns) +lookupMod :: ModName -> Nodes -> Maybe Int+lookupMod (q,m) t = (msum . map isThis =<< Trie.lookup q t)+ where isThis ((ty,m'),nid) =+ case ty of+ CollapsedNode False -> Nothing -- Keep looking for the actual node+ Deleted -> Nothing+ _ -> guard (m == m') >> return nid +insMod :: ModName -> Int -> Nodes -> Nodes+insMod (q,m) n t = Trie.insert q ins t+ where+ ins xs = case xs of+ Nothing -> [ ((ModuleNode,m),n) ]+ Just ys -> ((ModuleNode,m),n) : ys +insSet :: Int -> Int -> Edges -> Edges+insSet x y m = IMap.insertWith ISet.union x (ISet.singleton y) m ++ pruneEdges :: Edges -> Edges pruneEdges es = foldr checkEdges es (IMap.toList es) where@@ -173,32 +201,12 @@ Nothing -> False Just t -> isIgnored t (qs,m) -lookupNode :: ModName -> NodesC -> Maybe Int-lookupNode ([],m) (Trie.Sub _ mb) = lookupBy (containsModule m) =<< mb -lookupNode (q:qs,m) (Trie.Sub ts mb) =- (lookupBy containsNode =<< mb) `mplus`- (lookupNode (qs,m) =<< Map.lookup q ts)-- where- containsNode :: (NodeT, String) -> Bool- containsNode (CollapsedNode _ t, q1) = q == q1 && isJust (lookupNode (qs,m) t)- containsNode (ModuleNode, _) = False--containsModule :: String -> (NodeT, String) -> Bool-containsModule q (ModuleNode, q1) = q == q1-containsModule q (CollapsedNode withMod _, q1) = withMod && q == q1--lookupBy :: (a -> Bool) -> [(a,b)] -> Maybe b-lookupBy p xs = listToMaybe [ y | (x,y) <- xs, p x ]---- -- XXX: We could combine collapseAll and collapse into a single pass -- to avoid traversing form the root each time.-collapseAll :: NodesC -> Trie.Trie String Bool -> NodesC-collapseAll t0 = foldr (\q t -> fromMaybe t (collapse t q)) t0 . toList+collapseAll :: Opts -> Nodes -> Trie.Trie String Bool -> Nodes+collapseAll opts t0 =+ foldr (\q t -> fromMaybe t (collapse opts t q)) t0 . toList where toList (Trie.Sub _ (Just x)) = return ([], x) toList (Trie.Sub as Nothing) = do (q,t) <- Map.toList as@@ -206,35 +214,79 @@ return (q:qs, x) -- NOTE: We use the Maybe type to indicate when things changed.-collapse :: NodesC -> (Qualifier,Bool) -> Maybe NodesC-collapse _ ([],_) = return Trie.empty -- Probably not terribly useful.+collapse :: Opts -> Nodes -> (Qualifier,Bool) -> Maybe Nodes+collapse _ _ ([],_) = return Trie.empty -- Probably not terribly useful. -collapse (Trie.Sub ts mb) ([q],alsoMod) =- do (n,withMod) <- fmap (\x -> (x,True)) useMod- `mplus` fmap (\x -> (x,False)) (getFirst =<< thisTrie)+collapse opts (Trie.Sub ts mb) ([q],alsoMod) =+ do t <- Map.lookup q ts+ let will_move = mod_in_cluster opts && Map.member q ts+ (thisMod,otherMods)+ | alsoMod || will_move = case findThisMod =<< mb of+ Nothing -> (Nothing, [])+ Just (nid,rest) -> (Just nid, rest)+ | otherwise = (Nothing, fromMaybe [] mb) - return $ Trie.Sub (Map.delete q ts)- $ Just $ ((CollapsedNode withMod collapsedTrie, q),n)- : if withMod then others else allNodes+ -- use this node-id to represent the collapsed cluster+ rep <- msum [ thisMod, getFirst t ] - where thisTrie = Map.lookup q ts- collapsedTrie = fromMaybe Trie.empty thisTrie- allNodes = fromMaybe [] mb- (thisNode,others) = partition (containsModule q . fst) allNodes- useMod = do guard alsoMod- listToMaybe (map snd thisNode)+ let close ((_,nm),_) = ((if will_move then Deleted else Redirect,nm),rep)+ ts' = Map.insert q (fmap (map close) t) ts+ newT | alsoMod || not will_move = CollapsedNode (isJust thisMod)+ | otherwise = ModuleNode - getFirst (Trie.Sub ts1 ms) =- msum (fmap snd (listToMaybe =<< ms) : map getFirst (Map.elems ts1))+ return (Trie.Sub ts' (Just (((newT,q),rep) : otherMods)))+ where+ findThisMod (((_,nm),nid) : more) | nm == q = Just (nid,more)+ findThisMod (x : more) = do (yes,more') <- findThisMod more+ return (yes, x:more')+ findThisMod [] = Nothing -collapse (Trie.Sub ts ms) (q : qs,x) =+ getFirst (Trie.Sub ts1 ms) =+ msum (fmap snd (listToMaybe =<< ms) : map getFirst (Map.elems ts1))++collapse opts (Trie.Sub ts ms) (q : qs,x) = do t <- Map.lookup q ts- t1 <- collapse t (qs,x)+ t1 <- collapse opts t (qs,x) return (Trie.Sub (Map.insert q t1 ts) ms) +-- | If inside cluster A.B we have a module M,+-- and there is a cluster A.B.M, then move M into that cluster as a special node+moveModulesInCluster :: Nodes -> Nodes+moveModulesInCluster (Trie.Sub su0 ms0) =+ goMb (fmap moveModulesInCluster su0) ms0+ where+ goMb su mb =+ case mb of+ Nothing -> Trie.Sub su Nothing+ Just xs -> go [] su xs + go ns su xs =+ case xs of+ [] -> Trie.Sub su $ if null ns then Nothing else Just ns+ y : ys ->+ case check y su of+ Left it -> go (it : ns) su ys+ Right su1 -> go ns su1 ys++ check it@((nt,s),i) mps =+ case nt of+ ModuleNode ->+ case Map.lookup s mps of+ Nothing -> Left it+ Just t -> Right (Map.insert s (Trie.insert [] add t) mps)+ where+ newM = ((ModuleInItsCluster,s),i)+ add xs = [newM] ++ fromMaybe [] xs+++ ModuleInItsCluster -> Left it+ CollapsedNode _ -> Left it+ Redirect -> Left it+ Deleted -> Left it++ -- We use tries to group modules by directory. -------------------------------------------------------------------------------- @@ -242,61 +294,92 @@ -- Render edges and a trie into the dot language ---------------------------------------------------------------------------------make_dot :: String -> Int -> Bool -> (FinalEdges,NodesC) -> String-make_dot sz col cl (es,t) =+make_dot :: Opts -> (AllEdges,Nodes) -> String+make_dot opts (es,t) = showDot $- do attribute ("size", sz)+ do attribute ("size", graph_size opts) attribute ("ratio", "fill")- if cl then make_clustered_dot (colors col) t- else make_unclustered_dot (colors col) "" t >> return ()- forM_ (IMap.toList es) $ \(x,ys) ->- forM_ (Set.toList ys) $ \(y,t) ->- let attrs = case t of- NormalImp -> []- SourceImp -> [("style","dashed")]- in edge (userNodeId x) (userNodeId y) attrs+ let cols = colors (color_scheme opts)+ if use_clusters opts+ then make_clustered_dot cols $+ if mod_in_cluster opts then moveModulesInCluster t else t+ else make_unclustered_dot cols "" t >> return ()+ genEdges normalAttr (normalEdges es)+ genEdges sourceAttr (sourceEdges es)+ where+ normalAttr _x _y = []+ sourceAttr _x _y = [("style","dashed")] + genEdges attr edges =+ forM_ (IMap.toList edges) $ \(x,ys) ->+ forM_ (ISet.toList ys) $ \y ->+ edge (userNodeId x) (userNodeId y) (attr x y) -make_clustered_dot :: [Color] -> NodesC -> Dot ()-make_clustered_dot c (Trie.Sub xs ys) =- do let col = renderColor (head c)- forM_ (fromMaybe [] ys) $ \((t,ls),n) ->- userNode (userNodeId n) $- [ ("label",ls) ] ++- case t of- CollapsedNode False _ -> [ ("shape", "box")- , ("style","filled")- , ("color", col)- ]- CollapsedNode True _ -> [ ("shape", "box")- , ("fillcolor", col)- , ("style","filled")- ]- ModuleNode -> [] - forM_ (Map.toList xs) $ \(name,sub) ->- cluster $- do attribute ("label", name)- attribute ("color" , col)- attribute ("style", "filled")- make_clustered_dot (tail c) sub -make_unclustered_dot :: [Color] -> String -> NodesC -> Dot [Color]++make_clustered_dot :: [Color] -> Nodes -> Dot ()+make_clustered_dot cs0 su = go (0,0,0) cs0 su >> return ()+ where+ clusterC = "#0000000F"++ go outer_col ~(this_col:more) (Trie.Sub xs ys) =+ do let outerC = renderColor outer_col+ thisC = renderColor this_col++ forM_ (fromMaybe [] ys) $ \((t,ls),n) ->+ unless (t == Redirect || t == Deleted) $+ userNode (userNodeId n) $+ [ ("label",ls) ] +++ case t of+ CollapsedNode False -> [ ("shape", "box")+ , ("style","filled")+ , ("color", clusterC)+ ]+ CollapsedNode True -> [ ("style","filled")+ , ("fillcolor", clusterC)+ ]+ ModuleInItsCluster -> [ ("style","filled,bold")+ , ("fillcolor", outerC)+ ]++ ModuleNode -> [ ("style", "filled")+ , ("fillcolor", thisC)+ , ("penwidth","0")+ ]+ Redirect -> []+ Deleted -> []+ goSub this_col more (Map.toList xs)++ goSub _ cs [] = return cs+ goSub outer_col cs ((name,sub) : more) =+ do (_,cs1) <- cluster $ do attribute ("label", name)+ attribute ("color" , clusterC)+ attribute ("style", "filled")+ go outer_col cs sub++ goSub outer_col cs1 more+++make_unclustered_dot :: [Color] -> String -> Nodes -> Dot [Color] make_unclustered_dot c pre (Trie.Sub xs ys') = do let col = renderColor (head c) let ys = fromMaybe [] ys' forM_ ys $ \((t,ls),n) ->- userNode (userNodeId n) $- [ ("fillcolor", col)- , ("style", "filled")- , ("label", pre ++ ls)- ] ++- case t of- CollapsedNode False _ -> [ ("shape", "box"), ("color", col) ]- CollapsedNode True _ -> [ ("shape", "box") ]- ModuleNode -> []+ userNode (userNodeId n) $+ [ ("fillcolor", col)+ , ("style", "filled")+ , ("label", pre ++ ls)+ ] +++ case t of+ CollapsedNode False -> [ ("shape", "box"), ("color", col) ]+ CollapsedNode True -> [ ("shape", "box") ]+ Redirect -> []+ ModuleInItsCluster -> []+ ModuleNode -> []+ Deleted -> [] let c1 = if null ys then c else tail c c1 `seq` loop (Map.toList xs) c1@@ -311,25 +394,25 @@ type Color = (Int,Int,Int) colors :: Int -> [Color]-colors n = light_dark $ drop n $ cycle colorses+colors n = cycle $ mix_colors $ drop n $ palettes renderColor :: Color -> String renderColor (x,y,z) = '#' : showHex (mk x) (showHex (mk y) (showHex (mk z) ""))- where mk n = 0xFF - n * 0x33+ where mk n = 0xFF - n * 0x44 -light_dark :: [[a]] -> [a]-light_dark (xs : ys : zs) = xs ++ reverse ys ++ light_dark zs-light_dark [x] = x-light_dark [] = []-+mix_colors :: [[a]] -> [a]+mix_colors css = mk set1 ++ mk set2+ where+ (set1,set2) = unzip $ map (splitAt 3) css+ mk = concat . transpose -colorses :: [[Color]]-colorses = [green, cyan, blue, magenta, red, yellow]+palettes :: [[Color]]+palettes = [green, yellow, blue, red, cyan, magenta ] where red :: [Color]- red = [ (0,1,1), (0,2,2), (0,3,3), (1,2,2), (1,3,3), (2,3,3) ]+ red = [ (0,1,1), (0,2,2), (0,3,3), (1,2,3), (1,3,3), (2,3,3) ] green = map rotR red blue = map rotR green [cyan,magenta,yellow] = map (map compl . reverse) [red, green, blue]@@ -384,6 +467,7 @@ , quiet :: Bool , with_missing :: Bool , use_clusters :: Bool+ , mod_in_cluster:: Bool , ignore_mods :: IgnoreSet , collapse_quals :: Trie.Trie String Bool -- ^ The "Bool" tells us if we should collapse modules as well.@@ -408,6 +492,7 @@ , quiet = False , with_missing = False , use_clusters = True+ , mod_in_cluster = True , ignore_mods = Trie.empty , collapse_quals = Trie.empty , show_version = False@@ -431,6 +516,9 @@ , Option [] ["no-cluster"] (NoArg set_no_cluster) "Do not cluster directories" + , Option [] ["no-module-in-cluster"] (NoArg set_no_mod_in_cluster)+ "Do not place modules matching a cluster's name inside it."+ , Option ['r'] ["remove-module"] (ReqArg add_ignore_mod "NAME") "Do not display module NAME" @@ -475,6 +563,9 @@ set_no_cluster :: OptT set_no_cluster o = o { use_clusters = False }++set_no_mod_in_cluster :: OptT+set_no_mod_in_cluster o = o { mod_in_cluster = False } add_inc :: FilePath -> OptT add_inc d o = o { inc_dirs = d : inc_dirs o }
src/Trie.hs view
@@ -17,3 +17,6 @@ insert [] f (Sub as b) = Sub as (Just (f b)) insert (k:ks) f (Sub as b) = Sub (Map.alter upd k as) b where upd j = Just $ insert ks f $ fromMaybe empty j++instance Functor (Trie a) where+ fmap f (Sub m mb) = Sub (fmap (fmap f) m) (fmap f mb)