{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-}

-- | This is a fast non-pretty-printer for turning the internal representation
--   of generic structured XML documents into Lazy ByteStrings.
--   Like in Text.Xml.HaXml.Pretty, there is one pp function for each type in
--   Text.Xml.HaXml.Types, so you can pretty-print as much or as little
--   of the document as you wish.

module Network.XmlRpc.Pretty (document, content, element, 
                              doctypedecl, prolog, cp) where

import Prelude hiding (maybe, elem, concat, null, head)
import qualified Prelude as P
import Data.ByteString.Lazy.Char8 (ByteString(), elem, empty)
import qualified Data.ByteString.Lazy.UTF8 as BU
import Text.XML.HaXml.Types
import Blaze.ByteString.Builder (Builder, fromLazyByteString, toLazyByteString)
import Blaze.ByteString.Builder.Char.Utf8 (fromString)
import Data.Maybe (isNothing)
import Data.Monoid
import qualified GHC.Exts as Ext

-- |A 'Builder' with a recognizable empty value.
newtype MBuilder = MBuilder { unMB :: Maybe Builder } deriving Monoid

-- |'Maybe' eliminator specialized for 'MBuilder'.
maybe :: (t -> MBuilder) -> Maybe t -> MBuilder
maybe _ Nothing = mempty
maybe f (Just x) = f x

-- |Nullity predicate for 'MBuilder'.
null :: MBuilder -> Bool
null = isNothing . unMB

-- |Helper for injecting 'ByteString's into 'MBuilder'.
fromLBS :: ByteString -> MBuilder
fromLBS = MBuilder . Just . fromLazyByteString

-- Helper needed when using Data.Binary.Builder.
-- fromString :: String -> Builder
-- fromString = fromLazyByteString . BU.fromString

-- |Support for the OverloadedStrings extension to improve templating
-- syntax.
instance Ext.IsString MBuilder where
  fromString "" = mempty
  fromString s = MBuilder . Just . fromString $ s

-- A simple implementation of the pretty-printing combinator interface,
-- but for plain ByteStrings:
infixr 6 <>
infixr 6 <+>
infixr 5 $$

-- |Beside.
(<>) :: MBuilder -> MBuilder -> MBuilder
(<>) = mappend

-- |Concatenate two 'MBuilder's with a single space in between
-- them. If either of the component 'MBuilder's is empty, then the
-- other is returned without any additional space.
(<+>) :: MBuilder -> MBuilder -> MBuilder
(<+>) b1 b2
  | null b2 = b1
  | null b1 = b2
  | otherwise = b1 <> " " <> b2

-- |Concatenate two 'MBuilder's with a single newline in between
-- them. If either of the component 'MBuilder's is empty, then the
-- other is returned without any additional newline.
($$) :: MBuilder -> MBuilder -> MBuilder
($$) b1 b2 
  | null b2 = b1
  | null b1 = b2
  | otherwise =  b1 <> "\n" <> b2

-- |Concatenate a list of 'MBuilder's with a given 'MBuilder' inserted
-- between each non-empty element of the list.
intercalate :: MBuilder -> [MBuilder] -> MBuilder
intercalate sep = aux . filter (not . null)
  where aux []     = mempty
        aux (x:xs) = x <> mconcat (map (sep <>) xs)

-- |List version of '<+>'.
hsep :: [MBuilder] -> MBuilder             
hsep = intercalate " "

-- |List version of '$$'.
vcat :: [MBuilder] -> MBuilder
vcat = intercalate "\n"

hcatMap :: (a -> MBuilder) -> [a] -> MBuilder
hcatMap = (mconcat .) . map

vcatMap :: (a -> MBuilder) -> [a] -> MBuilder
vcatMap = (vcat .) . map

-- |``Paragraph fill'' version of 'sep'.
fsep :: [MBuilder] -> MBuilder     
fsep = hsep

-- |Bracket an 'MBuilder' with parentheses.
parens :: MBuilder -> MBuilder
parens p = "(" <> p <> ")"

text :: String -> MBuilder
text = MBuilder . Just . fromString

name :: QName -> MBuilder
name = MBuilder . Just . fromString . unQ
  where unQ (QN (Namespace prefix uri) n) = prefix++":"++n
        unQ (N n) = n

----
-- Now for the XML pretty-printing interface.
-- (Basically copied direct from Text.XML.HaXml.Pretty).

-- |Render a 'Document' to a 'ByteString'.
document    :: Document i  -> ByteString
content     :: Content i   -> ByteString
element     :: Element i   -> ByteString
doctypedecl :: DocTypeDecl -> ByteString
prolog      :: Prolog      -> ByteString
cp          :: CP          -> ByteString

-- Builder variants of exported functions.
documentB    :: Document i  -> MBuilder
contentB     :: Content i   -> MBuilder
elementB     :: Element i   -> MBuilder
doctypedeclB :: DocTypeDecl -> MBuilder
prologB      :: Prolog      -> MBuilder
cpB          :: CP          -> MBuilder

xmldecl    :: XMLDecl    -> MBuilder
misc       :: Misc       -> MBuilder
sddecl     :: Bool       -> MBuilder
markupdecl :: MarkupDecl -> MBuilder
attribute  :: Attribute  -> MBuilder

-- |Run an 'MBuilder' to generate a 'ByteString'.
runMBuilder :: MBuilder -> ByteString
runMBuilder = aux . unMB
  where aux Nothing = empty
        aux (Just b) = toLazyByteString b

document    = runMBuilder . documentB
content     = runMBuilder . contentB
element     = runMBuilder . elementB
doctypedecl = runMBuilder . doctypedeclB
prolog      = runMBuilder . prologB
cp          = runMBuilder . cpB

documentB (Document p _ e m) = prologB p $$ elementB e $$ vcatMap misc m

prologB (Prolog x m1 dtd m2) = maybe xmldecl x $$
                               vcatMap misc m1 $$
                               maybe doctypedeclB dtd $$
                               vcatMap misc m2

xmldecl (XMLDecl v e sd)    = "<?xml version='" <> text v <> "'" <+>
                              maybe encodingdecl e <+>
                              maybe sddecl sd <+> "?>"

misc (Comment s)            = "<!--" <+> text s <+> "-->"
misc (PI (n,s))             = "<?" <> text n <+> text s <+> "?>"

sddecl sd   | sd            = "standalone='yes'"
            | otherwise     = "standalone='no'"

doctypedeclB (DTD n eid ds)  = if P.null ds then hd <> ">"
                               else hd <+> " [" $$ vcatMap markupdecl ds $$ "]>"
  where hd = "<!DOCTYPE" <+> name n <+> maybe externalid eid

markupdecl (Element e)      = elementdecl e
markupdecl (AttList a)      = attlistdecl a
markupdecl (Entity e)       = entitydecl e
markupdecl (Notation n)     = notationdecl n
markupdecl (MarkupMisc m)   = misc m

elementB (Elem n as []) = "<" <> (name n <+> fsep (map attribute as)) <> "/>"
elementB (Elem n as cs) 
  | isText (P.head cs)  = "<" <> (name n <+> fsep (map attribute as)) <> ">" <>
                          hcatMap contentB cs <> "</" <> name n <> ">"
  | otherwise           = "<" <> (name n <+> fsep (map attribute as)) <> ">" <>
                          hcatMap contentB cs <> "</" <> name n <> ">"

isText :: Content t -> Bool
isText (CString _ _ _) = True
isText (CRef _ _)      = True
isText _               = False

attribute (n,v) = name n <> "=" <> attvalue v

contentB (CElem e _)         = elementB e
contentB (CString False s _) = chardata s
contentB (CString True s _)  = cdsect s
contentB (CRef r _)          = reference r
contentB (CMisc m _)         = misc m

elementdecl :: ElementDecl -> MBuilder
elementdecl (ElementDecl n cs) = "<!ELEMENT" <+> name n <+>
                                 contentspec cs <> ">"

contentspec :: ContentSpec -> MBuilder
contentspec EMPTY           = "EMPTY"
contentspec ANY             = "ANY"
contentspec (Mixed m)       = mixed m
contentspec (ContentSpec c) = cpB c

cpB (TagName n m) = name n <> modifier m
cpB (Choice cs m) = parens (intercalate "|" (map cpB cs)) <> modifier m
cpB (Seq cs m)    = parens (intercalate "," (map cpB cs)) <> modifier m

modifier :: Modifier -> MBuilder
modifier None  = mempty
modifier Query = "?"
modifier Star  = "*"
modifier Plus  = "+"

mixed :: Mixed -> MBuilder
mixed  PCDATA         = "(#PCDATA)"
mixed (PCDATAplus ns) = "(#PCDATA |" <+> intercalate "|" (map name ns) <> ")*"

attlistdecl :: AttListDecl -> MBuilder
attlistdecl (AttListDecl n ds) = "<!ATTLIST" <+> name n <+> 
                                 fsep (map attdef ds) <> ">"

attdef :: AttDef -> MBuilder
attdef (AttDef n t d)          = name n <+> atttype t <+> defaultdecl d

atttype :: AttType -> MBuilder
atttype  StringType            = "CDATA"
atttype (TokenizedType t)      = tokenizedtype t
atttype (EnumeratedType t)     = enumeratedtype t

tokenizedtype :: TokenizedType -> MBuilder
tokenizedtype ID               = "ID"
tokenizedtype IDREF            = "IDREF"
tokenizedtype IDREFS           = "IDREFS"
tokenizedtype ENTITY           = "ENTITY"
tokenizedtype ENTITIES         = "ENTITIES"
tokenizedtype NMTOKEN          = "NMTOKEN"
tokenizedtype NMTOKENS         = "NMTOKENS"

enumeratedtype :: EnumeratedType -> MBuilder
enumeratedtype (NotationType n) = notationtype n
enumeratedtype (Enumeration e)  = enumeration e

notationtype :: [[Char]] -> MBuilder
notationtype ns                = "NOTATION" <+>
                                 parens (intercalate "|" (map text ns))

enumeration :: [[Char]] -> MBuilder
enumeration ns                 = parens (intercalate "|" (map nmtoken ns))

defaultdecl :: DefaultDecl -> MBuilder
defaultdecl  REQUIRED          = "#REQUIRED"
defaultdecl  IMPLIED           = "#IMPLIED"
defaultdecl (DefaultTo a f)    = maybe (const "#FIXED") f <+> attvalue a

reference :: Reference -> MBuilder
reference (RefEntity er)       = entityref er
reference (RefChar cr)         = charref cr

entityref :: [Char] -> MBuilder
entityref n                    = "&" <> text n <> ";"

charref :: (Show a) => a -> MBuilder
charref c                      = "&#" <> text (show c) <> ";"

entitydecl :: EntityDecl -> MBuilder
entitydecl (EntityGEDecl d)    = gedecl d
entitydecl (EntityPEDecl d)    = pedecl d

gedecl :: GEDecl -> MBuilder
gedecl (GEDecl n ed)           = "<!ENTITY" <+> text n <+> entitydef ed <> ">"

pedecl :: PEDecl -> MBuilder
pedecl (PEDecl n pd)           = "<!ENTITY %" <> text n <+> pedef pd <> ">"

entitydef :: EntityDef -> MBuilder
entitydef (DefEntityValue ew)  = entityvalue ew
entitydef (DefExternalID i nd) = externalid i <+> maybe ndatadecl nd

pedef :: PEDef -> MBuilder
pedef (PEDefEntityValue ew)    = entityvalue ew
pedef (PEDefExternalID eid)    = externalid eid

externalid :: ExternalID -> MBuilder
externalid (SYSTEM sl)         = "SYSTEM" <+> systemliteral sl
externalid (PUBLIC i sl)       = "PUBLIC" <+> pubidliteral i <+> systemliteral sl

ndatadecl :: NDataDecl -> MBuilder
ndatadecl (NDATA n)            = "NDATA" <+> text n

notationdecl :: NotationDecl -> MBuilder
notationdecl (NOTATION n e)    = "<!NOTATION" <+> text n <+>
                                 either externalid publicid e <> ">"

publicid :: PublicID -> MBuilder
publicid (PUBLICID p)          = "PUBLICID" <+> pubidliteral p

encodingdecl :: EncodingDecl -> MBuilder
encodingdecl (EncodingDecl s)  = "encoding='" <> text s <> "'"

nmtoken :: [Char] -> MBuilder
nmtoken s                      = text s

attvalue :: AttValue -> MBuilder
attvalue (AttValue esr)        = "\"" <> hcatMap attVal esr <> "\""
  where attVal = either text reference

entityvalue :: EntityValue -> MBuilder
entityvalue (EntityValue evs)
  | containsDoubleQuote evs    = "'"  <> hcatMap ev evs <> "'"
  | otherwise                  = "\"" <> hcatMap ev evs <> "\""

ev :: EV -> MBuilder
ev (EVString s)                = text s
ev (EVRef r)                   = reference r

pubidliteral :: PubidLiteral -> MBuilder
pubidliteral (PubidLiteral s)
    | '"' `elem` s' = "'" <> fromLBS s' <> "'"
    | otherwise     = "\"" <> fromLBS s' <> "\""
    where s' = BU.fromString s

systemliteral :: SystemLiteral -> MBuilder
systemliteral (SystemLiteral s)
    | '"' `elem` s' = "'" <> fromLBS s' <> "'"
    | otherwise     = "\"" <> fromLBS s' <> "\""
    where s' = BU.fromString s

chardata, cdsect :: [Char] -> MBuilder
chardata s                     = {-if all isSpace s then empty else-} text s
cdsect c                       = "<![CDATA[" <> chardata c <> "]]>"

containsDoubleQuote :: [EV] -> Bool
containsDoubleQuote evs = any csq evs
    where csq (EVString s) = '"' `elem` BU.fromString s
          csq _            = False