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