graphmod 1.1.3 → 1.2
raw patch · 4 files changed
+254/−106 lines, 4 filesdep +containersdep ~basedep ~dotgen
Dependencies added: containers
Dependency ranges changed: base, dotgen
Files
- graphmod.cabal +8/−7
- src/Main.hs +201/−80
- src/Trie.hs +19/−0
- src/Utils.hs +26/−19
graphmod.cabal view
@@ -1,5 +1,5 @@ name: graphmod-version: 1.1.3+version: 1.2 license: BSD3 license-file: LICENSE author: Iavor S. Diatchki@@ -7,14 +7,15 @@ homepage: http://github.com/yav/graphmod build-type: Simple cabal-version: >= 1.2-synopsis: Present the module dependecies of a program as a "dot" graph.-description: This package contains a program that can compute "dot" grpahs- from the dependecies between a number of Haskell modules.+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. category: Development executable graphmod main-is: Main.hs- other-modules: Utils- build-depends: base, directory, filepath, dotgen >= 0.2 && < 0.3,- haskell-lexer+ other-modules: Utils, Trie+ build-depends: base < 5, directory, filepath, dotgen >= 0.2 && < 0.5,+ haskell-lexer, containers hs-source-dirs: src+ ghc-options: -Wall -O2
src/Main.hs view
@@ -1,17 +1,22 @@ import Utils+import qualified Trie import Text.Dot -import Control.Monad(when,forM_)+import Control.Monad(when,forM_,(<=<),mplus,msum) import Control.Monad.Fix(mfix) import Data.List(intersperse)-import Data.Maybe(mapMaybe,isJust)+import Data.Maybe(mapMaybe,isJust,fromMaybe,listToMaybe)+import qualified Data.IntMap as IMap+import qualified Data.Map as Map+import qualified Data.IntSet as Set import System.Environment(getArgs) import System.IO(hPutStrLn,stderr) import System.FilePath import System.Console.GetOpt import Numeric(showHex) +main :: IO () main = do xs <- getArgs let (fs, ms, errs) = getOpt Permute options xs case errs of@@ -31,80 +36,131 @@ +-- type Nodes = Trie.Trie String [(String,Int)]+type NodesC = Trie.Trie String [((NodeT,String),Int)]+type Edges = IMap.IntMap Set.IntSet -type Edges = [(Int,[Int])]+data NodeT = ModuleNode | CollapsedNode+ deriving (Show,Eq,Ord) -graph :: Opts -> [Input] -> IO (Edges, Trie)-graph opts ms = mfix (\ ~(_,g) -> loop g empty [] 0 ms)- where- loop :: Trie -> Trie -> Edges -> Int -> [Input] -> IO (Edges, Trie)- loop _ done es _ [] = return (es,done)- loop mods done es size (Module m:ms)- | isJust (lkp done m) = loop mods done es size ms- | otherwise =- do fs <- modToFile (inc_dirs opts) m- let size1 = size + 1- seq size1 $ case fs of- [] -> do warn opts (notFoundMsg m)- if with_missing opts- then add mods done es size m [] ms- else loop mods done es size ms- f : gs -> do when (not (null gs)) (warn opts (ambigMsg m fs))- (x,imps) <- parseFile f- add mods done es size x imps ms+graph :: Opts -> [Input] -> IO (Edges, NodesC)+graph opts inputs = mfix $ \ ~(_,mods) ->+ -- NOTE: 'mods' is the final value of 'done' in the funciton 'loop'. - loop mods done es size (File f:ms) =- do (m,is) <- parseFile f- case lkp done m of- Just {} -> loop mods done es size ms- Nothing -> add mods done es size m is ms+ let nodeFor x = lookupNode x mods -- Recursion happens here! - add mods done es size m imps ms =- let deps = mapMaybe (lkp mods) imps- size1 = size + 1- in size1 `seq` loop mods (ins (m,size) done)- ((size,deps) : es)- size1- (map Module imps ++ ms)+ loop :: NodesC -> Edges -> Int -> [Input] -> IO (Edges, NodesC) + loop done es _ [] = return (es, collapseAll done (collapse_quals opts)) + 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 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 size x imps todo --- We use tries to group modules by directory.---------------------------------------------------------------------------------+ loop done es size (File f : todo) =+ do (m,is) <- parseFile f+ if ignore done m+ then loop done es size todo+ else add done es size m is todo --- | The labels on the nodes correspond to directories,--- the nodes on the leaves correspond to (unqualified) modules.--- Eeach module has a unique number.-data Trie = Sub [(String, Trie)] [(String,Int)] deriving Show-empty = Sub [] []+ add done es size m imps ms =+ let ms1 = map Module imps ++ ms+ imp_ids = Set.fromList (mapMaybe nodeFor imps)+ size1 = 1 + size+ es1 = case nodeFor m of+ Just n -> IMap.insertWith Set.union n imp_ids es+ Nothing -> es+ in size1 `seq` loop (insMod m size done) es1 size1 ms1 -lkp (Sub _ bs) ([],a) = lookup a bs-lkp (Sub as _) (k:ks,a) = (`lkp` (ks,a)) =<< lookup k as+ 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+ || isJust (lookupMod m done) + in loop Trie.empty IMap.empty 0 inputs -ins (([],x),n) (Sub as bs) = Sub as ((x,n):bs)-ins ((a:as,x),n) (Sub ts bs) = Sub (upd ts) bs- where new = ((as,x),n) - upd ((k,t):ts)- | k < a = (k,t) : upd ts- | k == a = (k, ins new t) : ts- upd ts = (a, ins new empty) : ts+isIgnored :: IgnoreSet -> ModName -> Bool+isIgnored (Trie.Sub _ (Just IgnoreAll)) _ = True+isIgnored (Trie.Sub _ (Just (IgnoreSome ms))) ([],m) = elem m ms+isIgnored (Trie.Sub _ Nothing) ([],_) = False+isIgnored (Trie.Sub ts _) (q:qs,m) =+ case Map.lookup q ts of+ Nothing -> False+ Just t -> isIgnored t (qs,m) +lookupNode :: ModName -> NodesC -> Maybe Int+lookupNode ([],m) (Trie.Sub _ mb) = lookup (ModuleNode,m) =<< mb --- Render edges and a trie into the dot language+lookupNode (q:qs,m) (Trie.Sub ts mb) =+ (lookup (CollapsedNode,q) =<< mb) `mplus`+ (lookupNode (qs,m) =<< Map.lookup q ts)+++-- 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 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)++-- We use the Maybe type to indicate when things changed.+collapse :: NodesC -> Qualifier -> 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.empty $ Just+ $ ((CollapsedNode,q),n) : fromMaybe [] mb+ where getFirst (Trie.Sub ts1 ms) =+ msum (fmap snd (listToMaybe =<< ms) : map getFirst (Map.elems ts1))++collapse (Trie.Sub ts ms) (q : qs) =+ do t <- Map.lookup q ts+ t1 <- collapse t qs+ return (Trie.Sub (Map.insert q t1 ts) ms)+++-- We use tries to group modules by directory. -------------------------------------------------------------------------------- +++-- Render edges and a trie into the dot language+--------------------------------------------------------------------------------+make_dot :: Bool -> (Edges,NodesC) -> String make_dot cl (es,t) = showDot $ do if cl then make_clustered_dot 0 t else make_unclustered_dot 0 "" t >> return ()- forM_ es $ \(x,ys) -> forM_ ys $ \y -> userNodeId x .->. userNodeId y-+ forM_ (IMap.toList es) $ \(x,ys) ->+ forM_ (Set.toList ys) $ \y -> userNodeId x .->. userNodeId y -make_clustered_dot c (Sub xs ys) =- do forM_ ys $ \(xs,n) -> userNode (userNodeId n) [("label",xs)]- forM_ xs $ \(name,sub) ->+make_clustered_dot :: Int -> NodesC -> Dot ()+make_clustered_dot c (Trie.Sub xs ys) =+ do forM_ (fromMaybe [] ys) $ \((t,ls),n) ->+ userNode (userNodeId n) $+ ("label",ls) :+ case t of+ CollapsedNode -> [ ("shape","box")+ , ("color",colors !! c)+ , ("style","filled")+ ]+ _ -> []+ forM_ (Map.toList xs) $ \(name,sub) -> cluster $ do attribute ("label", name) attribute ("color" , colors !! c)@@ -113,25 +169,33 @@ c1 `seq` make_clustered_dot c1 sub -make_unclustered_dot c pre (Sub xs ys) =- do forM_ ys $ \(xs,n) -> userNode (userNodeId n) [ ("label", pre ++ xs)- , ("color", colors !! c)- , ("style", "filled")- ]+make_unclustered_dot :: Int -> String -> NodesC -> Dot Int+make_unclustered_dot c pre (Trie.Sub xs ys') =+ do 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)+ , ("style", "filled")+ ] let c1 = if null ys then c else c + 1- c1 `seq` loop xs c1+ c1 `seq` loop (Map.toList xs) c1 where- loop ((name,sub):xs) c1 =+ loop ((name,sub):ms) c1 = do let pre1 = pre ++ name ++ "." c2 <- make_unclustered_dot c1 pre1 sub- loop xs c2+ loop ms c2 loop [] c2 = return c2 +type Color = (Int,Int,Int) -- XXX: generate all?+colors :: [String] colors = map col (ys1 ++ ys2) ++ repeat "#cccccc" 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@@ -145,8 +209,7 @@ -- Warnings and error messages ---------------------------------------------------------------------------------err msg = error ("ERROR: " ++ msg)-+warn :: Opts -> String -> IO () warn o _ | quiet o = return () warn _ msg = hPutStrLn stderr ("WARNING: " ++ msg) @@ -162,33 +225,91 @@ -- Command line options -------------------------------------------------------------------------------- data Opts = Opts- { inc_dirs :: [FilePath]- , quiet :: Bool- , with_missing :: Bool- , use_clusters :: Bool+ { inc_dirs :: [FilePath]+ , quiet :: Bool+ , with_missing :: Bool+ , use_clusters :: Bool+ , ignore_mods :: IgnoreSet+ , collapse_quals :: Trie.Trie String () } +type IgnoreSet = Trie.Trie String IgnoreSpec+data IgnoreSpec = IgnoreAll | IgnoreSome [String] deriving Show++type OptT = Opts -> Opts++default_opts :: Opts default_opts = Opts { inc_dirs = [] , quiet = False , with_missing = False , use_clusters = True+ , ignore_mods = Trie.empty+ , collapse_quals = Trie.empty } -add_current o = case inc_dirs o of- [] -> o { inc_dirs = ["."] }- _ -> o+options :: [OptDescr OptT] options =- [ Option ['q'] ["quiet"] (NoArg set_quiet) "Do not show warnings"- , Option ['i'] [] (ReqArg add_inc "DIR") "Add a search directory"- , Option ['a'] ["all"] (NoArg set_all) "Add nodes for missing modules"+ [ Option ['q'] ["quiet"] (NoArg set_quiet)+ "Do not show warnings."++ , Option ['i'] [] (ReqArg add_inc "DIR")+ "Add a search directory."++ , Option ['a'] ["all"] (NoArg set_all)+ "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-qual"] (ReqArg add_ignore_qual "QUALIFIER")+ "Remove all modules that start with the given qualifier."++ , Option ['c'] ["collapse"] (ReqArg add_collapse_qual "QUALIFIER")+ "Display modules matching the qualifier as a single node." ] -set_quiet o = o { quiet = True }-set_all o = o { with_missing = True }-add_inc d o = o { inc_dirs = d : inc_dirs o }-set_no_cluster o = o { use_clusters = False }+add_current :: OptT+add_current o = case inc_dirs o of+ [] -> o { inc_dirs = ["."] }+ _ -> o++set_quiet :: OptT+set_quiet o = o { quiet = True }++set_all :: OptT+set_all o = o { with_missing = True }++set_no_cluster :: OptT+set_no_cluster o = o { use_clusters = False }++add_inc :: FilePath -> OptT+add_inc d o = o { inc_dirs = d : inc_dirs o }++add_ignore_mod :: String -> OptT+add_ignore_mod s o = o { ignore_mods = ins (splitModName s) }+ where+ ins (q,m) = Trie.insert q (upd m) (ignore_mods o)++ upd _ (Just IgnoreAll) = IgnoreAll+ upd m (Just (IgnoreSome ms)) = IgnoreSome (m:ms)+ upd m Nothing = IgnoreSome [m]++add_ignore_qual :: String -> OptT+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)+ (collapse_quals o) }++ where+ upd _ t@(Trie.Sub _ (Just _)) = t+ upd [] _ = Trie.Sub Map.empty (Just ())+ upd (q:qs) (Trie.Sub as _) = Trie.Sub (Map.alter add q as) Nothing+ where add j = Just $ upd qs $ fromMaybe Trie.empty j
+ src/Trie.hs view
@@ -0,0 +1,19 @@+module Trie where++import qualified Data.Map as Map+import Data.Maybe(fromMaybe)++data Trie a b = Sub (Map.Map a (Trie a b)) (Maybe b)+ deriving Show++empty :: Trie a b+empty = Sub Map.empty Nothing++lookup :: Ord a => [a] -> Trie a b -> Maybe b+lookup [] (Sub _ b) = b+lookup (k:ks) (Sub as _) = Trie.lookup ks =<< Map.lookup k as++insert :: (Ord a) => [a] -> (Maybe b -> b) -> Trie a b -> Trie a b+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
src/Utils.hs view
@@ -1,6 +1,8 @@ module Utils ( parseFile , parseString+ , Qualifier+ , splitQualifier , ModName , splitModName , joinModName@@ -9,27 +11,23 @@ , suffixes ) where -import Language.Haskell.Lexer(lexerPass1,Token(..))+import Language.Haskell.Lexer(lexerPass1,Token(..),PosToken) import Data.Maybe(catMaybes) import Data.List(intersperse,isPrefixOf) import System.Directory(doesFileExist) import System.FilePath -import Debug.Trace- -- | Get the imports of a file. parseFile :: FilePath -> IO (ModName,[ModName])-parseFile f = (debug . parseString . get_text) `fmap` readFile f+parseFile f = (parseString . get_text) `fmap` readFile f where get_text txt = if takeExtension f == ".lhs" then delit txt else txt- debug z@(x,y) = z -- trace ("imports of " ++ show x ++ show y) z -- | Get the imports from a string that represents a program. parseString :: String -> (ModName,[ModName])-parseString = parse . debug . lexerPass1- where debug xs = xs -- trace (unlines $ "tokens: " : map show xs) xs-+parseString = parse . lexerPass1 +isImp :: [PosToken] -> Maybe (String, [PosToken]) isImp (_ : (Conid, (_,x)) : xs) = Just (x,xs) isImp (_ : (Qconid, (_,x)) : xs) = Just (x,xs) -- isImp (_ : (Specialid,_) : (Conid, (_,x)) : xs) = Just (x,xs)@@ -38,35 +36,44 @@ isImp (_ : (Varid,_) : (Qconid, (_,x)) : xs) = Just (x,xs) isImp _ = Nothing --- parse xs | trace (show (take 10 xs)) False = undefined+parse :: [PosToken] -> (ModName,[ModName]) parse (_ : (Reservedid,(_,"module")) : (_,(_,m)) : is) = (splitModName m,imports is)-parse is = {-trace ("Defaulting to Main: " ++ show (take 10 is))-}- (([],"Main"),imports is)+parse is = (([],"Main"),imports is) -imports xs = case isImp $ snd $ break (("import" ==) . snd . snd) xs of+imports :: [PosToken] -> [ModName]+imports ts = case isImp $ snd $ break (("import" ==) . snd . snd) ts of Just (x,xs) -> splitModName x : imports xs _ -> [] --- | A hirarchical module name.-type ModName = ([String],String)+-- | A hierarchical module name.+type Qualifier = [String]+type ModName = (Qualifier,String) --- | Convert a string name into a hirarchical name.++-- | Convert a string name into a hierarchical name qualifier.+splitQualifier :: String -> Qualifier+splitQualifier cs = case break ('.'==) cs of+ (xs,_:ys) -> xs : splitQualifier ys+ _ -> [cs]++-- | Convert a string name into a hierarchical name. splitModName :: String -> ModName-splitModName xs = case break ('.'==) xs of+splitModName cs = case break ('.'==) cs of (xs,_:ys) -> let (as,bs) = splitModName ys in (xs:as,bs)- _ -> ([],xs)+ _ -> ([],cs) joinModName :: ModName -> String joinModName (xs,y) = concat $ intersperse "." (xs ++ [y]) --- | The files in which a module moght reside.+-- | The files in which a module might reside. relPaths :: ModName -> [FilePath] relPaths (xs,y) = [ prefix ++ suffix | suffix <- suffixes ] where prefix = foldr (</>) y xs -suffixes = [".hs",".lhs"]+suffixes :: [String]+suffixes = [".hs",".lhs"] -- | The files in which a module might reside. -- We report only files that exist.