{-# LANGUAGE RecordWildCards #-}

-- | Prepare the call graph for rendering
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

-- | A directly printable string uniquely identifying a declaration.
type ID = String

-- | A representation of the call graph that's convenient for rendering.
-- Structurally, it's the same as 'CallGraph', in that it's a tree of nodes and a flat list of edges.
-- The differences is that as much of the non-backend-specific preprocessing has already been taken care of.
--   - Nodes and modules have a unique string ID
--   - Nodes and modules contain their desired label
--   - Render roots are guaranteed to be non-empty
--   - Set of calls and types are empty on --hide-{calls, types}
--   - Modules are flattened depending on --no-cluster-modules
data RenderGraph = RenderGraph
  { RenderGraph
-> Either (NonEmpty RenderModule) (NonEmpty (Tree RenderNode))
renderRoots :: Either (NonEmpty RenderModule) (NonEmpty (Tree RenderNode)), -- Right if --no-cluster-modules
    RenderGraph -> Set (ID, ID)
callEdges :: Set (ID, ID), -- empty if --hide-calls
    RenderGraph -> Set (ID, ID)
typeEdges :: Set (ID, ID) -- empty if --hide-types
  }

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

-- TODO this needs to be moved to an appropriate Util/Lib module
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