{-# LANGUAGE NamedFieldPuns #-}
module Calligraphy.Phases.EdgeCleanup (EdgeCleanupConfig, cleanupEdges, pEdgeCleanupConfig) where
import Prelude hiding (Node, Decl)
import Control.Monad.State.Strict
import Data.Set (Set)
import Data.Tree
import Options.Applicative
import qualified Data.Set as Set
import Calligraphy.Util.Types (CallGraph(CallGraph), Decl(..), Key, DeclType(..), forT_, modForest)
data EdgeCleanupConfig = EdgeCleanupConfig
{ EdgeCleanupConfig -> Bool
cleanDoubles :: Bool,
EdgeCleanupConfig -> Bool
cleanLoops :: Bool,
EdgeCleanupConfig -> Bool
cleanData :: Bool,
EdgeCleanupConfig -> Bool
cleanClass :: Bool
}
cleanupEdges :: EdgeCleanupConfig -> CallGraph -> CallGraph
cleanupEdges :: EdgeCleanupConfig -> CallGraph -> CallGraph
cleanupEdges
EdgeCleanupConfig {Bool
cleanDoubles :: Bool
cleanDoubles :: EdgeCleanupConfig -> Bool
cleanDoubles, Bool
cleanLoops :: Bool
cleanLoops :: EdgeCleanupConfig -> Bool
cleanLoops, Bool
cleanData :: Bool
cleanData :: EdgeCleanupConfig -> Bool
cleanData, Bool
cleanClass :: Bool
cleanClass :: EdgeCleanupConfig -> Bool
cleanClass}
(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) -> Set (Key, Key)
cleanLoopsFn Set (Key, Key)
calls) (Set (Key, Key) -> Set (Key, Key)
cleanLoopsFn forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Key, Key) -> Set (Key, Key)
cleanDoublesFn forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Key, Key) -> Set (Key, Key)
cleanDataFn forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Key, Key) -> Set (Key, Key)
cleanClassFn forall a b. (a -> b) -> a -> b
$ Set (Key, Key)
types)
where
cleanLoopsFn :: Set (Key, Key) -> Set (Key, Key)
cleanLoopsFn = if Bool
cleanLoops then forall a. (a -> Bool) -> Set a -> Set a
Set.filter (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Eq a => a -> a -> Bool
(/=)) else forall a. a -> a
id
cleanDoublesFn :: Set (Key, Key) -> Set (Key, Key)
cleanDoublesFn = if Bool
cleanDoubles then (forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set (Key, Key)
calls) else forall a. a -> a
id
cleanDataFn :: Set (Key, Key) -> Set (Key, Key)
cleanDataFn = if Bool
cleanData then (forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set (Key, Key)
dataEdges) else forall a. a -> a
id
cleanClassFn :: Set (Key, Key) -> Set (Key, Key)
cleanClassFn = if Bool
cleanClass then (forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set (Key, Key)
classEdges) else forall a. a -> a
id
dataEdges :: Set (Key, Key)
dataEdges = 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 (Forest 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]
mods Tree Decl -> State (Set (Key, Key)) ()
go) forall a. Monoid a => a
mempty
where
go :: Tree Decl -> State (Set (Key, Key)) ()
go :: Tree Decl -> State (Set (Key, Key)) ()
go (Node (Decl String
_ Key
k EnumSet GHCKey
_ Bool
_ DeclType
DataDecl Loc
_) Forest Decl
children) = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ (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
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse) (\Decl
d -> forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall a. Ord a => a -> Set a -> Set a
Set.insert (Decl -> Key
declKey Decl
d, Key
k))) Forest Decl
children
go (Node Decl
_ Forest Decl
children) = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Tree Decl -> State (Set (Key, Key)) ()
go Forest Decl
children
classEdges :: Set (Key, Key)
classEdges = 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 (Forest 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]
mods Tree Decl -> State (Set (Key, Key)) ()
go) forall a. Monoid a => a
mempty
where
go :: Tree Decl -> State (Set (Key, Key)) ()
go :: Tree Decl -> State (Set (Key, Key)) ()
go (Node (Decl String
_ Key
k EnumSet GHCKey
_ Bool
_ DeclType
ClassDecl Loc
_) Forest Decl
children) = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ (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
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse) (\Decl
d -> forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall a. Ord a => a -> Set a -> Set a
Set.insert (Decl -> Key
declKey Decl
d, Key
k))) Forest Decl
children
go (Node Decl
_ Forest Decl
children) = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Tree Decl -> State (Set (Key, Key)) ()
go Forest Decl
children
pEdgeCleanupConfig :: Parser EdgeCleanupConfig
pEdgeCleanupConfig :: Parser EdgeCleanupConfig
pEdgeCleanupConfig =
Bool -> Bool -> Bool -> Bool -> EdgeCleanupConfig
EdgeCleanupConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> a -> Mod FlagFields a -> Parser a
flag Bool
True Bool
False (forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"no-clean-double-edges" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
help String
"Don't remove type edges when value edges already exist.")
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> a -> Mod FlagFields a -> Parser a
flag Bool
True Bool
False (forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"no-clean-loops" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
help String
"Don't remove edges that start and stop at the same node, i.e. simple recursion.")
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> a -> Mod FlagFields a -> Parser a
flag Bool
True Bool
False (forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"no-clean-data" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
help String
"Don't remove type edges constructors/records back to the parent data type. These are removed by default because their behavior is unreliable, and they're generally redundant.")
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> a -> Mod FlagFields a -> Parser a
flag Bool
True Bool
False (forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"no-clean-classes" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
help String
"Don't remove type edges from class members back to the parent class. These are removed by default because their behavior is unreliable, and they're generally redundant.")