{-# 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 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.")