{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ViewPatterns #-}
module Data.Array.Accelerate.Pretty.Graphviz.Type
where
import Data.Maybe
import Data.Hashable
import Text.Printf
import Text.PrettyPrint.ANSI.Leijen
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, Doc))
data NodeId = NodeId !Int
type Label = String
type Port = String
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 -> Doc
ppGraph (Graph l ss) =
vcat [ text "digraph" <+> text l <+> lbrace
, nest 4 $ vcat
$ punctuate semi
$ text "graph [compound=true]"
: text "node [shape=record,fontsize=10]"
: map ppStatement ss
, rbrace
]
ppSubgraph :: Graph -> Doc
ppSubgraph (Graph l ss) =
vcat [ text "subgraph cluster_" <> text l <+> lbrace
, nest 4 $ vcat
$ punctuate semi
$ text "label" <> equals <> text l
: map ppStatement ss
, rbrace
]
ppStatement :: Statement -> Doc
ppStatement (N n) = ppNode n
ppStatement (E e) = ppEdge e
ppStatement (G g) = ppSubgraph g
ppEdge :: Edge -> Doc
ppEdge (Edge from to) = ppVertex from <+> text "->" <+> ppVertex to
ppVertex :: Vertex -> Doc
ppVertex (Vertex n p) = ppNodeId n <> maybe empty (colon<>) (fmap text p)
ppNode :: Node -> Doc
ppNode (Node label nid body) =
hcat [ ppNodeId nid
, brackets
$ hcat
$ punctuate comma
$ catMaybes [ fmap ((\x -> text "xlabel" <> equals <> x) . dquotes . text) label
, Just ( text "label" <> equals <> dquotes (ppNodeTree body))
]
]
ppNodeTree :: Tree (Maybe Port, Doc) -> Doc
ppNodeTree (Forest trees) = braces $ hcat (punctuate (char '|') (map ppNodeTree trees))
ppNodeTree (Leaf (port, body)) = maybe empty (\p -> char '<' <> p <> char '>') (fmap text port) <> pp body
where
pp :: Doc -> Doc
pp = encode . renderSmart 0.7 120
encode :: SimpleDoc -> Doc
encode doc =
let
go SFail = error "unexpected failure rendering SimpleDoc"
go SEmpty = (empty, False)
go (SChar c x) = let (x',m) = go x in (text (escape c) <> x', m)
go (SText _ t x) = let (x',m) = go x in (text (concatMap escape t) <> x', m)
go (SLine i x) = let (x',_) = go x in (text "\\l" <> spaces i <> x', True)
go (SSGR _ x) = go x
(doc',multiline) = go doc
in
doc' <> if multiline
then text "\\l"
else empty
spaces :: Int -> Doc
spaces i | i <= 0 = empty
| otherwise = text (concat (replicate i "\\ "))
escape :: Char -> String
escape ' ' = "\\ "
escape '>' = "\\>"
escape '<' = "\\<"
escape '|' = "\\|"
escape c = [c]
ppNodeId :: NodeId -> Doc
ppNodeId (NodeId nid) = text (printf "Node_%#0x" nid)