module Text.XML.Light.Output
( showTopElement, showContent, showElement, showCData, showQName, showAttr
, ppTopElement, ppContent, ppElement
, ppcTopElement, ppcContent, ppcElement
, ConfigPP
, defaultConfigPP, prettyConfigPP
, useShortEmptyTags, useExtraWhiteSpace
, tagEnd, xml_header
) where
import Text.XML.Light.Types
import Data.Char
import Data.List ( isPrefixOf )
xml_header :: String
= String
"<?xml version='1.0' ?>"
data ConfigPP = ConfigPP
{ ConfigPP -> QName -> Bool
shortEmptyTag :: QName -> Bool
, ConfigPP -> Bool
prettify :: Bool
}
defaultConfigPP :: ConfigPP
defaultConfigPP :: ConfigPP
defaultConfigPP = ConfigPP { shortEmptyTag :: QName -> Bool
shortEmptyTag = Bool -> QName -> Bool
forall a b. a -> b -> a
const Bool
True
, prettify :: Bool
prettify = Bool
False
}
useShortEmptyTags :: (QName -> Bool) -> ConfigPP -> ConfigPP
useShortEmptyTags :: (QName -> Bool) -> ConfigPP -> ConfigPP
useShortEmptyTags QName -> Bool
p ConfigPP
c = ConfigPP
c { shortEmptyTag = p }
useExtraWhiteSpace :: Bool -> ConfigPP -> ConfigPP
Bool
p ConfigPP
c = ConfigPP
c { prettify = p }
prettyConfigPP :: ConfigPP
prettyConfigPP :: ConfigPP
prettyConfigPP = Bool -> ConfigPP -> ConfigPP
useExtraWhiteSpace Bool
True ConfigPP
defaultConfigPP
ppTopElement :: Element -> String
ppTopElement :: Element -> String
ppTopElement = ConfigPP -> Element -> String
ppcTopElement ConfigPP
prettyConfigPP
ppElement :: Element -> String
ppElement :: Element -> String
ppElement = ConfigPP -> Element -> String
ppcElement ConfigPP
prettyConfigPP
ppContent :: Content -> String
ppContent :: Content -> String
ppContent = ConfigPP -> Content -> String
ppcContent ConfigPP
prettyConfigPP
ppcTopElement :: ConfigPP -> Element -> String
ppcTopElement :: ConfigPP -> Element -> String
ppcTopElement ConfigPP
c Element
e = [String] -> String
unlines [String
xml_header,ConfigPP -> Element -> String
ppcElement ConfigPP
c Element
e]
ppcElement :: ConfigPP -> Element -> String
ppcElement :: ConfigPP -> Element -> String
ppcElement ConfigPP
c Element
e = ConfigPP -> String -> Element -> ShowS
ppElementS ConfigPP
c String
"" Element
e String
""
ppcContent :: ConfigPP -> Content -> String
ppcContent :: ConfigPP -> Content -> String
ppcContent ConfigPP
c Content
x = ConfigPP -> String -> Content -> ShowS
ppContentS ConfigPP
c String
"" Content
x String
""
ppContentS :: ConfigPP -> String -> Content -> ShowS
ppContentS :: ConfigPP -> String -> Content -> ShowS
ppContentS ConfigPP
c String
i Content
x String
xs = case Content
x of
Elem Element
e -> ConfigPP -> String -> Element -> ShowS
ppElementS ConfigPP
c String
i Element
e String
xs
Text CData
t -> ConfigPP -> String -> CData -> ShowS
ppCDataS ConfigPP
c String
i CData
t String
xs
CRef String
r -> String -> ShowS
showCRefS String
r String
xs
ppElementS :: ConfigPP -> String -> Element -> ShowS
ppElementS :: ConfigPP -> String -> Element -> ShowS
ppElementS ConfigPP
c String
i Element
e String
xs = String
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ (QName -> [Attr] -> ShowS
tagStart (Element -> QName
elName Element
e) (Element -> [Attr]
elAttribs Element
e) ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
case Element -> [Content]
elContent Element
e of
[] | String
"?" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` QName -> String
qName QName
name -> String
" ?>" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
xs
| ConfigPP -> QName -> Bool
shortEmptyTag ConfigPP
c QName
name -> String
" />" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
xs
[Text CData
t] -> String
">" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ConfigPP -> String -> CData -> ShowS
ppCDataS ConfigPP
c String
"" CData
t (QName -> ShowS
tagEnd QName
name String
xs)
[Content]
cs -> Char
'>' Char -> ShowS
forall a. a -> [a] -> [a]
: String
nl String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Content -> ShowS) -> String -> [Content] -> String
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Content -> ShowS
ppSub (String
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ QName -> ShowS
tagEnd QName
name String
xs) [Content]
cs
where ppSub :: Content -> ShowS
ppSub Content
e1 = ConfigPP -> String -> Content -> ShowS
ppContentS ConfigPP
c (String
sp String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
i) Content
e1 ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
nl
(String
nl,String
sp) = if ConfigPP -> Bool
prettify ConfigPP
c then (String
"\n",String
" ") else (String
"",String
"")
)
where name :: QName
name = Element -> QName
elName Element
e
ppCDataS :: ConfigPP -> String -> CData -> ShowS
ppCDataS :: ConfigPP -> String -> CData -> ShowS
ppCDataS ConfigPP
c String
i CData
t String
xs = String
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ if CData -> CDataKind
cdVerbatim CData
t CDataKind -> CDataKind -> Bool
forall a. Eq a => a -> a -> Bool
/= CDataKind
CDataText Bool -> Bool -> Bool
|| Bool -> Bool
not (ConfigPP -> Bool
prettify ConfigPP
c)
then CData -> ShowS
showCDataS CData
t String
xs
else (Char -> ShowS) -> String -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Char -> ShowS
cons String
xs (CData -> String
showCData CData
t)
where cons :: Char -> String -> String
cons :: Char -> ShowS
cons Char
'\n' String
ys = String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ys
cons Char
y String
ys = Char
y Char -> ShowS
forall a. a -> [a] -> [a]
: String
ys
showTopElement :: Element -> String
showTopElement :: Element -> String
showTopElement Element
c = String
xml_header String -> ShowS
forall a. [a] -> [a] -> [a]
++ Element -> String
showElement Element
c
showContent :: Content -> String
showContent :: Content -> String
showContent Content
c = ConfigPP -> String -> Content -> ShowS
ppContentS ConfigPP
defaultConfigPP String
"" Content
c String
""
showElement :: Element -> String
showElement :: Element -> String
showElement Element
c = ConfigPP -> String -> Element -> ShowS
ppElementS ConfigPP
defaultConfigPP String
"" Element
c String
""
showCData :: CData -> String
showCData :: CData -> String
showCData CData
c = ConfigPP -> String -> CData -> ShowS
ppCDataS ConfigPP
defaultConfigPP String
"" CData
c String
""
showCRefS :: String -> ShowS
showCRefS :: String -> ShowS
showCRefS String
r String
xs = Char
'&' Char -> ShowS
forall a. a -> [a] -> [a]
: String
r String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
';' Char -> ShowS
forall a. a -> [a] -> [a]
: String
xs
showCDataS :: CData -> ShowS
showCDataS :: CData -> ShowS
showCDataS CData
cd =
case CData -> CDataKind
cdVerbatim CData
cd of
CDataKind
CDataText -> String -> ShowS
escStr (CData -> String
cdData CData
cd)
CDataKind
CDataVerbatim -> String -> ShowS
showString String
"<![CDATA[" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
escCData (CData -> String
cdData CData
cd)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"]]>"
CDataKind
CDataRaw -> \ String
xs -> CData -> String
cdData CData
cd String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
xs
escCData :: String -> ShowS
escCData :: String -> ShowS
escCData (Char
']' : Char
']' : Char
'>' : String
cs) = String -> ShowS
showString String
"]]]]><![CDATA[>" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
escCData String
cs
escCData (Char
c : String
cs) = Char -> ShowS
showChar Char
c ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
escCData String
cs
escCData [] = ShowS
forall a. a -> a
id
escChar :: Char -> ShowS
escChar :: Char -> ShowS
escChar Char
c = case Char
c of
Char
'<' -> String -> ShowS
showString String
"<"
Char
'>' -> String -> ShowS
showString String
">"
Char
'&' -> String -> ShowS
showString String
"&"
Char
'"' -> String -> ShowS
showString String
"""
Char
'\'' -> String -> ShowS
showString String
"'"
Char
_ | Char -> Bool
isPrint Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n' -> Char -> ShowS
showChar Char
c
| Bool
otherwise -> String -> ShowS
showString String
"&#" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
oc ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
';'
where oc :: Int
oc = Char -> Int
ord Char
c
escStr :: String -> ShowS
escStr :: String -> ShowS
escStr String
cs String
rs = (Char -> ShowS) -> String -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Char -> ShowS
escChar String
rs String
cs
tagEnd :: QName -> ShowS
tagEnd :: QName -> ShowS
tagEnd QName
qn String
rs = Char
'<'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'/'Char -> ShowS
forall a. a -> [a] -> [a]
:QName -> String
showQName QName
qn String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'>'Char -> ShowS
forall a. a -> [a] -> [a]
:String
rs
tagStart :: QName -> [Attr] -> ShowS
tagStart :: QName -> [Attr] -> ShowS
tagStart QName
qn [Attr]
as String
rs = Char
'<'Char -> ShowS
forall a. a -> [a] -> [a]
:QName -> String
showQName QName
qn String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
as_str String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
rs
where as_str :: String
as_str = if [Attr] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Attr]
as then String
"" else Char
' ' Char -> ShowS
forall a. a -> [a] -> [a]
: [String] -> String
unwords ((Attr -> String) -> [Attr] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Attr -> String
showAttr [Attr]
as)
showAttr :: Attr -> String
showAttr :: Attr -> String
showAttr (Attr QName
qn String
v) = QName -> String
showQName QName
qn String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'=' Char -> ShowS
forall a. a -> [a] -> [a]
: Char
'"' Char -> ShowS
forall a. a -> [a] -> [a]
: String -> ShowS
escStr String
v String
"\""
showQName :: QName -> String
showQName :: QName -> String
showQName QName
q = String
pre String -> ShowS
forall a. [a] -> [a] -> [a]
++ QName -> String
qName QName
q
where pre :: String
pre = case QName -> Maybe String
qPrefix QName
q of
Maybe String
Nothing -> String
""
Just String
p -> String
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":"