-- | This is a separate pretty-printer for HTML documents, recognising
-- some of the differences between HTML and true XML.
module Text.XML.HaXml.Html.Pretty
( document
, element
, attribute
, content
) where
import Prelude hiding (maybe,either)
import Data.Maybe hiding (maybe)
import Data.List (intersperse)
import Data.Char (isSpace)
import Text.PrettyPrint.HughesPJ
import Text.XML.HaXml.Types
import Text.XML.HaXml.Namespaces
either :: (a->c) -> (b->c) -> Either a b -> c
either f _g (Left x) = f x
either _f g (Right x) = g x
maybe :: (a->Doc) -> Maybe a -> Doc
maybe _f Nothing = empty
maybe f (Just x) = f x
--peref p = text "%" <> text p <> text ";"
----
document :: Document i -> Doc
prolog :: Prolog -> Doc
xmldecl :: XMLDecl -> Doc
misc :: Misc -> Doc
sddecl :: Bool -> Doc
doctypedecl :: DocTypeDecl -> Doc
markupdecl :: MarkupDecl -> Doc
--extsubset :: ExtSubset -> Doc
--extsubsetdecl :: ExtSubsetDecl -> Doc
element :: Element i -> Doc
attribute :: Attribute -> Doc --etc
content :: Content i -> Doc
----
document (Document p _ e m)= prolog p $$ element e $$ vcat (map misc m)
prolog (Prolog x m1 dtd m2)= maybe xmldecl x $$
vcat (map misc m1) $$
maybe doctypedecl dtd $$
vcat (map misc m2)
xmldecl (XMLDecl v e sd) = text " text v <> text "'" <+>
maybe encodingdecl e <+>
maybe sddecl sd <+>
text "?>"
misc (Comment s) = text ""
misc (PI (n,s)) = text "" <> text n <+> text s <+> text "?>"
sddecl sd | sd = text "standalone='yes'"
| otherwise = text "standalone='no'"
doctypedecl (DTD n eid ds) = if null ds then
hd <> text ">"
else hd <+> text " [" $$
vcat (map markupdecl ds) $$ text "]>"
where hd = text " qname 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
--markupdecl (MarkupPE p m) = peref p
--extsubset (ExtSubset t ds) = maybe textdecl t $$
-- vcat (map extsubsetdecl ds)
--extsubsetdecl (ExtMarkupDecl m) = markupdecl m
--extsubsetdecl (ExtConditionalSect c) = conditionalsect c
-- --extsubsetdecl (ExtPEReference p e) = peref p
element (Elem n as []) = text "<" <> qname n <+>
fsep (map attribute as) <> text "/>"
element e@(Elem n as cs)
-- | any isText cs = text "<" <> qname n <+> fsep (map attribute as) <>
-- text ">" <> hcat (map content cs) <>
-- text "" <> qname n <> text ">"
| isText (head cs) = text "<" <> qname n <+> fsep (map attribute as) <>
text ">" <> hcat (map content cs) <>
text "" <> qname n <> text ">"
| otherwise = let (d,c) = carryelem e empty
in d <> c
isText :: Content i -> Bool
isText (CString _ _ _) = True
isText (CRef _ _) = True
isText _ = False
carryelem :: Element i -> Doc -> (Doc, Doc)
carryelem (Elem n as []) c
= ( c <>
text "<" <> qname n <+> fsep (map attribute as)
, text "/>")
--carryelem e@(Elem n as cs) c
---- | any isText cs = ( c <> element e, empty)
-- | otherwise = let (cs',d') = carryscan carrycontent cs (text ">")
-- in
-- ( c <>
-- text "<" <> qname n <+> fsep (map attribute as) $$
-- nest 2 (vcat cs') <> -- $$
-- c' <> text "" <> qname n
-- , text ">")
--carrycontent (CElem e) c = carryelem e c
--carrycontent (CString _ s) c = (c <> chardata s, empty)
--carrycontent (CRef r) c = (c <> reference r, empty)
--carrycontent (CMisc m) c = (c <> misc m, empty)
--
--carryscan :: (a->c->(b,c)) -> [a] -> c -> ([b],c)
--carryscan f [] c = ([],c)
--carryscan f (a:as) c = let (b, c') = f a c
-- (bs,c'') = carryscan f as c'
-- in (b:bs, c'')
carryelem (Elem n as cs) c
| isText (head cs) =
( start <>
text ">" <> hcat (map content cs) <> text "" <> qname n
, text ">")
| otherwise =
let (d,c') = foldl carrycontent (start, text ">") cs in
( d <> c' <> text "" <> qname n
, text ">")
where start = c <> text "<" <> qname n <+> fsep (map attribute as)
carrycontent :: (Doc, Doc) -> Content i -> (Doc, Doc)
carrycontent (d,c) (CElem e _) = let (d',c') = carryelem e c in
(d $$ nest 2 d', c')
carrycontent (d,c) (CString _ s _) = (d <> c <> chardata s, empty)
carrycontent (d,c) (CRef r _) = (d <> c <> reference r,empty)
carrycontent (d,c) (CMisc m _) = (d $$ c <> misc m, empty)
attribute (n,v) = qname n <> text "=" <> attvalue v
content (CElem e _) = element e
content (CString _ s _) = chardata s
content (CRef r _) = reference r
content (CMisc m _) = misc m
elementdecl :: ElementDecl -> Doc
contentspec :: ContentSpec -> Doc
cp :: CP -> Doc
modifier :: Modifier -> Doc
mixed :: Mixed -> Doc
attlistdecl :: AttListDecl -> Doc
attdef :: AttDef -> Doc
atttype :: AttType -> Doc
tokenizedtype :: TokenizedType -> Doc
enumeratedtype :: EnumeratedType -> Doc
notationtype :: [String] -> Doc
enumeration :: [String] -> Doc
defaultdecl :: DefaultDecl -> Doc
reference :: Reference -> Doc
entityref :: String -> Doc
charref :: (Show a) => a -> Doc
entitydecl :: EntityDecl -> Doc
gedecl :: GEDecl -> Doc
pedecl :: PEDecl -> Doc
entitydef :: EntityDef -> Doc
pedef :: PEDef -> Doc
externalid :: ExternalID -> Doc
ndatadecl :: NDataDecl -> Doc
notationdecl :: NotationDecl -> Doc
publicid :: PublicID -> Doc
encodingdecl :: EncodingDecl -> Doc
nmtoken :: String -> Doc
attvalue :: AttValue -> Doc
entityvalue :: EntityValue -> Doc
ev :: EV -> Doc
pubidliteral :: PubidLiteral -> Doc
systemliteral :: SystemLiteral -> Doc
chardata :: [Char] -> Doc
elementdecl (ElementDecl n cs) = text " qname n <+>
contentspec cs <> text ">"
contentspec EMPTY = text "EMPTY"
contentspec ANY = text "ANY"
contentspec (Mixed m) = mixed m
contentspec (ContentSpec c) = cp c
--contentspec (ContentPE p cs) = peref p
cp (TagName n m) = qname n <> modifier m
cp (Choice cs m) = parens (hcat (intersperse (text "|") (map cp cs))) <>
modifier m
cp (Seq cs m) = parens (hcat (intersperse (text ",") (map cp cs))) <>
modifier m
--cp (CPPE p c) = peref p
modifier None = empty
modifier Query = text "?"
modifier Star = text "*"
modifier Plus = text "+"
mixed PCDATA = text "(#PCDATA)"
mixed (PCDATAplus ns) = text "(#PCDATA |" <+>
hcat (intersperse (text "|") (map qname ns)) <>
text ")*"
attlistdecl (AttListDecl n ds) = text " qname n <+>
fsep (map attdef ds) <> text ">"
attdef (AttDef n t d) = qname n <+> atttype t <+> defaultdecl d
atttype StringType = text "CDATA"
atttype (TokenizedType t) = tokenizedtype t
atttype (EnumeratedType t) = enumeratedtype t
tokenizedtype ID = text "ID"
tokenizedtype IDREF = text "IDREF"
tokenizedtype IDREFS = text "IDREFS"
tokenizedtype ENTITY = text "ENTITY"
tokenizedtype ENTITIES = text "ENTITIES"
tokenizedtype NMTOKEN = text "NMTOKEN"
tokenizedtype NMTOKENS = text "NMTOKENS"
enumeratedtype (NotationType n)= notationtype n
enumeratedtype (Enumeration e) = enumeration e
notationtype ns = text "NOTATION" <+>
parens (hcat (intersperse (text "|") (map text ns)))
enumeration ns = parens (hcat (intersperse (text "|") (map nmtoken ns)))
defaultdecl REQUIRED = text "#REQUIRED"
defaultdecl IMPLIED = text "#IMPLIED"
defaultdecl (DefaultTo a f) = maybe (const (text "#FIXED")) f <+> attvalue a
--conditionalsect (IncludeSect i)= text "
-- vcat (map extsubsetdecl i) <+> text "]]>"
--conditionalsect (IgnoreSect i) = text "
-- fsep (map ignoresectcontents i) <+> text "]]>"
--ignore (Ignore) = empty
--ignoresectcontents (IgnoreSectContents i is)
-- = ignore i <+> vcat (map internal is)
-- where internal (ics,i) = text "
-- ignoresectcontents ics <+>
-- text "]]>" <+> ignore i
reference (RefEntity er) = entityref er
reference (RefChar cr) = charref cr
entityref n = text "&" <> text n <> text ";"
charref c = text "" <> text (show c) <> text ";"
entitydecl (EntityGEDecl d) = gedecl d
entitydecl (EntityPEDecl d) = pedecl d
gedecl (GEDecl n ed) = text " text n <+> entitydef ed <>
text ">"
pedecl (PEDecl n pd) = text " text n <+> pedef pd <>
text ">"
entitydef (DefEntityValue ev) = entityvalue ev
entitydef (DefExternalID i nd) = externalid i <+> maybe ndatadecl nd
pedef (PEDefEntityValue ev) = entityvalue ev
pedef (PEDefExternalID eid) = externalid eid
externalid (SYSTEM sl) = text "SYSTEM" <+> systemliteral sl
externalid (PUBLIC i sl) = text "PUBLIC" <+> pubidliteral i <+>
systemliteral sl
ndatadecl (NDATA n) = text "NDATA" <+> text n
--textdecl (TextDecl vi ed) = text " maybe text vi <+>
-- encodingdecl ed <> text "?>"
--extparsedent (ExtParsedEnt t c)= maybe textdecl t <+> content c
--extpe (ExtPE t esd) = maybe textdecl t <+>
-- vcat (map extsubsetdecl esd)
notationdecl (NOTATION n e) = text " text n <+>
either externalid publicid e <>
text ">"
publicid (PUBLICID p) = text "PUBLICID" <+> pubidliteral p
encodingdecl (EncodingDecl s) = text "encoding='" <> text s <> text "'"
nmtoken s = text s
attvalue (AttValue esr) = text "\"" <>
hcat (map (either text reference) esr) <>
text "\""
entityvalue (EntityValue evs) = text "'" <> hcat (map ev evs) <> text "'"
ev (EVString s) = text s
--ev (EVPERef p e) = peref p
ev (EVRef r) = reference r
pubidliteral (PubidLiteral s) = text "'" <> text s <> text "'"
systemliteral (SystemLiteral s)= text "'" <> text s <> text "'"
chardata s = if all isSpace s then empty else text s
--cdsect c = text " chardata c <> text "]]>"
qname n = text (printableName n)
----