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
= "<?xml version='1.0' ?>"
data ConfigPP = ConfigPP
{ ConfigPP -> QName -> Bool
shortEmptyTag :: QName -> Bool
, ConfigPP -> Bool
prettify :: Bool
}
defaultConfigPP :: ConfigPP
defaultConfigPP :: ConfigPP
defaultConfigPP = ConfigPP :: (QName -> Bool) -> Bool -> ConfigPP
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 p :: QName -> Bool
p c :: ConfigPP
c = ConfigPP
c { shortEmptyTag :: QName -> Bool
shortEmptyTag = QName -> Bool
p }
useExtraWhiteSpace :: Bool -> ConfigPP -> ConfigPP
p :: Bool
p c :: ConfigPP
c = ConfigPP
c { prettify :: Bool
prettify = Bool
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 c :: ConfigPP
c e :: 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 c :: ConfigPP
c e :: Element
e = ConfigPP -> String -> Element -> ShowS
ppElementS ConfigPP
c "" Element
e ""
ppcContent :: ConfigPP -> Content -> String
ppcContent :: ConfigPP -> Content -> String
ppcContent c :: ConfigPP
c x :: Content
x = ConfigPP -> String -> Content -> ShowS
ppContentS ConfigPP
c "" Content
x ""
ppContentS :: ConfigPP -> String -> Content -> ShowS
ppContentS :: ConfigPP -> String -> Content -> ShowS
ppContentS c :: ConfigPP
c i :: String
i x :: Content
x xs :: String
xs = case Content
x of
Elem e :: Element
e -> ConfigPP -> String -> Element -> ShowS
ppElementS ConfigPP
c String
i Element
e String
xs
Text t :: CData
t -> ConfigPP -> String -> CData -> ShowS
ppCDataS ConfigPP
c String
i CData
t String
xs
CRef r :: String
r -> String -> ShowS
showCRefS String
r String
xs
ppElementS :: ConfigPP -> String -> Element -> ShowS
ppElementS :: ConfigPP -> String -> Element -> ShowS
ppElementS c :: ConfigPP
c i :: String
i e :: Element
e xs :: 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 -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` QName -> String
qName QName
name -> " ?>" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
xs
| ConfigPP -> QName -> Bool
shortEmptyTag ConfigPP
c QName
name -> " />" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
xs
[Text t :: CData
t] -> ">" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ConfigPP -> String -> CData -> ShowS
ppCDataS ConfigPP
c "" CData
t (QName -> ShowS
tagEnd QName
name String
xs)
cs :: [Content]
cs -> '>' Char -> ShowS
forall a. a -> [a] -> [a]
: String
nl String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Content -> ShowS) -> String -> [Content] -> String
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 e1 :: 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
(nl :: String
nl,sp :: String
sp) = if ConfigPP -> Bool
prettify ConfigPP
c then ("\n"," ") else ("","")
)
where name :: QName
name = Element -> QName
elName Element
e
ppCDataS :: ConfigPP -> String -> CData -> ShowS
ppCDataS :: ConfigPP -> String -> CData -> ShowS
ppCDataS c :: ConfigPP
c i :: String
i t :: CData
t xs :: 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 (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 '\n' ys :: String
ys = "\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ys
cons y :: Char
y ys :: String
ys = Char
y Char -> ShowS
forall a. a -> [a] -> [a]
: String
ys
showTopElement :: Element -> String
showTopElement :: Element -> String
showTopElement c :: Element
c = String
xml_header String -> ShowS
forall a. [a] -> [a] -> [a]
++ Element -> String
showElement Element
c
showContent :: Content -> String
showContent :: Content -> String
showContent c :: Content
c = ConfigPP -> String -> Content -> ShowS
ppContentS ConfigPP
defaultConfigPP "" Content
c ""
showElement :: Element -> String
showElement :: Element -> String
showElement c :: Element
c = ConfigPP -> String -> Element -> ShowS
ppElementS ConfigPP
defaultConfigPP "" Element
c ""
showCData :: CData -> String
showCData :: CData -> String
showCData c :: CData
c = ConfigPP -> String -> CData -> ShowS
ppCDataS ConfigPP
defaultConfigPP "" CData
c ""
showCRefS :: String -> ShowS
showCRefS :: String -> ShowS
showCRefS r :: String
r xs :: String
xs = '&' Char -> ShowS
forall a. a -> [a] -> [a]
: String
r String -> ShowS
forall a. [a] -> [a] -> [a]
++ ';' Char -> ShowS
forall a. a -> [a] -> [a]
: String
xs
showCDataS :: CData -> ShowS
showCDataS :: CData -> ShowS
showCDataS cd :: CData
cd =
case CData -> CDataKind
cdVerbatim CData
cd of
CDataText -> String -> ShowS
escStr (CData -> String
cdData CData
cd)
CDataVerbatim -> String -> ShowS
showString "<![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 "]]>"
CDataRaw -> \ xs :: String
xs -> CData -> String
cdData CData
cd String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
xs
escCData :: String -> ShowS
escCData :: String -> ShowS
escCData (']' : ']' : '>' : cs :: String
cs) = String -> ShowS
showString "]]]]><![CDATA[>" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
escCData String
cs
escCData (c :: Char
c : cs :: 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 c :: Char
c = case Char
c of
'<' -> String -> ShowS
showString "<"
'>' -> String -> ShowS
showString ">"
'&' -> String -> ShowS
showString "&"
'"' -> String -> ShowS
showString """
'\'' -> String -> ShowS
showString "'"
_ | Char -> Bool
isPrint Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\n' -> Char -> ShowS
showChar Char
c
| Bool
otherwise -> String -> ShowS
showString "&#" 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 ';'
where oc :: Int
oc = Char -> Int
ord Char
c
escStr :: String -> ShowS
escStr :: String -> ShowS
escStr cs :: String
cs rs :: String
rs = (Char -> ShowS) -> String -> ShowS
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 qn :: QName
qn rs :: String
rs = '<'Char -> ShowS
forall a. a -> [a] -> [a]
:'/'Char -> ShowS
forall a. a -> [a] -> [a]
:QName -> String
showQName QName
qn String -> ShowS
forall a. [a] -> [a] -> [a]
++ '>'Char -> ShowS
forall a. a -> [a] -> [a]
:String
rs
tagStart :: QName -> [Attr] -> ShowS
tagStart :: QName -> [Attr] -> ShowS
tagStart qn :: QName
qn as :: [Attr]
as rs :: String
rs = '<'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 (t :: * -> *) a. Foldable t => t a -> Bool
null [Attr]
as then "" else ' ' 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 qn :: QName
qn v :: String
v) = QName -> String
showQName QName
qn String -> ShowS
forall a. [a] -> [a] -> [a]
++ '=' Char -> ShowS
forall a. a -> [a] -> [a]
: '"' Char -> ShowS
forall a. a -> [a] -> [a]
: String -> ShowS
escStr String
v "\""
showQName :: QName -> String
showQName :: QName -> String
showQName q :: 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
Nothing -> ""
Just p :: String
p -> String
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ ":"