{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ViewPatterns #-}
module Data.Array.Accelerate.Pretty.Graphviz.Type
where
import Data.Hashable
import Data.Maybe
import Data.Text ( Text )
import Data.Text.Prettyprint.Doc
import Text.Printf
import qualified Data.Text as Text
import Data.Array.Accelerate.Pretty.Print ( Adoc, Keyword )
data Tree a = Leaf a
| Forest [Tree a]
instance Functor Tree where
fmap f (Leaf x) = Leaf (f x)
fmap f (Forest xs) = Forest (map (fmap f) xs)
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 Vertex
Vertex
deriving instance Eq NodeId
deriving instance Eq Vertex
instance Hashable NodeId where
hashWithSalt salt (NodeId ident) = hashWithSalt salt ident
instance Show Graph where
show = show . ppGraph
ppGraph :: Graph -> Adoc
ppGraph (Graph l ss) =
vcat [ "digraph" <+> pretty l <+> lbrace
, nest 4 $ vcat
$ punctuate semi
$ "graph [compound=true]"
: "node [shape=record,fontsize=10]"
: map ppStatement ss
, rbrace
]
ppSubgraph :: Graph -> Adoc
ppSubgraph (Graph l ss) =
vcat [ "subgraph cluster_" <> pretty l <+> lbrace
, nest 4 $ vcat
$ punctuate semi
$ "label" <> equals <> pretty l
: map ppStatement ss
, rbrace
]
ppStatement :: Statement -> Adoc
ppStatement (N n) = ppNode n
ppStatement (E e) = ppEdge e
ppStatement (G g) = ppSubgraph g
ppEdge :: Edge -> Adoc
ppEdge (Edge from to) = ppVertex from <+> "->" <+> ppVertex to
ppVertex :: Vertex -> Adoc
ppVertex (Vertex n p) = ppNodeId n <> maybe mempty (colon<>) (fmap pretty p)
ppNode :: Node -> Adoc
ppNode (Node label nid body) =
hcat [ ppNodeId nid
, brackets
$ hcat
$ punctuate comma
$ catMaybes [ fmap ((\x -> "xlabel" <> equals <> x) . dquotes . pretty) label
, Just ( "label" <> equals <> dquotes (ppNodeTree body))
]
]
ppNodeTree :: Tree (Maybe Port, Adoc) -> Adoc
ppNodeTree (Forest trees) = braces $ hcat (punctuate (pretty '|') (map ppNodeTree trees))
ppNodeTree (Leaf (port, body)) = maybe mempty (\p -> pretty '<' <> p <> pretty '>') (fmap pretty port) <> pp body
where
pp :: Adoc -> Adoc
pp = encode . layoutSmart defaultLayoutOptions
encode :: SimpleDocStream Keyword -> Adoc
encode doc =
let
go SFail = error "unexpected failure rendering SimpleDoc"
go SEmpty = (mempty, False)
go (SChar c x) = let (x',m) = go x in (pretty (escape c) <> x', m)
go (SText _ t x) = let (x',m) = go x in (pretty (Text.concatMap escape t) <> x', m)
go (SLine i x) = let (x',_) = go x in ("\\l" <> spaces i <> x', True)
go (SAnnPush a x) = let (x',m) = go x in (annotate a x', m)
go (SAnnPop x) = let (x',m) = go x in (unAnnotate x', m)
(doc',multiline) = go doc
in
doc' <> if multiline
then "\\l"
else mempty
spaces :: Int -> Doc ann
spaces i | i <= 0 = mempty
| otherwise = pretty (Text.replicate i "\\ ")
escape :: Char -> Text
escape ' ' = "\\ "
escape '>' = "\\>"
escape '<' = "\\<"
escape '|' = "\\|"
escape c = Text.singleton c
ppNodeId :: NodeId -> Adoc
ppNodeId (NodeId nid) = pretty (printf "Node_%#0x" nid :: String)