--------------------------------------------------------------------
-- |
-- Module  : Language.Dot.Pretty
-- License : GPL-3
--
-- Maintainer  : Marcelo Garlet Millani <marcelogmillani@gmail.com>
-- Stability   : experimental
-- Portability : portable
--
-- Pretty printer for DOT.
--------------------------------------------------------------------

module Language.Dot.Pretty (prettyPrint, render) where

import qualified Text.PrettyPrint  as PP ((<>), (<+>), ($$), ($+$), render)
import Text.PrettyPrint hiding ((<>), (<+>), ($$), ($+$), render)
import Language.Dot.Graph

class PP a where
  pp :: a -> Doc

instance PP GraphType where
  pp Graph = text "graph"
  pp Digraph = text "digraph"

instance PP Name where
  pp (StringID str) = doubleQuotes $ text str
  pp (XMLID xml) = text xml

instance PP a => PP (Maybe a) where
  pp (Just x) = pp x
  pp Nothing = empty

instance PP a => PP [a] where
  pp xs = hsep $ punctuate comma $ map pp xs

instance (PP a, PP b) => PP (a, b) where
  pp (a,b) = pp a PP.<+> equals PP.<+> pp b

instance PP Compass where
  pp North      = text "n"
  pp NorthEast  = text "ne"
  pp East       = text "e"
  pp SouthEast  = text "se"
  pp South      = text "s"
  pp SouthWest  = text "s"
  pp West       = text "w"
  pp NorthWest  = text "nw"
  pp Center     = text "c"

instance PP Port where
  pp (Port mname mcompass) = 
    case mname of
      Just name -> colon PP.<+> pp name
      Nothing -> empty
    PP.<+> case mcompass of
      Just compass -> colon PP.<+> pp compass
      Nothing -> empty

-- |Convert a graph into a PrettyPrint document.
prettyPrint :: (Bool, GraphType, Maybe Name, [Statement]) -> Doc
prettyPrint (strict, gType, name, stmts) = 
  (if strict then text "strict" else empty)
  PP.<+> pp gType
  PP.<+> pp name
  PP.<+> text "{" PP.$+$ (nest 1 $ ppStmts empty stmts) PP.$+$ text "}"
  where
    ppEdge = if gType == Digraph then text "->" else text "--"
    ppStmts doc [] = doc
    ppStmts doc ((EdgeStatement sgs attributes):stmts) = 
      ppStmts (doc PP.$+$
        ppEdgePath empty ppEdge sgs
        PP.<+> (if null attributes then empty else brackets $ pp attributes)
        PP.<> semi)
        stmts
    ppStmts doc ((NodeStatement name mport attributes):stmts) = 
      ppStmts (doc PP.$+$
        pp name
        PP.<+> pp mport
        PP.<+> (if null attributes then empty else brackets (pp attributes))
        PP.<> semi)
        stmts
    ppStmts doc ((SubgraphStatement subgraph):stmts) =
      ppStmts (hang doc 1 $ ppSubgraph subgraph) stmts
    ppStmts doc ((AttributeStatement attribute):stmts) =
      ppStmts (doc PP.$+$ (pp attribute <> semi)) stmts
    ppStmts doc ((EdgeAttribute attributes):stmts) = 
      ppStmts (doc PP.$+$
        text "edge"
        PP.<+> hsep (map pp attributes))
        stmts
    ppStmts doc ((NodeAttribute attributes):stmts) = 
      ppStmts (doc PP.$+$ 
        text "node"
        PP.<+> hsep (map pp attributes))
        stmts
    ppStmts doc ((GraphAttribute attributes):stmts) = 
      ppStmts (doc PP.$+$
        text "graph"
        PP.<+> hsep (map pp attributes))
        stmts
    ppEdgePath doc edge [] = doc
    ppEdgePath doc edge (g:gs) = 
      case g of
        NodeRef name mport -> ppEdgePath (doc PP.<+> pp name PP.<+> pp mport PP.<+> if null gs then empty else edge) edge gs
        Subgraph mname stmts ->
          ppEdgePath (hang doc 1 $ 
            case mname of
              Just name -> pp name
              Nothing -> empty
            PP.<+> text "{" PP.$+$ (nest 1 $ ppStmts empty stmts) PP.$+$ text "}" PP.<+> if null gs then empty else edge
            ) edge gs
    ppSubgraph subgraph = 
      case subgraph of
        NodeRef name mport -> pp name PP.<+> pp mport
        Subgraph mname stmts ->
            case mname of
              Just name -> pp name
              Nothing -> empty
            PP.<+> text "{" PP.$+$ (nest 1 $ ppStmts empty stmts) PP.$+$ text "}"
            

-- | Render a graph as a string.
-- Uses `prettyPrint` above.
render :: (Bool, GraphType, Maybe Name, [Statement]) -> String
render g = PP.render $ prettyPrint g