diff --git a/graphmod.cabal b/graphmod.cabal --- a/graphmod.cabal +++ b/graphmod.cabal @@ -1,5 +1,5 @@ name: graphmod -version: 1.2.2 +version: 1.2.3 license: BSD3 license-file: LICENSE author: Iavor S. Diatchki @@ -8,8 +8,8 @@ build-type: Simple cabal-version: >= 1.2 synopsis: Present the module dependencies of a program as a "dot" graph. -description: This package contains a program that can compute "dot" graphs - from the dependencies between a number of Haskell modules. +description: This package contains a program that computes "dot" graphs + from the dependencies of a number of Haskell modules. category: Development executable graphmod diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -3,9 +3,9 @@ import Text.Dot -import Control.Monad(when,forM_,(<=<),mplus,msum) +import Control.Monad(when,forM_,(<=<),mplus,msum,guard) import Control.Monad.Fix(mfix) -import Data.List(intersperse) +import Data.List(intersperse,partition) import Data.Maybe(mapMaybe,isJust,fromMaybe,listToMaybe) import qualified Data.IntMap as IMap import qualified Data.Map as Map @@ -28,7 +28,8 @@ | otherwise -> do g <- graph (add_current opts) (map to_input ms) - putStrLn (make_dot (use_clusters opts) g) + putStrLn (make_dot (color_scheme opts) + (use_clusters opts) g) where opts = foldr ($) default_opts fs _ -> hPutStrLn stderr $ @@ -49,7 +50,9 @@ type NodesC = Trie.Trie String [((NodeT,String),Int)] type Edges = IMap.IntMap Set.IntSet -data NodeT = ModuleNode | CollapsedNode + +data NodeT = ModuleNode + | CollapsedNode Bool -- ^ indicates if it contains module too deriving (Show,Eq,Ord) graph :: Opts -> [Input] -> IO (Edges, NodesC) @@ -109,40 +112,64 @@ Just t -> isIgnored t (qs,m) lookupNode :: ModName -> NodesC -> Maybe Int -lookupNode ([],m) (Trie.Sub _ mb) = lookup (ModuleNode,m) =<< mb +lookupNode ([],m) (Trie.Sub _ mb) = lookupBy (containsModule m) =<< mb lookupNode (q:qs,m) (Trie.Sub ts mb) = - (lookup (CollapsedNode,q) =<< mb) `mplus` + (lookupBy (isCollapsed q) =<< mb) `mplus` (lookupNode (qs,m) =<< Map.lookup q ts) +containsModule :: String -> (NodeT, String) -> Bool +containsModule q (ModuleNode, q1) = q == q1 +containsModule q (CollapsedNode withMod, q1) = withMod && q == q1 +isCollapsed :: String -> (NodeT, String) -> Bool +isCollapsed q (CollapsedNode _, q1) = q == q1 +isCollapsed _ (ModuleNode, _) = False + +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 () -> NodesC +collapseAll :: NodesC -> Trie.Trie String Bool -> NodesC collapseAll t0 = foldr (\q t -> fromMaybe t (collapse t q)) t0 . toList where - toList (Trie.Sub _ (Just _)) = return [] - toList (Trie.Sub as _) = do (q,t) <- Map.toList as - qs <- toList t - return (q:qs) + toList (Trie.Sub _ (Just x)) = return ([], x) + toList (Trie.Sub as Nothing) = do (q,t) <- Map.toList as + (qs,x) <- toList t + return (q:qs, x) --- We use the Maybe type to indicate when things changed. -collapse :: NodesC -> Qualifier -> Maybe NodesC -collapse _ [] = return Trie.empty -- Probably not terribly useful. +-- 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 (Trie.Sub ts mb) [q] = - do n <- getFirst =<< Map.lookup q ts - return $ Trie.Sub (Map.delete q ts) $ Just - $ ((CollapsedNode,q),n) : fromMaybe [] mb - where getFirst (Trie.Sub ts1 ms) = +collapse (Trie.Sub ts mb) ([q],alsoMod) = + do (n,withMod) <- fmap (\x -> (x,True)) useMod + `mplus` fmap (\x -> (x,False)) (getFirst =<< Map.lookup q ts) + + return $ Trie.Sub (Map.delete q ts) + $ Just $ ((CollapsedNode withMod,q),n) + : if withMod then others else allNodes + + where allNodes = fromMaybe [] mb + (thisNode,others) = partition (containsModule q . fst) allNodes + useMod = do guard alsoMod + listToMaybe (map snd thisNode) + + getFirst (Trie.Sub ts1 ms) = msum (fmap snd (listToMaybe =<< ms) : map getFirst (Map.elems ts1)) -collapse (Trie.Sub ts ms) (q : qs) = +collapse (Trie.Sub ts ms) (q : qs,x) = do t <- Map.lookup q ts - t1 <- collapse t qs + t1 <- collapse t (qs,x) return (Trie.Sub (Map.insert q t1 ts) ms) + + -- We use tries to group modules by directory. -------------------------------------------------------------------------------- @@ -150,45 +177,57 @@ -- Render edges and a trie into the dot language -------------------------------------------------------------------------------- -make_dot :: Bool -> (Edges,NodesC) -> String -make_dot cl (es,t) = +make_dot :: Int -> Bool -> (Edges,NodesC) -> String +make_dot col cl (es,t) = showDot $ - do if cl then make_clustered_dot 0 t - else make_unclustered_dot 0 "" t >> return () + do 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 -> userNodeId x .->. userNodeId y -make_clustered_dot :: Int -> NodesC -> Dot () + + +make_clustered_dot :: [Color] -> NodesC -> Dot () make_clustered_dot c (Trie.Sub xs ys) = - do forM_ (fromMaybe [] ys) $ \((t,ls),n) -> + do let col = renderColor (head c) + forM_ (fromMaybe [] ys) $ \((t,ls),n) -> userNode (userNodeId n) $ - ("label",ls) : + [ ("label",ls) ] ++ case t of - CollapsedNode -> [ ("shape","box") - , ("color",colors !! c) - , ("style","filled") - ] - _ -> [] + 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" , colors !! c) + attribute ("color" , col) attribute ("style", "filled") - let c1 = c + 1 - c1 `seq` make_clustered_dot c1 sub + make_clustered_dot (tail c) sub -make_unclustered_dot :: Int -> String -> NodesC -> Dot Int +make_unclustered_dot :: [Color] -> String -> NodesC -> Dot [Color] make_unclustered_dot c pre (Trie.Sub xs ys') = - do let ys = fromMaybe [] ys' + do let col = renderColor (head c) + let ys = fromMaybe [] ys' forM_ ys $ \((t,ls),n) -> userNode (userNodeId n) $ - (if t == CollapsedNode then [("shape","box")] else []) - ++ [ ("label", pre ++ ls) - , ("fillcolor", colors !! c) + [ ("fillcolor", col) , ("style", "filled") - ] - let c1 = if null ys then c else c + 1 + , ("label", pre ++ ls) + ] ++ + case t of + CollapsedNode False -> [ ("shape", "box"), ("color", col) ] + CollapsedNode True -> [ ("shape", "box") ] + ModuleNode -> [] + + let c1 = if null ys then c else tail c c1 `seq` loop (Map.toList xs) c1 where loop ((name,sub):ms) c1 = @@ -200,19 +239,30 @@ type Color = (Int,Int,Int) --- XXX: generate all? -colors :: [String] -colors = map col (ys1 ++ ys2) ++ repeat "#cccccc" +colors :: Int -> [Color] +colors n = light_dark $ drop n $ cycle colorses + +renderColor :: Color -> String +renderColor (x,y,z) = '#' : showHex (mk x) (showHex (mk y) (showHex (mk z) "")) + where mk n = 0xFF - n * 0x33 + + +light_dark :: [[a]] -> [a] +light_dark (xs : ys : zs) = xs ++ reverse ys ++ light_dark zs +light_dark [x] = x +light_dark [] = [] + + + +colorses :: [[Color]] +colorses = [green, cyan, blue, magenta, red, yellow] where - xs1 :: [Color] - xs1 = [ (1,0,1), (2,0,2), (3,0,3), (2,1,2), (3,1,3), (3,2,3) ] - xs2 = map rotR xs1 - xs3 = map rotR xs2 - ys1 = xs1 ++ xs2 ++ xs3 - ys2 = map compl (reverse ys1) + red :: [Color] + red = [ (0,1,1), (0,2,2), (0,3,3), (1,2,2), (1,3,3), (2,3,3) ] + green = map rotR red + blue = map rotR green + [cyan,magenta,yellow] = map (map compl . reverse) [red, green, blue] - col (x,y,z) = '#' : (showHex (mk x) $ showHex (mk y) $ showHex (mk z) "") - mk n = 0xFF - n * 0x33 rotR (x,y,z) = (z,x,y) compl (x,y,z) = (3-x,3-y,3-z) @@ -239,8 +289,12 @@ , with_missing :: Bool , use_clusters :: Bool , ignore_mods :: IgnoreSet - , collapse_quals :: Trie.Trie String () + , collapse_quals :: Trie.Trie String Bool + -- ^ The "Bool" tells us if we should collapse modules as well. + -- For example, "True" says that A.B.C would collapse not only A.B.C.* + -- but also the module A.B.C, if it exists. , show_version :: Bool + , color_scheme :: Int } type IgnoreSet = Trie.Trie String IgnoreSpec @@ -250,40 +304,47 @@ default_opts :: Opts default_opts = Opts - { inc_dirs = [] - , quiet = False - , with_missing = False - , use_clusters = True - , ignore_mods = Trie.empty - , collapse_quals = Trie.empty + { inc_dirs = [] + , quiet = False + , with_missing = False + , use_clusters = True + , ignore_mods = Trie.empty + , collapse_quals = Trie.empty , show_version = False + , color_scheme = 0 } options :: [OptDescr OptT] options = [ Option ['q'] ["quiet"] (NoArg set_quiet) - "Do not show warnings." + "Do not show warnings" , Option ['i'] [] (ReqArg add_inc "DIR") - "Add a search directory." + "Add a search directory" , Option ['a'] ["all"] (NoArg set_all) - "Add nodes for missing modules." + "Add nodes for missing modules" , Option [] ["no-cluster"] (NoArg set_no_cluster) - "Do not cluster directories." + "Do not cluster directories" - , Option ['r'] ["remove-module"] (ReqArg add_ignore_mod "MODULE") - "Remove a module from the graph." + , Option ['r'] ["remove-module"] (ReqArg add_ignore_mod "NAME") + "Do not display module NAME" - , Option ['R'] ["remove-qual"] (ReqArg add_ignore_qual "QUALIFIER") - "Remove all modules that start with the given qualifier." + , Option ['R'] ["remove-qual"] (ReqArg add_ignore_qual "NAME") + "Do not display modules NAME.*" - , Option ['c'] ["collapse"] (ReqArg add_collapse_qual "QUALIFIER") - "Display modules matching the qualifier as a single node." + , Option ['c'] ["collapse"] (ReqArg (add_collapse_qual False) "NAME") + "Display modules NAME.* as one node" + , Option ['C'] ["collapse-module"] (ReqArg (add_collapse_qual True) "NAME") + "Display modules NAME and NAME.* as one node" + + , Option ['s'] ["colors"] (ReqArg add_color_scheme "NUM") + "Choose a color scheme number (0-5)" + , Option ['v'] ["version"] (NoArg set_show_version) - "Display the current version." + "Show the current version." ] add_current :: OptT @@ -319,13 +380,19 @@ add_ignore_qual s o = o { ignore_mods = Trie.insert (splitQualifier s) (const IgnoreAll) (ignore_mods o) } -add_collapse_qual :: String -> OptT -add_collapse_qual s o = o { collapse_quals = upd (splitQualifier s) +add_color_scheme :: String -> OptT +add_color_scheme n o = o { color_scheme = case reads n of + [(x,"")] -> x + _ -> color_scheme default_opts } + +add_collapse_qual :: Bool -> String -> OptT +add_collapse_qual m s o = o { collapse_quals = upd (splitQualifier s) (collapse_quals o) } where + upd [] (Trie.Sub xs (Just _)) = Trie.Sub xs (Just m) upd _ t@(Trie.Sub _ (Just _)) = t - upd [] _ = Trie.Sub Map.empty (Just ()) + upd [] _ = Trie.Sub Map.empty (Just m) upd (q:qs) (Trie.Sub as _) = Trie.Sub (Map.alter add q as) Nothing where add j = Just $ upd qs $ fromMaybe Trie.empty j