tpdb-1.5.2: src/TPDB/Xml/Pretty.hs
-- | original author: Malcolm Wallace,
-- license: LGPL
-- http://hackage.haskell.org/packages/archive/HaXml/1.23.3/doc/html/Text-XML-HaXml-Pretty.html
--
-- modified by Johannes Waldmann
-- to use a different pretty-printer back-end.
--
-- This is a pretty-printer for turning the internal representation
-- of generic structured XML documents into the Doc type (which can
-- later be rendered using Text.PrettyPrint.HughesPJ.render).
-- Essentially 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.
{-# language OverloadedStrings #-}
module TPDB.Xml.Pretty
(
-- * Pretty-print a whole document
document
-- ** Just one content
, content
-- ** Just one tagged element
, element
-- * Pretty-print just a DTD
, doctypedecl
-- ** The prolog
, prolog
-- ** A content particle description
, cp
) where
import Prelude hiding (maybe,either)
import Data.Maybe hiding (maybe)
import Data.List (intersperse)
--import Char (isSpace)
-- import Text.PrettyPrint.HughesPJ
import TPDB.Pretty hiding ( text, Doc )
import qualified TPDB.Pretty as P
import Text.XML.HaXml.Types
import Text.XML.HaXml.Namespaces
import Data.String ( fromString )
type Doc = P.Doc ()
text = fromString
either :: (t -> t1) -> (t2 -> t1) -> Either t t2 -> t1
either f _ (Left x) = f x
either _ g (Right x) = g x
maybe :: (t -> Doc) -> Maybe t -> Doc
maybe _ Nothing = empty
maybe f (Just x) = f x
--peref p = "%" <> text p <> ";"
----
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
cp :: CP -> 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) = "<?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'"
doctypedecl (DTD n eid ds) = if null ds then
hd <> ">"
else hd <+> " [" $$
vcat (map markupdecl ds) $$ "]>"
where hd = "<!DOCTYPE" <+> 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)
--extmarkupdecl (ExtMarkupDecl m) = markupdecl m
--extsubsetdecl (ExtConditionalSect c) = conditionalsect c
-- -- extsubsetdecl (ExtPEReference p e) = peref p
element (Elem n as []) = "<" <> qname n <+>
fsep (map attribute as) <> "/>"
element e@(Elem n as cs)
| all isText cs = "<" <> qname n <+> fsep (map attribute as) <>
">" <> hcat (map content cs) <>
"</" <> qname n <> ">"
| otherwise = let (d,c) = carryelem e empty
in d <> c
isText :: Content t -> Bool
isText (CString _ _ _) = True
isText (CRef _ _) = True
isText _ = False
carryelem :: Element t -> Doc -> (Doc, Doc)
carrycontent :: Content t -> Doc -> (Doc, Doc)
spancontent :: [Content a] -> Doc -> ([Doc],Doc)
carryelem (Elem n as []) c = ( c <>
"<" <> qname n <+> fsep (map attribute as)
, "/>")
carryelem (Elem n as cs) c = let (cs0,d0) = spancontent cs (">") in
( c <>
"<"<>qname n <+> fsep (map attribute as) $$
nest 2 (vcat cs0) <>
d0 <> "</" <> qname n
, ">")
carrycontent (CElem e _) c = carryelem e c
carrycontent (CString False s _) c = (c <> chardata s, empty)
carrycontent (CString True s _) c = (c <> cdsect s, empty)
carrycontent (CRef r _) c = (c <> reference r, empty)
carrycontent (CMisc m _) c = (c <> misc m, empty)
spancontent [] c = ([],c)
spancontent (a:as) c | isText a = let (ts,rest) = span isText (a:as)
formatted = c <> hcat (map content ts)
in spancontent rest formatted
| otherwise = let (b, c0) = carrycontent a c
(bs,c1) = spancontent as c0
in (b:bs, c1)
attribute (n,v) = qname n <> "=" <> attvalue v
content (CElem e _) = element e
content (CString False s _) = chardata s
content (CString True s _) = cdsect s
content (CRef r _) = reference r
content (CMisc m _) = misc m
elementdecl :: ElementDecl -> Doc
elementdecl (ElementDecl n cs) = "<!ELEMENT" <+> qname n <+>
contentspec cs <> ">"
contentspec :: ContentSpec -> Doc
contentspec EMPTY = "EMPTY"
contentspec ANY = "ANY"
contentspec (Mixed m) = mixed m
contentspec (ContentSpec c) = cp c
--contentspec (ContentPE p cs) = peref p
cp (TagName n m) = parens (qname n) <> modifier m
cp (Choice cs m) = parens (hcat (intersperse ("|") (map cp cs))) <>
modifier m
cp (Seq cs m) = parens (hcat (intersperse (",") (map cp cs))) <>
modifier m
--cp (CPPE p c) = peref p
modifier :: Modifier -> Doc
modifier None = empty
modifier Query = "?"
modifier Star = "*"
modifier Plus = "+"
mixed :: Mixed -> Doc
mixed PCDATA = "(#PCDATA)"
mixed (PCDATAplus ns) = "(#PCDATA |" <+>
hcat (intersperse ("|") (map qname ns)) <>
")*"
attlistdecl :: AttListDecl -> Doc
attlistdecl (AttListDecl n ds) = "<!ATTLIST" <+> qname n <+>
fsep (map attdef ds) <> ">"
attdef :: AttDef -> Doc
attdef (AttDef n t d) = qname n <+> atttype t <+> defaultdecl d
atttype :: AttType -> Doc
atttype StringType = "CDATA"
atttype (TokenizedType t) = tokenizedtype t
atttype (EnumeratedType t) = enumeratedtype t
tokenizedtype :: TokenizedType -> Doc
tokenizedtype ID = "ID"
tokenizedtype IDREF = "IDREF"
tokenizedtype IDREFS = "IDREFS"
tokenizedtype ENTITY = "ENTITY"
tokenizedtype ENTITIES = "ENTITIES"
tokenizedtype NMTOKEN = "NMTOKEN"
tokenizedtype NMTOKENS = "NMTOKENS"
enumeratedtype :: EnumeratedType -> Doc
enumeratedtype (NotationType n)= notationtype n
enumeratedtype (Enumeration e) = enumeration e
notationtype :: [String] -> Doc
notationtype ns = "NOTATION" <+>
parens (hcat (intersperse ("|") (map text ns)))
enumeration :: [String] -> Doc
enumeration ns = parens (hcat (intersperse ("|") (map nmtoken ns)))
defaultdecl :: DefaultDecl -> Doc
defaultdecl REQUIRED = "#REQUIRED"
defaultdecl IMPLIED = "#IMPLIED"
defaultdecl (DefaultTo a f) = maybe (const ("#FIXED")) f <+> attvalue a
--conditionalsect (IncludeSect i)= "<![INCLUDE [" <+>
-- vcat (map extsubsetdecl i) <+> "]]>"
--conditionalsect (IgnoreSect i) = "<![IGNORE [" <+>
-- fsep (map ignoresectcontents i) <+> "]]>"
--ignore (Ignore) = empty
--ignoresectcontents (IgnoreSectContents i is)
-- = ignore i <+> vcat (map internal is)
-- where internal (ics,i) = "<![[" <+>
-- ignoresectcontents ics <+>
-- "]]>" <+> ignore i
reference :: Reference -> Doc
reference (RefEntity er) = entityref er
reference (RefChar cr) = charref cr
entityref :: String -> Doc
entityref n = "&" <> text n <> ";"
charref :: (Show a) => a -> Doc
charref c = "&#" <> text (show c) <> ";"
entitydecl :: EntityDecl -> Doc
entitydecl (EntityGEDecl d) = gedecl d
entitydecl (EntityPEDecl d) = pedecl d
gedecl :: GEDecl -> Doc
gedecl (GEDecl n ed) = "<!ENTITY" <+> text n <+> entitydef ed <>
">"
pedecl :: PEDecl -> Doc
pedecl (PEDecl n pd) = "<!ENTITY %" <+> text n <+> pedef pd <>
">"
entitydef :: EntityDef -> Doc
entitydef (DefEntityValue ew) = entityvalue ew
entitydef (DefExternalID i nd) = externalid i <+> maybe ndatadecl nd
pedef :: PEDef -> Doc
pedef (PEDefEntityValue ew) = entityvalue ew
pedef (PEDefExternalID eid) = externalid eid
externalid :: ExternalID -> Doc
externalid (SYSTEM sl) = "SYSTEM" <+> systemliteral sl
externalid (PUBLIC i sl) = "PUBLIC" <+> pubidliteral i <+>
systemliteral sl
ndatadecl :: NDataDecl -> Doc
ndatadecl (NDATA n) = "NDATA" <+> text n
--textdecl (TextDecl vi ed) = "<?xml" <+> maybe text vi <+>
-- encodingdecl ed <+> "?>"
--extparsedent (ExtParsedEnt t c)= maybe textdecl t <+> content c
--extpe (ExtPE t esd) = maybe textdecl t <+>
-- vcat (map extsubsetdecl esd)
notationdecl :: NotationDecl -> Doc
notationdecl (NOTATION n e) = "<!NOTATION" <+> text n <+>
either externalid publicid e <>
">"
publicid :: PublicID -> Doc
publicid (PUBLICID p) = "PUBLIC" <+> pubidliteral p
encodingdecl :: EncodingDecl -> Doc
encodingdecl (EncodingDecl s) = "encoding='" <> text s <> "'"
nmtoken :: String -> Doc
nmtoken s = text s
attvalue :: AttValue -> Doc
attvalue (AttValue esr) = "\"" <>
hcat (map (either text reference) esr) <>
"\""
entityvalue :: EntityValue -> Doc
entityvalue (EntityValue evs)
| containsDoubleQuote evs = "'" <> hcat (map ev evs) <> "'"
| otherwise = "\"" <> hcat (map ev evs) <> "\""
ev :: EV -> Doc
ev (EVString s) = text s
--ev (EVPERef p e) = peref p
ev (EVRef r) = reference r
pubidliteral :: PubidLiteral -> Doc
pubidliteral (PubidLiteral s)
| '"' `elem` s = "'" <> text s <> "'"
| otherwise = "\"" <> text s <> "\""
systemliteral :: SystemLiteral -> Doc
systemliteral (SystemLiteral s)
| '"' `elem` s = "'" <> text s <> "'"
| otherwise = "\"" <> text s <> "\""
chardata :: String -> Doc
chardata s = {-if all isSpace s then empty else-} text s
cdsect :: String -> Doc
cdsect c = "<![CDATA[" <> chardata c <> "]]>"
qname n = text (printableName n)
----
containsDoubleQuote :: [EV] -> Bool
containsDoubleQuote evs = any csq evs
where csq (EVString s) = '"' `elem` s
csq _ = False