graphmod-plugin (empty) → 0.1.0.0
raw patch · 10 files changed
+852/−0 lines, 10 filesdep +basedep +containersdep +directorysetup-changed
Dependencies added: base, containers, directory, dotgen, filepath, ghc, graphmod-plugin, syb, template-haskell
Files
- ChangeLog.md +5/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- graphmod-plugin.cabal +35/−0
- main/Main.hs +6/−0
- src/GraphMod.hs +183/−0
- src/GraphMod/Args.hs +154/−0
- src/GraphMod/Dot.hs +332/−0
- src/GraphMod/Trie.hs +22/−0
- src/GraphMod/Utils.hs +83/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for graphmod-plugin++## 0.1.0.0 -- 2018-09-29++* Initial Release
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2018, Matthew Pickering, Iavor S. Diatchki, Thomas Hallgren++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Matthew Pickering nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ graphmod-plugin.cabal view
@@ -0,0 +1,35 @@+name: graphmod-plugin+version: 0.1.0.0+synopsis: A reimplementation of graphmod as a source plugin+description: A reimplementation of graphmod as a source plugin.+license: BSD3+license-file: LICENSE+author: Matthew Pickering+maintainer: matthewtpickering@gmail.com+-- copyright:+--category:+build-type: Simple+extra-source-files: ChangeLog.md+cabal-version: >=1.10++library+ exposed-modules: GraphMod+ GraphMod.Dot GraphMod.Args GraphMod.Utils GraphMod.Trie+ build-depends: base >=4.10 && <4.13+ , syb+ , ghc >= 8.6+ , template-haskell+ , directory+ , filepath+ , containers+ , dotgen+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall++executable graphmod-plugin+ build-depends: base, graphmod-plugin+ hs-source-dirs: main+ default-language: Haskell2010+ main-is: Main.hs+ ghc-options: -Wall
+ main/Main.hs view
@@ -0,0 +1,6 @@+module Main where++import GraphMod++main :: IO ()+main = collectImports
+ src/GraphMod.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE TupleSections #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module GraphMod(plugin, collectImports) where++import GhcPlugins+import TcRnTypes+import HsExtension+import HsImpExp+import Binary++import Data.Maybe+import Data.List++import GraphMod.Utils as GraphMod+import GraphMod.Dot as GraphMod+import GraphMod.Args+import qualified GraphMod.Trie as Trie++import qualified Data.Map as Map++import System.FilePath+import System.Directory+import System.Console.GetOpt+import System.Environment(getArgs)+import System.IO++printStderr :: Show a => a -> IO ()+printStderr = hPutStrLn stderr . show++initBinMemSize :: Int+initBinMemSize = 1024 * 1024+++-- Installing the plugin+plugin :: Plugin+plugin = defaultPlugin {+ typeCheckResultAction = install+ , pluginRecompile = impurePlugin+ }++-- The main plugin function, it collects and serialises the import+-- information for a module.+install :: [CommandLineOption] -> ModSummary -> TcGblEnv -> TcM TcGblEnv+install opts ms tc_gbl = do+ let imps = tcg_rn_imports tc_gbl+ gm_imps = map (convertImport . unLoc) imps+ outdir = mkOutdir opts+ path = mkPath outdir (ms_mod ms)+ gm_modname = getModName ms+ liftIO $ do+ createDirectoryIfMissing False outdir+ writeBinary path (gm_modname, gm_imps)+ return tc_gbl++mkOutdir :: [CommandLineOption] -> FilePath+mkOutdir [] = defaultLocation+mkOutdir (x:_) = x++writeBinary :: Binary a => FilePath -> a -> IO ()+writeBinary path payload = do+ bh <- openBinMem initBinMemSize+ put_ bh payload+ writeBinMem bh path++mkPath :: FilePath -> Module -> FilePath+mkPath fp m+ = fp </> (moduleNameString (moduleName m) ++ (show (moduleUnitId m)))+++-- Converting to GraphMod data types+--+-- The type we are going to serialise+type Payload = (GraphMod.ModName, [GraphMod.Import])++getModName :: ModSummary -> GraphMod.ModName+getModName ms = GraphMod.splitModName . moduleNameString . moduleName . ms_mod $ ms+++convertImport :: ImportDecl GhcRn -> GraphMod.Import+convertImport (ImportDecl{..}) =+ GraphMod.Import { impMod = convertModName (ideclName)+ , impType = if ideclSource+ then GraphMod.SourceImp+ else GraphMod.NormalImp+ }+convertImport _ = error "Unreachable"++convertModName :: Located ModuleName -> GraphMod.ModName+convertModName (L _ mn) = GraphMod.splitModName (moduleNameString mn)++--+-- Finalisation logic+-- We run this code at the end to gather up all the results and+-- output the dotfile.+++readImports :: FilePath -> FilePath -> IO Payload+readImports outdir fp = do+ readBinMem (outdir </> fp) >>= get++collectImports :: IO ()+collectImports = do+ raw_opts <- getArgs+ printStderr raw_opts+ let (fs, _ms, _errs) = getOpt Permute options raw_opts+ opts = foldr ($) default_opts fs++ outdir = inputDir opts+ printStderr $ ("OutDir: ", outdir)+ files <- listDirectory outdir+ printStderr $ ("files:", concat files)+ usages <- mapM (readImports outdir) files+ printStderr usages+ let graph = buildGraph opts usages+ putStr (GraphMod.make_dot opts graph)++++-- Get all the ModNames to make nodes for+modGraph :: [Payload] -> [GraphMod.ModName]+modGraph = nub . foldMap do_one+ where+ do_one (mn, is) = mn : map do_import is++ do_import (GraphMod.Import n _) = n++--+buildGraph :: Opts -> [Payload] -> (GraphMod.AllEdges, GraphMod.Nodes)+buildGraph opts payloads = maybePrune opts (aes, process nodes)+ where+ process nodes = collapseAll opts nodes (collapse_quals opts)++ nodeMapList = zip (modGraph payloads) [0..]++ nodeMap = Map.fromList nodeMapList++ nodes = foldr insertMod Trie.empty nodeMapList++ aes = foldr (makeEdges nodeMap) GraphMod.noEdges+ (concatMap (\(p, is) -> map (p,) is) payloads)++ insertMod (n, k) t = GraphMod.insMod n k t++-- Make edges between the nodes+-- Invariant: All nodes already exist in the map+makeEdges :: Map.Map GraphMod.ModName Int+ -> (GraphMod.ModName, GraphMod.Import)+ -> GraphMod.AllEdges+ -> GraphMod.AllEdges+makeEdges nodeMap (m_from, m_to) aes = fromMaybe (error "makeEdges") $ do+ from_i <- Map.lookup m_from nodeMap+ to_i <- Map.lookup (GraphMod.impMod m_to) nodeMap+ return $ case GraphMod.impType m_to of+ GraphMod.SourceImp ->+ aes { GraphMod.sourceEdges+ = GraphMod.insSet from_i to_i (GraphMod.sourceEdges aes) }+ GraphMod.NormalImp ->+ aes { GraphMod.normalEdges = GraphMod.insSet from_i to_i (GraphMod.normalEdges aes) }++++--+-- Serialisation logic for GraphMod types++instance Binary GraphMod.Import where+ put_ bh (GraphMod.Import mn ip) = put_ bh mn >> put_ bh ip+ get bh = GraphMod.Import <$> get bh <*> get bh+instance Binary GraphMod.ImpType where+ put_ bh c =+ case c of+ GraphMod.NormalImp -> putByte bh 0+ GraphMod.SourceImp -> putByte bh 1+ get bh = getByte bh >>= return . \case+ 0 -> GraphMod.NormalImp+ 1 -> GraphMod.SourceImp+ _ -> error "Binary:GraphMod"+++
+ src/GraphMod/Args.hs view
@@ -0,0 +1,154 @@+-- Option parsing+module GraphMod.Args(Opts(..), default_opts, options, IgnoreSet, IgnoreSpec(..)+ , defaultLocation ) where+import GraphMod.Utils+import qualified GraphMod.Trie as Trie++import Data.Maybe(fromMaybe)+import qualified Data.Map as Map+import System.Console.GetOpt+++-- Command line options+--------------------------------------------------------------------------------+data Opts = Opts+ { inputDir :: 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+ }++type IgnoreSet = Trie.Trie String IgnoreSpec+data IgnoreSpec = IgnoreAll | IgnoreSome [String] deriving Show++type OptT = Opts -> Opts++defaultLocation :: FilePath+defaultLocation = "/root/graphmod-plugin/output"++default_opts :: Opts+default_opts = Opts+ { inputDir = defaultLocation+ , 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"+ }++options :: [OptDescr OptT]+options =+ [ Option ['i'] ["indir"] (ReqArg add_indir "DIR")+ "Directory where the plugin placed the files"+ , Option ['q'] ["quiet"] (NoArg set_quiet)+ "Do not show warnings"++ , 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 ['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_indir :: FilePath -> OptT+add_indir d o = o { inputDir = d }++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 }+
+ src/GraphMod/Dot.hs view
@@ -0,0 +1,332 @@+module GraphMod.Dot(make_dot+ , AllEdges+ , Nodes+ , noEdges+ , insMod+ , insSet+ , sourceEdges+ , normalEdges+ , maybePrune+ , collapseAll+ ) where+import GraphMod.Utils+import qualified GraphMod.Trie as Trie+import GraphMod.Args+import Text.Dot++import Control.Monad(forM_,msum,unless)+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.IO(hPutStrLn,stderr)+import System.Console.GetOpt+import Numeric(showHex)++--import Paths_graphmod (version)+-- import Data.Version (showVersion)++version = "0"++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+ }+++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+++maybePrune :: Opts -> (AllEdges, Nodes) -> (AllEdges, Nodes)+maybePrune opts (es,ns)+ | prune_edges opts = (es { normalEdges = pruneEdges (normalEdges es) }, ns)+ | otherwise = (es,ns)++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 _ _ ([],_) = return Trie.empty -- Probably not terribly useful.++collapse opts (Trie.Sub ts mb) ([q],alsoMod) =+ do t <- Map.lookup q ts+ let will_move = mod_in_cluster opts && Map.member q ts+ (thisMod,otherMods)+ | alsoMod || will_move = case findThisMod =<< mb of+ Nothing -> (Nothing, [])+ Just (nid,rest) -> (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)+++
+ src/GraphMod/Trie.hs view
@@ -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)
+ src/GraphMod/Utils.hs view
@@ -0,0 +1,83 @@+module GraphMod.Utils+ (+ Qualifier+ , Import(..)+ , ImpType(..)+ , splitQualifier+ , ModName+ , splitModName+ , joinModName+ , relPaths+ , modToFile+ , suffixes+ ) where++import Control.Monad(mplus)+import Control.Exception(evaluate)+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)+++-- | 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 = 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...+++