{-# LANGUAGE NamedFieldPuns #-}

-- | This modules collects some opinionated common-sense heuristics for removing edges that are probably redundant.
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.")