{-# LANGUAGE RecordWildCards #-}
module Calligraphy.Phases.NodeFilter
( filterNodes,
NodeFilterConfig (..),
pNodeFilterConfig,
)
where
import Calligraphy.Prelude hiding (Decl)
import Calligraphy.Util.Types
import Control.Monad.State
import Data.EnumMap (EnumMap)
import qualified Data.EnumMap as EnumMap
import Data.Maybe (catMaybes)
import Data.Tree (Tree)
import qualified Data.Tree as Tree
import Options.Applicative
data Mode = Show | Collapse | Hide
deriving (Mode -> Mode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Mode -> Mode -> Bool
$c/= :: Mode -> Mode -> Bool
== :: Mode -> Mode -> Bool
$c== :: Mode -> Mode -> Bool
Eq, Int -> Mode -> ShowS
[Mode] -> ShowS
Mode -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Mode] -> ShowS
$cshowList :: [Mode] -> ShowS
show :: Mode -> String
$cshow :: Mode -> String
showsPrec :: Int -> Mode -> ShowS
$cshowsPrec :: Int -> Mode -> ShowS
Show)
data NodeFilterConfig = NodeFilterConfig
{ NodeFilterConfig -> Bool
hideLocals :: Bool,
NodeFilterConfig -> Bool
collapseModules :: Bool,
NodeFilterConfig -> Mode
collapseClasses :: Mode,
NodeFilterConfig -> Mode
collapseData :: Mode,
NodeFilterConfig -> Mode
collapseValues :: Mode,
NodeFilterConfig -> Mode
collapseConstructors :: Mode,
NodeFilterConfig -> Bool
hideRecords :: Bool
}
pNodeFilterConfig :: Parser NodeFilterConfig
pNodeFilterConfig :: Parser NodeFilterConfig
pNodeFilterConfig =
Bool
-> Bool -> Mode -> Mode -> Mode -> Mode -> Bool -> NodeFilterConfig
NodeFilterConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mod FlagFields Bool -> Parser Bool
switch (forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"exports-only" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"hide-local-bindings" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
help String
"Remove all non-exported bindings, merging all edges into its parent, if one exist.")
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod FlagFields Bool -> Parser Bool
switch (forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"collapse-modules" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
help String
"Collapse all nodes into a single node per module.")
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> String -> Parser Mode
pMode String
"classes" String
"class"
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> String -> Parser Mode
pMode String
"data" String
"data"
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> String -> Parser Mode
pMode String
"values" String
"value"
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> String -> Parser Mode
pMode String
"constructors" String
"constructor"
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> a -> Mod FlagFields a -> Parser a
flag Bool
False Bool
True (forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"hide-records" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
help String
"Remove all record nodes.")
where
pMode :: String -> String -> Parser Mode
pMode :: String -> String -> Parser Mode
pMode String
flagName String
helpName =
forall a. a -> Mod FlagFields a -> Parser a
flag' Mode
Collapse (forall (f :: * -> *) a. HasName f => String -> Mod f a
long (String
"collapse-" forall a. Semigroup a => a -> a -> a
<> String
flagName) forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
help String
collapseHelp)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. a -> Mod FlagFields a -> Parser a
flag' Mode
Hide (forall (f :: * -> *) a. HasName f => String -> Mod f a
long (String
"hide-" forall a. Semigroup a => a -> a -> a
<> String
flagName) forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
help String
hideHelp)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure Mode
Show
where
collapseHelp :: String
collapseHelp = String
"Remove all " forall a. Semigroup a => a -> a -> a
<> String
helpName forall a. Semigroup a => a -> a -> a
<> String
" nodes's children, merging the children's edges into itself."
hideHelp :: String
hideHelp = String
"Remove all " forall a. Semigroup a => a -> a -> a
<> String
helpName forall a. Semigroup a => a -> a -> a
<> String
" nodes and their children."
filterNodes :: NodeFilterConfig -> CallGraph -> CallGraph
filterNodes :: NodeFilterConfig -> CallGraph -> CallGraph
filterNodes NodeFilterConfig {Bool
Mode
hideRecords :: Bool
collapseConstructors :: Mode
collapseValues :: Mode
collapseData :: Mode
collapseClasses :: Mode
collapseModules :: Bool
hideLocals :: Bool
hideRecords :: NodeFilterConfig -> Bool
collapseConstructors :: NodeFilterConfig -> Mode
collapseValues :: NodeFilterConfig -> Mode
collapseData :: NodeFilterConfig -> Mode
collapseClasses :: NodeFilterConfig -> Mode
collapseModules :: NodeFilterConfig -> Bool
hideLocals :: NodeFilterConfig -> Bool
..} (CallGraph [Module]
modules Set (Key, Key)
calls Set (Key, Key)
types) =
let ([Module]
modules', EnumMap Key Key
reps) =
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> (a, s)
runState forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Module]
modules forall a b. (a -> b) -> a -> b
$
if Bool
collapseModules
then Module -> State (EnumMap Key Key) Module
collapseModule
else Traversal' Module (Forest Decl)
modForest (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [Maybe a] -> [a]
catMaybes 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 (Maybe Decl
-> Tree Decl -> State (EnumMap Key Key) (Maybe (Tree Decl))
go forall a. Maybe a
Nothing))
in [Module] -> Set (Key, Key) -> Set (Key, Key) -> CallGraph
CallGraph [Module]
modules' (forall a b.
(Enum a, Ord b) =>
EnumMap a b -> Set (a, a) -> Set (b, b)
rekeyCalls EnumMap Key Key
reps Set (Key, Key)
calls) (forall a b.
(Enum a, Ord b) =>
EnumMap a b -> Set (a, a) -> Set (b, b)
rekeyCalls EnumMap Key Key
reps Set (Key, Key)
types)
where
collapseModule :: Module -> State (EnumMap Key Key) Module
collapseModule :: Module -> State (EnumMap Key Key) Module
collapseModule (Module String
modname String
path []) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> String -> Forest Decl -> Module
Module String
modname String
path []
collapseModule (Module String
modname String
path forest :: Forest Decl
forest@(Tree.Node Decl
rep Forest Decl
_ : Forest Decl
_)) = do
let repKey :: Key
repKey = Decl -> Key
declKey Decl
rep
forall (m :: * -> *) s t a b.
Applicative m =>
Traversal s t a b -> s -> (a -> m ()) -> m ()
forT_ forall a b. Traversal (Forest a) (Forest b) a b
forestT Forest Decl
forest forall a b. (a -> b) -> a -> b
$ \Decl
decl -> Key -> Key -> StateT (EnumMap Key Key) Identity ()
assoc (Decl -> Key
declKey Decl
decl) Key
repKey
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> String -> Forest Decl -> Module
Module String
modname String
path [forall a. a -> [Tree a] -> Tree a
Tree.Node (String -> Key -> EnumSet GHCKey -> Bool -> DeclType -> Loc -> Decl
Decl String
modname Key
repKey forall a. Monoid a => a
mempty Bool
True DeclType
ValueDecl (Int -> Int -> Loc
Loc Int
1 Int
1)) []]
shouldCollapse :: Decl -> Bool
shouldCollapse :: Decl -> Bool
shouldCollapse Decl
decl = case Decl -> DeclType
declType Decl
decl of
DeclType
ValueDecl -> Mode
collapseValues forall a. Eq a => a -> a -> Bool
== Mode
Collapse
DeclType
ClassDecl -> Mode
collapseClasses forall a. Eq a => a -> a -> Bool
== Mode
Collapse
DeclType
ConDecl -> Mode
collapseConstructors forall a. Eq a => a -> a -> Bool
== Mode
Collapse
DeclType
DataDecl -> Mode
collapseData forall a. Eq a => a -> a -> Bool
== Mode
Collapse
DeclType
_ -> Bool
False
shouldHide :: Decl -> Bool
shouldHide :: Decl -> Bool
shouldHide Decl
decl = DeclType -> Bool
typ (Decl -> DeclType
declType Decl
decl) Bool -> Bool -> Bool
|| (Bool
hideLocals Bool -> Bool -> Bool
&& Bool -> Bool
not (Decl -> Bool
declExported Decl
decl))
where
typ :: DeclType -> Bool
typ DeclType
ClassDecl = Mode
collapseClasses forall a. Eq a => a -> a -> Bool
== Mode
Hide
typ DeclType
DataDecl = Mode
collapseData forall a. Eq a => a -> a -> Bool
== Mode
Hide
typ DeclType
ValueDecl = Mode
collapseValues forall a. Eq a => a -> a -> Bool
== Mode
Hide
typ DeclType
ConDecl = Mode
collapseConstructors forall a. Eq a => a -> a -> Bool
== Mode
Hide
typ DeclType
RecDecl = Bool
hideRecords
go :: Maybe Decl -> Tree Decl -> State (EnumMap Key Key) (Maybe (Tree Decl))
go :: Maybe Decl
-> Tree Decl -> State (EnumMap Key Key) (Maybe (Tree Decl))
go Maybe Decl
mparent node :: Tree Decl
node@(Tree.Node Decl
decl Forest Decl
children)
| Decl -> Bool
shouldHide Decl
decl = do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Decl
mparent forall a b. (a -> b) -> a -> b
$ \Decl
parent ->
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Tree Decl
node forall a b. (a -> b) -> a -> b
$ \Decl
child -> Key -> Key -> StateT (EnumMap Key Key) Identity ()
assoc (Decl -> Key
declKey Decl
child) (Decl -> Key
declKey Decl
parent)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
| Decl -> Bool
shouldCollapse Decl
decl = do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Tree Decl
node forall a b. (a -> b) -> a -> b
$ \Decl
child ->
Key -> Key -> StateT (EnumMap Key Key) Identity ()
assoc (Decl -> Key
declKey Decl
child) (Decl -> Key
declKey Decl
decl)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> [Tree a] -> Tree a
Tree.Node Decl
decl []
| Bool
otherwise = do
Key -> Key -> StateT (EnumMap Key Key) Identity ()
assoc (Decl -> Key
declKey Decl
decl) (Decl -> Key
declKey Decl
decl)
Forest Decl
children' <- forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Maybe Decl
-> Tree Decl -> State (EnumMap Key Key) (Maybe (Tree Decl))
go (forall a. a -> Maybe a
Just Decl
decl)) Forest Decl
children
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> [Tree a] -> Tree a
Tree.Node Decl
decl Forest Decl
children'
assoc :: Key -> Key -> State (EnumMap Key Key) ()
assoc :: Key -> Key -> StateT (EnumMap Key Key) Identity ()
assoc Key
key Key
rep = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a
EnumMap.insert Key
key Key
rep)