module HyLo.Model.PrettyPrint ( toDot, toDotStr, toDotFrame )

where

import Text.PrettyPrint

import Data.Foldable ( toList )

import HyLo.Model     ( Model, worlds, succs, namesOf, propsOf )
import HyLo.Signature ( getSignature, relSymbols )
import HyLo.Signature.String ( NomSymbol(..), PropSymbol(..), RelSymbol(..))


toDotStr :: Model NomSymbol NomSymbol PropSymbol RelSymbol -> String
toDotStr m = render dotDoc
    where dotDoc  = text "digraph M" <+> lbrace $+$ (nest 2 $ vcat [
                          text "node [fontname=helvetica];",
                          (vcat $ map nodeDef ws),
                          empty,
                          text "edge [fontname=helvetica];",
                          (vcat [relDef w r v | r <- rs,
                                                w <- ws,
                                                v <- toList $ succs m r w])]
                      ) $+$
                    rbrace
          nodeDef w = textSN w <+> (brackets $
                        text "label = " <>
                         (doubleQuotes $
                            (braces . hsep . punctuate comma $ map textSN $ namesOf w m) <> text "\\n" <>
                            (braces . hsep . punctuate comma $ map textSP $ propsOf w m)    )) <>
                      semi
          relDef w r v = textSN w <+> text "->" <+> textSN v <+>
                         labIfNeeded r <> semi
          labIfNeeded  = if gt1 rs
                          then \r -> brackets $
                                 text "label =" <> doubleQuotes (textSR r)
                          else const empty
          --
          ws = toList . worlds $ m
          rs = toList . relSymbols . getSignature $ m
          --
          gt1 (_:_:_) = True
          gt1 _       = False


toDot :: (Show w, Show n, Show p, Show r, Ord w) => Model w n p r -> String
toDot m = render dotDoc
    where dotDoc  = text "digraph M" <+> lbrace $+$ (nest 2 $ vcat [
                          text "node [fontname=helvetica];",
                          (vcat $ map nodeDef ws),
                          empty,
                          text "edge [fontname=helvetica];",
                          (vcat [relDef w r v | r <- rs,
                                                w <- ws,
                                                v <- toList $ succs m r w])]
                      ) $+$
                    rbrace
          nodeDef w = textS w <+> (brackets $
                        text "label = " <>
                         (doubleQuotes $
                            text (show w) <> text "\\n" <>
                            (braces . hsep . punctuate comma $
                                (map textS $ namesOf w m) ++
                                (map textS $ propsOf w m)))) <>
                      semi
          relDef w r v = textS w <+> text "->" <+> textS v <+>
                         labIfNeeded r <> semi
          labIfNeeded  = if gt1 rs
                          then \r -> brackets $
                                 text "label =" <> doubleQuotes (textS r)
                          else const empty
          --
          ws = toList . worlds $ m
          rs = toList . relSymbols . getSignature $ m
          --
          gt1 (_:_:_) = True
          gt1 _       = False

textS :: Show a => a -> Doc
textS = text . show

textSN :: NomSymbol -> Doc
textSN (NomSymbol str) = text str

textSP :: PropSymbol -> Doc
textSP (PropSymbol str) = text str

textSR :: RelSymbol -> Doc
textSR (RelSymbol str) = text str

toDotFrame :: (Show w, Show n, Show p, Show r, Ord w) => Model w n p r -> String
toDotFrame m = render dotDoc
    where dotDoc  = text "digraph M" <+> lbrace $+$ (nest 2 $ vcat [
                          text "node [fontname=helvetica];",
                          (vcat $ map nodeDef ws),
                          empty,
                          text "edge [fontname=helvetica];",
                          (vcat [relDef w r v | r <- rs,
                                                w <- ws,
                                                v <- toList $ succs m r w])]
                      ) $+$
                    rbrace
          nodeDef w = textS w
          relDef w r v = textS w <+> text "->" <+> textS v <+>
                         labIfNeeded r <> semi
          labIfNeeded  = if gt1 rs
                          then \r -> brackets $
                                 text "label =" <> doubleQuotes (textS r)
                          else const empty
          --
          ws = toList . worlds $ m
          rs = toList . relSymbols . getSignature $ m
          --
          gt1 (_:_:_) = True
          gt1 _       = False