{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

-- | Rendering takes a callgraph, and produces a dot file
module Calligraphy.Phases.Render (render, pRenderConfig, RenderConfig (..)) where

import Calligraphy.Util.Printer
import Calligraphy.Util.Types
import Control.Monad
import qualified Data.EnumSet as EnumSet
import Data.List (intercalate)
import Data.Tree (Tree (..))
import Options.Applicative hiding (style)
import Text.Show (showListWith)

data RenderConfig = RenderConfig
  { RenderConfig -> Bool
showCalls :: Bool,
    RenderConfig -> Bool
showTypes :: Bool,
    RenderConfig -> Bool
showKey :: Bool,
    RenderConfig -> Bool
showGHCKeys :: Bool,
    RenderConfig -> Bool
showModulePath :: Bool,
    RenderConfig -> Bool
showChildArrowhead :: Bool,
    RenderConfig -> LocMode
locMode :: LocMode,
    RenderConfig -> Bool
clusterModules :: Bool,
    RenderConfig -> Bool
clusterGroups :: Bool,
    RenderConfig -> Bool
splines :: Bool,
    RenderConfig -> Bool
reverseDependencyRank :: Bool
  }

render :: RenderConfig -> Prints CallGraph
render :: RenderConfig -> Prints CallGraph
render RenderConfig {Bool
LocMode
reverseDependencyRank :: Bool
splines :: Bool
clusterGroups :: Bool
clusterModules :: Bool
locMode :: LocMode
showChildArrowhead :: Bool
showModulePath :: Bool
showGHCKeys :: Bool
showKey :: Bool
showTypes :: Bool
showCalls :: Bool
reverseDependencyRank :: RenderConfig -> Bool
splines :: RenderConfig -> Bool
clusterGroups :: RenderConfig -> Bool
clusterModules :: RenderConfig -> Bool
locMode :: RenderConfig -> LocMode
showChildArrowhead :: RenderConfig -> Bool
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) = do
  forall (m :: * -> *) a.
MonadPrint m =>
[Char] -> [Char] -> m a -> m a
brack [Char]
"digraph calligraphy {" [Char]
"}" forall a b. (a -> b) -> a -> b
$ do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
splines forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadPrint m => Text -> m ()
textLn Text
"splines=false;"
    forall (m :: * -> *). MonadPrint m => Text -> m ()
textLn Text
"node [style=filled fillcolor=\"#ffffffcf\"];"
    forall (m :: * -> *). MonadPrint m => Text -> m ()
textLn Text
"graph [outputorder=edgesfirst];"
    let nonEmptyModules :: [Module]
nonEmptyModules = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> Forest Decl
moduleForest) [Module]
modules
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. [a] -> [b] -> [(a, b)]
zip [Module]
nonEmptyModules [Int
0 :: Int ..]) forall a b. (a -> b) -> a -> b
$
      \(Module [Char]
modName [Char]
modPath Forest Decl
forest, Int
moduleIx) ->
        forall a. Int -> [Char] -> Printer a -> Printer a
moduleCluster Int
moduleIx (if Bool
showModulePath then [Char]
modPath else [Char]
modName) forall a b. (a -> b) -> a -> b
$
          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. [a] -> [b] -> [(a, b)]
zip Forest Decl
forest [Int
0 :: Int ..]) forall a b. (a -> b) -> a -> b
$ \(Tree Decl
root, Int
forestIx) -> do
            forall a. Int -> Int -> Printer a -> Printer a
treeCluster Int
moduleIx Int
forestIx forall a b. (a -> b) -> a -> b
$
              Prints (Tree Decl)
renderTreeNode Tree Decl
root
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
showCalls forall a b. (a -> b) -> a -> b
$
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Set (Key, Key)
calls forall a b. (a -> b) -> a -> b
$ \(Key
caller, Key
callee) ->
        if Bool
reverseDependencyRank
          then forall (m :: * -> *). MonadPrint m => Key -> Key -> Style -> m ()
edge Key
caller Key
callee []
          else forall (m :: * -> *). MonadPrint m => Key -> Key -> Style -> m ()
edge Key
callee Key
caller [[Char]
"dir" [Char] -> [Char] -> ([Char], [Char])
.= [Char]
"back"]
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
showTypes forall a b. (a -> b) -> a -> b
$
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Set (Key, Key)
types forall a b. (a -> b) -> a -> b
$ \(Key
caller, Key
callee) ->
        if Bool
reverseDependencyRank
          then forall (m :: * -> *). MonadPrint m => Key -> Key -> Style -> m ()
edge Key
caller Key
callee [[Char]
"style" [Char] -> [Char] -> ([Char], [Char])
.= [Char]
"dotted"]
          else forall (m :: * -> *). MonadPrint m => Key -> Key -> Style -> m ()
edge Key
callee Key
caller [[Char]
"style" [Char] -> [Char] -> ([Char], [Char])
.= [Char]
"dotted", [Char]
"dir" [Char] -> [Char] -> ([Char], [Char])
.= [Char]
"back"]
  where
    moduleCluster :: Int -> String -> Printer a -> Printer a
    moduleCluster :: forall a. Int -> [Char] -> Printer a -> Printer a
moduleCluster Int
modIx [Char]
title Printer a
inner
      | Bool
clusterModules =
          forall (m :: * -> *) a.
MonadPrint m =>
[Char] -> [Char] -> m a -> m a
brack ([Char]
"subgraph cluster_module_" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
modIx forall a. Semigroup a => a -> a -> a
<> [Char]
" {") [Char]
"}" forall a b. (a -> b) -> a -> b
$ do
            forall (m :: * -> *). MonadPrint m => [Char] -> m ()
strLn forall a b. (a -> b) -> a -> b
$ [Char]
"label=" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show [Char]
title forall a. Semigroup a => a -> a -> a
<> [Char]
";"
            Printer a
inner
      | Bool
otherwise = Printer a
inner
    treeCluster :: Int -> Int -> Printer a -> Printer a
    treeCluster :: forall a. Int -> Int -> Printer a -> Printer a
treeCluster Int
modIx Int
groupIx Printer a
inner
      | Bool
clusterGroups =
          forall (m :: * -> *) a.
MonadPrint m =>
[Char] -> [Char] -> m a -> m a
brack ([Char]
"subgraph cluster_" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
modIx forall a. Semigroup a => a -> a -> a
<> [Char]
"_" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
groupIx forall a. Semigroup a => a -> a -> a
<> [Char]
" {") [Char]
"}" forall a b. (a -> b) -> a -> b
$ do
            forall (m :: * -> *). MonadPrint m => Text -> m ()
textLn Text
"style=invis;"
            Printer a
inner
      | Bool
otherwise = Printer a
inner
    nodeLabel :: Decl -> String
    nodeLabel :: Decl -> [Char]
nodeLabel (Decl [Char]
name Key
key EnumSet GHCKey
ghcKeys Bool
_ DeclType
_ Loc
loc) =
      forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n"
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> [a]
cons [Char]
name
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Bool -> a -> [a] -> [a]
consIf Bool
showKey (forall a. Show a => a -> [Char]
show (Key -> Int
unKey Key
key))
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Foldable f => Bool -> f a -> [a] -> [a]
consManyIf Bool
showGHCKeys (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Show a => a -> [Char]
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. GHCKey -> Int
unGHCKey) (forall k. Enum k => EnumSet k -> [k]
EnumSet.toList EnumSet GHCKey
ghcKeys))
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. ( case LocMode
locMode of
              LocMode
Hide -> forall a. a -> a
id
              LocMode
Line -> forall a. a -> [a] -> [a]
cons (Char
'L' forall a. a -> [a] -> [a]
: forall a. Show a => a -> [Char]
show (Loc -> Int
locLine Loc
loc))
              LocMode
LineCol -> forall a. a -> [a] -> [a]
cons (forall a. Show a => a -> [Char]
show Loc
loc)
          )
        forall a b. (a -> b) -> a -> b
$ []

    renderTreeNode :: Prints (Tree Decl)
    renderTreeNode :: Prints (Tree Decl)
renderTreeNode (Node decl :: Decl
decl@(Decl [Char]
_ Key
key EnumSet GHCKey
_ Bool
exported DeclType
typ Loc
_) Forest Decl
children) = do
      forall (m :: * -> *). MonadPrint m => [Char] -> m ()
strLn forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show (Key -> Int
unKey Key
key) forall a. Semigroup a => a -> a -> a
<> [Char]
" " forall a. Semigroup a => a -> a -> a
<> Style -> [Char]
style [[Char]
"label" [Char] -> [Char] -> ([Char], [Char])
.= ([Char]
"\"" forall a. Semigroup a => a -> a -> a
<> Decl -> [Char]
nodeLabel Decl
decl forall a. Semigroup a => a -> a -> a
<> [Char]
"\""), [Char]
"shape" [Char] -> [Char] -> ([Char], [Char])
.= DeclType -> [Char]
nodeShape DeclType
typ, [Char]
"style" [Char] -> [Char] -> ([Char], [Char])
.= [Char]
nodeStyle]
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Forest Decl
children forall a b. (a -> b) -> a -> b
$ \child :: Tree Decl
child@(Node Decl
childDecl Forest Decl
_) -> do
        Prints (Tree Decl)
renderTreeNode Tree Decl
child
        forall (m :: * -> *). MonadPrint m => Key -> Key -> Style -> m ()
edge Key
key (Decl -> Key
declKey Decl
childDecl)
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> [a]
cons ([Char]
"style" [Char] -> [Char] -> ([Char], [Char])
.= [Char]
"dashed")
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Bool -> a -> [a] -> [a]
consIf (Bool -> Bool
not Bool
showChildArrowhead) ([Char]
"arrowhead" [Char] -> [Char] -> ([Char], [Char])
.= [Char]
"none")
          forall a b. (a -> b) -> a -> b
$ []
      where
        nodeStyle :: String
        nodeStyle :: [Char]
nodeStyle =
          forall a. Show a => a -> [Char]
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", "
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Bool -> a -> [a] -> [a]
consIf (DeclType
typ forall a. Eq a => a -> a -> Bool
== DeclType
RecDecl) [Char]
"rounded"
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Bool -> a -> [a] -> [a]
consIf (Bool -> Bool
not Bool
exported) [Char]
"dashed"
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> [a]
cons [Char]
"filled"
            forall a b. (a -> b) -> a -> b
$ []

cons :: a -> [a] -> [a]
cons :: forall a. a -> [a] -> [a]
cons = (:)

consIf :: Bool -> a -> [a] -> [a]
consIf :: forall a. Bool -> a -> [a] -> [a]
consIf Bool
True = (:)
consIf Bool
False = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. a -> b -> a
const

consManyIf :: Foldable f => Bool -> f a -> [a] -> [a]
consManyIf :: forall (f :: * -> *) a. Foldable f => Bool -> f a -> [a] -> [a]
consManyIf Bool
True f a
fs [a]
as = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (:) [a]
as f a
fs
consManyIf Bool
False f a
_ [a]
as = [a]
as

nodeShape :: DeclType -> String
nodeShape :: DeclType -> [Char]
nodeShape DeclType
DataDecl = [Char]
"octagon"
nodeShape DeclType
ConDecl = [Char]
"box"
nodeShape DeclType
RecDecl = [Char]
"box"
nodeShape DeclType
ClassDecl = [Char]
"house"
nodeShape DeclType
ValueDecl = [Char]
"ellipse"

edge :: MonadPrint m => Key -> Key -> Style -> m ()
edge :: forall (m :: * -> *). MonadPrint m => Key -> Key -> Style -> m ()
edge (Key Int
from) (Key Int
to) Style
sty = forall (m :: * -> *). MonadPrint m => [Char] -> m ()
strLn forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Int
from forall a. Semigroup a => a -> a -> a
<> [Char]
" -> " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
to forall a. Semigroup a => a -> a -> a
<> [Char]
" " forall a. Semigroup a => a -> a -> a
<> Style -> [Char]
style Style
sty

(.=) :: String -> String -> (String, String)
.= :: [Char] -> [Char] -> ([Char], [Char])
(.=) = (,)

style :: Style -> String
style :: Style -> [Char]
style Style
sty = forall a. (a -> ShowS) -> [a] -> ShowS
showListWith (\([Char]
key, [Char]
val) -> [Char] -> ShowS
showString [Char]
key forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'=' forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString [Char]
val) Style
sty [Char]
";"

type Style = [(String, String)]

data LocMode = Hide | Line | LineCol

pLocMode :: Parser LocMode
pLocMode :: Parser LocMode
pLocMode =
  forall a. a -> Mod FlagFields a -> Parser a
flag' LocMode
Line (forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"show-line" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"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 => [Char] -> Mod f a
long [Char]
"show-line-col" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"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

pRenderConfig :: Parser RenderConfig
pRenderConfig :: Parser RenderConfig
pRenderConfig =
  Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> LocMode
-> Bool
-> Bool
-> Bool
-> Bool
-> 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 => [Char] -> Mod f a
long [Char]
"hide-calls" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"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 => [Char] -> Mod f a
long [Char]
"hide-types" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"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 => [Char] -> Mod f a
long [Char]
"show-key" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"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 => [Char] -> Mod f a
long [Char]
"show-ghc-key" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"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 => [Char] -> Mod f a
long [Char]
"show-module-path" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"Show a module's filepath instead of its name")
    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 => [Char] -> Mod f a
long [Char]
"show-child-arrowhead" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"Put an arrowhead at the end of a parent-child edge")
    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
<*> forall a. a -> a -> Mod FlagFields a -> Parser a
flag Bool
True Bool
False (forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"no-cluster-modules" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"Don't draw modules as a cluster.")
    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 => [Char] -> Mod f a
long [Char]
"no-cluster-trees" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"Don't draw definition trees as a cluster.")
    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 => [Char] -> Mod f a
long [Char]
"no-splines" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"Render arrows as straight lines instead of splines")
    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 => [Char] -> Mod f a
long [Char]
"reverse-dependency-rank" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"Make dependencies have lower rank than the dependee, i.e. show dependencies above their parent.")