{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}

-- | Dependency filtering is removing all nodes that are not part of a certain dependency tree
module Calligraphy.Phases.DependencyFilter
  ( DependencyFilterConfig,
    DependencyFilterError (..),
    ppFilterError,
    dependencyFilter,
    pDependencyFilterConfig,
  )
where

import Calligraphy.Util.Optparse (boolFlags)
import Calligraphy.Util.Printer
import Calligraphy.Util.Types
import Control.Monad.State.Strict
import Data.Bifunctor (bimap)
import Data.EnumMap (EnumMap)
import qualified Data.EnumMap as EnumMap
import Data.EnumSet (EnumSet)
import qualified Data.EnumSet as EnumSet
import Data.Foldable (toList)
import Data.List.NonEmpty (NonEmpty, nonEmpty)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Monoid
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Tree
import Data.Tuple (swap)
import Options.Applicative
import Prelude hiding (filter)

data DependencyFilterConfig = DependencyFilterConfig
  { DependencyFilterConfig -> Maybe (NonEmpty String)
_depRoot :: Maybe (NonEmpty String),
    DependencyFilterConfig -> Maybe (NonEmpty String)
_revDepRoot :: Maybe (NonEmpty String),
    DependencyFilterConfig -> Maybe Int
_depDepth :: Maybe Int,
    DependencyFilterConfig -> Bool
_followParent :: Bool,
    DependencyFilterConfig -> Bool
_followChildren :: Bool,
    DependencyFilterConfig -> Bool
_followCalls :: Bool,
    DependencyFilterConfig -> Bool
_followTypes :: Bool
  }

pDependencyFilterConfig :: Parser DependencyFilterConfig
pDependencyFilterConfig :: Parser DependencyFilterConfig
pDependencyFilterConfig =
  Maybe (NonEmpty String)
-> Maybe (NonEmpty String)
-> Maybe Int
-> Bool
-> Bool
-> Bool
-> Bool
-> DependencyFilterConfig
DependencyFilterConfig
    (Maybe (NonEmpty String)
 -> Maybe (NonEmpty String)
 -> Maybe Int
 -> Bool
 -> Bool
 -> Bool
 -> Bool
 -> DependencyFilterConfig)
-> Parser (Maybe (NonEmpty String))
-> Parser
     (Maybe (NonEmpty String)
      -> Maybe Int
      -> Bool
      -> Bool
      -> Bool
      -> Bool
      -> DependencyFilterConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (([String] -> Maybe (NonEmpty String))
-> Parser [String] -> Parser (Maybe (NonEmpty String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [String] -> Maybe (NonEmpty String)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty (Parser [String] -> Parser (Maybe (NonEmpty String)))
-> (Parser String -> Parser [String])
-> Parser String
-> Parser (Maybe (NonEmpty String))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser String -> Parser [String]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many)
      ( Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
          ( String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"forward-root"
              Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'f'
              Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"NAME"
              Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"Name of a dependency filter root. Specifying a dependency filter root hides everything that's not a (transitive) dependency of a root. The name can be qualified. This argument can be repeated."
          )
      )
    Parser
  (Maybe (NonEmpty String)
   -> Maybe Int
   -> Bool
   -> Bool
   -> Bool
   -> Bool
   -> DependencyFilterConfig)
-> Parser (Maybe (NonEmpty String))
-> Parser
     (Maybe Int
      -> Bool -> Bool -> Bool -> Bool -> DependencyFilterConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (([String] -> Maybe (NonEmpty String))
-> Parser [String] -> Parser (Maybe (NonEmpty String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [String] -> Maybe (NonEmpty String)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty (Parser [String] -> Parser (Maybe (NonEmpty String)))
-> (Parser String -> Parser [String])
-> Parser String
-> Parser (Maybe (NonEmpty String))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser String -> Parser [String]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many)
      ( Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
          ( String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"reverse-root"
              Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'r'
              Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"NAME"
              Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"Name of a reverse dependency filter root. Specifying a dependency filter root hides everything that's not a reverse (transitive) dependency of a root. The name can be qualified. This argument can be repeated."
          )
      )
    Parser
  (Maybe Int
   -> Bool -> Bool -> Bool -> Bool -> DependencyFilterConfig)
-> Parser (Maybe Int)
-> Parser (Bool -> Bool -> Bool -> Bool -> DependencyFilterConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Int -> Parser (Maybe Int)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ReadM Int -> Mod OptionFields Int -> Parser Int
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM Int
forall a. Read a => ReadM a
auto (String -> Mod OptionFields Int
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"max-depth" Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Int
forall (f :: * -> *) a. String -> Mod f a
help String
"Maximum search depth for transitive dependencies."))
    Parser (Bool -> Bool -> Bool -> Bool -> DependencyFilterConfig)
-> Parser Bool
-> Parser (Bool -> Bool -> Bool -> DependencyFilterConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> String -> String -> Mod FlagFields Bool -> Parser Bool
boolFlags Bool
True String
"follow-parent" String
"In calculating (transitive) dependencies, follow edges to from a child to its parent." Mod FlagFields Bool
forall a. Monoid a => a
mempty
    Parser (Bool -> Bool -> Bool -> DependencyFilterConfig)
-> Parser Bool -> Parser (Bool -> Bool -> DependencyFilterConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> String -> String -> Mod FlagFields Bool -> Parser Bool
boolFlags Bool
True String
"follow-child" String
"In calculating (transitive) dependencies, follow edges from a parent to its children." Mod FlagFields Bool
forall a. Monoid a => a
mempty
    Parser (Bool -> Bool -> DependencyFilterConfig)
-> Parser Bool -> Parser (Bool -> DependencyFilterConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> String -> String -> Mod FlagFields Bool -> Parser Bool
boolFlags Bool
True String
"follow-value" String
"In calculating (transitive) dependencies, follow normal edges." Mod FlagFields Bool
forall a. Monoid a => a
mempty
    Parser (Bool -> DependencyFilterConfig)
-> Parser Bool -> Parser DependencyFilterConfig
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> String -> String -> Mod FlagFields Bool -> Parser Bool
boolFlags Bool
False String
"follow-type" String
"In calculating (transitive) dependencies, follow type edges." Mod FlagFields Bool
forall a. Monoid a => a
mempty

newtype DependencyFilterError = UnknownRootName String

ppFilterError :: Prints DependencyFilterError
ppFilterError :: Prints DependencyFilterError
ppFilterError (UnknownRootName String
root) = String -> Printer ()
forall (m :: * -> *). MonadPrint m => String -> m ()
strLn (String -> Printer ()) -> String -> Printer ()
forall a b. (a -> b) -> a -> b
$ String
"Unknown root name: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
root

pruneModules :: (Decl -> Bool) -> CallGraph -> CallGraph
pruneModules :: (Decl -> Bool) -> CallGraph -> CallGraph
pruneModules Decl -> Bool
p (CallGraph [Module]
modules Set (Key, Key)
calls Set (Key, Key)
types) = CallGraph -> CallGraph
removeDeadCalls (CallGraph -> CallGraph) -> CallGraph -> CallGraph
forall a b. (a -> b) -> a -> b
$ [Module] -> Set (Key, Key) -> Set (Key, Key) -> CallGraph
CallGraph [Module]
modules' Set (Key, Key)
calls Set (Key, Key)
types
  where
    modules' :: [Module]
modules' = Traversal [Module] [Module] [Tree Decl] [Tree Decl]
-> ([Tree Decl] -> [Tree Decl]) -> [Module] -> [Module]
forall s t a b. Traversal s t a b -> (a -> b) -> s -> t
over ((Module -> m Module) -> [Module] -> m [Module]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Module -> m Module) -> [Module] -> m [Module])
-> (([Tree Decl] -> m [Tree Decl]) -> Module -> m Module)
-> ([Tree Decl] -> m [Tree Decl])
-> [Module]
-> m [Module]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Tree Decl] -> m [Tree Decl]) -> Module -> m Module
Traversal' Module [Tree Decl]
modForest) ([Tree Decl] -> (Tree Decl -> [Tree Decl]) -> [Tree Decl]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tree Decl -> [Tree Decl]
go) [Module]
modules
    go :: Tree Decl -> [Tree Decl]
    go :: Tree Decl -> [Tree Decl]
go (Node Decl
decl [Tree Decl]
children) = do
      let children' :: [Tree Decl]
children' = [Tree Decl]
children [Tree Decl] -> (Tree Decl -> [Tree Decl]) -> [Tree Decl]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tree Decl -> [Tree Decl]
go
       in if Decl -> Bool
p Decl
decl then Tree Decl -> [Tree Decl]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Decl -> [Tree Decl] -> Tree Decl
forall a. a -> Forest a -> Tree a
Node Decl
decl [Tree Decl]
children') else [Tree Decl]
children'

-- | Remove all calls and typings (i.e. edges) where one end is not present in the graph.
-- This is intended to be used after an operation that may have removed nodes from the graph.
removeDeadCalls :: CallGraph -> CallGraph
removeDeadCalls :: CallGraph -> CallGraph
removeDeadCalls (CallGraph [Module]
mods Set (Key, Key)
calls Set (Key, Key)
types) = [Module] -> Set (Key, Key) -> Set (Key, Key) -> CallGraph
CallGraph [Module]
mods Set (Key, Key)
calls' Set (Key, Key)
types'
  where
    outputKeys :: EnumSet Key
outputKeys = State (EnumSet Key) () -> EnumSet Key -> EnumSet Key
forall s a. State s a -> s -> s
execState (Traversal [Module] [Module] Decl Decl
-> [Module]
-> (Decl -> State (EnumSet Key) ())
-> State (EnumSet Key) ()
forall (m :: * -> *) s t a b.
Applicative m =>
Traversal s t a b -> s -> (a -> m ()) -> m ()
forT_ ((Module -> m Module) -> [Module] -> m [Module]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Module -> m Module) -> [Module] -> m [Module])
-> ((Decl -> m Decl) -> Module -> m Module)
-> (Decl -> m Decl)
-> [Module]
-> m [Module]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Decl -> m Decl) -> Module -> m Module
Traversal' Module Decl
modDecls) [Module]
mods ((EnumSet Key -> EnumSet Key) -> State (EnumSet Key) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((EnumSet Key -> EnumSet Key) -> State (EnumSet Key) ())
-> (Decl -> EnumSet Key -> EnumSet Key)
-> Decl
-> State (EnumSet Key) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> EnumSet Key -> EnumSet Key
forall k. Enum k => k -> EnumSet k -> EnumSet k
EnumSet.insert (Key -> EnumSet Key -> EnumSet Key)
-> (Decl -> Key) -> Decl -> EnumSet Key -> EnumSet Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Decl -> Key
declKey)) EnumSet Key
forall a. Monoid a => a
mempty
    calls' :: Set (Key, Key)
calls' = ((Key, Key) -> Bool) -> Set (Key, Key) -> Set (Key, Key)
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (\(Key
a, Key
b) -> Key -> EnumSet Key -> Bool
forall k. Enum k => k -> EnumSet k -> Bool
EnumSet.member Key
a EnumSet Key
outputKeys Bool -> Bool -> Bool
&& Key -> EnumSet Key -> Bool
forall k. Enum k => k -> EnumSet k -> Bool
EnumSet.member Key
b EnumSet Key
outputKeys) Set (Key, Key)
calls
    types' :: Set (Key, Key)
types' = ((Key, Key) -> Bool) -> Set (Key, Key) -> Set (Key, Key)
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (\(Key
a, Key
b) -> Key -> EnumSet Key -> Bool
forall k. Enum k => k -> EnumSet k -> Bool
EnumSet.member Key
a EnumSet Key
outputKeys Bool -> Bool -> Bool
&& Key -> EnumSet Key -> Bool
forall k. Enum k => k -> EnumSet k -> Bool
EnumSet.member Key
b EnumSet Key
outputKeys) Set (Key, Key)
types

dependencyFilter :: DependencyFilterConfig -> CallGraph -> Either DependencyFilterError CallGraph
dependencyFilter :: DependencyFilterConfig
-> CallGraph -> Either DependencyFilterError CallGraph
dependencyFilter (DependencyFilterConfig Maybe (NonEmpty String)
mfw Maybe (NonEmpty String)
mbw Maybe Int
maxDepth Bool
useParent Bool
useChild Bool
useCalls Bool
useTypes) mods :: CallGraph
mods@(CallGraph [Module]
modules Set (Key, Key)
calls Set (Key, Key)
types) = do
  Maybe (Decl -> Bool)
fwFilter <- Maybe (NonEmpty String)
-> (NonEmpty String -> Either DependencyFilterError (Decl -> Bool))
-> Either DependencyFilterError (Maybe (Decl -> Bool))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe (NonEmpty String)
mfw ((NonEmpty String -> Either DependencyFilterError (Decl -> Bool))
 -> Either DependencyFilterError (Maybe (Decl -> Bool)))
-> (NonEmpty String -> Either DependencyFilterError (Decl -> Bool))
-> Either DependencyFilterError (Maybe (Decl -> Bool))
forall a b. (a -> b) -> a -> b
$ (NonEmpty String
 -> Set (Key, Key) -> Either DependencyFilterError (Decl -> Bool))
-> Set (Key, Key)
-> NonEmpty String
-> Either DependencyFilterError (Decl -> Bool)
forall a b c. (a -> b -> c) -> b -> a -> c
flip NonEmpty String
-> Set (Key, Key) -> Either DependencyFilterError (Decl -> Bool)
mkDepFilter Set (Key, Key)
edges
  Maybe (Decl -> Bool)
bwFilter <- Maybe (NonEmpty String)
-> (NonEmpty String -> Either DependencyFilterError (Decl -> Bool))
-> Either DependencyFilterError (Maybe (Decl -> Bool))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe (NonEmpty String)
mbw ((NonEmpty String -> Either DependencyFilterError (Decl -> Bool))
 -> Either DependencyFilterError (Maybe (Decl -> Bool)))
-> (NonEmpty String -> Either DependencyFilterError (Decl -> Bool))
-> Either DependencyFilterError (Maybe (Decl -> Bool))
forall a b. (a -> b) -> a -> b
$ (NonEmpty String
 -> Set (Key, Key) -> Either DependencyFilterError (Decl -> Bool))
-> Set (Key, Key)
-> NonEmpty String
-> Either DependencyFilterError (Decl -> Bool)
forall a b c. (a -> b -> c) -> b -> a -> c
flip NonEmpty String
-> Set (Key, Key) -> Either DependencyFilterError (Decl -> Bool)
mkDepFilter (((Key, Key) -> (Key, Key)) -> Set (Key, Key) -> Set (Key, Key)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (Key, Key) -> (Key, Key)
forall a b. (a, b) -> (b, a)
swap Set (Key, Key)
edges)
  CallGraph -> Either DependencyFilterError CallGraph
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CallGraph -> Either DependencyFilterError CallGraph)
-> CallGraph -> Either DependencyFilterError CallGraph
forall a b. (a -> b) -> a -> b
$
    let p :: Decl -> Bool
p = case (Maybe (Decl -> Bool)
fwFilter, Maybe (Decl -> Bool)
bwFilter) of
          (Maybe (Decl -> Bool)
Nothing, Maybe (Decl -> Bool)
Nothing) -> Bool -> Decl -> Bool
forall a b. a -> b -> a
const Bool
True
          (Just Decl -> Bool
fa, Maybe (Decl -> Bool)
Nothing) -> Decl -> Bool
fa
          (Maybe (Decl -> Bool)
Nothing, Just Decl -> Bool
fb) -> Decl -> Bool
fb
          (Just Decl -> Bool
fa, Just Decl -> Bool
fb) -> \Decl
decl -> Decl -> Bool
fa Decl
decl Bool -> Bool -> Bool
|| Decl -> Bool
fb Decl
decl
     in (Decl -> Bool) -> CallGraph -> CallGraph
pruneModules Decl -> Bool
p CallGraph
mods
  where
    names :: Map String (EnumSet Key)
    names :: Map String (EnumSet Key)
names = (EnumSet Key -> EnumSet Key -> EnumSet Key)
-> [Map String (EnumSet Key)] -> Map String (EnumSet Key)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith EnumSet Key -> EnumSet Key -> EnumSet Key
forall a. Monoid a => a -> a -> a
mappend ((Module -> Map String (EnumSet Key))
-> [Module] -> [Map String (EnumSet Key)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Module -> Map String (EnumSet Key)
resolveNames [Module]
modules)
    mkDepFilter :: NonEmpty String -> Set (Key, Key) -> Either DependencyFilterError (Decl -> Bool)
    mkDepFilter :: NonEmpty String
-> Set (Key, Key) -> Either DependencyFilterError (Decl -> Bool)
mkDepFilter NonEmpty String
rootNames Set (Key, Key)
edges = do
      NonEmpty [Key]
rootKeys <- NonEmpty String
-> (String -> Either DependencyFilterError [Key])
-> Either DependencyFilterError (NonEmpty [Key])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM NonEmpty String
rootNames ((String -> Either DependencyFilterError [Key])
 -> Either DependencyFilterError (NonEmpty [Key]))
-> (String -> Either DependencyFilterError [Key])
-> Either DependencyFilterError (NonEmpty [Key])
forall a b. (a -> b) -> a -> b
$ \String
name -> Either DependencyFilterError [Key]
-> (EnumSet Key -> Either DependencyFilterError [Key])
-> Maybe (EnumSet Key)
-> Either DependencyFilterError [Key]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (DependencyFilterError -> Either DependencyFilterError [Key]
forall a b. a -> Either a b
Left (DependencyFilterError -> Either DependencyFilterError [Key])
-> DependencyFilterError -> Either DependencyFilterError [Key]
forall a b. (a -> b) -> a -> b
$ String -> DependencyFilterError
UnknownRootName String
name) ([Key] -> Either DependencyFilterError [Key]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Key] -> Either DependencyFilterError [Key])
-> (EnumSet Key -> [Key])
-> EnumSet Key
-> Either DependencyFilterError [Key]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnumSet Key -> [Key]
forall k. Enum k => EnumSet k -> [k]
EnumSet.toList) (String -> Map String (EnumSet Key) -> Maybe (EnumSet Key)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
name Map String (EnumSet Key)
names)
      let ins :: EnumSet Key
ins = Maybe Int -> [Key] -> Set (Key, Key) -> EnumSet Key
forall a. Enum a => Maybe Int -> [a] -> Set (a, a) -> EnumSet a
transitives Maybe Int
maxDepth ([[Key]] -> [Key]
forall a. Monoid a => [a] -> a
mconcat ([[Key]] -> [Key]) -> [[Key]] -> [Key]
forall a b. (a -> b) -> a -> b
$ NonEmpty [Key] -> [[Key]]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty [Key]
rootKeys) Set (Key, Key)
edges
      (Decl -> Bool) -> Either DependencyFilterError (Decl -> Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Decl -> Bool) -> Either DependencyFilterError (Decl -> Bool))
-> (Decl -> Bool) -> Either DependencyFilterError (Decl -> Bool)
forall a b. (a -> b) -> a -> b
$ \Decl
decl -> Key -> EnumSet Key -> Bool
forall k. Enum k => k -> EnumSet k -> Bool
EnumSet.member (Decl -> Key
declKey Decl
decl) EnumSet Key
ins

    edges :: Set (Key, Key)
edges =
      [Set (Key, Key)] -> Set (Key, Key)
forall a. Monoid a => [a] -> a
mconcat
        [ if Bool
useParent then Set (Key, Key)
parentEdges else Set (Key, Key)
forall a. Monoid a => a
mempty,
          if Bool
useChild then Set (Key, Key)
childEdges else Set (Key, Key)
forall a. Monoid a => a
mempty,
          if Bool
useCalls then Set (Key, Key)
calls else Set (Key, Key)
forall a. Monoid a => a
mempty,
          if Bool
useTypes then Set (Key, Key)
types else Set (Key, Key)
forall a. Monoid a => a
mempty
        ]

    parentEdges, childEdges :: Set (Key, Key)
    (Set (Key, Key)
parentEdges, Set (Key, Key)
childEdges) = State (Set (Key, Key), Set (Key, Key)) ()
-> (Set (Key, Key), Set (Key, Key))
-> (Set (Key, Key), Set (Key, Key))
forall s a. State s a -> s -> s
execState (Traversal [Module] [Module] (Tree Decl) (Tree Decl)
-> [Module]
-> (Tree Decl -> State (Set (Key, Key), Set (Key, Key)) ())
-> State (Set (Key, Key), Set (Key, Key)) ()
forall (m :: * -> *) s t a b.
Applicative m =>
Traversal s t a b -> s -> (a -> m ()) -> m ()
forT_ ((Module -> m Module) -> [Module] -> m [Module]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Module -> m Module) -> [Module] -> m [Module])
-> ((Tree Decl -> m (Tree Decl)) -> Module -> m Module)
-> (Tree Decl -> m (Tree Decl))
-> [Module]
-> m [Module]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Tree Decl] -> m [Tree Decl]) -> Module -> m Module
Traversal' Module [Tree Decl]
modForest (([Tree Decl] -> m [Tree Decl]) -> Module -> m Module)
-> ((Tree Decl -> m (Tree Decl)) -> [Tree Decl] -> m [Tree Decl])
-> (Tree Decl -> m (Tree Decl))
-> Module
-> m Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tree Decl -> m (Tree Decl)) -> [Tree Decl] -> m [Tree Decl]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse) [Module]
modules Tree Decl -> State (Set (Key, Key), Set (Key, Key)) ()
go) (Set (Key, Key), Set (Key, Key))
forall a. Monoid a => a
mempty
      where
        go :: Tree Decl -> State (Set (Key, Key), Set (Key, Key)) ()
        go :: Tree Decl -> State (Set (Key, Key), Set (Key, Key)) ()
go (Node Decl
parent [Tree Decl]
children) =
          [Tree Decl]
-> (Tree Decl -> State (Set (Key, Key), Set (Key, Key)) ())
-> State (Set (Key, Key), Set (Key, Key)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Tree Decl]
children ((Tree Decl -> State (Set (Key, Key), Set (Key, Key)) ())
 -> State (Set (Key, Key), Set (Key, Key)) ())
-> (Tree Decl -> State (Set (Key, Key), Set (Key, Key)) ())
-> State (Set (Key, Key), Set (Key, Key)) ()
forall a b. (a -> b) -> a -> b
$ \childNode :: Tree Decl
childNode@(Node Decl
child [Tree Decl]
_) -> do
            let kParent :: Key
kParent = Decl -> Key
declKey Decl
parent
                kChild :: Key
kChild = Decl -> Key
declKey Decl
child
            ((Set (Key, Key), Set (Key, Key))
 -> (Set (Key, Key), Set (Key, Key)))
-> State (Set (Key, Key), Set (Key, Key)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (((Set (Key, Key), Set (Key, Key))
  -> (Set (Key, Key), Set (Key, Key)))
 -> State (Set (Key, Key), Set (Key, Key)) ())
-> ((Set (Key, Key), Set (Key, Key))
    -> (Set (Key, Key), Set (Key, Key)))
-> State (Set (Key, Key), Set (Key, Key)) ()
forall a b. (a -> b) -> a -> b
$ (Set (Key, Key) -> Set (Key, Key))
-> (Set (Key, Key) -> Set (Key, Key))
-> (Set (Key, Key), Set (Key, Key))
-> (Set (Key, Key), Set (Key, Key))
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ((Key, Key) -> Set (Key, Key) -> Set (Key, Key)
forall a. Ord a => a -> Set a -> Set a
Set.insert (Key
kParent, Key
kChild)) ((Key, Key) -> Set (Key, Key) -> Set (Key, Key)
forall a. Ord a => a -> Set a -> Set a
Set.insert (Key
kChild, Key
kParent))
            Tree Decl -> State (Set (Key, Key), Set (Key, Key)) ()
go Tree Decl
childNode

-- | Create a map of all names, and the keys they correspond to.
-- For every name in the source, this introduces two entries; one naked, and one qualified with the module name.
resolveNames :: Module -> Map String (EnumSet Key)
resolveNames :: Module -> Map String (EnumSet Key)
resolveNames (Module String
modName String
_ [Tree Decl]
forest) =
  (State (Map String (EnumSet Key)) (Forest ())
 -> Map String (EnumSet Key) -> Map String (EnumSet Key))
-> Map String (EnumSet Key)
-> State (Map String (EnumSet Key)) (Forest ())
-> Map String (EnumSet Key)
forall a b c. (a -> b -> c) -> b -> a -> c
flip State (Map String (EnumSet Key)) (Forest ())
-> Map String (EnumSet Key) -> Map String (EnumSet Key)
forall s a. State s a -> s -> s
execState Map String (EnumSet Key)
forall a. Monoid a => a
mempty (State (Map String (EnumSet Key)) (Forest ())
 -> Map String (EnumSet Key))
-> State (Map String (EnumSet Key)) (Forest ())
-> Map String (EnumSet Key)
forall a b. (a -> b) -> a -> b
$
    ((Decl -> StateT (Map String (EnumSet Key)) Identity ())
 -> [Tree Decl] -> State (Map String (EnumSet Key)) (Forest ()))
-> [Tree Decl]
-> (Decl -> StateT (Map String (EnumSet Key)) Identity ())
-> State (Map String (EnumSet Key)) (Forest ())
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Decl -> StateT (Map String (EnumSet Key)) Identity ())
-> [Tree Decl] -> State (Map String (EnumSet Key)) (Forest ())
forall a b. Traversal (Forest a) (Forest b) a b
forestT [Tree Decl]
forest ((Decl -> StateT (Map String (EnumSet Key)) Identity ())
 -> State (Map String (EnumSet Key)) (Forest ()))
-> (Decl -> StateT (Map String (EnumSet Key)) Identity ())
-> State (Map String (EnumSet Key)) (Forest ())
forall a b. (a -> b) -> a -> b
$
      \(Decl String
name Key
key EnumSet GHCKey
_ Bool
_ DeclType
_ Loc
_) ->
        (Map String (EnumSet Key) -> Map String (EnumSet Key))
-> StateT (Map String (EnumSet Key)) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Map String (EnumSet Key) -> Map String (EnumSet Key))
 -> StateT (Map String (EnumSet Key)) Identity ())
-> (Map String (EnumSet Key) -> Map String (EnumSet Key))
-> StateT (Map String (EnumSet Key)) Identity ()
forall a b. (a -> b) -> a -> b
$
          (EnumSet Key -> EnumSet Key -> EnumSet Key)
-> String
-> EnumSet Key
-> Map String (EnumSet Key)
-> Map String (EnumSet Key)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith EnumSet Key -> EnumSet Key -> EnumSet Key
forall a. Semigroup a => a -> a -> a
(<>) (String
modName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
name) (Key -> EnumSet Key
forall k. Enum k => k -> EnumSet k
EnumSet.singleton Key
key)
            (Map String (EnumSet Key) -> Map String (EnumSet Key))
-> (Map String (EnumSet Key) -> Map String (EnumSet Key))
-> Map String (EnumSet Key)
-> Map String (EnumSet Key)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EnumSet Key -> EnumSet Key -> EnumSet Key)
-> String
-> EnumSet Key
-> Map String (EnumSet Key)
-> Map String (EnumSet Key)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith EnumSet Key -> EnumSet Key -> EnumSet Key
forall a. Semigroup a => a -> a -> a
(<>) String
name (Key -> EnumSet Key
forall k. Enum k => k -> EnumSet k
EnumSet.singleton Key
key)

transitives :: forall a. Enum a => Maybe Int -> [a] -> Set (a, a) -> EnumSet a
transitives :: Maybe Int -> [a] -> Set (a, a) -> EnumSet a
transitives Maybe Int
maxDepth [a]
roots Set (a, a)
deps = Int -> EnumSet a -> EnumSet a -> EnumSet a
go Int
0 EnumSet a
forall a. Monoid a => a
mempty ([a] -> EnumSet a
forall k. Enum k => [k] -> EnumSet k
EnumSet.fromList [a]
roots)
  where
    go :: Int -> EnumSet a -> EnumSet a -> EnumSet a
    go :: Int -> EnumSet a -> EnumSet a -> EnumSet a
go Int
depth EnumSet a
old EnumSet a
new
      | EnumSet a -> Bool
forall k. EnumSet k -> Bool
EnumSet.null EnumSet a
new = EnumSet a
old
      | Bool -> (Int -> Bool) -> Maybe Int -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
depth) Maybe Int
maxDepth = EnumSet a
old
      | Bool
otherwise =
          let old' :: EnumSet a
old' = EnumSet a
old EnumSet a -> EnumSet a -> EnumSet a
forall a. Semigroup a => a -> a -> a
<> EnumSet a
new
              new' :: EnumSet a
new' = (a -> EnumSet a -> EnumSet a)
-> EnumSet a -> EnumSet a -> EnumSet a
forall k b. Enum k => (k -> b -> b) -> b -> EnumSet k -> b
EnumSet.foldr (\a
a -> (EnumSet a -> EnumSet a)
-> (EnumSet a -> EnumSet a -> EnumSet a)
-> Maybe (EnumSet a)
-> EnumSet a
-> EnumSet a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe EnumSet a -> EnumSet a
forall a. a -> a
id EnumSet a -> EnumSet a -> EnumSet a
forall a. Monoid a => a -> a -> a
mappend (Maybe (EnumSet a) -> EnumSet a -> EnumSet a)
-> Maybe (EnumSet a) -> EnumSet a -> EnumSet a
forall a b. (a -> b) -> a -> b
$ a -> EnumMap a (EnumSet a) -> Maybe (EnumSet a)
forall k a. Enum k => k -> EnumMap k a -> Maybe a
EnumMap.lookup a
a EnumMap a (EnumSet a)
adjacencies) EnumSet a
forall a. Monoid a => a
mempty EnumSet a
new
           in Int -> EnumSet a -> EnumSet a -> EnumSet a
go (Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) EnumSet a
old' (EnumSet a
new' EnumSet a -> EnumSet a -> EnumSet a
forall k. EnumSet k -> EnumSet k -> EnumSet k
EnumSet.\\ EnumSet a
old')
    adjacencies :: EnumMap a (EnumSet a)
    adjacencies :: EnumMap a (EnumSet a)
adjacencies = ((a, a) -> EnumMap a (EnumSet a) -> EnumMap a (EnumSet a))
-> EnumMap a (EnumSet a) -> Set (a, a) -> EnumMap a (EnumSet a)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(a
from, a
to) -> (EnumSet a -> EnumSet a -> EnumSet a)
-> a -> EnumSet a -> EnumMap a (EnumSet a) -> EnumMap a (EnumSet a)
forall k a.
Enum k =>
(a -> a -> a) -> k -> a -> EnumMap k a -> EnumMap k a
EnumMap.insertWith EnumSet a -> EnumSet a -> EnumSet a
forall a. Semigroup a => a -> a -> a
(<>) a
from (a -> EnumSet a
forall k. Enum k => k -> EnumSet k
EnumSet.singleton a
to)) EnumMap a (EnumSet a)
forall a. Monoid a => a
mempty Set (a, a)
deps