diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for graphmod-plugin + +## 0.1.0.0 -- 2018-09-29 + +* Initial Release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/graphmod-plugin.cabal b/graphmod-plugin.cabal new file mode 100644 --- /dev/null +++ b/graphmod-plugin.cabal @@ -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 diff --git a/main/Main.hs b/main/Main.hs new file mode 100644 --- /dev/null +++ b/main/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import GraphMod + +main :: IO () +main = collectImports diff --git a/src/GraphMod.hs b/src/GraphMod.hs new file mode 100644 --- /dev/null +++ b/src/GraphMod.hs @@ -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" + + + diff --git a/src/GraphMod/Args.hs b/src/GraphMod/Args.hs new file mode 100644 --- /dev/null +++ b/src/GraphMod/Args.hs @@ -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 } + diff --git a/src/GraphMod/Dot.hs b/src/GraphMod/Dot.hs new file mode 100644 --- /dev/null +++ b/src/GraphMod/Dot.hs @@ -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) + + + 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,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... + + +