diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. + diff --git a/graphmod.cabal b/graphmod.cabal --- a/graphmod.cabal +++ b/graphmod.cabal @@ -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 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 } diff --git a/src/Trie.hs b/src/Trie.hs --- a/src/Trie.hs +++ b/src/Trie.hs @@ -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)