{-# LANGUAGE RecordWildCards #-}
module Calligraphy.Phases.Render.Common
( RenderConfig (..),
pRenderConfig,
renderGraph,
RenderError,
ppRenderError,
ID,
RenderGraph (..),
RenderModule (..),
RenderNode (..),
ClusterModules (..),
if',
)
where
import Calligraphy.Util.Printer (Prints, strLn)
import Calligraphy.Util.Types (CallGraph (..), Decl (..), DeclType, GHCKey (unGHCKey), Key (..), Loc (..), Module (..))
import Control.Applicative ((<|>))
import Data.Bifunctor (bimap)
import qualified Data.EnumSet as EnumSet
import Data.List.NonEmpty (NonEmpty, nonEmpty)
import Data.Maybe (catMaybes, mapMaybe)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Tree (Tree)
import Options.Applicative (Parser, flag, flag', help, long)
data RenderConfig = RenderConfig
{ RenderConfig -> Bool
showCalls :: Bool,
RenderConfig -> Bool
showTypes :: Bool,
RenderConfig -> Bool
showKey :: Bool,
RenderConfig -> Bool
showGHCKeys :: Bool,
RenderConfig -> Bool
showModulePath :: Bool,
RenderConfig -> LocMode
locMode :: LocMode,
RenderConfig -> ClusterModules
clusterModules :: ClusterModules
}
data ClusterModules
= ClusterNever
| ClusterWhenMultiple
| ClusterAlways
pRenderConfig :: Parser RenderConfig
pRenderConfig :: Parser RenderConfig
pRenderConfig =
Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> LocMode
-> ClusterModules
-> RenderConfig
RenderConfig
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 => ID -> Mod f a
long ID
"hide-calls" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. ID -> Mod f a
help ID
"Don't show call arrows")
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 => ID -> Mod f a
long ID
"hide-types" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. ID -> Mod f a
help ID
"Don't show type arrows")
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 => ID -> Mod f a
long ID
"show-key" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. ID -> Mod f a
help ID
"Show internal keys with identifiers. Useful for debugging.")
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 => ID -> Mod f a
long ID
"show-ghc-key" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. ID -> Mod f a
help ID
"Show GHC keys with identifiers. Useful for debugging.")
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 => ID -> Mod f a
long ID
"show-module-path" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. ID -> Mod f a
help ID
"Show a module's filepath instead of its name")
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser LocMode
pLocMode
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ClusterModules
pClusterModules
pClusterModules :: Parser ClusterModules
pClusterModules :: Parser ClusterModules
pClusterModules =
forall a. a -> Mod FlagFields a -> Parser a
flag' ClusterModules
ClusterNever (forall (f :: * -> *) a. HasName f => ID -> Mod f a
long ID
"no-cluster-modules" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. ID -> Mod f a
help ID
"Don't draw modules as a cluster.")
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. a -> Mod FlagFields a -> Parser a
flag' ClusterModules
ClusterAlways (forall (f :: * -> *) a. HasName f => ID -> Mod f a
long ID
"force-cluster-modules" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. ID -> Mod f a
help ID
"Draw modules as a cluster, even if there is only one.")
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure ClusterModules
ClusterWhenMultiple
type ID = String
data RenderGraph = RenderGraph
{ RenderGraph
-> Either (NonEmpty RenderModule) (NonEmpty (Tree RenderNode))
renderRoots :: Either (NonEmpty RenderModule) (NonEmpty (Tree RenderNode)),
RenderGraph -> Set (ID, ID)
callEdges :: Set (ID, ID),
RenderGraph -> Set (ID, ID)
typeEdges :: Set (ID, ID)
}
data RenderModule = RenderModule
{ RenderModule -> ID
moduleLabel :: String,
RenderModule -> ID
moduleId :: ID,
RenderModule -> NonEmpty (Tree RenderNode)
moduleDecls :: NonEmpty (Tree RenderNode)
}
data RenderNode = RenderNode
{ RenderNode -> ID
nodeId :: ID,
RenderNode -> DeclType
nodeType :: DeclType,
RenderNode -> [ID]
nodeLabelLines :: [String],
RenderNode -> Bool
nodeExported :: Bool
}
data LocMode = Hide | Line | LineCol
data RenderError = EmptyGraph
ppRenderError :: Prints RenderError
ppRenderError :: Prints RenderError
ppRenderError RenderError
EmptyGraph = ID -> Printer ()
strLn ID
"Output graph is empty"
renderGraph :: RenderConfig -> CallGraph -> Either RenderError RenderGraph
renderGraph :: RenderConfig -> CallGraph -> Either RenderError RenderGraph
renderGraph
RenderConfig {Bool
LocMode
ClusterModules
clusterModules :: ClusterModules
locMode :: LocMode
showModulePath :: Bool
showGHCKeys :: Bool
showKey :: Bool
showTypes :: Bool
showCalls :: Bool
clusterModules :: RenderConfig -> ClusterModules
locMode :: RenderConfig -> LocMode
showModulePath :: RenderConfig -> Bool
showGHCKeys :: RenderConfig -> Bool
showKey :: RenderConfig -> Bool
showTypes :: RenderConfig -> Bool
showCalls :: RenderConfig -> Bool
..}
(CallGraph [Module]
modules Set (Key, Key)
calls Set (Key, Key)
types) =
case forall a. [a] -> Maybe (NonEmpty a)
nonEmpty (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Module -> Int -> Maybe RenderModule
mkModule) (forall a b. [a] -> [b] -> [(a, b)]
zip [Module]
modules [Int
0 ..])) of
Maybe (NonEmpty RenderModule)
Nothing -> forall a b. a -> Either a b
Left RenderError
EmptyGraph
Just NonEmpty RenderModule
neModules ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
Either (NonEmpty RenderModule) (NonEmpty (Tree RenderNode))
-> Set (ID, ID) -> Set (ID, ID) -> RenderGraph
RenderGraph
( let cluster :: Bool
cluster = case ClusterModules
clusterModules of
ClusterModules
ClusterAlways -> Bool
True
ClusterModules
ClusterWhenMultiple -> forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty RenderModule
neModules forall a. Ord a => a -> a -> Bool
> Int
1
ClusterModules
ClusterNever -> Bool
False
in if Bool
cluster then forall a b. a -> Either a b
Left NonEmpty RenderModule
neModules else forall a b. b -> Either a b
Right (NonEmpty RenderModule
neModules forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RenderModule -> NonEmpty (Tree RenderNode)
moduleDecls)
)
(if Bool
showCalls then forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Key -> ID
keyId Key -> ID
keyId) Set (Key, Key)
calls else forall a. Set a
Set.empty)
(if Bool
showTypes then forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Key -> ID
keyId Key -> ID
keyId) Set (Key, Key)
types else forall a. Set a
Set.empty)
where
keyId :: Key -> ID
keyId :: Key -> ID
keyId (Key Int
k) = ID
"node_" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> ID
show Int
k
mkModule :: Module -> Int -> Maybe RenderModule
mkModule :: Module -> Int -> Maybe RenderModule
mkModule (Module ID
name ID
path Forest Decl
decls) Int
ix =
(\NonEmpty (Tree Decl)
ne -> ID -> ID -> NonEmpty (Tree RenderNode) -> RenderModule
RenderModule ID
label (ID
"module_" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> ID
show Int
ix) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Decl -> RenderNode
mkNode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Tree Decl)
ne)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> Maybe (NonEmpty a)
nonEmpty Forest Decl
decls
where
label :: ID
label
| Bool
showModulePath = ID
path
| Bool
otherwise = ID
name
mkNode :: Decl -> RenderNode
mkNode :: Decl -> RenderNode
mkNode (Decl ID
name Key
key EnumSet GHCKey
ghcKeys Bool
x DeclType
t Loc
loc) = ID -> DeclType -> [ID] -> Bool -> RenderNode
RenderNode (Key -> ID
keyId Key
key) DeclType
t (forall a. [Maybe a] -> [a]
catMaybes [Maybe ID]
lbls) Bool
x
where
lbls :: [Maybe ID]
lbls =
[ forall (f :: * -> *) a. Applicative f => a -> f a
pure ID
name,
forall a. Bool -> a -> Maybe a
if' Bool
showKey forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> ID
show (Key -> Int
unKey Key
key),
forall a. Bool -> a -> Maybe a
if' Bool
showGHCKeys forall a b. (a -> b) -> a -> b
$ ID
"GHC Keys: " forall a. Semigroup a => a -> a -> a
<> ([ID] -> ID
unwords forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Show a => a -> ID
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. GHCKey -> Int
unGHCKey) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k. Enum k => EnumSet k -> [k]
EnumSet.toList forall a b. (a -> b) -> a -> b
$ EnumSet GHCKey
ghcKeys),
case LocMode
locMode of
LocMode
Hide -> forall a. Maybe a
Nothing
LocMode
Line -> forall a. a -> Maybe a
Just (Char
'L' forall a. a -> [a] -> [a]
: forall a. Show a => a -> ID
show (Loc -> Int
locLine Loc
loc))
LocMode
LineCol -> forall a. a -> Maybe a
Just (forall a. Show a => a -> ID
show Loc
loc)
]
pLocMode :: Parser LocMode
pLocMode :: Parser LocMode
pLocMode =
forall a. a -> Mod FlagFields a -> Parser a
flag' LocMode
Line (forall (f :: * -> *) a. HasName f => ID -> Mod f a
long ID
"show-line" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. ID -> Mod f a
help ID
"Show line numbers")
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. a -> Mod FlagFields a -> Parser a
flag' LocMode
LineCol (forall (f :: * -> *) a. HasName f => ID -> Mod f a
long ID
"show-line-col" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. ID -> Mod f a
help ID
"Show line and column numbers")
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure LocMode
Hide
if' :: Bool -> a -> Maybe a
if' :: forall a. Bool -> a -> Maybe a
if' Bool
True a
a = forall a. a -> Maybe a
Just a
a
if' Bool
False a
_ = forall a. Maybe a
Nothing