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