graphmod 1.2.8 → 1.2.9
raw patch · 4 files changed
+229/−51 lines, 4 filesdep +Cabal
Dependencies added: Cabal
Files
- graphmod.cabal +6/−3
- src/CabalSupport.hs +64/−0
- src/Main.hs +101/−33
- src/Utils.hs +58/−15
graphmod.cabal view
@@ -1,5 +1,5 @@ name: graphmod-version: 1.2.8+version: 1.2.9 license: BSD3 license-file: LICENSE author: Iavor S. Diatchki@@ -12,14 +12,17 @@ from the dependencies of a number of Haskell modules. category: Development +tested-with: GHC==7.10.3, GHC==7.8.4+ executable graphmod main-is: Main.hs- other-modules: Utils, Trie, Paths_graphmod+ other-modules: Utils, Trie, Paths_graphmod, CabalSupport build-depends: base < 5, directory, filepath, dotgen >= 0.2 && < 0.5,- haskell-lexer, containers+ haskell-lexer, containers, Cabal hs-source-dirs: src ghc-options: -Wall -O2 source-repository head type: git location: git://github.com/yav/graphmod+
+ src/CabalSupport.hs view
@@ -0,0 +1,64 @@+module CabalSupport (parseCabalFile,Unit(..),UnitName(..)) where++import Utils(ModName)++import Data.Maybe(maybeToList)+import System.FilePath((</>))++-- Interface to cabal.+import Distribution.PackageDescription.Parse(readPackageDescription)+import Distribution.Verbosity(silent)+import Distribution.PackageDescription+ ( GenericPackageDescription, PackageDescription(..)+ , Library(..), Executable(..), BuildInfo(..) )+import Distribution.PackageDescription.Configuration (flattenPackageDescription)+import Distribution.ModuleName(ModuleName,components)+++++parseCabalFile :: FilePath -> IO [Unit]+parseCabalFile f = fmap findUnits (readPackageDescription silent f)+++-- | This is our abstraction for something in a cabal file.+data Unit = Unit+ { unitName :: UnitName+ , unitPaths :: [FilePath]+ , unitModules :: [ModName]+ , unitFiles :: [FilePath]+ } deriving Show++data UnitName = UnitLibrary | UnitExecutable String+ deriving Show+++libUnit :: Library -> Unit+libUnit lib = Unit { unitName = UnitLibrary+ , unitPaths = hsSourceDirs (libBuildInfo lib)+ , unitModules = map toMod (exposedModules lib)+ -- other modules?+ , unitFiles = []+ }++exeUnit :: Executable -> Unit+exeUnit exe = Unit { unitName = UnitExecutable (exeName exe)+ , unitPaths = hsSourceDirs (buildInfo exe)+ , unitModules = [] -- other modules?+ , unitFiles = case hsSourceDirs (buildInfo exe) of+ [] -> [ modulePath exe ]+ ds -> [ d </> modulePath exe | d <- ds ]+ }++toMod :: ModuleName -> ModName+toMod m = case components m of+ [] -> error "Empty module name."+ xs -> (init xs, last xs)++findUnits :: GenericPackageDescription -> [Unit]+findUnits g = maybeToList (fmap libUnit (library pkg)) +++ fmap exeUnit (executables pkg)+ where+ pkg = flattenPackageDescription g -- we just ignore flags++
src/Main.hs view
@@ -1,19 +1,23 @@ import Utils import qualified Trie+import CabalSupport(parseCabalFile,Unit(..)) import Text.Dot import Control.Monad(when,forM_,(<=<),mplus,msum,guard) import Control.Monad.Fix(mfix)+import Control.Exception(catch,SomeException(..)) import Data.List(intersperse,partition) 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 qualified Data.IntSet as ISet+import qualified Data.Set as Set import System.Environment(getArgs) import System.IO(hPutStrLn,stderr) import System.FilePath import System.Console.GetOpt+import System.Directory(getDirectoryContents) import Numeric(showHex) import Paths_graphmod (version)@@ -27,7 +31,9 @@ putStrLn ("graphmod " ++ showVersion version) | otherwise ->- do g <- graph (add_current opts) (map to_input ms)+ 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) where opts = foldr ($) default_opts fs@@ -37,6 +43,7 @@ data Input = File FilePath | Module ModName+ deriving Show -- | Guess if we have a file or a module name to_input :: String -> Input@@ -50,7 +57,8 @@ type NodesC = Trie.Trie String [((NodeT,String),Int)] -- Maps a path to: ((node, label), nodeId) -type Edges = IMap.IntMap Set.IntSet+type Edges = IMap.IntMap ISet.IntSet+type FinalEdges = IMap.IntMap (Set.Set (Int,ImpType)) data NodeT = ModuleNode@@ -60,79 +68,100 @@ -- draw edges "into" the collapsed node or not. deriving (Show,Eq,Ord) -graph :: Opts -> [Input] -> IO (Edges, NodesC)-graph opts inputs = fmap maybePrune $ mfix $ \ ~(_,mods) ->+graph :: Opts -> [Input] -> IO (FinalEdges, NodesC)+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! - loop :: NodesC -> Edges -> Int -> [Input] -> IO (Edges, NodesC)+ loop :: NodesC ->+ Edges {- normal edges -} ->+ Edges {- SOURCE (i.e., back) edges -} ->+ Int {- size -} ->+ [Input] {- root files/modules -} ->+ IO (Edges {- normal-}, Edges {- SOURCES -}, NodesC) - loop done es _ [] = return (es, collapseAll done (collapse_quals opts))+ loop done es bes _ [] =+ return (es, bes, collapseAll done (collapse_quals opts)) - loop done es size (Module m : todo)- | ignore done m = loop done es size todo+ loop done es bes size (Module m : todo)+ | ignore done m = loop done es bes 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+ then add done es bes size m [] todo+ else loop done es bes 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+ add done es bes size x imps todo - loop done es size (File f : todo) =+ loop done es bes 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+ then loop done es bes size todo+ else add done es bes size m is todo - add done es size m imps ms =- let ms1 = map Module imps ++ ms- imp_ids = Set.fromList (mapMaybe nodeFor imps)+ add done es bes size m imps ms =+ let (sourceImps,normalImps) = partition ((== SourceImp) . impType) imps+ srcMods = map impMod sourceImps+ nrmMods = map impMod normalImps++ ms1 = map Module (srcMods ++ nrmMods) ++ ms++ normIds = ISet.fromList (mapMaybe nodeFor nrmMods)+ srcIds = ISet.fromList (mapMaybe nodeFor srcMods)+ 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 + (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+ 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+ in loop Trie.empty IMap.empty IMap.empty 0 inputs where- maybePrune (es,ns) = if prune_edges opts then (pruneEdges es, ns)- else (es,ns)+ 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) + pruneEdges :: Edges -> Edges pruneEdges es = foldr checkEdges es (IMap.toList es) where reachIn _ _ _ [] = False reachIn g tgt visited (x : xs)- | x `Set.member` visited = reachIn g tgt visited xs+ | x `ISet.member` visited = reachIn g tgt visited xs | x == tgt = True | otherwise = let vs = neighbours g x- in reachIn g tgt (Set.insert x visited) (vs ++ xs)+ in reachIn g tgt (ISet.insert x visited) (vs ++ xs) - neighbours g x = Set.toList (IMap.findWithDefault Set.empty x g)+ neighbours g x = ISet.toList (IMap.findWithDefault ISet.empty x g) - reachableIn g x y = reachIn g y Set.empty [x]+ reachableIn g x y = reachIn g y ISet.empty [x] - rmEdge x y g = IMap.adjust (Set.delete y) x g+ rmEdge x y g = IMap.adjust (ISet.delete y) x g checkEdge x y g = let g1 = rmEdge x y g in if reachableIn g1 x y then g1 else g - checkEdges (x,vs) g = foldr (checkEdge x) g (Set.toList vs)+ checkEdges (x,vs) g = foldr (checkEdge x) g (ISet.toList vs) isIgnored :: IgnoreSet -> ModName -> Bool@@ -213,7 +242,7 @@ -- Render edges and a trie into the dot language ---------------------------------------------------------------------------------make_dot :: String -> Int -> Bool -> (Edges,NodesC) -> String+make_dot :: String -> Int -> Bool -> (FinalEdges,NodesC) -> String make_dot sz col cl (es,t) = showDot $ do attribute ("size", sz)@@ -221,7 +250,11 @@ 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+ forM_ (Set.toList ys) $ \(y,t) ->+ let attrs = case t of+ NormalImp -> []+ SourceImp -> [("style","dashed")]+ in edge (userNodeId x) (userNodeId y) attrs @@ -319,6 +352,31 @@ ++ " (picking the first):\n" ++ concat (intersperse "," xs) ++--------------------------------------------------------------------------------+++fromCabal :: Bool -> IO ([FilePath],[Input])+fromCabal True =+ do fs <- getDirectoryContents "." -- XXX+ case filter ((".cabal" ==) . takeExtension) fs of+ f : _ -> do units <- parseCabalFile f+ `catch` \SomeException {} -> return []+ return (fromUnits units)+ _ -> return ([],[])+fromCabal _ = return ([],[])+++fromUnits :: [Unit] -> ([FilePath], [Input])+fromUnits us = (concat fs, concat is)+ where+ (fs,is) = unzip (map fromUnit us)++fromUnit :: Unit -> ([FilePath], [Input])+fromUnit u = (unitPaths u, map File (unitFiles u) ++ map Module (unitModules u))+++ -- Command line options -------------------------------------------------------------------------------- data Opts = Opts@@ -335,6 +393,8 @@ , color_scheme :: Int , prune_edges :: Bool , graph_size :: String++ , use_cabal :: Bool -- ^ should we try to use a cabal file, if any } type IgnoreSet = Trie.Trie String IgnoreSpec@@ -354,6 +414,7 @@ , color_scheme = 0 , prune_edges = False , graph_size = "6,4"+ , use_cabal = True } options :: [OptDescr OptT]@@ -391,6 +452,9 @@ , Option ['s'] ["colors"] (ReqArg add_color_scheme "NUM") "Choose a color scheme number (0-5)" + , Option [] ["no-cabal"] (NoArg (set_cabal False))+ "Do not use Cabal for paths and modules."+ , Option ['v'] ["version"] (NoArg set_show_version) "Show the current version." ]@@ -449,3 +513,7 @@ set_size :: String -> OptT set_size s o = o { graph_size = s }++set_cabal :: Bool -> OptT+set_cabal on o = o { use_cabal = on }+
src/Utils.hs view
@@ -2,6 +2,8 @@ ( parseFile , parseString , Qualifier+ , Import(..)+ , ImpType(..) , splitQualifier , ModName , splitModName@@ -11,15 +13,22 @@ , suffixes ) where -import Language.Haskell.Lexer(lexerPass1,Token(..),PosToken,line)+import Language.Haskell.Lexer(lexerPass0,Token(..),PosToken,line) +import Control.Monad(mplus) import Data.Maybe(catMaybes) import Data.List(intersperse,isPrefixOf) import System.Directory(doesFileExist) import System.FilePath +data Import = Import { impMod :: ModName, impType :: ImpType }+ deriving Show++data ImpType = NormalImp | SourceImp+ deriving (Show,Eq,Ord)+ -- | Get the imports of a file.-parseFile :: FilePath -> IO (ModName,[ModName])+parseFile :: FilePath -> IO (ModName,[Import]) parseFile f = do (modName, imps) <- (parseString . get_text) `fmap` readFile f if ext == ".imports"@@ -31,9 +40,29 @@ ext = takeExtension f -- | Get the imports from a string that represents a program.-parseString :: String -> (ModName,[ModName])-parseString = parse . dropApproxCPP . lexerPass1+parseString :: String -> (ModName,[Import])+parseString = parse . dropApproxCPP . dropComments . lexerPass0 ++-- | Drop comments, but keep {-# SOURCE #-} pragmas.+dropComments :: [PosToken] -> [PosToken]+dropComments = filter (not . skip)+ where+ skip (t, (_,txt))+ | t == Whitespace+ || t == Commentstart+ || t == Comment+ || t == LiterateComment = True+ | t == NestedComment = not (isSourcePragma txt)+ | otherwise = False+++isSourcePragma :: String -> Bool+isSourcePragma txt = case words txt of+ ["{-#", "SOURCE", "#-}"] -> True+ _ -> False++ dropApproxCPP :: [PosToken] -> [PosToken] -- this is some artifact of the lexer@@ -56,23 +85,37 @@ dropApproxCPP [] = [] -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)--- isImp (_ : (Specialid,_) : (Qconid, (_,x)) : xs) = Just (x,xs)-isImp (_ : (Varid,_) : (Conid, (_,x)) : xs) = Just (x,xs)-isImp (_ : (Varid,_) : (Qconid, (_,x)) : xs) = Just (x,xs)-isImp _ = Nothing+-- 'import' maybe_src maybe_safe optqualified maybe_pkg modid+-- maybeas maybeimpspec+isImp :: [PosToken] -> Maybe (Import, [PosToken])+isImp ts = attempt (1::Int) (drop 1 ts)+ where+ attempt n toks+ -- import safe qualified "package" ModId+ | n > 4 = Nothing+ | otherwise = mplus (isMod toks) (attempt (n+1) (drop 1 toks)) -parse :: [PosToken] -> (ModName,[ModName])+ isMod ((ty, (_,x)) : xs) = case ty of+ Conid -> Just (toImp x,xs)+ Qconid -> Just (toImp x,xs)+ _ -> Nothing+ isMod _ = Nothing++ toImp x = Import { impMod = splitModName x, impType = isSrc }+ isSrc = case ts of+ _ : (_,(_,x)) : _ | isSourcePragma x -> SourceImp+ _ -> NormalImp++++parse :: [PosToken] -> (ModName,[Import]) parse ((Reservedid,(_,"module")) : (_,(_,m)) : is) = (splitModName m,imports is) parse is = (([],"Main"),imports is) -imports :: [PosToken] -> [ModName]+imports :: [PosToken] -> [Import] imports ts = case isImp $ snd $ break (("import" ==) . snd . snd) ts of- Just (x,xs) -> splitModName x : imports xs+ Just (x,xs) -> x : imports xs _ -> [] -- | A hierarchical module name.