diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,19 @@ +* 1.4.5.1 + - Support for Cabal 3.6 + +* 1.4.5 + Several Main modules in one package are disambiguated + as follows (see https://github.com/yav/graphmod/issues/28). + When the module name is Main and there are no qualifiers + (Cabal does not allow any) + Then the qualifiers are the directories leading up to the + source file and the module name is replaced by the file's + basename. + E.g. when the Main module resides in + app/Program/Main.hs + then the node in the graph is labelled + app.Program.Main + * Version 1.4.1 - Support for Cabal 2 - Updates to build infrastructure diff --git a/driver/Main.hs b/driver/Main.hs new file mode 100644 --- /dev/null +++ b/driver/Main.hs @@ -0,0 +1,7 @@ +module Main (main) where + +import Graphmod (graphmod) +import System.Environment (getArgs) + +main :: IO () +main = getArgs >>= graphmod diff --git a/graphmod.cabal b/graphmod.cabal --- a/graphmod.cabal +++ b/graphmod.cabal @@ -1,5 +1,5 @@ name: graphmod -version: 1.4.4 +version: 1.4.5.1 license: BSD3 license-file: LICENSE author: Iavor S. Diatchki @@ -12,16 +12,25 @@ from the dependencies of a number of Haskell modules. category: Development -tested-with: GHC==8.0.1, GHC==8.0.2, - GHC==8.2.1, - GHC==8.6.3, GHC==8.6.4, - GHC==8.8.1 +tested-with: GHC==8.6.5, + GHC==8.8.4, + GHC==8.10.3, + GHC==9.2.4 extra-source-files: CHANGELOG.md executable graphmod - main-is: Main.hs - other-modules: Utils, Trie, Paths_graphmod, CabalSupport + main-is: Main.hs + hs-source-dirs: driver + ghc-options: -Wall -O2 + build-depends: + base < 5 + , graphmod + default-language: Haskell2010 + +library + exposed-modules: Graphmod, Graphmod.Utils + other-modules: Graphmod.Trie, Graphmod.CabalSupport, Paths_graphmod build-depends: base < 5, directory, filepath, dotgen >= 0.2 && < 0.5, haskell-lexer >= 1.0.2, containers, Cabal, pretty hs-source-dirs: src diff --git a/src/CabalSupport.hs b/src/CabalSupport.hs deleted file mode 100644 --- a/src/CabalSupport.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# language CPP #-} - -module CabalSupport (parseCabalFile,Unit(..),UnitName(..)) where - -import Utils(ModName) - -import Data.Maybe(maybeToList) -import System.FilePath(()) - --- Interface to cabal. -import Distribution.Verbosity(silent) -import Distribution.PackageDescription - ( GenericPackageDescription, PackageDescription(..) - , Library(..), Executable(..), BuildInfo(..) ) -import Distribution.PackageDescription.Configuration (flattenPackageDescription) -import Distribution.ModuleName(ModuleName,components) - -#if MIN_VERSION_Cabal(2,0,0) -#if MIN_VERSION_Cabal(2,2,0) -import Distribution.PackageDescription.Parsec(readGenericPackageDescription) -#else -import Distribution.PackageDescription.Parse(readGenericPackageDescription) -#endif -import Distribution.Types.UnqualComponentName (UnqualComponentName) - -#if MIN_VERSION_Cabal(2,2,0) -import Distribution.Pretty (prettyShow) - -pretty :: UnqualComponentName -> String -pretty = prettyShow -#else -import Distribution.Text (disp) -import Text.PrettyPrint (render) - -pretty :: UnqualComponentName -> String -pretty = render . disp -#endif -#else -import Distribution.PackageDescription.Parse(readPackageDescription) -import Distribution.Verbosity (Verbosity) - -readGenericPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription -readGenericPackageDescription = readPackageDescription - -pretty :: String -> String -pretty = id -#endif - - -parseCabalFile :: FilePath -> IO [Unit] -parseCabalFile f = fmap findUnits (readGenericPackageDescription 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 (pretty $ 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/Graphmod.hs b/src/Graphmod.hs new file mode 100644 --- /dev/null +++ b/src/Graphmod.hs @@ -0,0 +1,619 @@ +module Graphmod (graphmod) where + +import Graphmod.Utils +import qualified Graphmod.Trie as Trie +import Graphmod.CabalSupport(parseCabalFile,Unit(..)) +import Text.Dot + +import Control.Monad(forM_,msum,guard,unless) +import Control.Monad.Fix(mfix) +import Control.Exception (SomeException(..)) +import qualified Control.Exception as X (catch) +import Data.List(intercalate,transpose) +import Data.Maybe(isJust,fromMaybe,listToMaybe) +import qualified Data.IntMap as IMap +import qualified Data.Map as Map +import qualified Data.IntSet as ISet +import System.IO(hPutStrLn,stderr) +import System.FilePath (takeExtension) +import System.Console.GetOpt +import System.Directory(getDirectoryContents) +import Numeric(showHex) + +import Paths_graphmod (version) +import Data.Version (showVersion) + +graphmod :: [String] -> IO () +graphmod xs = do + let (fs, ms, errs) = getOpt Permute options xs + case errs of + [] | show_version opts -> + putStrLn ("graphmod " ++ showVersion version) + + | otherwise -> + do (incs,inps) <- fromCabal (use_cabal opts) + g <- graph (foldr add_inc (add_current opts) incs) + (inps ++ map to_input ms) + putStr (make_dot opts g) + where opts = foldr ($) default_opts fs + + _ -> hPutStrLn stderr $ + usageInfo "usage: graphmod MODULES/PATHS" options + +data Input = File FilePath | Module ModName + deriving Show + +-- | Guess if we have a file or a module name +to_input :: String -> Input +to_input m + | takeExtension m `elem` suffixes = File m + | otherwise = Module (splitModName m) + + + +type Nodes = Trie.Trie String [((NodeT,String),Int)] + -- Maps a path to: ((node, label), nodeId) + +type Edges = IMap.IntMap ISet.IntSet + +data NodeT = ModuleNode + + | ModuleInItsCluster + -- ^ A module that has been relocated to its cluster + + | Redirect + -- ^ This is not rendered. It is there to support replacing + -- one node with another (e.g., when collapsing) + + | Deleted + -- ^ This is not rendered, and edges to/from it are also + -- not rendered. + + | CollapsedNode Bool + -- ^ indicates if it contains module too. + deriving (Show,Eq,Ord) + +data AllEdges = AllEdges + { normalEdges :: Edges + , sourceEdges :: Edges + } + +noEdges :: AllEdges +noEdges = AllEdges { normalEdges = IMap.empty + , sourceEdges = IMap.empty + } + +graph :: Opts -> [Input] -> IO (AllEdges, Nodes) +graph opts inputs = fmap maybePrune $ mfix $ \ ~(_,mods) -> + -- NOTE: 'mods' is the final value of 'done' in the funciton 'loop'. + + let nodeFor x = lookupMod x mods -- Recursion happens here! + + loop :: Nodes -> + AllEdges {- all kinds of edges -} -> + Int {- size -} -> + [Input] {- root files/modules -} -> + IO (AllEdges, Nodes) + + loop done es _ [] = + return (es, collapseAll opts 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 unless (null gs) (warn opts (ambigMsg m fs)) + (x,imps) <- parseFile f + add done es size x imps todo + + 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 + + add done es size m imps ms = size1 `seq` loop done1 es1 size1 ms1 + where + es1 = case nodeFor m of + Just src -> foldr (addEdge src) es imps + Nothing -> es + size1 = size + 1 + ms1 = map (Module . impMod) imps ++ ms + done1 = insMod m size done + + + addEdge nFrom i aes = + case nodeFor (impMod i) of + Nothing -> aes + Just nTo -> + case impType i of + SourceImp -> + aes { sourceEdges = insSet nFrom nTo (sourceEdges aes) } + NormalImp -> + aes { normalEdges = insSet nFrom nTo (normalEdges aes) } + + + in loop Trie.empty noEdges 0 inputs + + where + maybePrune (es,ns) + | prune_edges opts = (es { normalEdges = pruneEdges (normalEdges es) }, ns) + | otherwise = (es,ns) + + ignore done m = isIgnored (ignore_mods opts) m + || isJust (lookupMod m done) + + + + +lookupMod :: ModName -> Nodes -> Maybe Int +lookupMod (q,m) t = msum . map isThis =<< Trie.lookup (qualifierNodes q) t + where isThis ((ty,m'),nid) = + case ty of + CollapsedNode False -> Nothing -- Keep looking for the actual node + Deleted -> Nothing + _ -> guard (m == m') >> return nid + +insMod :: ModName -> Int -> Nodes -> Nodes +insMod (q,m) n t = Trie.insert (qualifierNodes q) ins t + where + ins xs = ((ModuleNode,m),n) : fromMaybe [] xs + +insSet :: Int -> Int -> Edges -> Edges +insSet x y m = IMap.insertWith ISet.union x (ISet.singleton y) m + + + +pruneEdges :: Edges -> Edges +pruneEdges es = foldr checkEdges es (IMap.toList es) + where + reachIn _ _ _ [] = False + reachIn g tgt visited (x : xs) + | x `ISet.member` visited = reachIn g tgt visited xs + | x == tgt = True + | otherwise = let vs = neighbours g x + in reachIn g tgt (ISet.insert x visited) (vs ++ xs) + + neighbours g x = ISet.toList (IMap.findWithDefault ISet.empty x g) + + reachableIn g x y = reachIn g y ISet.empty [x] + + 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 (ISet.toList vs) + + +isIgnored :: IgnoreSet -> ModName -> Bool +isIgnored (Trie.Sub _ (Just IgnoreAll)) _ = True +isIgnored (Trie.Sub ts i ) (q,m) = + case qualifierNodes q of + [] -> + case i of + Just (IgnoreSome ms) -> elem m ms + Just IgnoreAll -> error "BUG: IgnoreAll should be matched" + Nothing -> False + x : xs -> + case Map.lookup x ts of + Nothing -> False + Just t -> isIgnored t (fromHierarchy xs,m) + + +-- XXX: We could combine collapseAll and collapse into a single pass +-- to avoid traversing form the root each time. +collapseAll :: Opts -> Nodes -> Trie.Trie String Bool -> Nodes +collapseAll opts t0 = + foldr (\q t -> fromMaybe t (collapse opts t q)) t0 . toList + where + 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) + +-- NOTE: We use the Maybe type to indicate when things changed. +collapse :: Opts -> Nodes -> ([String],Bool) -> Maybe Nodes +collapse _ _ ([],_) = Nothing + +collapse opts (Trie.Sub ts mb) ([q],alsoMod') = + do t <- Map.lookup q ts + let alsoMod = alsoMod' || mod_in_cluster opts + -- if modules are moved in their sub-directory clsuter, + -- then we always want to collapse them, irrspective of the flag given + + + nestedMods = [ nm | Trie.Sub _ (Just xs) <- Map.elems ts + , ((_,nm),_) <- xs ] + will_move = mod_in_cluster opts && (q `elem` nestedMods) + (thisMod,otherMods) + | alsoMod || will_move + , Just (nid,rest) <- findThisMod =<< mb = (Just nid, rest) + | otherwise = (Nothing, fromMaybe [] mb) + + -- use this node-id to represent the collapsed cluster + rep <- msum [ thisMod, getFirst t ] + + let close ((_,nm),_) = ((if will_move then Deleted else Redirect,nm),rep) + ts' = Map.insert q (fmap (map close) t) ts + newT | alsoMod || not will_move = CollapsedNode (isJust thisMod) + | otherwise = ModuleNode + + return (Trie.Sub ts' (Just (((newT,q),rep) : otherMods))) + where + findThisMod (((_,nm),nid) : more) | nm == q = Just (nid,more) + findThisMod (x : more) = do (yes,more') <- findThisMod more + return (yes, x:more') + findThisMod [] = Nothing + + getFirst (Trie.Sub ts1 ms) = + msum (fmap snd (listToMaybe =<< ms) : map getFirst (Map.elems ts1)) + +collapse opts (Trie.Sub ts ms) (q : qs,x) = + do t <- Map.lookup q ts + t1 <- collapse opts t (qs,x) + return (Trie.Sub (Map.insert q t1 ts) ms) + + + +-- | If inside cluster A.B we have a module M, +-- and there is a cluster A.B.M, then move M into that cluster as a special node +moveModulesInCluster :: Nodes -> Nodes +moveModulesInCluster (Trie.Sub su0 ms0) = + goMb (fmap moveModulesInCluster su0) ms0 + where + goMb su mb = + case mb of + Nothing -> Trie.Sub su Nothing + Just xs -> go [] su xs + + go ns su xs = + case xs of + [] -> Trie.Sub su $ if null ns then Nothing else Just ns + y : ys -> + case check y su of + Left it -> go (it : ns) su ys + Right su1 -> go ns su1 ys + + check it@((nt,s),i) mps = + case nt of + ModuleNode -> + case Map.lookup s mps of + Nothing -> Left it + Just t -> Right (Map.insert s (Trie.insert [] add t) mps) + where + newM = ((ModuleInItsCluster,s),i) + add xs = newM : fromMaybe [] xs + + + ModuleInItsCluster -> Left it + CollapsedNode _ -> Left it + Redirect -> Left it + Deleted -> Left it + + +-- We use tries to group modules by directory. +-------------------------------------------------------------------------------- + + + +-- Render edges and a trie into the dot language +-------------------------------------------------------------------------------- +make_dot :: Opts -> (AllEdges,Nodes) -> String +make_dot opts (es,t) = + showDot $ + do attribute ("size", graph_size opts) + attribute ("ratio", "fill") + let cols = colors (color_scheme opts) + if use_clusters opts + then make_clustered_dot cols $ + if mod_in_cluster opts then moveModulesInCluster t else t + else make_unclustered_dot cols "" t >> return () + genEdges normalAttr (normalEdges es) + genEdges sourceAttr (sourceEdges es) + where + normalAttr _x _y = [] + sourceAttr _x _y = [("style","dashed")] + + genEdges attr edges = + forM_ (IMap.toList edges) $ \(x,ys) -> + forM_ (ISet.toList ys) $ \y -> + edge (userNodeId x) (userNodeId y) (attr x y) + + + + + + +make_clustered_dot :: [Color] -> Nodes -> Dot () +make_clustered_dot cs0 su = go (0,0,0) cs0 su >> return () + where + clusterC = "#0000000F" + + go outer_col ~(this_col:more) (Trie.Sub xs ys) = + do let outerC = renderColor outer_col + thisC = renderColor this_col + + forM_ (fromMaybe [] ys) $ \((t,ls),n) -> + unless (t == Redirect || t == Deleted) $ + userNode (userNodeId n) $ + ("label",ls) : + case t of + CollapsedNode False -> [ ("shape", "box") + , ("style","filled") + , ("color", clusterC) + ] + CollapsedNode True -> [ ("style","filled") + , ("fillcolor", clusterC) + ] + ModuleInItsCluster -> [ ("style","filled,bold") + , ("fillcolor", outerC) + ] + + ModuleNode -> [ ("style", "filled") + , ("fillcolor", thisC) + , ("penwidth","0") + ] + Redirect -> [] + Deleted -> [] + goSub this_col more (Map.toList xs) + + goSub _ cs [] = return cs + goSub outer_col cs ((name,sub) : more) = + do (_,cs1) <- cluster $ do attribute ("label", name) + attribute ("color" , clusterC) + attribute ("style", "filled") + go outer_col cs sub + + goSub outer_col cs1 more + + +make_unclustered_dot :: [Color] -> String -> Nodes -> Dot [Color] +make_unclustered_dot c pre (Trie.Sub xs ys') = + do let col = renderColor (head c) + let ys = fromMaybe [] ys' + forM_ ys $ \((t,ls),n) -> + userNode (userNodeId n) $ + [ ("fillcolor", col) + , ("style", "filled") + , ("label", pre ++ ls) + ] ++ + case t of + CollapsedNode False -> [ ("shape", "box"), ("color", col) ] + CollapsedNode True -> [ ("shape", "box") ] + Redirect -> [] + ModuleInItsCluster -> [] + ModuleNode -> [] + Deleted -> [] + + let c1 = if null ys then c else tail c + c1 `seq` loop (Map.toList xs) c1 + where + loop ((name,sub):ms) c1 = + do let pre1 = pre ++ name ++ "." + c2 <- make_unclustered_dot c1 pre1 sub + loop ms c2 + loop [] c2 = return c2 + + +type Color = (Int,Int,Int) + +colors :: Int -> [Color] +colors n = cycle $ mix_colors $ drop n palettes + +renderColor :: Color -> String +renderColor (x,y,z) = '#' : showHex (mk x) (showHex (mk y) (showHex (mk z) "")) + where mk n = 0xFF - n * 0x44 + + +mix_colors :: [[a]] -> [a] +mix_colors css = mk set1 ++ mk set2 + where + (set1,set2) = unzip $ map (splitAt 3) css + mk = concat . transpose + + +palettes :: [[Color]] +palettes = [green, yellow, blue, red, cyan, magenta ] + where + red :: [Color] + red = [ (0,1,1), (0,2,2), (0,3,3), (1,2,3), (1,3,3), (2,3,3) ] + green = map rotR red + blue = map rotR green + [cyan,magenta,yellow] = map (map compl . reverse) [red, green, blue] + + rotR (x,y,z) = (z,x,y) + compl (x,y,z) = (3-x,3-y,3-z) + +-- Warnings and error messages +-------------------------------------------------------------------------------- +warn :: Opts -> String -> IO () +warn o _ | quiet o = return () +warn _ msg = hPutStrLn stderr ("WARNING: " ++ msg) + +notFoundMsg :: ModName -> String +notFoundMsg m = "Cannot find a file for module " + ++ joinModName m ++ " (ignoring)" + +ambigMsg :: ModName -> [FilePath] -> String +ambigMsg m xs = "Multiple files for module " ++ joinModName m + ++ " (picking the first):\n" + ++ intercalate "," xs + + +-------------------------------------------------------------------------------- + + +fromCabal :: Bool -> IO ([FilePath],[Input]) +fromCabal True = + do fs <- getDirectoryContents "." -- XXX + case filter ((".cabal" ==) . takeExtension) fs of + f : _ -> do units <- parseCabalFile f + `X.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 + { inc_dirs :: [FilePath] + , quiet :: Bool + , with_missing :: Bool + , use_clusters :: Bool + , mod_in_cluster:: Bool + , ignore_mods :: IgnoreSet + , 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 + , 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 +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 + , mod_in_cluster = True + , ignore_mods = Trie.empty + , collapse_quals = Trie.empty + , show_version = False + , color_scheme = 0 + , prune_edges = False + , graph_size = "6,4" + , use_cabal = True + } + +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 [] ["no-cluster"] (NoArg set_no_cluster) + "Do not cluster directories" + + , Option [] ["no-module-in-cluster"] (NoArg set_no_mod_in_cluster) + "Do not place modules matching a cluster's name inside it." + + , Option ['r'] ["remove-module"] (ReqArg add_ignore_mod "NAME") + "Do not display module NAME" + + , Option ['R'] ["remove-qual"] (ReqArg add_ignore_qual "NAME") + "Do not display modules NAME.*" + + , 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 ['p'] ["prune-edges"] (NoArg set_prune) + "Remove imports if the module is imported by another imported module" + + , Option ['d'] ["graph-dim"] (ReqArg set_size "SIZE,SIZE") + "Set dimensions of the graph. See the `size` attribute of graphvize." + + , 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." + ] + +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_show_version :: OptT +set_show_version o = o { show_version = True } + +set_all :: OptT +set_all o = o { with_missing = True } + +set_no_cluster :: OptT +set_no_cluster o = o { use_clusters = False } + +set_no_mod_in_cluster :: OptT +set_no_mod_in_cluster o = o { mod_in_cluster = 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 (qualifierNodes 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 ((qualifierNodes.splitQualifier) s) + (const IgnoreAll) (ignore_mods o) } + +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 ((qualifierNodes.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 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 + +set_prune :: OptT +set_prune o = o { prune_edges = True } + +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/Graphmod/CabalSupport.hs b/src/Graphmod/CabalSupport.hs new file mode 100644 --- /dev/null +++ b/src/Graphmod/CabalSupport.hs @@ -0,0 +1,112 @@ +{-# language CPP #-} + +module Graphmod.CabalSupport (parseCabalFile,Unit(..),UnitName(..)) where + +import Graphmod.Utils(ModName,fromHierarchy) + +import Data.Maybe(maybeToList) +import System.FilePath(()) + +-- Interface to cabal. +import Distribution.Verbosity(silent) +import Distribution.PackageDescription + ( GenericPackageDescription, PackageDescription(..) + , Library(..), Executable(..), BuildInfo(..) ) +import Distribution.PackageDescription.Configuration (flattenPackageDescription) +import Distribution.ModuleName(ModuleName,components) + +#if MIN_VERSION_Cabal(3,6,0) +import Distribution.Utils.Path (SymbolicPath, PackageDir, SourceDir, getSymbolicPath) +#endif + +#if MIN_VERSION_Cabal(2,0,0) + +#if MIN_VERSION_Cabal(3,8,1) +import Distribution.Simple.PackageDescription(readGenericPackageDescription) +#elif MIN_VERSION_Cabal(2,2,0) +import Distribution.PackageDescription.Parsec(readGenericPackageDescription) +#else +import Distribution.PackageDescription.Parse(readGenericPackageDescription) +#endif + +import Distribution.Types.UnqualComponentName (UnqualComponentName) + +#if MIN_VERSION_Cabal(2,2,0) +import Distribution.Pretty (prettyShow) + +pretty :: UnqualComponentName -> String +pretty = prettyShow +#else +import Distribution.Text (disp) +import Text.PrettyPrint (render) + +pretty :: UnqualComponentName -> String +pretty = render . disp +#endif + + +#else +import Distribution.PackageDescription.Parse(readPackageDescription) +import Distribution.Verbosity (Verbosity) + +readGenericPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription +readGenericPackageDescription = readPackageDescription + +pretty :: String -> String +pretty = id +#endif + +-- Note that this isn't nested under the above #if because we need +-- the backwards-compatible version to be available for all Cabal +-- versions prior to 3.6 +#if MIN_VERSION_Cabal(3,6,0) +sourceDirToFilePath :: SymbolicPath PackageDir SourceDir -> FilePath +sourceDirToFilePath = getSymbolicPath +#else +sourceDirToFilePath :: FilePath -> FilePath +sourceDirToFilePath = id +#endif + +parseCabalFile :: FilePath -> IO [Unit] +parseCabalFile f = fmap findUnits (readGenericPackageDescription 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 = sourceDirToFilePath <$> hsSourceDirs (libBuildInfo lib) + , unitModules = map toMod (exposedModules lib) + -- other modules? + , unitFiles = [] + } + +exeUnit :: Executable -> Unit +exeUnit exe = Unit { unitName = UnitExecutable (pretty $ exeName exe) + , unitPaths = sourceDirToFilePath <$> hsSourceDirs (buildInfo exe) + , unitModules = [] -- other modules? + , unitFiles = case hsSourceDirs (buildInfo exe) of + [] -> [ modulePath exe ] + ds -> [ sourceDirToFilePath d modulePath exe | d <- ds ] + } + +toMod :: ModuleName -> ModName +toMod m = case components m of + [] -> error "Empty module name." + xs -> (fromHierarchy (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/Graphmod/Trie.hs b/src/Graphmod/Trie.hs new file mode 100644 --- /dev/null +++ b/src/Graphmod/Trie.hs @@ -0,0 +1,22 @@ +module Graphmod.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 (Eq, Ord, 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 _) = Graphmod.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 + +instance Functor (Trie a) where + fmap f (Sub m mb) = Sub (fmap (fmap f) m) (fmap f mb) diff --git a/src/Graphmod/Utils.hs b/src/Graphmod/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Graphmod/Utils.hs @@ -0,0 +1,205 @@ +module Graphmod.Utils + ( parseFile + , parseString + , Qualifier + , qualifierNodes + , fromHierarchy + , Import(..) + , ImpType(..) + , splitQualifier + , ModName + , splitModName + , joinModName + , relPaths + , modToFile + , suffixes + ) where + +import Language.Haskell.Lexer(lexerPass0,Token(..),PosToken,line) + +import Control.Monad(mplus, filterM) +import Control.Exception(evaluate) +import Data.List(intercalate,isPrefixOf,nub) +import System.Directory(doesFileExist) +import qualified System.IO as IO +import System.FilePath + +data Import = Import { impMod :: ModName, impType :: ImpType } + deriving (Show, Eq) + +data ImpType = NormalImp | SourceImp + deriving (Show,Eq,Ord) + +-- | Get the imports of a file. +parseFile :: FilePath -> IO (ModName,[Import]) +parseFile f = + do h <- IO.openFile f IO.ReadMode + IO.hSetEncoding h IO.utf8 + (modName, imps) <- (parseString . get_text) `fmap` IO.hGetContents h + _ <- evaluate (length imps) -- this is here so that the file gets closed + IO.hClose h + if ext == ".imports" + then return (splitModName (takeBaseName f), imps) + else case modName of + -- disambiguate Main modules with no qualifiers + (Hierarchy [],"Main") -> return (splitFilePath f,imps) + _ -> return (modName, imps) + + + where get_text txt = if ext == ".lhs" then delit txt else txt + ext = takeExtension f + +-- | Get the imports from a string that represents a program. +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 +dropApproxCPP ((_, (_,"")) : more) = dropApproxCPP more + +dropApproxCPP ((Varsym, (_,"#")) : (_, (pos,tok)) : more) + | tok `elem` [ "if", "ifdef", "ifndef" ] = dropToEndif more + | tok `elem` [ "include", "define", "undef" ] = dropToEOL more + where + dropToEndif ((Varsym, (_,"#")) : (_, (_,"endif")) : rest) + = dropApproxCPP rest + dropToEndif (_ : rest) = dropToEndif rest + dropToEndif [] = [] + + dropToEOL ((_, (pos1,_)) : rest) + | line pos == line pos1 = dropToEOL rest + dropToEOL xs = dropApproxCPP xs + +dropApproxCPP (x : xs) = x : dropApproxCPP xs +dropApproxCPP [] = [] + + +-- '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)) + + 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 = ((Hierarchy [],"Main"),imports is) +-- TODO: special handling for Main modules, +-- to disambiguate multiple main Modules in a single project + +imports :: [PosToken] -> [Import] +imports ts = case isImp $ dropWhile (not . (("import" ==) . snd . snd)) ts of + Just (x,xs) -> x : imports xs + _ -> [] + +-- | A hierarchical module name. +-- We make this an opaque type with accessors 'qualifierNodes' and 'fromHierarchy' +-- so that we can transparently add new structure to this type. +data Qualifier = Hierarchy [String] + | FromFile [String] deriving (Show, Eq) +qualifierNodes :: Qualifier -> [String] +qualifierNodes (Hierarchy qs) = qs +qualifierNodes (FromFile qs) = qs +fromHierarchy :: [String] -> Qualifier +fromHierarchy = Hierarchy + +type ModName = (Qualifier,String) + +-- | Convert a string name into a hierarchical name qualifier. +splitQualifier :: String -> Qualifier +splitQualifier cs = case break ('.'==) cs of + (xs,_:ys) -> let Hierarchy qs = splitQualifier ys + in Hierarchy (xs:qs) + _ -> Hierarchy [cs] + +-- | The 'Qualifier' for a Main module is the path leading to it, +-- the module name is the file's basename, which is Main in typical cases. +splitFilePath :: FilePath -> ModName +splitFilePath path = let (d,f) = splitFileName path + in (FromFile . splitDirectories . takeDirectory $ d, dropExtensions f) + +-- | Convert a string name into a hierarchical name. +-- It is important that +-- +-- @ +-- f `elem` (('relPaths' . 'splitFilePath') f) +-- @ +splitModName :: String -> ModName +splitModName cs = case break ('.'==) cs of + (xs,_:ys) -> let (Hierarchy as,bs) = splitModName ys + in (Hierarchy (xs:as),bs) + _ -> (Hierarchy [],cs) + +joinModName :: ModName -> String +joinModName (q,y) = intercalate "." (qualifierNodes q ++ [y]) + +-- | The files in which a module might reside. +relPaths :: ModName -> [FilePath] +relPaths (q,y) = [ prefix ++ suffix | suffix <- suffixes ] + where prefix = foldr () y (qualifierNodes q) + +suffixes :: [String] +suffixes = [".hs",".lhs", ".imports"] + +-- | The files in which a module might reside. +-- We report only files that exist. +modToFile :: [FilePath] -> ModName -> IO [FilePath] +modToFile dirs m = nub `fmap` filterM doesFileExist paths + where + paths = [ d r | d <- dirs, r <- relPaths m ] + + +delit :: String -> String +delit txt = unlines $ bird $ lines txt + where + bird (('>' : cs) : ls) = (' ' : cs) : bird ls + bird (l : ls) + | "\\begin{code}" `isPrefixOf` l = in_code ls + | otherwise = bird ls + bird [] = [] + + in_code (l : ls) + | "\\end{code}" `isPrefixOf` l = bird ls + | otherwise = l : in_code ls + in_code [] = [] -- unterminated code... + + + diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -1,617 +0,0 @@ -import Utils -import qualified Trie -import CabalSupport(parseCabalFile,Unit(..)) -import Text.Dot - -import Control.Monad(when,forM_,msum,guard,unless) -import Control.Monad.Fix(mfix) -import Control.Exception (SomeException(..)) -import qualified Control.Exception as X (catch) -import Data.List(intersperse,transpose) -import Data.Maybe(isJust,fromMaybe,listToMaybe) -import qualified Data.IntMap as IMap -import qualified Data.Map as Map -import qualified Data.IntSet as ISet -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) -import Data.Version (showVersion) - -main :: IO () -main = do xs <- getArgs - let (fs, ms, errs) = getOpt Permute options xs - case errs of - [] | show_version opts -> - putStrLn ("graphmod " ++ showVersion version) - - | otherwise -> - do (incs,inps) <- fromCabal (use_cabal opts) - g <- graph (foldr add_inc (add_current opts) incs) - (inps ++ map to_input ms) - putStr (make_dot opts g) - where opts = foldr ($) default_opts fs - - _ -> hPutStrLn stderr $ - usageInfo "usage: graphmod MODULES/PATHS" options - - -data Input = File FilePath | Module ModName - deriving Show - --- | Guess if we have a file or a module name -to_input :: String -> Input -to_input m - | takeExtension m `elem` suffixes = File m - | otherwise = Module (splitModName m) - - - -type Nodes = Trie.Trie String [((NodeT,String),Int)] - -- Maps a path to: ((node, label), nodeId) - -type Edges = IMap.IntMap ISet.IntSet - -data NodeT = ModuleNode - - | ModuleInItsCluster - -- ^ A module that has been relocated to its cluster - - | Redirect - -- ^ This is not rendered. It is there to support replacing - -- one node with another (e.g., when collapsing) - - | Deleted - -- ^ This is not rendered, and edges to/from it are also - -- not rendered. - - | CollapsedNode Bool - -- ^ indicates if it contains module too. - deriving (Show,Eq,Ord) - -data AllEdges = AllEdges - { normalEdges :: Edges - , sourceEdges :: Edges - } - -noEdges :: AllEdges -noEdges = AllEdges { normalEdges = IMap.empty - , sourceEdges = IMap.empty - } - -graph :: Opts -> [Input] -> IO (AllEdges, Nodes) -graph opts inputs = fmap maybePrune $ mfix $ \ ~(_,mods) -> - -- NOTE: 'mods' is the final value of 'done' in the funciton 'loop'. - - let nodeFor x = lookupMod x mods -- Recursion happens here! - - loop :: Nodes -> - AllEdges {- all kinds of edges -} -> - Int {- size -} -> - [Input] {- root files/modules -} -> - IO (AllEdges, Nodes) - - loop done es _ [] = - return (es, collapseAll opts 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 - - 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 - - add done es size m imps ms = size1 `seq` loop done1 es1 size1 ms1 - where - es1 = case nodeFor m of - Just src -> foldr (addEdge src) es imps - Nothing -> es - size1 = size + 1 - ms1 = map (Module . impMod) imps ++ ms - done1 = insMod m size done - - - addEdge nFrom i aes = - case nodeFor (impMod i) of - Nothing -> aes - Just nTo -> - case impType i of - SourceImp -> - aes { sourceEdges = insSet nFrom nTo (sourceEdges aes) } - NormalImp -> - aes { normalEdges = insSet nFrom nTo (normalEdges aes) } - - - in loop Trie.empty noEdges 0 inputs - - where - maybePrune (es,ns) - | prune_edges opts = (es { normalEdges = pruneEdges (normalEdges es) }, ns) - | otherwise = (es,ns) - - ignore done m = isIgnored (ignore_mods opts) m - || isJust (lookupMod m done) - - - - -lookupMod :: ModName -> Nodes -> Maybe Int -lookupMod (q,m) t = (msum . map isThis =<< Trie.lookup q t) - where isThis ((ty,m'),nid) = - case ty of - CollapsedNode False -> Nothing -- Keep looking for the actual node - Deleted -> Nothing - _ -> guard (m == m') >> return nid - -insMod :: ModName -> Int -> Nodes -> Nodes -insMod (q,m) n t = Trie.insert q ins t - where - ins xs = case xs of - Nothing -> [ ((ModuleNode,m),n) ] - Just ys -> ((ModuleNode,m),n) : ys - -insSet :: Int -> Int -> Edges -> Edges -insSet x y m = IMap.insertWith ISet.union x (ISet.singleton y) m - - - -pruneEdges :: Edges -> Edges -pruneEdges es = foldr checkEdges es (IMap.toList es) - where - reachIn _ _ _ [] = False - reachIn g tgt visited (x : xs) - | x `ISet.member` visited = reachIn g tgt visited xs - | x == tgt = True - | otherwise = let vs = neighbours g x - in reachIn g tgt (ISet.insert x visited) (vs ++ xs) - - neighbours g x = ISet.toList (IMap.findWithDefault ISet.empty x g) - - reachableIn g x y = reachIn g y ISet.empty [x] - - 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 (ISet.toList vs) - - -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) - - --- XXX: We could combine collapseAll and collapse into a single pass --- to avoid traversing form the root each time. -collapseAll :: Opts -> Nodes -> Trie.Trie String Bool -> Nodes -collapseAll opts t0 = - foldr (\q t -> fromMaybe t (collapse opts t q)) t0 . toList - where - 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) - --- NOTE: We use the Maybe type to indicate when things changed. -collapse :: Opts -> Nodes -> (Qualifier,Bool) -> Maybe Nodes -collapse _ _ ([],_) = Nothing - -collapse opts (Trie.Sub ts mb) ([q],alsoMod') = - do t <- Map.lookup q ts - let alsoMod = alsoMod' || mod_in_cluster opts - -- if modules are moved in their sub-directory clsuter, - -- then we always want to collapse them, irrspective of the flag given - - - nestedMods = [ nm | Trie.Sub _ (Just xs) <- Map.elems ts - , ((_,nm),_) <- xs ] - will_move = mod_in_cluster opts && (q `elem` nestedMods) - (thisMod,otherMods) - | alsoMod || will_move - , Just (nid,rest) <- findThisMod =<< mb = (Just nid, rest) - | otherwise = (Nothing, fromMaybe [] mb) - - -- use this node-id to represent the collapsed cluster - rep <- msum [ thisMod, getFirst t ] - - let close ((_,nm),_) = ((if will_move then Deleted else Redirect,nm),rep) - ts' = Map.insert q (fmap (map close) t) ts - newT | alsoMod || not will_move = CollapsedNode (isJust thisMod) - | otherwise = ModuleNode - - return (Trie.Sub ts' (Just (((newT,q),rep) : otherMods))) - where - findThisMod (((_,nm),nid) : more) | nm == q = Just (nid,more) - findThisMod (x : more) = do (yes,more') <- findThisMod more - return (yes, x:more') - findThisMod [] = Nothing - - getFirst (Trie.Sub ts1 ms) = - msum (fmap snd (listToMaybe =<< ms) : map getFirst (Map.elems ts1)) - -collapse opts (Trie.Sub ts ms) (q : qs,x) = - do t <- Map.lookup q ts - t1 <- collapse opts t (qs,x) - return (Trie.Sub (Map.insert q t1 ts) ms) - - - --- | If inside cluster A.B we have a module M, --- and there is a cluster A.B.M, then move M into that cluster as a special node -moveModulesInCluster :: Nodes -> Nodes -moveModulesInCluster (Trie.Sub su0 ms0) = - goMb (fmap moveModulesInCluster su0) ms0 - where - goMb su mb = - case mb of - Nothing -> Trie.Sub su Nothing - Just xs -> go [] su xs - - go ns su xs = - case xs of - [] -> Trie.Sub su $ if null ns then Nothing else Just ns - y : ys -> - case check y su of - Left it -> go (it : ns) su ys - Right su1 -> go ns su1 ys - - check it@((nt,s),i) mps = - case nt of - ModuleNode -> - case Map.lookup s mps of - Nothing -> Left it - Just t -> Right (Map.insert s (Trie.insert [] add t) mps) - where - newM = ((ModuleInItsCluster,s),i) - add xs = [newM] ++ fromMaybe [] xs - - - ModuleInItsCluster -> Left it - CollapsedNode _ -> Left it - Redirect -> Left it - Deleted -> Left it - - --- We use tries to group modules by directory. --------------------------------------------------------------------------------- - - - --- Render edges and a trie into the dot language --------------------------------------------------------------------------------- -make_dot :: Opts -> (AllEdges,Nodes) -> String -make_dot opts (es,t) = - showDot $ - do attribute ("size", graph_size opts) - attribute ("ratio", "fill") - let cols = colors (color_scheme opts) - if use_clusters opts - then make_clustered_dot cols $ - if mod_in_cluster opts then moveModulesInCluster t else t - else make_unclustered_dot cols "" t >> return () - genEdges normalAttr (normalEdges es) - genEdges sourceAttr (sourceEdges es) - where - normalAttr _x _y = [] - sourceAttr _x _y = [("style","dashed")] - - genEdges attr edges = - forM_ (IMap.toList edges) $ \(x,ys) -> - forM_ (ISet.toList ys) $ \y -> - edge (userNodeId x) (userNodeId y) (attr x y) - - - - - - -make_clustered_dot :: [Color] -> Nodes -> Dot () -make_clustered_dot cs0 su = go (0,0,0) cs0 su >> return () - where - clusterC = "#0000000F" - - go outer_col ~(this_col:more) (Trie.Sub xs ys) = - do let outerC = renderColor outer_col - thisC = renderColor this_col - - forM_ (fromMaybe [] ys) $ \((t,ls),n) -> - unless (t == Redirect || t == Deleted) $ - userNode (userNodeId n) $ - [ ("label",ls) ] ++ - case t of - CollapsedNode False -> [ ("shape", "box") - , ("style","filled") - , ("color", clusterC) - ] - CollapsedNode True -> [ ("style","filled") - , ("fillcolor", clusterC) - ] - ModuleInItsCluster -> [ ("style","filled,bold") - , ("fillcolor", outerC) - ] - - ModuleNode -> [ ("style", "filled") - , ("fillcolor", thisC) - , ("penwidth","0") - ] - Redirect -> [] - Deleted -> [] - goSub this_col more (Map.toList xs) - - goSub _ cs [] = return cs - goSub outer_col cs ((name,sub) : more) = - do (_,cs1) <- cluster $ do attribute ("label", name) - attribute ("color" , clusterC) - attribute ("style", "filled") - go outer_col cs sub - - goSub outer_col cs1 more - - -make_unclustered_dot :: [Color] -> String -> Nodes -> Dot [Color] -make_unclustered_dot c pre (Trie.Sub xs ys') = - do let col = renderColor (head c) - let ys = fromMaybe [] ys' - forM_ ys $ \((t,ls),n) -> - userNode (userNodeId n) $ - [ ("fillcolor", col) - , ("style", "filled") - , ("label", pre ++ ls) - ] ++ - case t of - CollapsedNode False -> [ ("shape", "box"), ("color", col) ] - CollapsedNode True -> [ ("shape", "box") ] - Redirect -> [] - ModuleInItsCluster -> [] - ModuleNode -> [] - Deleted -> [] - - let c1 = if null ys then c else tail c - c1 `seq` loop (Map.toList xs) c1 - where - loop ((name,sub):ms) c1 = - do let pre1 = pre ++ name ++ "." - c2 <- make_unclustered_dot c1 pre1 sub - loop ms c2 - loop [] c2 = return c2 - - -type Color = (Int,Int,Int) - -colors :: Int -> [Color] -colors n = cycle $ mix_colors $ drop n $ palettes - -renderColor :: Color -> String -renderColor (x,y,z) = '#' : showHex (mk x) (showHex (mk y) (showHex (mk z) "")) - where mk n = 0xFF - n * 0x44 - - -mix_colors :: [[a]] -> [a] -mix_colors css = mk set1 ++ mk set2 - where - (set1,set2) = unzip $ map (splitAt 3) css - mk = concat . transpose - - -palettes :: [[Color]] -palettes = [green, yellow, blue, red, cyan, magenta ] - where - red :: [Color] - red = [ (0,1,1), (0,2,2), (0,3,3), (1,2,3), (1,3,3), (2,3,3) ] - green = map rotR red - blue = map rotR green - [cyan,magenta,yellow] = map (map compl . reverse) [red, green, blue] - - rotR (x,y,z) = (z,x,y) - compl (x,y,z) = (3-x,3-y,3-z) - --- Warnings and error messages --------------------------------------------------------------------------------- -warn :: Opts -> String -> IO () -warn o _ | quiet o = return () -warn _ msg = hPutStrLn stderr ("WARNING: " ++ msg) - -notFoundMsg :: ModName -> String -notFoundMsg m = "Cannot find a file for module " - ++ joinModName m ++ " (ignoring)" - -ambigMsg :: ModName -> [FilePath] -> String -ambigMsg m xs = "Multiple files for module " ++ joinModName m - ++ " (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 - `X.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 - { inc_dirs :: [FilePath] - , quiet :: Bool - , with_missing :: Bool - , use_clusters :: Bool - , mod_in_cluster:: Bool - , ignore_mods :: IgnoreSet - , 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 - , 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 -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 - , mod_in_cluster = True - , ignore_mods = Trie.empty - , collapse_quals = Trie.empty - , show_version = False - , color_scheme = 0 - , prune_edges = False - , graph_size = "6,4" - , use_cabal = True - } - -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 [] ["no-cluster"] (NoArg set_no_cluster) - "Do not cluster directories" - - , Option [] ["no-module-in-cluster"] (NoArg set_no_mod_in_cluster) - "Do not place modules matching a cluster's name inside it." - - , Option ['r'] ["remove-module"] (ReqArg add_ignore_mod "NAME") - "Do not display module NAME" - - , Option ['R'] ["remove-qual"] (ReqArg add_ignore_qual "NAME") - "Do not display modules NAME.*" - - , 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 ['p'] ["prune-edges"] (NoArg set_prune) - "Remove imports if the module is imported by another imported module" - - , Option ['d'] ["graph-dim"] (ReqArg set_size "SIZE,SIZE") - "Set dimensions of the graph. See the `size` attribute of graphvize." - - , 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." - ] - -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_show_version :: OptT -set_show_version o = o { show_version = True } - -set_all :: OptT -set_all o = o { with_missing = True } - -set_no_cluster :: OptT -set_no_cluster o = o { use_clusters = False } - -set_no_mod_in_cluster :: OptT -set_no_mod_in_cluster o = o { mod_in_cluster = 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_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 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 - -set_prune :: OptT -set_prune o = o { prune_edges = True } - -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/Trie.hs b/src/Trie.hs deleted file mode 100644 --- a/src/Trie.hs +++ /dev/null @@ -1,22 +0,0 @@ -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 (Eq, Ord, 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 - -instance Functor (Trie a) where - fmap f (Sub m mb) = Sub (fmap (fmap f) m) (fmap f mb) diff --git a/src/Utils.hs b/src/Utils.hs deleted file mode 100644 --- a/src/Utils.hs +++ /dev/null @@ -1,177 +0,0 @@ -module Utils - ( parseFile - , parseString - , Qualifier - , Import(..) - , ImpType(..) - , splitQualifier - , ModName - , splitModName - , joinModName - , relPaths - , modToFile - , suffixes - ) where - -import Language.Haskell.Lexer(lexerPass0,Token(..),PosToken,line) - -import Control.Monad(mplus) -import Control.Exception(evaluate) -import Data.Maybe(catMaybes) -import Data.List(intersperse,isPrefixOf,nub) -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,[Import]) -parseFile f = - do (modName, imps) <- (parseString . get_text) `fmap` readFile f - _ <- evaluate (length imps) -- this is here so that the file gets closed - if ext == ".imports" - then return (splitModName (takeBaseName f), imps) - else return (modName, imps) - - - where get_text txt = if ext == ".lhs" then delit txt else txt - ext = takeExtension f - --- | Get the imports from a string that represents a program. -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 -dropApproxCPP ((_, (_,"")) : more) = dropApproxCPP more - -dropApproxCPP ((Varsym, (_,"#")) : (_, (pos,tok)) : more) - | tok `elem` [ "if", "ifdef", "ifndef" ] = dropToEndif more - | tok `elem` [ "include", "define", "undef" ] = dropToEOL more - where - dropToEndif ((Varsym, (_,"#")) : (_, (_,"endif")) : rest) - = dropApproxCPP rest - dropToEndif (_ : rest) = dropToEndif rest - dropToEndif [] = [] - - dropToEOL ((_, (pos1,_)) : rest) - | line pos == line pos1 = dropToEOL rest - dropToEOL xs = dropApproxCPP xs - -dropApproxCPP (x : xs) = x : dropApproxCPP xs -dropApproxCPP [] = [] - - --- '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)) - - 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] -> [Import] -imports ts = case isImp $ snd $ break (("import" ==) . snd . snd) ts of - Just (x,xs) -> x : imports xs - _ -> [] - --- | A hierarchical module name. -type Qualifier = [String] -type ModName = (Qualifier,String) - - --- | 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 cs = case break ('.'==) cs of - (xs,_:ys) -> let (as,bs) = splitModName ys - in (xs:as,bs) - _ -> ([],cs) - -joinModName :: ModName -> String -joinModName (xs,y) = concat $ intersperse "." (xs ++ [y]) - --- | The files in which a module might reside. -relPaths :: ModName -> [FilePath] -relPaths (xs,y) = [ prefix ++ suffix | suffix <- suffixes ] - where prefix = foldr () y xs - -suffixes :: [String] -suffixes = [".hs",".lhs", ".imports"] - --- | The files in which a module might reside. --- We report only files that exist. -modToFile :: [FilePath] -> ModName -> IO [FilePath] -modToFile dirs m = (nub . catMaybes) `fmap` mapM check paths - where - paths = [ d r | d <- dirs, r <- relPaths m ] - check p = do x <- doesFileExist p - return (if x then Just p else Nothing) - - -delit :: String -> String -delit txt = unlines $ bird $ lines txt - where - bird (('>' : cs) : ls) = (' ' : cs) : bird ls - bird (l : ls) - | "\\begin{code}" `isPrefixOf` l = in_code ls - | otherwise = bird ls - bird [] = [] - - in_code (l : ls) - | "\\end{code}" `isPrefixOf` l = bird ls - | otherwise = l : in_code ls - in_code [] = [] -- unterminated code... - - -