{-# 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.Prelude hiding (Decl, Node)
import Calligraphy.Util.Types (CallGraph (CallGraph), Decl (..), DeclType (..), Key, forT_, modForest)
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.")