{-# LANGUAGE NamedFieldPuns #-}
module Calligraphy.Phases.EdgeCleanup (EdgeCleanupConfig, cleanupEdges, pEdgeCleanupConfig) where
import Calligraphy.Util.Types
import Control.Monad.State.Strict
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Tree
import Options.Applicative
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 (Set (Key, Key) -> Set (Key, Key))
-> (Set (Key, Key) -> Set (Key, Key))
-> Set (Key, Key)
-> Set (Key, Key)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Key, Key) -> Set (Key, Key)
cleanDoublesFn (Set (Key, Key) -> Set (Key, Key))
-> (Set (Key, Key) -> Set (Key, Key))
-> Set (Key, Key)
-> Set (Key, Key)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Key, Key) -> Set (Key, Key)
cleanDataFn (Set (Key, Key) -> Set (Key, Key))
-> (Set (Key, Key) -> Set (Key, Key))
-> Set (Key, Key)
-> Set (Key, Key)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Key, Key) -> Set (Key, Key)
cleanClassFn (Set (Key, Key) -> Set (Key, Key))
-> Set (Key, Key) -> Set (Key, Key)
forall a b. (a -> b) -> a -> b
$ Set (Key, Key)
types)
where
cleanLoopsFn :: Set (Key, Key) -> Set (Key, Key)
cleanLoopsFn = if Bool
cleanLoops then ((Key, Key) -> Bool) -> Set (Key, Key) -> Set (Key, Key)
forall a. (a -> Bool) -> Set a -> Set a
Set.filter ((Key -> Key -> Bool) -> (Key, Key) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
(/=)) else Set (Key, Key) -> Set (Key, Key)
forall a. a -> a
id
cleanDoublesFn :: Set (Key, Key) -> Set (Key, Key)
cleanDoublesFn = if Bool
cleanDoubles then (Set (Key, Key) -> Set (Key, Key) -> Set (Key, Key)
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set (Key, Key)
calls) else Set (Key, Key) -> Set (Key, Key)
forall a. a -> a
id
cleanDataFn :: Set (Key, Key) -> Set (Key, Key)
cleanDataFn = if Bool
cleanData then (Set (Key, Key) -> Set (Key, Key) -> Set (Key, Key)
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set (Key, Key)
dataEdges) else Set (Key, Key) -> Set (Key, Key)
forall a. a -> a
id
cleanClassFn :: Set (Key, Key) -> Set (Key, Key)
cleanClassFn = if Bool
cleanClass then (Set (Key, Key) -> Set (Key, Key) -> Set (Key, Key)
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set (Key, Key)
classEdges) else Set (Key, Key) -> Set (Key, Key)
forall a. a -> a
id
dataEdges :: Set (Key, Key)
dataEdges = State (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)) ())
-> State (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
. (Forest Decl -> m (Forest Decl)) -> Module -> m Module
Traversal' Module (Forest Decl)
modForest ((Forest Decl -> m (Forest Decl)) -> Module -> m Module)
-> ((Tree Decl -> m (Tree Decl)) -> Forest Decl -> m (Forest Decl))
-> (Tree Decl -> m (Tree Decl))
-> Module
-> m Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tree Decl -> m (Tree Decl)) -> Forest Decl -> m (Forest Decl)
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) Set (Key, Key)
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) = StateT (Set (Key, Key)) Identity [Tree ()]
-> State (Set (Key, Key)) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT (Set (Key, Key)) Identity [Tree ()]
-> State (Set (Key, Key)) ())
-> StateT (Set (Key, Key)) Identity [Tree ()]
-> State (Set (Key, Key)) ()
forall a b. (a -> b) -> a -> b
$ ((Tree Decl -> StateT (Set (Key, Key)) Identity (Tree ()))
-> Forest Decl -> StateT (Set (Key, Key)) Identity [Tree ()]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Tree Decl -> StateT (Set (Key, Key)) Identity (Tree ()))
-> Forest Decl -> StateT (Set (Key, Key)) Identity [Tree ()])
-> ((Decl -> State (Set (Key, Key)) ())
-> Tree Decl -> StateT (Set (Key, Key)) Identity (Tree ()))
-> (Decl -> State (Set (Key, Key)) ())
-> Forest Decl
-> StateT (Set (Key, Key)) Identity [Tree ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Decl -> State (Set (Key, Key)) ())
-> Tree Decl -> StateT (Set (Key, Key)) Identity (Tree ())
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse) (\Decl
d -> (Set (Key, Key) -> Set (Key, Key)) -> State (Set (Key, Key)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Key, Key) -> Set (Key, Key) -> Set (Key, Key)
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) = (Tree Decl -> State (Set (Key, Key)) ())
-> Forest Decl -> State (Set (Key, Key)) ()
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 = State (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)) ())
-> State (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
. (Forest Decl -> m (Forest Decl)) -> Module -> m Module
Traversal' Module (Forest Decl)
modForest ((Forest Decl -> m (Forest Decl)) -> Module -> m Module)
-> ((Tree Decl -> m (Tree Decl)) -> Forest Decl -> m (Forest Decl))
-> (Tree Decl -> m (Tree Decl))
-> Module
-> m Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tree Decl -> m (Tree Decl)) -> Forest Decl -> m (Forest Decl)
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) Set (Key, Key)
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) = StateT (Set (Key, Key)) Identity [Tree ()]
-> State (Set (Key, Key)) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT (Set (Key, Key)) Identity [Tree ()]
-> State (Set (Key, Key)) ())
-> StateT (Set (Key, Key)) Identity [Tree ()]
-> State (Set (Key, Key)) ()
forall a b. (a -> b) -> a -> b
$ ((Tree Decl -> StateT (Set (Key, Key)) Identity (Tree ()))
-> Forest Decl -> StateT (Set (Key, Key)) Identity [Tree ()]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Tree Decl -> StateT (Set (Key, Key)) Identity (Tree ()))
-> Forest Decl -> StateT (Set (Key, Key)) Identity [Tree ()])
-> ((Decl -> State (Set (Key, Key)) ())
-> Tree Decl -> StateT (Set (Key, Key)) Identity (Tree ()))
-> (Decl -> State (Set (Key, Key)) ())
-> Forest Decl
-> StateT (Set (Key, Key)) Identity [Tree ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Decl -> State (Set (Key, Key)) ())
-> Tree Decl -> StateT (Set (Key, Key)) Identity (Tree ())
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse) (\Decl
d -> (Set (Key, Key) -> Set (Key, Key)) -> State (Set (Key, Key)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Key, Key) -> Set (Key, Key) -> Set (Key, Key)
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) = (Tree Decl -> State (Set (Key, Key)) ())
-> Forest Decl -> State (Set (Key, Key)) ()
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
(Bool -> Bool -> Bool -> Bool -> EdgeCleanupConfig)
-> Parser Bool
-> Parser (Bool -> Bool -> Bool -> EdgeCleanupConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Bool -> Mod FlagFields Bool -> Parser Bool
forall a. a -> a -> Mod FlagFields a -> Parser a
flag Bool
True Bool
False (String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"no-clean-double-edges" Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help String
"Don't remove type edges when value edges already exist.")
Parser (Bool -> Bool -> Bool -> EdgeCleanupConfig)
-> Parser Bool -> Parser (Bool -> Bool -> EdgeCleanupConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> Bool -> Mod FlagFields Bool -> Parser Bool
forall a. a -> a -> Mod FlagFields a -> Parser a
flag Bool
True Bool
False (String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"no-clean-loops" Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
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.")
Parser (Bool -> Bool -> EdgeCleanupConfig)
-> Parser Bool -> Parser (Bool -> EdgeCleanupConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> Bool -> Mod FlagFields Bool -> Parser Bool
forall a. a -> a -> Mod FlagFields a -> Parser a
flag Bool
True Bool
False (String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"no-clean-data" Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
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.")
Parser (Bool -> EdgeCleanupConfig)
-> Parser Bool -> Parser EdgeCleanupConfig
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> Bool -> Mod FlagFields Bool -> Parser Bool
forall a. a -> a -> Mod FlagFields a -> Parser a
flag Bool
True Bool
False (String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"no-clean-classes" Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
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.")