{-# LANGUAGE CPP #-}
module Language.Dot.Pretty
  ( prettyPrintDot
  , renderDot
  , PP(..)
  )
  where

#if MIN_VERSION_base(4,11,0)
import Prelude hiding ((<>))
#endif

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

import Numeric
import Text.PrettyPrint

import Language.Dot.Syntax

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

prettyPrintDot :: Graph -> Doc
prettyPrintDot :: Graph -> Doc
prettyPrintDot = forall a. PP a => a -> Doc
pp

renderDot :: Graph -> String
renderDot :: Graph -> String
renderDot = Doc -> String
render forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PP a => a -> Doc
pp

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

class PP a where
  pp :: a -> Doc

instance (PP a) => PP (Maybe a) where
  pp :: Maybe a -> Doc
pp (Just a
v) = forall a. PP a => a -> Doc
pp a
v
  pp Maybe a
Nothing  = Doc
empty

instance PP Graph where
  pp :: Graph -> Doc
pp (Graph GraphStrictness
s GraphDirectedness
d Maybe Id
mi [Statement]
ss) = forall a. PP a => a -> Doc
pp GraphStrictness
s Doc -> Doc -> Doc
<+> forall a. PP a => a -> Doc
pp GraphDirectedness
d Doc -> Doc -> Doc
<+> forall a. PP a => a -> Doc
pp Maybe Id
mi Doc -> Doc -> Doc
<+> Doc
lbrace Doc -> Doc -> Doc
$+$ Doc -> Doc
indent (forall a. PP a => [a] -> Doc
vcat' [Statement]
ss) Doc -> Doc -> Doc
$+$ Doc
rbrace

instance PP GraphStrictness where
  pp :: GraphStrictness -> Doc
pp GraphStrictness
StrictGraph   = String -> Doc
text String
"strict"
  pp GraphStrictness
UnstrictGraph = Doc
empty

instance PP GraphDirectedness where
  pp :: GraphDirectedness -> Doc
pp GraphDirectedness
DirectedGraph   = String -> Doc
text String
"digraph"
  pp GraphDirectedness
UndirectedGraph = String -> Doc
text String
"graph"

instance PP Id where
  pp :: Id -> Doc
pp (NameId String
v)    = String -> Doc
text String
v
  pp (StringId String
v)  = Doc -> Doc
doubleQuotes (String -> Doc
text String
v)
  pp (IntegerId Integer
v) = Integer -> Doc
integer Integer
v
  pp (FloatId Float
v)   = Float -> Doc
ffloat Float
v
  pp (XmlId Xml
v)     = Doc
langle Doc -> Doc -> Doc
<> forall a. PP a => a -> Doc
pp Xml
v Doc -> Doc -> Doc
<> Doc
rangle

instance PP Statement where
  pp :: Statement -> Doc
pp (NodeStatement NodeId
ni [Attribute]
as)       = forall a. PP a => a -> Doc
pp NodeId
ni Doc -> Doc -> Doc
<+> if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Attribute]
as) then Doc -> Doc
brackets (forall a. PP a => [a] -> Doc
hsep' [Attribute]
as) else Doc
empty
  pp (EdgeStatement [Entity]
es [Attribute]
as)       = forall a. PP a => [a] -> Doc
hsep' [Entity]
es Doc -> Doc -> Doc
<+> if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Attribute]
as) then Doc -> Doc
brackets (forall a. PP a => [a] -> Doc
hsep' [Attribute]
as) else Doc
empty
  pp (AttributeStatement AttributeStatementType
t [Attribute]
as)   = forall a. PP a => a -> Doc
pp AttributeStatementType
t Doc -> Doc -> Doc
<+> Doc -> Doc
brackets (forall a. PP a => [a] -> Doc
hsep' [Attribute]
as)
  pp (AssignmentStatement Id
i0 Id
i1) = forall a. PP a => a -> Doc
pp Id
i0 Doc -> Doc -> Doc
<> Doc
equals Doc -> Doc -> Doc
<> forall a. PP a => a -> Doc
pp Id
i1
  pp (SubgraphStatement Subgraph
s)       = forall a. PP a => a -> Doc
pp Subgraph
s

instance PP AttributeStatementType where
  pp :: AttributeStatementType -> Doc
pp AttributeStatementType
GraphAttributeStatement = String -> Doc
text String
"graph"
  pp AttributeStatementType
NodeAttributeStatement  = String -> Doc
text String
"node"
  pp AttributeStatementType
EdgeAttributeStatement  = String -> Doc
text String
"edge"

instance PP Attribute where
  pp :: Attribute -> Doc
pp (AttributeSetTrue Id
i)      = forall a. PP a => a -> Doc
pp Id
i
  pp (AttributeSetValue Id
i0 Id
i1) = forall a. PP a => a -> Doc
pp Id
i0 Doc -> Doc -> Doc
<> Doc
equals Doc -> Doc -> Doc
<> forall a. PP a => a -> Doc
pp Id
i1

instance PP NodeId where
  pp :: NodeId -> Doc
pp (NodeId Id
i Maybe Port
mp) = forall a. PP a => a -> Doc
pp Id
i Doc -> Doc -> Doc
<> forall a. PP a => a -> Doc
pp Maybe Port
mp

instance PP Port where
  pp :: Port -> Doc
pp (PortI Id
i Maybe Compass
mc) = Doc
colon Doc -> Doc -> Doc
<> forall a. PP a => a -> Doc
pp Id
i Doc -> Doc -> Doc
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
empty ((Doc
colon Doc -> Doc -> Doc
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PP a => a -> Doc
pp) Maybe Compass
mc
  pp (PortC Compass
c)    = Doc
colon Doc -> Doc -> Doc
<> forall a. PP a => a -> Doc
pp Compass
c

instance PP Compass where
  pp :: Compass -> Doc
pp Compass
CompassN  = String -> Doc
text String
"n"
  pp Compass
CompassE  = String -> Doc
text String
"e"
  pp Compass
CompassS  = String -> Doc
text String
"s"
  pp Compass
CompassW  = String -> Doc
text String
"w"
  pp Compass
CompassNE = String -> Doc
text String
"ne"
  pp Compass
CompassNW = String -> Doc
text String
"nw"
  pp Compass
CompassSE = String -> Doc
text String
"se"
  pp Compass
CompassSW = String -> Doc
text String
"sw"

instance PP Subgraph where
  pp :: Subgraph -> Doc
pp (NewSubgraph Maybe Id
mi [Statement]
ss) = String -> Doc
text String
"subgraph" Doc -> Doc -> Doc
<+> forall a. PP a => a -> Doc
pp Maybe Id
mi Doc -> Doc -> Doc
<+> Doc
lbrace Doc -> Doc -> Doc
$+$ Doc -> Doc
indent (forall a. PP a => [a] -> Doc
vcat' [Statement]
ss) Doc -> Doc -> Doc
$+$ Doc
rbrace
  pp (SubgraphRef Id
i)     = String -> Doc
text String
"subgraph" Doc -> Doc -> Doc
<+> forall a. PP a => a -> Doc
pp Id
i

instance PP Entity where
  pp :: Entity -> Doc
pp (ENodeId EdgeType
et NodeId
ni)   = forall a. PP a => a -> Doc
pp EdgeType
et Doc -> Doc -> Doc
<+> forall a. PP a => a -> Doc
pp NodeId
ni
  pp (ESubgraph EdgeType
et Subgraph
sg) = forall a. PP a => a -> Doc
pp EdgeType
et Doc -> Doc -> Doc
<+> forall a. PP a => a -> Doc
pp Subgraph
sg

instance PP EdgeType where
  pp :: EdgeType -> Doc
pp EdgeType
NoEdge         = Doc
empty
  pp EdgeType
DirectedEdge   = String -> Doc
text String
"->"
  pp EdgeType
UndirectedEdge = String -> Doc
text String
"--"

instance PP Xml where
  pp :: Xml -> Doc
pp (XmlEmptyTag XmlName
n [XmlAttribute]
as) = Doc
langle Doc -> Doc -> Doc
<> forall a. PP a => a -> Doc
pp XmlName
n Doc -> Doc -> Doc
<+> forall a. PP a => [a] -> Doc
hsep' [XmlAttribute]
as Doc -> Doc -> Doc
<> Doc
slash Doc -> Doc -> Doc
<> Doc
rangle
  pp (XmlTag XmlName
n [XmlAttribute]
as [Xml]
xs)   = Doc
langle Doc -> Doc -> Doc
<> forall a. PP a => a -> Doc
pp XmlName
n Doc -> Doc -> Doc
<+> forall a. PP a => [a] -> Doc
hsep' [XmlAttribute]
as Doc -> Doc -> Doc
<> Doc
rangle Doc -> Doc -> Doc
<> forall a. PP a => [a] -> Doc
hcat' [Xml]
xs Doc -> Doc -> Doc
<> Doc
langle Doc -> Doc -> Doc
<> Doc
slash Doc -> Doc -> Doc
<> forall a. PP a => a -> Doc
pp XmlName
n Doc -> Doc -> Doc
<> Doc
rangle
  pp (XmlText String
t)        = String -> Doc
text String
t

instance PP XmlName where
  pp :: XmlName -> Doc
pp (XmlName String
n) = String -> Doc
text String
n

instance PP XmlAttribute where
  pp :: XmlAttribute -> Doc
pp (XmlAttribute XmlName
n XmlAttributeValue
v) = forall a. PP a => a -> Doc
pp XmlName
n Doc -> Doc -> Doc
<> Doc
equals Doc -> Doc -> Doc
<> forall a. PP a => a -> Doc
pp XmlAttributeValue
v

instance PP XmlAttributeValue where
  pp :: XmlAttributeValue -> Doc
pp (XmlAttributeValue String
v) = Doc -> Doc
doubleQuotes (String -> Doc
text String
v)

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

indent :: Doc -> Doc
indent :: Doc -> Doc
indent = Int -> Doc -> Doc
nest Int
2

hcat' :: (PP a) => [a] -> Doc
hcat' :: forall a. PP a => [a] -> Doc
hcat' = [Doc] -> Doc
hcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. PP a => a -> Doc
pp

hsep' :: (PP a) => [a] -> Doc
hsep' :: forall a. PP a => [a] -> Doc
hsep' = [Doc] -> Doc
hsep forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. PP a => a -> Doc
pp

vcat' :: (PP a) => [a] -> Doc
vcat' :: forall a. PP a => [a] -> Doc
vcat' = [Doc] -> Doc
vcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. PP a => a -> Doc
pp

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

langle :: Doc
rangle :: Doc
slash  :: Doc

langle :: Doc
langle = Char -> Doc
char Char
'<'
rangle :: Doc
rangle = Char -> Doc
char Char
'>'
slash :: Doc
slash  = Char -> Doc
char Char
'/'

ffloat :: Float -> Doc
ffloat :: Float -> Doc
ffloat Float
v = String -> Doc
text (forall a. RealFloat a => Maybe Int -> a -> ShowS
showFFloat forall a. Maybe a
Nothing Float
v String
"")