graphmod 1.2.2 → 1.2.3
raw patch · 2 files changed
+145/−78 lines, 2 files
Files
- graphmod.cabal +3/−3
- src/Main.hs +142/−75
graphmod.cabal view
@@ -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
src/Main.hs view
@@ -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