{-# 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.Prelude hiding (Decl, DeclType, Node, filter)
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 qualified Data.Foldable as Foldable
import Data.List.NonEmpty (NonEmpty, nonEmpty)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Tree (Tree)
import qualified Data.Tree as Tree
import Data.Tuple (swap)
import Options.Applicative

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
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> Maybe (NonEmpty a)
nonEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Alternative f => f a -> f [a]
many)
      ( forall s. IsString s => Mod OptionFields s -> Parser s
strOption
          ( forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"forward-root"
              forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'f'
              forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"NAME"
              forall a. Semigroup a => a -> a -> a
<> 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."
          )
      )
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> Maybe (NonEmpty a)
nonEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Alternative f => f a -> f [a]
many)
      ( forall s. IsString s => Mod OptionFields s -> Parser s
strOption
          ( forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"reverse-root"
              forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'r'
              forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"NAME"
              forall a. Semigroup a => a -> a -> a
<> 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."
          )
      )
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall a. ReadM a -> Mod OptionFields a -> Parser a
option forall a. Read a => ReadM a
auto (forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"max-depth" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
help String
"Maximum search depth for transitive dependencies."))
    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." forall a. Monoid a => a
mempty
    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." forall a. Monoid a => a
mempty
    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." forall a. Monoid a => a
mempty
    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." forall a. Monoid a => a
mempty

newtype DependencyFilterError = UnknownRootName String

ppFilterError :: Prints DependencyFilterError
ppFilterError :: Prints DependencyFilterError
ppFilterError (UnknownRootName String
root) = String -> Printer ()
strLn forall a b. (a -> b) -> a -> b
$ String
"Unknown root name: " 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 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' = forall s t a b. Traversal s t a b -> (a -> b) -> s -> t
over (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. Traversal' Module [Tree Decl]
modForest) (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 (Tree.Node Decl
decl [Tree Decl]
children) = do
      let children' :: [Tree Decl]
children' = [Tree Decl]
children 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 forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> [Tree a] -> Tree a
Tree.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 = forall s a. State s a -> s -> s
execState (forall (m :: * -> *) s t a b.
Applicative m =>
Traversal s t a b -> s -> (a -> m ()) -> m ()
forT_ (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. Traversal' Module Decl
modDecls) [Module]
mods (forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k. Enum k => k -> EnumSet k -> EnumSet k
EnumSet.insert forall b c a. (b -> c) -> (a -> b) -> a -> c
. Decl -> Key
declKey)) forall a. Monoid a => a
mempty
    calls' :: Set (Key, Key)
calls' = forall a. (a -> Bool) -> Set a -> Set a
Set.filter (\(Key
a, Key
b) -> forall k. Enum k => k -> EnumSet k -> Bool
EnumSet.member Key
a EnumSet Key
outputKeys Bool -> Bool -> 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' = forall a. (a -> Bool) -> Set a -> Set a
Set.filter (\(Key
a, Key
b) -> forall k. Enum k => k -> EnumSet k -> Bool
EnumSet.member Key
a EnumSet Key
outputKeys Bool -> Bool -> 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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe (NonEmpty String)
mfw forall a b. (a -> b) -> a -> b
$ 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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe (NonEmpty String)
mbw forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip NonEmpty String
-> Set (Key, Key) -> Either DependencyFilterError (Decl -> Bool)
mkDepFilter (forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall a b. (a, b) -> (b, a)
swap Set (Key, Key)
edges)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure 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) -> 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 = forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith forall a. Monoid a => a -> a -> a
mappend (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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM NonEmpty String
rootNames forall a b. (a -> b) -> a -> b
$ \String
name -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> DependencyFilterError
UnknownRootName String
name) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k. Enum k => EnumSet k -> [k]
EnumSet.toList) (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 = forall a. Enum a => Maybe Int -> [a] -> Set (a, a) -> EnumSet a
transitives Maybe Int
maxDepth (forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList NonEmpty [Key]
rootKeys) Set (Key, Key)
edges
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ \Decl
decl -> forall k. Enum k => k -> EnumSet k -> Bool
EnumSet.member (Decl -> Key
declKey Decl
decl) EnumSet Key
ins

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

    parentEdges, childEdges :: Set (Key, Key)
    (Set (Key, Key)
parentEdges, Set (Key, Key)
childEdges) = forall s a. State s a -> s -> s
execState (forall (m :: * -> *) s t a b.
Applicative m =>
Traversal s t a b -> s -> (a -> m ()) -> m ()
forT_ (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. Traversal' Module [Tree Decl]
modForest forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) 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 (Tree.Node Decl
parent [Tree Decl]
children) =
          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Tree Decl]
children forall a b. (a -> b) -> a -> b
$ \childNode :: Tree Decl
childNode@(Tree.Node Decl
child [Tree Decl]
_) -> do
            let kParent :: Key
kParent = Decl -> Key
declKey Decl
parent
                kChild :: Key
kChild = Decl -> Key
declKey Decl
child
            forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (forall a. Ord a => a -> Set a -> Set a
Set.insert (Key
kParent, Key
kChild)) (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) =
  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> s
execState forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$
    forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. Traversal (Forest a) (Forest b) a b
forestT [Tree Decl]
forest forall a b. (a -> b) -> a -> b
$
      \(Decl String
name Key
key EnumSet GHCKey
_ Bool
_ DeclType
_ Loc
_) ->
        forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$
          forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith forall a. Semigroup a => a -> a -> a
(<>) (String
modName forall a. Semigroup a => a -> a -> a
<> String
"." forall a. Semigroup a => a -> a -> a
<> String
name) (forall k. Enum k => k -> EnumSet k
EnumSet.singleton Key
key)
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith forall a. Semigroup a => a -> a -> a
(<>) String
name (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 :: forall a. Enum a => 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 forall a. Monoid a => a
mempty (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
      | forall k. EnumSet k -> Bool
EnumSet.null EnumSet a
new = EnumSet a
old
      | forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (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 forall a. Semigroup a => a -> a -> a
<> EnumSet a
new
              new' :: EnumSet a
new' = forall k b. Enum k => (k -> b -> b) -> b -> EnumSet k -> b
EnumSet.foldr (\a
a -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall a. Monoid a => a -> a -> a
mappend forall a b. (a -> b) -> a -> b
$ forall k a. Enum k => k -> EnumMap k a -> Maybe a
EnumMap.lookup a
a EnumMap a (EnumSet a)
adjacencies) forall a. Monoid a => a
mempty EnumSet a
new
           in Int -> EnumSet a -> EnumSet a -> EnumSet a
go (Int
depth forall a. Num a => a -> a -> a
+ Int
1) EnumSet a
old' (EnumSet a
new' forall k. EnumSet k -> EnumSet k -> EnumSet k
EnumSet.\\ EnumSet a
old')
    adjacencies :: EnumMap a (EnumSet a)
    adjacencies :: EnumMap a (EnumSet a)
adjacencies = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(a
from, a
to) -> forall k a.
Enum k =>
(a -> a -> a) -> k -> a -> EnumMap k a -> EnumMap k a
EnumMap.insertWith forall a. Semigroup a => a -> a -> a
(<>) a
from (forall k. Enum k => k -> EnumSet k
EnumSet.singleton a
to)) forall a. Monoid a => a
mempty Set (a, a)
deps