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

-- | Guess if we have a file or a module name
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)]
                    -- 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 (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) ->
  -- NOTE: 'mods' is the final value of 'done' in the funciton 'loop'.

  let nodeFor :: ModName -> Maybe Int
nodeFor ModName
x         = ModName -> Nodes -> Maybe Int
lookupMod ModName
x Nodes
mods    -- Recursion happens here!

      loop :: Nodes ->
              AllEdges    {- all kinds of edges -} ->
              Int         {- size -} ->
              [Input]     {- root files/modules -} ->
              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 -- Keep looking for the actual node
            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)


-- 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 -> 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)

-- NOTE: We use the Maybe type to indicate when things changed.
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
         -- if modules are moved in their sub-directory clsuter,
         -- then we always want to collapse them, irrspective of the flag given


         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)

     -- use this node-id to represent the collapsed cluster
     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)



-- | 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 :: 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


-- 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 -> (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)

-- Warnings and error messages
--------------------------------------------------------------------------------
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
"." -- XXX
     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))



-- Command line options
--------------------------------------------------------------------------------
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
    -- ^ 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.
  , 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 -- ^ should we try to use a cabal file, if any
  }

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 }