----------------------------------------------------------------------
-- |
-- Module      : Graphviz
-- Maintainer  : BB
-- Stability   : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/09/15 18:10:44 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.2 $
--
-- Graphviz DOT format representation and printing.
-----------------------------------------------------------------------------

module GF.Data.Graphviz (
                          Graph(..), GraphType(..),
                          Node(..), Edge(..),
                          Attr,
                          addSubGraphs,
                          setName,
                          setAttr,
                          prGraphviz
                        ) where

import Data.Char

import GF.Data.Utilities

-- | Graph type, graph ID, graph attirbutes, graph nodes, graph edges, subgraphs
data Graph = Graph {
                    Graph -> GraphType
gType :: GraphType,
                    Graph -> Maybe String
gId :: Maybe String,
                    Graph -> [Attr]
gAttrs :: [Attr],
                    Graph -> [Node]
gNodes :: [Node],
                    Graph -> [Edge]
gEdges :: [Edge],
                    Graph -> [Graph]
gSubgraphs :: [Graph]
                   }
  deriving (Int -> Graph -> ShowS
[Graph] -> ShowS
Graph -> String
(Int -> Graph -> ShowS)
-> (Graph -> String) -> ([Graph] -> ShowS) -> Show Graph
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Graph] -> ShowS
$cshowList :: [Graph] -> ShowS
show :: Graph -> String
$cshow :: Graph -> String
showsPrec :: Int -> Graph -> ShowS
$cshowsPrec :: Int -> Graph -> ShowS
Show)

data GraphType = Directed | Undirected
  deriving (Int -> GraphType -> ShowS
[GraphType] -> ShowS
GraphType -> String
(Int -> GraphType -> ShowS)
-> (GraphType -> String)
-> ([GraphType] -> ShowS)
-> Show GraphType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GraphType] -> ShowS
$cshowList :: [GraphType] -> ShowS
show :: GraphType -> String
$cshow :: GraphType -> String
showsPrec :: Int -> GraphType -> ShowS
$cshowsPrec :: Int -> GraphType -> ShowS
Show)

data Node = Node String [Attr]
  deriving Int -> Node -> ShowS
[Node] -> ShowS
Node -> String
(Int -> Node -> ShowS)
-> (Node -> String) -> ([Node] -> ShowS) -> Show Node
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Node] -> ShowS
$cshowList :: [Node] -> ShowS
show :: Node -> String
$cshow :: Node -> String
showsPrec :: Int -> Node -> ShowS
$cshowsPrec :: Int -> Node -> ShowS
Show

data Edge = Edge String String [Attr]
  deriving Int -> Edge -> ShowS
[Edge] -> ShowS
Edge -> String
(Int -> Edge -> ShowS)
-> (Edge -> String) -> ([Edge] -> ShowS) -> Show Edge
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Edge] -> ShowS
$cshowList :: [Edge] -> ShowS
show :: Edge -> String
$cshow :: Edge -> String
showsPrec :: Int -> Edge -> ShowS
$cshowsPrec :: Int -> Edge -> ShowS
Show

type Attr = (String,String)

--
-- * Graph construction
--

addSubGraphs :: [Graph] -> Graph -> Graph
addSubGraphs :: [Graph] -> Graph -> Graph
addSubGraphs [Graph]
gs Graph
g = Graph
g { gSubgraphs :: [Graph]
gSubgraphs = [Graph]
gs [Graph] -> [Graph] -> [Graph]
forall a. [a] -> [a] -> [a]
++ Graph -> [Graph]
gSubgraphs Graph
g }

setName :: String -> Graph -> Graph
setName :: String -> Graph -> Graph
setName String
n Graph
g = Graph
g { gId :: Maybe String
gId = String -> Maybe String
forall a. a -> Maybe a
Just String
n }

setAttr :: String -> String -> Graph -> Graph
setAttr :: String -> String -> Graph -> Graph
setAttr String
n String
v Graph
g = Graph
g { gAttrs :: [Attr]
gAttrs = String -> String -> [Attr] -> [Attr]
forall a b. Eq a => a -> b -> [(a, b)] -> [(a, b)]
tableSet String
n String
v (Graph -> [Attr]
gAttrs Graph
g) }

--
-- * Pretty-printing
--

prGraphviz :: Graph -> String
prGraphviz :: Graph -> String
prGraphviz g :: Graph
g@(Graph GraphType
t Maybe String
i [Attr]
_ [Node]
_ [Edge]
_ [Graph]
_) =
    GraphType -> String
graphtype GraphType
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> ShowS -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" ShowS
esc Maybe String
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" {\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Graph -> String
prGraph Graph
g String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"}\n"

prSubGraph :: Graph -> String
prSubGraph :: Graph -> String
prSubGraph g :: Graph
g@(Graph GraphType
_ Maybe String
i [Attr]
_ [Node]
_ [Edge]
_ [Graph]
_) =
    String
"subgraph" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> ShowS -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" ShowS
esc Maybe String
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" {\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Graph -> String
prGraph Graph
g String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"}"

prGraph :: Graph -> String
prGraph :: Graph -> String
prGraph (Graph GraphType
t Maybe String
id [Attr]
at [Node]
ns [Edge]
es [Graph]
ss) =
    [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> ShowS
forall a. [a] -> [a] -> [a]
++String
";") ((Attr -> String) -> [Attr] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Attr -> String
prAttr [Attr]
at
                           [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Node -> String) -> [Node] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Node -> String
prNode [Node]
ns
                           [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Edge -> String) -> [Edge] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (GraphType -> Edge -> String
prEdge GraphType
t) [Edge]
es
                           [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Graph -> String) -> [Graph] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Graph -> String
prSubGraph [Graph]
ss)

graphtype :: GraphType -> String
graphtype :: GraphType -> String
graphtype GraphType
Directed = String
"digraph"
graphtype GraphType
Undirected = String
"graph"

prNode :: Node -> String
prNode :: Node -> String
prNode (Node String
n [Attr]
at) = ShowS
esc String
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Attr] -> String
prAttrList [Attr]
at

prEdge :: GraphType -> Edge -> String
prEdge :: GraphType -> Edge -> String
prEdge GraphType
t (Edge String
x String
y [Attr]
at) = ShowS
esc String
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ GraphType -> String
edgeop GraphType
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
esc String
y String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Attr] -> String
prAttrList [Attr]
at

edgeop :: GraphType -> String
edgeop :: GraphType -> String
edgeop GraphType
Directed = String
"->"
edgeop GraphType
Undirected = String
"--"

prAttrList :: [Attr] -> String
prAttrList :: [Attr] -> String
prAttrList [] = String
""
prAttrList [Attr]
at = String
"[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
join String
"," ((Attr -> String) -> [Attr] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Attr -> String
prAttr [Attr]
at) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]"

prAttr :: Attr -> String
prAttr :: Attr -> String
prAttr (String
n,String
v) = ShowS
esc String
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
esc String
v

esc :: String -> String
esc :: ShowS
esc String
s | String -> Bool
needEsc String
s = String
"\"" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ if Char -> Bool
shouldEsc Char
c then [Char
'\\',Char
c] else [Char
c] | Char
c <- String
s ] String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\""
      | Bool
otherwise = String
s
  where shouldEsc :: Char -> Bool
shouldEsc = (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'"', Char
'\\'])

needEsc :: String -> Bool
needEsc :: String -> Bool
needEsc [] = Bool
True
needEsc String
xs | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit String
xs = Bool
False
needEsc (Char
x:String
xs) = Bool -> Bool
not (Char -> Bool
isIDFirst Char
x Bool -> Bool -> Bool
&& (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isIDChar String
xs)

isIDFirst, isIDChar :: Char -> Bool
isIDFirst :: Char -> Bool
isIDFirst Char
c = Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char
'_']String -> ShowS
forall a. [a] -> [a] -> [a]
++[Char
'a'..Char
'z']String -> ShowS
forall a. [a] -> [a] -> [a]
++[Char
'A'..Char
'Z'])
isIDChar :: Char -> Bool
isIDChar Char
c = Char -> Bool
isIDFirst Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c