{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ViewPatterns       #-}
-- |
-- Module      : Data.Array.Accelerate.Pretty.Graphviz.Type
-- Copyright   : [2015..2020] The Accelerate Team
-- License     : BSD3
--
-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)
--
-- Simple data types for representing (simple, directed) graphs and
-- pretty-printing to Graphviz dot format.
--
module Data.Array.Accelerate.Pretty.Graphviz.Type
  where

import Data.Hashable
import Data.Maybe
import Data.Text                                          ( Text )
import Prettyprinter
import Text.Printf
import qualified Data.Text                                as Text

import Data.Array.Accelerate.Pretty.Print                 ( Adoc, Keyword )


-- Rose tree, with all information at the leaves.
--
data Tree a = Leaf a
            | Forest [Tree a]

instance Functor Tree where
  fmap :: forall a b. (a -> b) -> Tree a -> Tree b
fmap a -> b
f (Leaf a
x)    = b -> Tree b
forall a. a -> Tree a
Leaf (a -> b
f a
x)
  fmap a -> b
f (Forest [Tree a]
xs) = [Tree b] -> Tree b
forall a. [Tree a] -> Tree a
Forest ((Tree a -> Tree b) -> [Tree a] -> [Tree b]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> b) -> Tree a -> Tree b
forall a b. (a -> b) -> Tree a -> Tree b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) [Tree a]
xs)


-- Representation for simple Graphviz graphs
--
data Graph      = Graph Label [Statement]
data Statement  = N Node | E Edge | G Graph

data Node       = Node (Maybe Label) NodeId (Tree (Maybe Port, Adoc))
data NodeId     = NodeId !Int

type Label      = Text
type Port       = Text

data Vertex     = Vertex NodeId (Maybe Port)
data Edge       = Edge {- from -} Vertex
                       {-  to  -} Vertex

deriving instance Eq NodeId
deriving instance Eq Vertex

instance Hashable NodeId where
  hashWithSalt :: Int -> NodeId -> Int
hashWithSalt Int
salt (NodeId Int
ident) = Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
salt Int
ident

instance Show Graph where
  show :: Graph -> String
show = Adoc -> String
forall a. Show a => a -> String
show (Adoc -> String) -> (Graph -> Adoc) -> Graph -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph -> Adoc
ppGraph

-- Pretty print a (directed) graph to dot format
--
ppGraph :: Graph -> Adoc
ppGraph :: Graph -> Adoc
ppGraph (Graph Text
l [Statement]
ss) =
  [Adoc] -> Adoc
forall ann. [Doc ann] -> Doc ann
vcat [ Adoc
"digraph" Adoc -> Adoc -> Adoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Adoc
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
l Adoc -> Adoc -> Adoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Adoc
forall ann. Doc ann
lbrace
       , Int -> Adoc -> Adoc
forall ann. Int -> Doc ann -> Doc ann
nest Int
4 (Adoc -> Adoc) -> Adoc -> Adoc
forall a b. (a -> b) -> a -> b
$ [Adoc] -> Adoc
forall ann. [Doc ann] -> Doc ann
vcat
                ([Adoc] -> Adoc) -> [Adoc] -> Adoc
forall a b. (a -> b) -> a -> b
$ Adoc -> [Adoc] -> [Adoc]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Adoc
forall ann. Doc ann
semi
                ([Adoc] -> [Adoc]) -> [Adoc] -> [Adoc]
forall a b. (a -> b) -> a -> b
$ Adoc
"graph [compound=true]"
                Adoc -> [Adoc] -> [Adoc]
forall a. a -> [a] -> [a]
: Adoc
"node  [shape=record,fontsize=10]"
                Adoc -> [Adoc] -> [Adoc]
forall a. a -> [a] -> [a]
: (Statement -> Adoc) -> [Statement] -> [Adoc]
forall a b. (a -> b) -> [a] -> [b]
map Statement -> Adoc
ppStatement [Statement]
ss
       , Adoc
forall ann. Doc ann
rbrace
       ]

ppSubgraph :: Graph -> Adoc
ppSubgraph :: Graph -> Adoc
ppSubgraph (Graph Text
l [Statement]
ss) =
  [Adoc] -> Adoc
forall ann. [Doc ann] -> Doc ann
vcat [ Adoc
"subgraph cluster_" Adoc -> Adoc -> Adoc
forall a. Semigroup a => a -> a -> a
<> Text -> Adoc
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
l Adoc -> Adoc -> Adoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Adoc
forall ann. Doc ann
lbrace
       , Int -> Adoc -> Adoc
forall ann. Int -> Doc ann -> Doc ann
nest Int
4 (Adoc -> Adoc) -> Adoc -> Adoc
forall a b. (a -> b) -> a -> b
$ [Adoc] -> Adoc
forall ann. [Doc ann] -> Doc ann
vcat
                ([Adoc] -> Adoc) -> [Adoc] -> Adoc
forall a b. (a -> b) -> a -> b
$ Adoc -> [Adoc] -> [Adoc]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Adoc
forall ann. Doc ann
semi
                ([Adoc] -> [Adoc]) -> [Adoc] -> [Adoc]
forall a b. (a -> b) -> a -> b
$ Adoc
"label" Adoc -> Adoc -> Adoc
forall a. Semigroup a => a -> a -> a
<> Adoc
forall ann. Doc ann
equals Adoc -> Adoc -> Adoc
forall a. Semigroup a => a -> a -> a
<> Text -> Adoc
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
l
                Adoc -> [Adoc] -> [Adoc]
forall a. a -> [a] -> [a]
: (Statement -> Adoc) -> [Statement] -> [Adoc]
forall a b. (a -> b) -> [a] -> [b]
map Statement -> Adoc
ppStatement [Statement]
ss
       , Adoc
forall ann. Doc ann
rbrace
       ]

ppStatement :: Statement -> Adoc
ppStatement :: Statement -> Adoc
ppStatement (N Node
n) = Node -> Adoc
ppNode Node
n
ppStatement (E Edge
e) = Edge -> Adoc
ppEdge Edge
e
ppStatement (G Graph
g) = Graph -> Adoc
ppSubgraph Graph
g

ppEdge :: Edge -> Adoc
ppEdge :: Edge -> Adoc
ppEdge (Edge Vertex
from Vertex
to) = Vertex -> Adoc
ppVertex Vertex
from Adoc -> Adoc -> Adoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Adoc
"->" Adoc -> Adoc -> Adoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Vertex -> Adoc
ppVertex Vertex
to

ppVertex :: Vertex -> Adoc
ppVertex :: Vertex -> Adoc
ppVertex (Vertex NodeId
n Maybe Text
p) = NodeId -> Adoc
ppNodeId NodeId
n Adoc -> Adoc -> Adoc
forall a. Semigroup a => a -> a -> a
<> Adoc -> (Adoc -> Adoc) -> Maybe Adoc -> Adoc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Adoc
forall a. Monoid a => a
mempty (Adoc
forall ann. Doc ann
colonAdoc -> Adoc -> Adoc
forall a. Semigroup a => a -> a -> a
<>) ((Text -> Adoc) -> Maybe Text -> Maybe Adoc
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Adoc
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Maybe Text
p)

ppNode :: Node -> Adoc
ppNode :: Node -> Adoc
ppNode (Node Maybe Text
label NodeId
nid Tree (Maybe Text, Adoc)
body) =
  [Adoc] -> Adoc
forall ann. [Doc ann] -> Doc ann
hcat [ NodeId -> Adoc
ppNodeId NodeId
nid
       , Adoc -> Adoc
forall ann. Doc ann -> Doc ann
brackets
       (Adoc -> Adoc) -> Adoc -> Adoc
forall a b. (a -> b) -> a -> b
$ [Adoc] -> Adoc
forall ann. [Doc ann] -> Doc ann
hcat
       ([Adoc] -> Adoc) -> [Adoc] -> Adoc
forall a b. (a -> b) -> a -> b
$ Adoc -> [Adoc] -> [Adoc]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Adoc
forall ann. Doc ann
comma
       ([Adoc] -> [Adoc]) -> [Adoc] -> [Adoc]
forall a b. (a -> b) -> a -> b
$ [Maybe Adoc] -> [Adoc]
forall a. [Maybe a] -> [a]
catMaybes [ (Text -> Adoc) -> Maybe Text -> Maybe Adoc
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((\Adoc
x -> Adoc
"xlabel" Adoc -> Adoc -> Adoc
forall a. Semigroup a => a -> a -> a
<> Adoc
forall ann. Doc ann
equals Adoc -> Adoc -> Adoc
forall a. Semigroup a => a -> a -> a
<> Adoc
x) (Adoc -> Adoc) -> (Text -> Adoc) -> Text -> Adoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Adoc -> Adoc
forall ann. Doc ann -> Doc ann
dquotes (Adoc -> Adoc) -> (Text -> Adoc) -> Text -> Adoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Adoc
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty) Maybe Text
label
                   , Adoc -> Maybe Adoc
forall a. a -> Maybe a
Just (       Adoc
"label"  Adoc -> Adoc -> Adoc
forall a. Semigroup a => a -> a -> a
<> Adoc
forall ann. Doc ann
equals Adoc -> Adoc -> Adoc
forall a. Semigroup a => a -> a -> a
<>      Adoc -> Adoc
forall ann. Doc ann -> Doc ann
dquotes (Tree (Maybe Text, Adoc) -> Adoc
ppNodeTree Tree (Maybe Text, Adoc)
body))
                   ]
       ]

ppNodeTree :: Tree (Maybe Port, Adoc) -> Adoc
ppNodeTree :: Tree (Maybe Text, Adoc) -> Adoc
ppNodeTree (Forest [Tree (Maybe Text, Adoc)]
trees)      = Adoc -> Adoc
forall ann. Doc ann -> Doc ann
braces (Adoc -> Adoc) -> Adoc -> Adoc
forall a b. (a -> b) -> a -> b
$ [Adoc] -> Adoc
forall ann. [Doc ann] -> Doc ann
hcat (Adoc -> [Adoc] -> [Adoc]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate (Char -> Adoc
forall ann. Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
'|') ((Tree (Maybe Text, Adoc) -> Adoc)
-> [Tree (Maybe Text, Adoc)] -> [Adoc]
forall a b. (a -> b) -> [a] -> [b]
map Tree (Maybe Text, Adoc) -> Adoc
ppNodeTree [Tree (Maybe Text, Adoc)]
trees))
ppNodeTree (Leaf (Maybe Text
port, Adoc
body)) = Adoc -> (Adoc -> Adoc) -> Maybe Adoc -> Adoc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Adoc
forall a. Monoid a => a
mempty (\Adoc
p -> Char -> Adoc
forall ann. Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
'<' Adoc -> Adoc -> Adoc
forall a. Semigroup a => a -> a -> a
<> Adoc
p Adoc -> Adoc -> Adoc
forall a. Semigroup a => a -> a -> a
<> Char -> Adoc
forall ann. Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
'>') ((Text -> Adoc) -> Maybe Text -> Maybe Adoc
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Adoc
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Maybe Text
port) Adoc -> Adoc -> Adoc
forall a. Semigroup a => a -> a -> a
<> Adoc -> Adoc
pp Adoc
body
  where
    -- In order for the text to be properly rendered by graphviz, we need to
    -- escape some special characters. If the text takes up more than one line,
    -- then newlines '\n' need be be replaced with '\l', to ensure that the text
    -- is left justified rather than centred. The last line also needs a final
    -- '\l'. Single lines of text remain centred, which provides better
    -- formatting for short statements and port labels.
    --
    pp :: Adoc -> Adoc
    pp :: Adoc -> Adoc
pp = SimpleDocStream Keyword -> Adoc
encode (SimpleDocStream Keyword -> Adoc)
-> (Adoc -> SimpleDocStream Keyword) -> Adoc -> Adoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Adoc -> SimpleDocStream Keyword
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutSmart LayoutOptions
defaultLayoutOptions
    -- pp = encode . renderSmart 0.7 120

    encode :: SimpleDocStream Keyword -> Adoc
    encode :: SimpleDocStream Keyword -> Adoc
encode SimpleDocStream Keyword
doc =
      let
          go :: SimpleDocStream ann -> (Doc ann, Bool)
go SimpleDocStream ann
SFail          = String -> (Doc ann, Bool)
forall a. HasCallStack => String -> a
error String
"unexpected failure rendering SimpleDoc"
          go SimpleDocStream ann
SEmpty         = (Doc ann
forall a. Monoid a => a
mempty, Bool
False)
          go (SChar Char
c SimpleDocStream ann
x)    = let (Doc ann
x',Bool
m) = SimpleDocStream ann -> (Doc ann, Bool)
go SimpleDocStream ann
x in (Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Char -> Text
escape Char
c) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
x', Bool
m)
          go (SText Int
_ Text
t SimpleDocStream ann
x)  = let (Doc ann
x',Bool
m) = SimpleDocStream ann -> (Doc ann, Bool)
go SimpleDocStream ann
x in (Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ((Char -> Text) -> Text -> Text
Text.concatMap Char -> Text
escape Text
t) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
x', Bool
m)
          go (SLine Int
i SimpleDocStream ann
x)    = let (Doc ann
x',Bool
_) = SimpleDocStream ann -> (Doc ann, Bool)
go SimpleDocStream ann
x in (Doc ann
"\\l" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Doc ann
forall ann. Int -> Doc ann
spaces Int
i Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
x', Bool
True)  -- [1] left justify
          go (SAnnPush ann
a SimpleDocStream ann
x) = let (Doc ann
x',Bool
m) = SimpleDocStream ann -> (Doc ann, Bool)
go SimpleDocStream ann
x in (ann -> Doc ann -> Doc ann
forall ann. ann -> Doc ann -> Doc ann
annotate ann
a Doc ann
x', Bool
m)
          go (SAnnPop SimpleDocStream ann
x)    = let (Doc ann
x',Bool
m) = SimpleDocStream ann -> (Doc ann, Bool)
go SimpleDocStream ann
x in (Doc ann -> Doc ann
forall ann xxx. Doc ann -> Doc xxx
unAnnotate Doc ann
x', Bool
m)

          (Adoc
doc',Bool
multiline) = SimpleDocStream Keyword -> (Adoc, Bool)
forall {ann}. SimpleDocStream ann -> (Doc ann, Bool)
go SimpleDocStream Keyword
doc
      in
      Adoc
doc' Adoc -> Adoc -> Adoc
forall a. Semigroup a => a -> a -> a
<> if Bool
multiline
                then Adoc
"\\l"
                else Adoc
forall a. Monoid a => a
mempty

    spaces :: Int -> Doc ann
    spaces :: forall ann. Int -> Doc ann
spaces Int
i | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0    = Doc ann
forall a. Monoid a => a
mempty
             | Bool
otherwise = Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Int -> Text -> Text
Text.replicate Int
i Text
"\\ ")

    escape :: Char -> Text
    escape :: Char -> Text
escape Char
' '  = Text
"\\ "         -- don't collapse multiple spaces
    escape Char
'>'  = Text
"\\>"
    escape Char
'<'  = Text
"\\<"
    escape Char
'|'  = Text
"\\|"
    -- escape '\n' = "\\l"      -- handled at [1] instead
    escape Char
c    = Char -> Text
Text.singleton Char
c

ppNodeId :: NodeId -> Adoc
ppNodeId :: NodeId -> Adoc
ppNodeId (NodeId Int
nid) = String -> Adoc
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"Node_%#0x" Int
nid :: String)