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 :: [String] -> IO ()
graphmod [String]
xs = do
let ([OptT]
fs, [String]
ms, [String]
errs) = forall a.
ArgOrder a -> [OptDescr a] -> [String] -> ([a], [String], [String])
getOpt forall a. ArgOrder a
Permute [OptDescr OptT]
options [String]
xs
case [String]
errs of
[] | Opts -> Bool
show_version Opts
opts ->
String -> IO ()
putStrLn (String
"graphmod " forall a. [a] -> [a] -> [a]
++ Version -> String
showVersion Version
version)
| Bool
otherwise ->
do ([String]
incs,[Input]
inps) <- Bool -> IO ([String], [Input])
fromCabal (Opts -> Bool
use_cabal Opts
opts)
(AllEdges, Nodes)
g <- Opts -> [Input] -> IO (AllEdges, Nodes)
graph (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr String -> OptT
add_inc (OptT
add_current Opts
opts) [String]
incs)
([Input]
inps forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map String -> Input
to_input [String]
ms)
String -> IO ()
putStr (Opts -> (AllEdges, Nodes) -> String
make_dot Opts
opts (AllEdges, Nodes)
g)
where opts :: Opts
opts = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a b. (a -> b) -> a -> b
($) Opts
default_opts [OptT]
fs
[String]
_ -> Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$
forall a. String -> [OptDescr a] -> String
usageInfo String
"usage: graphmod MODULES/PATHS" [OptDescr OptT]
options
data Input = File FilePath | Module ModName
deriving Int -> Input -> ShowS
[Input] -> ShowS
Input -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Input] -> ShowS
$cshowList :: [Input] -> ShowS
show :: Input -> String
$cshow :: Input -> String
showsPrec :: Int -> Input -> ShowS
$cshowsPrec :: Int -> Input -> ShowS
Show
to_input :: String -> Input
to_input :: String -> Input
to_input String
m
| ShowS
takeExtension String
m forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
suffixes = String -> Input
File String
m
| Bool
otherwise = ModName -> Input
Module (String -> ModName
splitModName String
m)
type Nodes = Trie.Trie String [((NodeT,String),Int)]
type Edges = IMap.IntMap ISet.IntSet
data NodeT = ModuleNode
| ModuleInItsCluster
| Redirect
| Deleted
| CollapsedNode Bool
deriving (Int -> NodeT -> ShowS
[NodeT] -> ShowS
NodeT -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NodeT] -> ShowS
$cshowList :: [NodeT] -> ShowS
show :: NodeT -> String
$cshow :: NodeT -> String
showsPrec :: Int -> NodeT -> ShowS
$cshowsPrec :: Int -> NodeT -> ShowS
Show,NodeT -> NodeT -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NodeT -> NodeT -> Bool
$c/= :: NodeT -> NodeT -> Bool
== :: NodeT -> NodeT -> Bool
$c== :: NodeT -> NodeT -> Bool
Eq,Eq NodeT
NodeT -> NodeT -> Bool
NodeT -> NodeT -> Ordering
NodeT -> NodeT -> NodeT
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: NodeT -> NodeT -> NodeT
$cmin :: NodeT -> NodeT -> NodeT
max :: NodeT -> NodeT -> NodeT
$cmax :: NodeT -> NodeT -> NodeT
>= :: NodeT -> NodeT -> Bool
$c>= :: NodeT -> NodeT -> Bool
> :: NodeT -> NodeT -> Bool
$c> :: NodeT -> NodeT -> Bool
<= :: NodeT -> NodeT -> Bool
$c<= :: NodeT -> NodeT -> Bool
< :: NodeT -> NodeT -> Bool
$c< :: NodeT -> NodeT -> Bool
compare :: NodeT -> NodeT -> Ordering
$ccompare :: NodeT -> NodeT -> Ordering
Ord)
data AllEdges = AllEdges
{ AllEdges -> Edges
normalEdges :: Edges
, AllEdges -> Edges
sourceEdges :: Edges
}
noEdges :: AllEdges
noEdges :: AllEdges
noEdges = AllEdges { normalEdges :: Edges
normalEdges = forall a. IntMap a
IMap.empty
, sourceEdges :: Edges
sourceEdges = forall a. IntMap a
IMap.empty
}
graph :: Opts -> [Input] -> IO (AllEdges, Nodes)
graph :: Opts -> [Input] -> IO (AllEdges, Nodes)
graph Opts
opts [Input]
inputs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {b}. (AllEdges, b) -> (AllEdges, b)
maybePrune forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix forall a b. (a -> b) -> a -> b
$ \ ~(AllEdges
_,Nodes
mods) ->
let nodeFor :: ModName -> Maybe Int
nodeFor ModName
x = ModName -> Nodes -> Maybe Int
lookupMod ModName
x Nodes
mods
loop :: Nodes ->
AllEdges ->
Int ->
[Input] ->
IO (AllEdges, Nodes)
loop :: Nodes -> AllEdges -> Int -> [Input] -> IO (AllEdges, Nodes)
loop Nodes
done AllEdges
es Int
_ [] =
forall (m :: * -> *) a. Monad m => a -> m a
return (AllEdges
es, Opts -> Nodes -> Trie String Bool -> Nodes
collapseAll Opts
opts Nodes
done (Opts -> Trie String Bool
collapse_quals Opts
opts))
loop Nodes
done AllEdges
es Int
size (Module ModName
m : [Input]
todo)
| Nodes -> ModName -> Bool
ignore Nodes
done ModName
m = Nodes -> AllEdges -> Int -> [Input] -> IO (AllEdges, Nodes)
loop Nodes
done AllEdges
es Int
size [Input]
todo
| Bool
otherwise =
do [String]
fs <- [String] -> ModName -> IO [String]
modToFile (Opts -> [String]
inc_dirs Opts
opts) ModName
m
case [String]
fs of
[] -> do Opts -> String -> IO ()
warn Opts
opts (ModName -> String
notFoundMsg ModName
m)
if Opts -> Bool
with_missing Opts
opts
then Nodes
-> AllEdges
-> Int
-> ModName
-> [Import]
-> [Input]
-> IO (AllEdges, Nodes)
add Nodes
done AllEdges
es Int
size ModName
m [] [Input]
todo
else Nodes -> AllEdges -> Int -> [Input] -> IO (AllEdges, Nodes)
loop Nodes
done AllEdges
es Int
size [Input]
todo
String
f : [String]
gs -> do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
gs) (Opts -> String -> IO ()
warn Opts
opts (ModName -> [String] -> String
ambigMsg ModName
m [String]
fs))
(ModName
x,[Import]
imps) <- String -> IO (ModName, [Import])
parseFile String
f
Nodes
-> AllEdges
-> Int
-> ModName
-> [Import]
-> [Input]
-> IO (AllEdges, Nodes)
add Nodes
done AllEdges
es Int
size ModName
x [Import]
imps [Input]
todo
loop Nodes
done AllEdges
es Int
size (File String
f : [Input]
todo) =
do (ModName
m,[Import]
is) <- String -> IO (ModName, [Import])
parseFile String
f
if Nodes -> ModName -> Bool
ignore Nodes
done ModName
m
then Nodes -> AllEdges -> Int -> [Input] -> IO (AllEdges, Nodes)
loop Nodes
done AllEdges
es Int
size [Input]
todo
else Nodes
-> AllEdges
-> Int
-> ModName
-> [Import]
-> [Input]
-> IO (AllEdges, Nodes)
add Nodes
done AllEdges
es Int
size ModName
m [Import]
is [Input]
todo
add :: Nodes
-> AllEdges
-> Int
-> ModName
-> [Import]
-> [Input]
-> IO (AllEdges, Nodes)
add Nodes
done AllEdges
es Int
size ModName
m [Import]
imps [Input]
ms = Int
size1 seq :: forall a b. a -> b -> b
`seq` Nodes -> AllEdges -> Int -> [Input] -> IO (AllEdges, Nodes)
loop Nodes
done1 AllEdges
es1 Int
size1 [Input]
ms1
where
es1 :: AllEdges
es1 = case ModName -> Maybe Int
nodeFor ModName
m of
Just Int
src -> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Int -> Import -> AllEdges -> AllEdges
addEdge Int
src) AllEdges
es [Import]
imps
Maybe Int
Nothing -> AllEdges
es
size1 :: Int
size1 = Int
size forall a. Num a => a -> a -> a
+ Int
1
ms1 :: [Input]
ms1 = forall a b. (a -> b) -> [a] -> [b]
map (ModName -> Input
Module forall b c a. (b -> c) -> (a -> b) -> a -> c
. Import -> ModName
impMod) [Import]
imps forall a. [a] -> [a] -> [a]
++ [Input]
ms
done1 :: Nodes
done1 = ModName -> Int -> Nodes -> Nodes
insMod ModName
m Int
size Nodes
done
addEdge :: Int -> Import -> AllEdges -> AllEdges
addEdge Int
nFrom Import
i AllEdges
aes =
case ModName -> Maybe Int
nodeFor (Import -> ModName
impMod Import
i) of
Maybe Int
Nothing -> AllEdges
aes
Just Int
nTo ->
case Import -> ImpType
impType Import
i of
ImpType
SourceImp ->
AllEdges
aes { sourceEdges :: Edges
sourceEdges = Int -> Int -> Edges -> Edges
insSet Int
nFrom Int
nTo (AllEdges -> Edges
sourceEdges AllEdges
aes) }
ImpType
NormalImp ->
AllEdges
aes { normalEdges :: Edges
normalEdges = Int -> Int -> Edges -> Edges
insSet Int
nFrom Int
nTo (AllEdges -> Edges
normalEdges AllEdges
aes) }
in Nodes -> AllEdges -> Int -> [Input] -> IO (AllEdges, Nodes)
loop forall a b. Trie a b
Trie.empty AllEdges
noEdges Int
0 [Input]
inputs
where
maybePrune :: (AllEdges, b) -> (AllEdges, b)
maybePrune (AllEdges
es,b
ns)
| Opts -> Bool
prune_edges Opts
opts = (AllEdges
es { normalEdges :: Edges
normalEdges = Edges -> Edges
pruneEdges (AllEdges -> Edges
normalEdges AllEdges
es) }, b
ns)
| Bool
otherwise = (AllEdges
es,b
ns)
ignore :: Nodes -> ModName -> Bool
ignore Nodes
done ModName
m = IgnoreSet -> ModName -> Bool
isIgnored (Opts -> IgnoreSet
ignore_mods Opts
opts) ModName
m
Bool -> Bool -> Bool
|| forall a. Maybe a -> Bool
isJust (ModName -> Nodes -> Maybe Int
lookupMod ModName
m Nodes
done)
lookupMod :: ModName -> Nodes -> Maybe Int
lookupMod :: ModName -> Nodes -> Maybe Int
lookupMod (Qualifier
q,String
m) Nodes
t = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {a}. ((NodeT, String), a) -> Maybe a
isThis forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a b. Ord a => [a] -> Trie a b -> Maybe b
Trie.lookup (Qualifier -> [String]
qualifierNodes Qualifier
q) Nodes
t
where isThis :: ((NodeT, String), a) -> Maybe a
isThis ((NodeT
ty,String
m'),a
nid) =
case NodeT
ty of
CollapsedNode Bool
False -> forall a. Maybe a
Nothing
NodeT
Deleted -> forall a. Maybe a
Nothing
NodeT
_ -> forall (f :: * -> *). Alternative f => Bool -> f ()
guard (String
m forall a. Eq a => a -> a -> Bool
== String
m') forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return a
nid
insMod :: ModName -> Int -> Nodes -> Nodes
insMod :: ModName -> Int -> Nodes -> Nodes
insMod (Qualifier
q,String
m) Int
n Nodes
t = forall a b. Ord a => [a] -> (Maybe b -> b) -> Trie a b -> Trie a b
Trie.insert (Qualifier -> [String]
qualifierNodes Qualifier
q) Maybe [((NodeT, String), Int)] -> [((NodeT, String), Int)]
ins Nodes
t
where
ins :: Maybe [((NodeT, String), Int)] -> [((NodeT, String), Int)]
ins Maybe [((NodeT, String), Int)]
xs = ((NodeT
ModuleNode,String
m),Int
n) forall a. a -> [a] -> [a]
: forall a. a -> Maybe a -> a
fromMaybe [] Maybe [((NodeT, String), Int)]
xs
insSet :: Int -> Int -> Edges -> Edges
insSet :: Int -> Int -> Edges -> Edges
insSet Int
x Int
y Edges
m = forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IMap.insertWith IntSet -> IntSet -> IntSet
ISet.union Int
x (Int -> IntSet
ISet.singleton Int
y) Edges
m
pruneEdges :: Edges -> Edges
pruneEdges :: Edges -> Edges
pruneEdges Edges
es = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Int, IntSet) -> Edges -> Edges
checkEdges Edges
es (forall a. IntMap a -> [(Int, a)]
IMap.toList Edges
es)
where
reachIn :: Edges -> Int -> IntSet -> [Int] -> Bool
reachIn Edges
_ Int
_ IntSet
_ [] = Bool
False
reachIn Edges
g Int
tgt IntSet
visited (Int
x : [Int]
xs)
| Int
x Int -> IntSet -> Bool
`ISet.member` IntSet
visited = Edges -> Int -> IntSet -> [Int] -> Bool
reachIn Edges
g Int
tgt IntSet
visited [Int]
xs
| Int
x forall a. Eq a => a -> a -> Bool
== Int
tgt = Bool
True
| Bool
otherwise = let vs :: [Int]
vs = Edges -> Int -> [Int]
neighbours Edges
g Int
x
in Edges -> Int -> IntSet -> [Int] -> Bool
reachIn Edges
g Int
tgt (Int -> IntSet -> IntSet
ISet.insert Int
x IntSet
visited) ([Int]
vs forall a. [a] -> [a] -> [a]
++ [Int]
xs)
neighbours :: Edges -> Int -> [Int]
neighbours Edges
g Int
x = IntSet -> [Int]
ISet.toList (forall a. a -> Int -> IntMap a -> a
IMap.findWithDefault IntSet
ISet.empty Int
x Edges
g)
reachableIn :: Edges -> Int -> Int -> Bool
reachableIn Edges
g Int
x Int
y = Edges -> Int -> IntSet -> [Int] -> Bool
reachIn Edges
g Int
y IntSet
ISet.empty [Int
x]
rmEdge :: Int -> Int -> Edges -> Edges
rmEdge Int
x Int
y Edges
g = forall a. (a -> a) -> Int -> IntMap a -> IntMap a
IMap.adjust (Int -> IntSet -> IntSet
ISet.delete Int
y) Int
x Edges
g
checkEdge :: Int -> Int -> Edges -> Edges
checkEdge Int
x Int
y Edges
g = let g1 :: Edges
g1 = Int -> Int -> Edges -> Edges
rmEdge Int
x Int
y Edges
g
in if Edges -> Int -> Int -> Bool
reachableIn Edges
g1 Int
x Int
y then Edges
g1 else Edges
g
checkEdges :: (Int, IntSet) -> Edges -> Edges
checkEdges (Int
x,IntSet
vs) Edges
g = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Int -> Int -> Edges -> Edges
checkEdge Int
x) Edges
g (IntSet -> [Int]
ISet.toList IntSet
vs)
isIgnored :: IgnoreSet -> ModName -> Bool
isIgnored :: IgnoreSet -> ModName -> Bool
isIgnored (Trie.Sub Map String IgnoreSet
_ (Just IgnoreSpec
IgnoreAll)) ModName
_ = Bool
True
isIgnored (Trie.Sub Map String IgnoreSet
ts Maybe IgnoreSpec
i ) (Qualifier
q,String
m) =
case Qualifier -> [String]
qualifierNodes Qualifier
q of
[] ->
case Maybe IgnoreSpec
i of
Just (IgnoreSome [String]
ms) -> forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
m [String]
ms
Just IgnoreSpec
IgnoreAll -> forall a. HasCallStack => String -> a
error String
"BUG: IgnoreAll should be matched"
Maybe IgnoreSpec
Nothing -> Bool
False
String
x : [String]
xs ->
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
x Map String IgnoreSet
ts of
Maybe IgnoreSet
Nothing -> Bool
False
Just IgnoreSet
t -> IgnoreSet -> ModName -> Bool
isIgnored IgnoreSet
t ([String] -> Qualifier
fromHierarchy [String]
xs,String
m)
collapseAll :: Opts -> Nodes -> Trie.Trie String Bool -> Nodes
collapseAll :: Opts -> Nodes -> Trie String Bool -> Nodes
collapseAll Opts
opts Nodes
t0 =
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\([String], Bool)
q Nodes
t -> forall a. a -> Maybe a -> a
fromMaybe Nodes
t (Opts -> Nodes -> ([String], Bool) -> Maybe Nodes
collapse Opts
opts Nodes
t ([String], Bool)
q)) Nodes
t0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b}. Trie a b -> [([a], b)]
toList
where
toList :: Trie a b -> [([a], b)]
toList (Trie.Sub Map a (Trie a b)
_ (Just b
x)) = forall (m :: * -> *) a. Monad m => a -> m a
return ([], b
x)
toList (Trie.Sub Map a (Trie a b)
as Maybe b
Nothing) = do (a
q,Trie a b
t) <- forall k a. Map k a -> [(k, a)]
Map.toList Map a (Trie a b)
as
([a]
qs,b
x) <- Trie a b -> [([a], b)]
toList Trie a b
t
forall (m :: * -> *) a. Monad m => a -> m a
return (a
qforall a. a -> [a] -> [a]
:[a]
qs, b
x)
collapse :: Opts -> Nodes -> ([String],Bool) -> Maybe Nodes
collapse :: Opts -> Nodes -> ([String], Bool) -> Maybe Nodes
collapse Opts
_ Nodes
_ ([],Bool
_) = forall a. Maybe a
Nothing
collapse Opts
opts (Trie.Sub Map String Nodes
ts Maybe [((NodeT, String), Int)]
mb) ([String
q],Bool
alsoMod') =
do Nodes
t <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
q Map String Nodes
ts
let alsoMod :: Bool
alsoMod = Bool
alsoMod' Bool -> Bool -> Bool
|| Opts -> Bool
mod_in_cluster Opts
opts
nestedMods :: [String]
nestedMods = [ String
nm | Trie.Sub Map String Nodes
_ (Just [((NodeT, String), Int)]
xs) <- forall k a. Map k a -> [a]
Map.elems Map String Nodes
ts
, ((NodeT
_,String
nm),Int
_) <- [((NodeT, String), Int)]
xs ]
will_move :: Bool
will_move = Opts -> Bool
mod_in_cluster Opts
opts Bool -> Bool -> Bool
&& (String
q forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
nestedMods)
(Maybe Int
thisMod,[((NodeT, String), Int)]
otherMods)
| Bool
alsoMod Bool -> Bool -> Bool
|| Bool
will_move
, Just (Int
nid,[((NodeT, String), Int)]
rest) <- forall {a} {a}. [((a, String), a)] -> Maybe (a, [((a, String), a)])
findThisMod forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe [((NodeT, String), Int)]
mb = (forall a. a -> Maybe a
Just Int
nid, [((NodeT, String), Int)]
rest)
| Bool
otherwise = (forall a. Maybe a
Nothing, forall a. a -> Maybe a -> a
fromMaybe [] Maybe [((NodeT, String), Int)]
mb)
Int
rep <- forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [ Maybe Int
thisMod, forall {k} {a} {a}. Trie k [(a, a)] -> Maybe a
getFirst Nodes
t ]
let close :: ((a, b), b) -> ((NodeT, b), Int)
close ((a
_,b
nm),b
_) = ((if Bool
will_move then NodeT
Deleted else NodeT
Redirect,b
nm),Int
rep)
ts' :: Map String Nodes
ts' = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
q (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {b}. ((a, b), b) -> ((NodeT, b), Int)
close) Nodes
t) Map String Nodes
ts
newT :: NodeT
newT | Bool
alsoMod Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
will_move = Bool -> NodeT
CollapsedNode (forall a. Maybe a -> Bool
isJust Maybe Int
thisMod)
| Bool
otherwise = NodeT
ModuleNode
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. Map a (Trie a b) -> Maybe b -> Trie a b
Trie.Sub Map String Nodes
ts' (forall a. a -> Maybe a
Just (((NodeT
newT,String
q),Int
rep) forall a. a -> [a] -> [a]
: [((NodeT, String), Int)]
otherMods)))
where
findThisMod :: [((a, String), a)] -> Maybe (a, [((a, String), a)])
findThisMod (((a
_,String
nm),a
nid) : [((a, String), a)]
more) | String
nm forall a. Eq a => a -> a -> Bool
== String
q = forall a. a -> Maybe a
Just (a
nid,[((a, String), a)]
more)
findThisMod (((a, String), a)
x : [((a, String), a)]
more) = do (a
yes,[((a, String), a)]
more') <- [((a, String), a)] -> Maybe (a, [((a, String), a)])
findThisMod [((a, String), a)]
more
forall (m :: * -> *) a. Monad m => a -> m a
return (a
yes, ((a, String), a)
xforall a. a -> [a] -> [a]
:[((a, String), a)]
more')
findThisMod [] = forall a. Maybe a
Nothing
getFirst :: Trie k [(a, a)] -> Maybe a
getFirst (Trie.Sub Map k (Trie k [(a, a)])
ts1 Maybe [(a, a)]
ms) =
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd (forall a. [a] -> Maybe a
listToMaybe forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe [(a, a)]
ms) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map Trie k [(a, a)] -> Maybe a
getFirst (forall k a. Map k a -> [a]
Map.elems Map k (Trie k [(a, a)])
ts1))
collapse Opts
opts (Trie.Sub Map String Nodes
ts Maybe [((NodeT, String), Int)]
ms) (String
q : [String]
qs,Bool
x) =
do Nodes
t <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
q Map String Nodes
ts
Nodes
t1 <- Opts -> Nodes -> ([String], Bool) -> Maybe Nodes
collapse Opts
opts Nodes
t ([String]
qs,Bool
x)
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. Map a (Trie a b) -> Maybe b -> Trie a b
Trie.Sub (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
q Nodes
t1 Map String Nodes
ts) Maybe [((NodeT, String), Int)]
ms)
moveModulesInCluster :: Nodes -> Nodes
moveModulesInCluster :: Nodes -> Nodes
moveModulesInCluster (Trie.Sub Map String Nodes
su0 Maybe [((NodeT, String), Int)]
ms0) =
forall {a} {b}.
Ord a =>
Map a (Trie a [((NodeT, a), b)])
-> Maybe [((NodeT, a), b)] -> Trie a [((NodeT, a), b)]
goMb (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Nodes -> Nodes
moveModulesInCluster Map String Nodes
su0) Maybe [((NodeT, String), Int)]
ms0
where
goMb :: Map a (Trie a [((NodeT, a), b)])
-> Maybe [((NodeT, a), b)] -> Trie a [((NodeT, a), b)]
goMb Map a (Trie a [((NodeT, a), b)])
su Maybe [((NodeT, a), b)]
mb =
case Maybe [((NodeT, a), b)]
mb of
Maybe [((NodeT, a), b)]
Nothing -> forall a b. Map a (Trie a b) -> Maybe b -> Trie a b
Trie.Sub Map a (Trie a [((NodeT, a), b)])
su forall a. Maybe a
Nothing
Just [((NodeT, a), b)]
xs -> forall {a} {b}.
Ord a =>
[((NodeT, a), b)]
-> Map a (Trie a [((NodeT, a), b)])
-> [((NodeT, a), b)]
-> Trie a [((NodeT, a), b)]
go [] Map a (Trie a [((NodeT, a), b)])
su [((NodeT, a), b)]
xs
go :: [((NodeT, a), b)]
-> Map a (Trie a [((NodeT, a), b)])
-> [((NodeT, a), b)]
-> Trie a [((NodeT, a), b)]
go [((NodeT, a), b)]
ns Map a (Trie a [((NodeT, a), b)])
su [((NodeT, a), b)]
xs =
case [((NodeT, a), b)]
xs of
[] -> forall a b. Map a (Trie a b) -> Maybe b -> Trie a b
Trie.Sub Map a (Trie a [((NodeT, a), b)])
su forall a b. (a -> b) -> a -> b
$ if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [((NodeT, a), b)]
ns then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just [((NodeT, a), b)]
ns
((NodeT, a), b)
y : [((NodeT, a), b)]
ys ->
case forall {k} {a} {b}.
(Ord k, Ord a) =>
((NodeT, k), b)
-> Map k (Trie a [((NodeT, k), b)])
-> Either ((NodeT, k), b) (Map k (Trie a [((NodeT, k), b)]))
check ((NodeT, a), b)
y Map a (Trie a [((NodeT, a), b)])
su of
Left ((NodeT, a), b)
it -> [((NodeT, a), b)]
-> Map a (Trie a [((NodeT, a), b)])
-> [((NodeT, a), b)]
-> Trie a [((NodeT, a), b)]
go (((NodeT, a), b)
it forall a. a -> [a] -> [a]
: [((NodeT, a), b)]
ns) Map a (Trie a [((NodeT, a), b)])
su [((NodeT, a), b)]
ys
Right Map a (Trie a [((NodeT, a), b)])
su1 -> [((NodeT, a), b)]
-> Map a (Trie a [((NodeT, a), b)])
-> [((NodeT, a), b)]
-> Trie a [((NodeT, a), b)]
go [((NodeT, a), b)]
ns Map a (Trie a [((NodeT, a), b)])
su1 [((NodeT, a), b)]
ys
check :: ((NodeT, k), b)
-> Map k (Trie a [((NodeT, k), b)])
-> Either ((NodeT, k), b) (Map k (Trie a [((NodeT, k), b)]))
check it :: ((NodeT, k), b)
it@((NodeT
nt,k
s),b
i) Map k (Trie a [((NodeT, k), b)])
mps =
case NodeT
nt of
NodeT
ModuleNode ->
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
s Map k (Trie a [((NodeT, k), b)])
mps of
Maybe (Trie a [((NodeT, k), b)])
Nothing -> forall a b. a -> Either a b
Left ((NodeT, k), b)
it
Just Trie a [((NodeT, k), b)]
t -> forall a b. b -> Either a b
Right (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
s (forall a b. Ord a => [a] -> (Maybe b -> b) -> Trie a b -> Trie a b
Trie.insert [] Maybe [((NodeT, k), b)] -> [((NodeT, k), b)]
add Trie a [((NodeT, k), b)]
t) Map k (Trie a [((NodeT, k), b)])
mps)
where
newM :: ((NodeT, k), b)
newM = ((NodeT
ModuleInItsCluster,k
s),b
i)
add :: Maybe [((NodeT, k), b)] -> [((NodeT, k), b)]
add Maybe [((NodeT, k), b)]
xs = ((NodeT, k), b)
newM forall a. a -> [a] -> [a]
: forall a. a -> Maybe a -> a
fromMaybe [] Maybe [((NodeT, k), b)]
xs
NodeT
ModuleInItsCluster -> forall a b. a -> Either a b
Left ((NodeT, k), b)
it
CollapsedNode Bool
_ -> forall a b. a -> Either a b
Left ((NodeT, k), b)
it
NodeT
Redirect -> forall a b. a -> Either a b
Left ((NodeT, k), b)
it
NodeT
Deleted -> forall a b. a -> Either a b
Left ((NodeT, k), b)
it
make_dot :: Opts -> (AllEdges,Nodes) -> String
make_dot :: Opts -> (AllEdges, Nodes) -> String
make_dot Opts
opts (AllEdges
es,Nodes
t) =
forall a. Dot a -> String
showDot forall a b. (a -> b) -> a -> b
$
do (String, String) -> Dot ()
attribute (String
"size", Opts -> String
graph_size Opts
opts)
(String, String) -> Dot ()
attribute (String
"ratio", String
"fill")
let cols :: [Color]
cols = Int -> [Color]
colors (Opts -> Int
color_scheme Opts
opts)
if Opts -> Bool
use_clusters Opts
opts
then [Color] -> Nodes -> Dot ()
make_clustered_dot [Color]
cols forall a b. (a -> b) -> a -> b
$
if Opts -> Bool
mod_in_cluster Opts
opts then Nodes -> Nodes
moveModulesInCluster Nodes
t else Nodes
t
else [Color] -> String -> Nodes -> Dot [Color]
make_unclustered_dot [Color]
cols String
"" Nodes
t forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Int -> Int -> [(String, String)]) -> Edges -> Dot ()
genEdges forall {p} {p} {a}. p -> p -> [a]
normalAttr (AllEdges -> Edges
normalEdges AllEdges
es)
(Int -> Int -> [(String, String)]) -> Edges -> Dot ()
genEdges forall {p} {p}. p -> p -> [(String, String)]
sourceAttr (AllEdges -> Edges
sourceEdges AllEdges
es)
where
normalAttr :: p -> p -> [a]
normalAttr p
_x p
_y = []
sourceAttr :: p -> p -> [(String, String)]
sourceAttr p
_x p
_y = [(String
"style",String
"dashed")]
genEdges :: (Int -> Int -> [(String, String)]) -> Edges -> Dot ()
genEdges Int -> Int -> [(String, String)]
attr Edges
edges =
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. IntMap a -> [(Int, a)]
IMap.toList Edges
edges) forall a b. (a -> b) -> a -> b
$ \(Int
x,IntSet
ys) ->
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (IntSet -> [Int]
ISet.toList IntSet
ys) forall a b. (a -> b) -> a -> b
$ \Int
y ->
NodeId -> NodeId -> [(String, String)] -> Dot ()
edge (Int -> NodeId
userNodeId Int
x) (Int -> NodeId
userNodeId Int
y) (Int -> Int -> [(String, String)]
attr Int
x Int
y)
make_clustered_dot :: [Color] -> Nodes -> Dot ()
make_clustered_dot :: [Color] -> Nodes -> Dot ()
make_clustered_dot [Color]
cs0 Nodes
su = Color -> [Color] -> Nodes -> Dot [Color]
go (Int
0,Int
0,Int
0) [Color]
cs0 Nodes
su forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
clusterC :: String
clusterC = String
"#0000000F"
go :: Color -> [Color] -> Nodes -> Dot [Color]
go Color
outer_col ~(Color
this_col:[Color]
more) (Trie.Sub Map String Nodes
xs Maybe [((NodeT, String), Int)]
ys) =
do let outerC :: String
outerC = Color -> String
renderColor Color
outer_col
thisC :: String
thisC = Color -> String
renderColor Color
this_col
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. a -> Maybe a -> a
fromMaybe [] Maybe [((NodeT, String), Int)]
ys) forall a b. (a -> b) -> a -> b
$ \((NodeT
t,String
ls),Int
n) ->
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (NodeT
t forall a. Eq a => a -> a -> Bool
== NodeT
Redirect Bool -> Bool -> Bool
|| NodeT
t forall a. Eq a => a -> a -> Bool
== NodeT
Deleted) forall a b. (a -> b) -> a -> b
$
NodeId -> [(String, String)] -> Dot ()
userNode (Int -> NodeId
userNodeId Int
n) forall a b. (a -> b) -> a -> b
$
(String
"label",String
ls) forall a. a -> [a] -> [a]
:
case NodeT
t of
CollapsedNode Bool
False -> [ (String
"shape", String
"box")
, (String
"style",String
"filled")
, (String
"color", String
clusterC)
]
CollapsedNode Bool
True -> [ (String
"style",String
"filled")
, (String
"fillcolor", String
clusterC)
]
NodeT
ModuleInItsCluster -> [ (String
"style",String
"filled,bold")
, (String
"fillcolor", String
outerC)
]
NodeT
ModuleNode -> [ (String
"style", String
"filled")
, (String
"fillcolor", String
thisC)
, (String
"penwidth",String
"0")
]
NodeT
Redirect -> []
NodeT
Deleted -> []
Color -> [Color] -> [(String, Nodes)] -> Dot [Color]
goSub Color
this_col [Color]
more (forall k a. Map k a -> [(k, a)]
Map.toList Map String Nodes
xs)
goSub :: Color -> [Color] -> [(String, Nodes)] -> Dot [Color]
goSub Color
_ [Color]
cs [] = forall (m :: * -> *) a. Monad m => a -> m a
return [Color]
cs
goSub Color
outer_col [Color]
cs ((String
name,Nodes
sub) : [(String, Nodes)]
more) =
do (NodeId
_,[Color]
cs1) <- forall a. Dot a -> Dot (NodeId, a)
cluster forall a b. (a -> b) -> a -> b
$ do (String, String) -> Dot ()
attribute (String
"label", String
name)
(String, String) -> Dot ()
attribute (String
"color" , String
clusterC)
(String, String) -> Dot ()
attribute (String
"style", String
"filled")
Color -> [Color] -> Nodes -> Dot [Color]
go Color
outer_col [Color]
cs Nodes
sub
Color -> [Color] -> [(String, Nodes)] -> Dot [Color]
goSub Color
outer_col [Color]
cs1 [(String, Nodes)]
more
make_unclustered_dot :: [Color] -> String -> Nodes -> Dot [Color]
make_unclustered_dot :: [Color] -> String -> Nodes -> Dot [Color]
make_unclustered_dot [Color]
c String
pre (Trie.Sub Map String Nodes
xs Maybe [((NodeT, String), Int)]
ys') =
do let col :: String
col = Color -> String
renderColor (forall a. [a] -> a
head [Color]
c)
let ys :: [((NodeT, String), Int)]
ys = forall a. a -> Maybe a -> a
fromMaybe [] Maybe [((NodeT, String), Int)]
ys'
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [((NodeT, String), Int)]
ys forall a b. (a -> b) -> a -> b
$ \((NodeT
t,String
ls),Int
n) ->
NodeId -> [(String, String)] -> Dot ()
userNode (Int -> NodeId
userNodeId Int
n) forall a b. (a -> b) -> a -> b
$
[ (String
"fillcolor", String
col)
, (String
"style", String
"filled")
, (String
"label", String
pre forall a. [a] -> [a] -> [a]
++ String
ls)
] forall a. [a] -> [a] -> [a]
++
case NodeT
t of
CollapsedNode Bool
False -> [ (String
"shape", String
"box"), (String
"color", String
col) ]
CollapsedNode Bool
True -> [ (String
"shape", String
"box") ]
NodeT
Redirect -> []
NodeT
ModuleInItsCluster -> []
NodeT
ModuleNode -> []
NodeT
Deleted -> []
let c1 :: [Color]
c1 = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [((NodeT, String), Int)]
ys then [Color]
c else forall a. [a] -> [a]
tail [Color]
c
[Color]
c1 seq :: forall a b. a -> b -> b
`seq` [(String, Nodes)] -> [Color] -> Dot [Color]
loop (forall k a. Map k a -> [(k, a)]
Map.toList Map String Nodes
xs) [Color]
c1
where
loop :: [(String, Nodes)] -> [Color] -> Dot [Color]
loop ((String
name,Nodes
sub):[(String, Nodes)]
ms) [Color]
c1 =
do let pre1 :: String
pre1 = String
pre forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
"."
[Color]
c2 <- [Color] -> String -> Nodes -> Dot [Color]
make_unclustered_dot [Color]
c1 String
pre1 Nodes
sub
[(String, Nodes)] -> [Color] -> Dot [Color]
loop [(String, Nodes)]
ms [Color]
c2
loop [] [Color]
c2 = forall (m :: * -> *) a. Monad m => a -> m a
return [Color]
c2
type Color = (Int,Int,Int)
colors :: Int -> [Color]
colors :: Int -> [Color]
colors Int
n = forall a. [a] -> [a]
cycle forall a b. (a -> b) -> a -> b
$ forall a. [[a]] -> [a]
mix_colors forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
n [[Color]]
palettes
renderColor :: Color -> String
renderColor :: Color -> String
renderColor (Int
x,Int
y,Int
z) = Char
'#' forall a. a -> [a] -> [a]
: forall a. (Integral a, Show a) => a -> ShowS
showHex (forall {a}. Num a => a -> a
mk Int
x) (forall a. (Integral a, Show a) => a -> ShowS
showHex (forall {a}. Num a => a -> a
mk Int
y) (forall a. (Integral a, Show a) => a -> ShowS
showHex (forall {a}. Num a => a -> a
mk Int
z) String
""))
where mk :: a -> a
mk a
n = a
0xFF forall a. Num a => a -> a -> a
- a
n forall a. Num a => a -> a -> a
* a
0x44
mix_colors :: [[a]] -> [a]
mix_colors :: forall a. [[a]] -> [a]
mix_colors [[a]]
css = forall a. [[a]] -> [a]
mk [[a]]
set1 forall a. [a] -> [a] -> [a]
++ forall a. [[a]] -> [a]
mk [[a]]
set2
where
([[a]]
set1,[[a]]
set2) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. Int -> [a] -> ([a], [a])
splitAt Int
3) [[a]]
css
mk :: [[a]] -> [a]
mk = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [[a]] -> [[a]]
transpose
palettes :: [[Color]]
palettes :: [[Color]]
palettes = [[Color]
green, [Color]
yellow, [Color]
blue, [Color]
red, [Color]
cyan, [Color]
magenta ]
where
red :: [Color]
red :: [Color]
red = [ (Int
0,Int
1,Int
1), (Int
0,Int
2,Int
2), (Int
0,Int
3,Int
3), (Int
1,Int
2,Int
3), (Int
1,Int
3,Int
3), (Int
2,Int
3,Int
3) ]
green :: [Color]
green = forall a b. (a -> b) -> [a] -> [b]
map forall {b} {c} {a}. (b, c, a) -> (a, b, c)
rotR [Color]
red
blue :: [Color]
blue = forall a b. (a -> b) -> [a] -> [b]
map forall {b} {c} {a}. (b, c, a) -> (a, b, c)
rotR [Color]
green
[[Color]
cyan,[Color]
magenta,[Color]
yellow] = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {c}. (Num a, Num b, Num c) => (a, b, c) -> (a, b, c)
compl forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse) [[Color]
red, [Color]
green, [Color]
blue]
rotR :: (b, c, a) -> (a, b, c)
rotR (b
x,c
y,a
z) = (a
z,b
x,c
y)
compl :: (a, b, c) -> (a, b, c)
compl (a
x,b
y,c
z) = (a
3forall a. Num a => a -> a -> a
-a
x,b
3forall a. Num a => a -> a -> a
-b
y,c
3forall a. Num a => a -> a -> a
-c
z)
warn :: Opts -> String -> IO ()
warn :: Opts -> String -> IO ()
warn Opts
o String
_ | Opts -> Bool
quiet Opts
o = forall (m :: * -> *) a. Monad m => a -> m a
return ()
warn Opts
_ String
msg = Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"WARNING: " forall a. [a] -> [a] -> [a]
++ String
msg)
notFoundMsg :: ModName -> String
notFoundMsg :: ModName -> String
notFoundMsg ModName
m = String
"Cannot find a file for module "
forall a. [a] -> [a] -> [a]
++ ModName -> String
joinModName ModName
m forall a. [a] -> [a] -> [a]
++ String
" (ignoring)"
ambigMsg :: ModName -> [FilePath] -> String
ambigMsg :: ModName -> [String] -> String
ambigMsg ModName
m [String]
xs = String
"Multiple files for module " forall a. [a] -> [a] -> [a]
++ ModName -> String
joinModName ModName
m
forall a. [a] -> [a] -> [a]
++ String
" (picking the first):\n"
forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
"," [String]
xs
fromCabal :: Bool -> IO ([FilePath],[Input])
fromCabal :: Bool -> IO ([String], [Input])
fromCabal Bool
True =
do [String]
fs <- String -> IO [String]
getDirectoryContents String
"."
case forall a. (a -> Bool) -> [a] -> [a]
filter ((String
".cabal" forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
takeExtension) [String]
fs of
String
f : [String]
_ -> do [Unit]
units <- String -> IO [Unit]
parseCabalFile String
f
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`X.catch` \SomeException {} -> forall (m :: * -> *) a. Monad m => a -> m a
return []
forall (m :: * -> *) a. Monad m => a -> m a
return ([Unit] -> ([String], [Input])
fromUnits [Unit]
units)
[String]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ([],[])
fromCabal Bool
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ([],[])
fromUnits :: [Unit] -> ([FilePath], [Input])
fromUnits :: [Unit] -> ([String], [Input])
fromUnits [Unit]
us = (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[String]]
fs, forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Input]]
is)
where
([[String]]
fs,[[Input]]
is) = forall a b. [(a, b)] -> ([a], [b])
unzip (forall a b. (a -> b) -> [a] -> [b]
map Unit -> ([String], [Input])
fromUnit [Unit]
us)
fromUnit :: Unit -> ([FilePath], [Input])
fromUnit :: Unit -> ([String], [Input])
fromUnit Unit
u = (Unit -> [String]
unitPaths Unit
u, forall a b. (a -> b) -> [a] -> [b]
map String -> Input
File (Unit -> [String]
unitFiles Unit
u) forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map ModName -> Input
Module (Unit -> [ModName]
unitModules Unit
u))
data Opts = Opts
{ Opts -> [String]
inc_dirs :: [FilePath]
, Opts -> Bool
quiet :: Bool
, Opts -> Bool
with_missing :: Bool
, Opts -> Bool
use_clusters :: Bool
, Opts -> Bool
mod_in_cluster:: Bool
, Opts -> IgnoreSet
ignore_mods :: IgnoreSet
, Opts -> Trie String Bool
collapse_quals :: Trie.Trie String Bool
, Opts -> Bool
show_version :: Bool
, Opts -> Int
color_scheme :: Int
, Opts -> Bool
prune_edges :: Bool
, Opts -> String
graph_size :: String
, Opts -> Bool
use_cabal :: Bool
}
type IgnoreSet = Trie.Trie String IgnoreSpec
data IgnoreSpec = IgnoreAll | IgnoreSome [String] deriving Int -> IgnoreSpec -> ShowS
[IgnoreSpec] -> ShowS
IgnoreSpec -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IgnoreSpec] -> ShowS
$cshowList :: [IgnoreSpec] -> ShowS
show :: IgnoreSpec -> String
$cshow :: IgnoreSpec -> String
showsPrec :: Int -> IgnoreSpec -> ShowS
$cshowsPrec :: Int -> IgnoreSpec -> ShowS
Show
type OptT = Opts -> Opts
default_opts :: Opts
default_opts :: Opts
default_opts = Opts
{ inc_dirs :: [String]
inc_dirs = []
, quiet :: Bool
quiet = Bool
False
, with_missing :: Bool
with_missing = Bool
False
, use_clusters :: Bool
use_clusters = Bool
True
, mod_in_cluster :: Bool
mod_in_cluster = Bool
True
, ignore_mods :: IgnoreSet
ignore_mods = forall a b. Trie a b
Trie.empty
, collapse_quals :: Trie String Bool
collapse_quals = forall a b. Trie a b
Trie.empty
, show_version :: Bool
show_version = Bool
False
, color_scheme :: Int
color_scheme = Int
0
, prune_edges :: Bool
prune_edges = Bool
False
, graph_size :: String
graph_size = String
"6,4"
, use_cabal :: Bool
use_cabal = Bool
True
}
options :: [OptDescr OptT]
options :: [OptDescr OptT]
options =
[ forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'q'] [String
"quiet"] (forall a. a -> ArgDescr a
NoArg OptT
set_quiet)
String
"Do not show warnings"
, forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'i'] [] (forall a. (String -> a) -> String -> ArgDescr a
ReqArg String -> OptT
add_inc String
"DIR")
String
"Add a search directory"
, forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'a'] [String
"all"] (forall a. a -> ArgDescr a
NoArg OptT
set_all)
String
"Add nodes for missing modules"
, forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [] [String
"no-cluster"] (forall a. a -> ArgDescr a
NoArg OptT
set_no_cluster)
String
"Do not cluster directories"
, forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [] [String
"no-module-in-cluster"] (forall a. a -> ArgDescr a
NoArg OptT
set_no_mod_in_cluster)
String
"Do not place modules matching a cluster's name inside it."
, forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'r'] [String
"remove-module"] (forall a. (String -> a) -> String -> ArgDescr a
ReqArg String -> OptT
add_ignore_mod String
"NAME")
String
"Do not display module NAME"
, forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'R'] [String
"remove-qual"] (forall a. (String -> a) -> String -> ArgDescr a
ReqArg String -> OptT
add_ignore_qual String
"NAME")
String
"Do not display modules NAME.*"
, forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'c'] [String
"collapse"] (forall a. (String -> a) -> String -> ArgDescr a
ReqArg (Bool -> String -> OptT
add_collapse_qual Bool
False) String
"NAME")
String
"Display modules NAME.* as one node"
, forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'C'] [String
"collapse-module"] (forall a. (String -> a) -> String -> ArgDescr a
ReqArg (Bool -> String -> OptT
add_collapse_qual Bool
True) String
"NAME")
String
"Display modules NAME and NAME.* as one node"
, forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'p'] [String
"prune-edges"] (forall a. a -> ArgDescr a
NoArg OptT
set_prune)
String
"Remove imports if the module is imported by another imported module"
, forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'd'] [String
"graph-dim"] (forall a. (String -> a) -> String -> ArgDescr a
ReqArg String -> OptT
set_size String
"SIZE,SIZE")
String
"Set dimensions of the graph. See the `size` attribute of graphvize."
, forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
's'] [String
"colors"] (forall a. (String -> a) -> String -> ArgDescr a
ReqArg String -> OptT
add_color_scheme String
"NUM")
String
"Choose a color scheme number (0-5)"
, forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [] [String
"no-cabal"] (forall a. a -> ArgDescr a
NoArg (Bool -> OptT
set_cabal Bool
False))
String
"Do not use Cabal for paths and modules."
, forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'v'] [String
"version"] (forall a. a -> ArgDescr a
NoArg OptT
set_show_version)
String
"Show the current version."
]
add_current :: OptT
add_current :: OptT
add_current Opts
o = case Opts -> [String]
inc_dirs Opts
o of
[] -> Opts
o { inc_dirs :: [String]
inc_dirs = [String
"."] }
[String]
_ -> Opts
o
set_quiet :: OptT
set_quiet :: OptT
set_quiet Opts
o = Opts
o { quiet :: Bool
quiet = Bool
True }
set_show_version :: OptT
set_show_version :: OptT
set_show_version Opts
o = Opts
o { show_version :: Bool
show_version = Bool
True }
set_all :: OptT
set_all :: OptT
set_all Opts
o = Opts
o { with_missing :: Bool
with_missing = Bool
True }
set_no_cluster :: OptT
set_no_cluster :: OptT
set_no_cluster Opts
o = Opts
o { use_clusters :: Bool
use_clusters = Bool
False }
set_no_mod_in_cluster :: OptT
set_no_mod_in_cluster :: OptT
set_no_mod_in_cluster Opts
o = Opts
o { mod_in_cluster :: Bool
mod_in_cluster = Bool
False }
add_inc :: FilePath -> OptT
add_inc :: String -> OptT
add_inc String
d Opts
o = Opts
o { inc_dirs :: [String]
inc_dirs = String
d forall a. a -> [a] -> [a]
: Opts -> [String]
inc_dirs Opts
o }
add_ignore_mod :: String -> OptT
add_ignore_mod :: String -> OptT
add_ignore_mod String
s Opts
o = Opts
o { ignore_mods :: IgnoreSet
ignore_mods = ModName -> IgnoreSet
ins (String -> ModName
splitModName String
s) }
where
ins :: ModName -> IgnoreSet
ins (Qualifier
q,String
m) = forall a b. Ord a => [a] -> (Maybe b -> b) -> Trie a b -> Trie a b
Trie.insert (Qualifier -> [String]
qualifierNodes Qualifier
q) (String -> Maybe IgnoreSpec -> IgnoreSpec
upd String
m) (Opts -> IgnoreSet
ignore_mods Opts
o)
upd :: String -> Maybe IgnoreSpec -> IgnoreSpec
upd String
_ (Just IgnoreSpec
IgnoreAll) = IgnoreSpec
IgnoreAll
upd String
m (Just (IgnoreSome [String]
ms)) = [String] -> IgnoreSpec
IgnoreSome (String
mforall a. a -> [a] -> [a]
:[String]
ms)
upd String
m Maybe IgnoreSpec
Nothing = [String] -> IgnoreSpec
IgnoreSome [String
m]
add_ignore_qual :: String -> OptT
add_ignore_qual :: String -> OptT
add_ignore_qual String
s Opts
o = Opts
o { ignore_mods :: IgnoreSet
ignore_mods = forall a b. Ord a => [a] -> (Maybe b -> b) -> Trie a b -> Trie a b
Trie.insert ((Qualifier -> [String]
qualifierNodesforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> Qualifier
splitQualifier) String
s)
(forall a b. a -> b -> a
const IgnoreSpec
IgnoreAll) (Opts -> IgnoreSet
ignore_mods Opts
o) }
add_color_scheme :: String -> OptT
add_color_scheme :: String -> OptT
add_color_scheme String
n Opts
o = Opts
o { color_scheme :: Int
color_scheme = case forall a. Read a => ReadS a
reads String
n of
[(Int
x,String
"")] -> Int
x
[(Int, String)]
_ -> Opts -> Int
color_scheme Opts
default_opts }
add_collapse_qual :: Bool -> String -> OptT
add_collapse_qual :: Bool -> String -> OptT
add_collapse_qual Bool
m String
s Opts
o = Opts
o { collapse_quals :: Trie String Bool
collapse_quals = forall {a}. Ord a => [a] -> Trie a Bool -> Trie a Bool
upd ((Qualifier -> [String]
qualifierNodesforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> Qualifier
splitQualifier) String
s)
(Opts -> Trie String Bool
collapse_quals Opts
o) }
where
upd :: [a] -> Trie a Bool -> Trie a Bool
upd [] (Trie.Sub Map a (Trie a Bool)
xs (Just Bool
_)) = forall a b. Map a (Trie a b) -> Maybe b -> Trie a b
Trie.Sub Map a (Trie a Bool)
xs (forall a. a -> Maybe a
Just Bool
m)
upd [a]
_ t :: Trie a Bool
t@(Trie.Sub Map a (Trie a Bool)
_ (Just Bool
_)) = Trie a Bool
t
upd [] Trie a Bool
_ = forall a b. Map a (Trie a b) -> Maybe b -> Trie a b
Trie.Sub forall k a. Map k a
Map.empty (forall a. a -> Maybe a
Just Bool
m)
upd (a
q:[a]
qs) (Trie.Sub Map a (Trie a Bool)
as Maybe Bool
_) = forall a b. Map a (Trie a b) -> Maybe b -> Trie a b
Trie.Sub (forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter Maybe (Trie a Bool) -> Maybe (Trie a Bool)
add a
q Map a (Trie a Bool)
as) forall a. Maybe a
Nothing
where add :: Maybe (Trie a Bool) -> Maybe (Trie a Bool)
add Maybe (Trie a Bool)
j = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [a] -> Trie a Bool -> Trie a Bool
upd [a]
qs forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe forall a b. Trie a b
Trie.empty Maybe (Trie a Bool)
j
set_prune :: OptT
set_prune :: OptT
set_prune Opts
o = Opts
o { prune_edges :: Bool
prune_edges = Bool
True }
set_size :: String -> OptT
set_size :: String -> OptT
set_size String
s Opts
o = Opts
o { graph_size :: String
graph_size = String
s }
set_cabal :: Bool -> OptT
set_cabal :: Bool -> OptT
set_cabal Bool
on Opts
o = Opts
o { use_cabal :: Bool
use_cabal = Bool
on }