{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
module Text.Pandoc.XML.Light.Output
(
ppTopElement
, ppElement
, ppContent
, ppcElement
, ppcContent
, showTopElement
, showElement
, showContent
, useShortEmptyTags
, defaultConfigPP
, ConfigPP(..)
) where
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Data.Text.Lazy.Builder (Builder, singleton, fromText, toLazyText)
import Text.Pandoc.XML.Light.Types
xmlHeader :: Text
= Text
"<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
data ConfigPP = ConfigPP
{ ConfigPP -> QName -> Bool
shortEmptyTag :: QName -> Bool
, ConfigPP -> Bool
prettify :: Bool
}
defaultConfigPP :: ConfigPP
defaultConfigPP :: ConfigPP
defaultConfigPP = ConfigPP { shortEmptyTag :: QName -> Bool
shortEmptyTag = 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 :: QName -> Bool
shortEmptyTag = QName -> Bool
p }
useExtraWhiteSpace :: Bool -> ConfigPP -> ConfigPP
Bool
p ConfigPP
c = ConfigPP
c { prettify :: Bool
prettify = Bool
p }
prettyConfigPP :: ConfigPP
prettyConfigPP :: ConfigPP
prettyConfigPP = Bool -> ConfigPP -> ConfigPP
useExtraWhiteSpace Bool
True ConfigPP
defaultConfigPP
ppTopElement :: Element -> Text
ppTopElement :: Element -> Text
ppTopElement = ConfigPP -> Element -> Text
ppcTopElement ConfigPP
prettyConfigPP
ppElement :: Element -> Text
ppElement :: Element -> Text
ppElement = ConfigPP -> Element -> Text
ppcElement ConfigPP
prettyConfigPP
ppContent :: Content -> Text
ppContent :: Content -> Text
ppContent = ConfigPP -> Content -> Text
ppcContent ConfigPP
prettyConfigPP
ppcTopElement :: ConfigPP -> Element -> Text
ppcTopElement :: ConfigPP -> Element -> Text
ppcTopElement ConfigPP
c Element
e = [Text] -> Text
T.unlines [Text
xmlHeader,ConfigPP -> Element -> Text
ppcElement ConfigPP
c Element
e]
ppcElement :: ConfigPP -> Element -> Text
ppcElement :: ConfigPP -> Element -> Text
ppcElement ConfigPP
c = Text -> Text
TL.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
toLazyText forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigPP -> Builder -> Element -> Builder
ppElementS ConfigPP
c forall a. Monoid a => a
mempty
ppcContent :: ConfigPP -> Content -> Text
ppcContent :: ConfigPP -> Content -> Text
ppcContent ConfigPP
c = Text -> Text
TL.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
toLazyText forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigPP -> Builder -> Content -> Builder
ppContentS ConfigPP
c forall a. Monoid a => a
mempty
ppcCData :: ConfigPP -> CData -> Text
ppcCData :: ConfigPP -> CData -> Text
ppcCData ConfigPP
c = Text -> Text
TL.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
toLazyText forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigPP -> Builder -> CData -> Builder
ppCDataS ConfigPP
c forall a. Monoid a => a
mempty
type Indent = Builder
ppContentS :: ConfigPP -> Indent -> Content -> Builder
ppContentS :: ConfigPP -> Builder -> Content -> Builder
ppContentS ConfigPP
c Builder
i Content
x = case Content
x of
Elem Element
e -> ConfigPP -> Builder -> Element -> Builder
ppElementS ConfigPP
c Builder
i Element
e
Text CData
t -> ConfigPP -> Builder -> CData -> Builder
ppCDataS ConfigPP
c Builder
i CData
t
CRef Text
r -> Text -> Builder
showCRefS Text
r
ppElementS :: ConfigPP -> Indent -> Element -> Builder
ppElementS :: ConfigPP -> Builder -> Element -> Builder
ppElementS ConfigPP
c Builder
i Element
e = Builder
i forall a. Semigroup a => a -> a -> a
<> QName -> [Attr] -> Builder
tagStart (Element -> QName
elName Element
e) (Element -> [Attr]
elAttribs Element
e) forall a. Semigroup a => a -> a -> a
<>
(case Element -> [Content]
elContent Element
e of
[] | Text
"?" Text -> Text -> Bool
`T.isPrefixOf` QName -> Text
qName QName
name -> Text -> Builder
fromText Text
" ?>"
| ConfigPP -> QName -> Bool
shortEmptyTag ConfigPP
c QName
name -> Text -> Builder
fromText Text
" />"
[Text CData
t] -> Char -> Builder
singleton Char
'>' forall a. Semigroup a => a -> a -> a
<> ConfigPP -> Builder -> CData -> Builder
ppCDataS ConfigPP
c forall a. Monoid a => a
mempty CData
t forall a. Semigroup a => a -> a -> a
<> QName -> Builder
tagEnd QName
name
[Content]
cs -> Char -> Builder
singleton Char
'>' forall a. Semigroup a => a -> a -> a
<> Builder
nl forall a. Semigroup a => a -> a -> a
<>
forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map ((forall a. Semigroup a => a -> a -> a
<> Builder
nl) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigPP -> Builder -> Content -> Builder
ppContentS ConfigPP
c (Builder
sp forall a. Semigroup a => a -> a -> a
<> Builder
i)) [Content]
cs) forall a. Semigroup a => a -> a -> a
<>
Builder
i forall a. Semigroup a => a -> a -> a
<> QName -> Builder
tagEnd QName
name
where (Builder
nl,Builder
sp) = if ConfigPP -> Bool
prettify ConfigPP
c then (Builder
"\n",Builder
" ") else (Builder
"",Builder
"")
)
where name :: QName
name = Element -> QName
elName Element
e
ppCDataS :: ConfigPP -> Indent -> CData -> Builder
ppCDataS :: ConfigPP -> Builder -> CData -> Builder
ppCDataS ConfigPP
c Builder
i CData
t = Builder
i forall a. Semigroup a => a -> a -> a
<> if CData -> CDataKind
cdVerbatim CData
t forall a. Eq a => a -> a -> Bool
/= CDataKind
CDataText Bool -> Bool -> Bool
|| Bool -> Bool
not (ConfigPP -> Bool
prettify ConfigPP
c)
then CData -> Builder
showCDataS CData
t
else forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Char -> Builder -> Builder
cons forall a. Monoid a => a
mempty (Text -> String
T.unpack (CData -> Text
showCData CData
t))
where cons :: Char -> Builder -> Builder
cons :: Char -> Builder -> Builder
cons Char
'\n' Builder
ys = Char -> Builder
singleton Char
'\n' forall a. Semigroup a => a -> a -> a
<> Builder
i forall a. Semigroup a => a -> a -> a
<> Builder
ys
cons Char
y Builder
ys = Char -> Builder
singleton Char
y forall a. Semigroup a => a -> a -> a
<> Builder
ys
showTopElement :: Element -> Text
showTopElement :: Element -> Text
showTopElement Element
c = Text
xmlHeader forall a. Semigroup a => a -> a -> a
<> Element -> Text
showElement Element
c
showContent :: Content -> Text
showContent :: Content -> Text
showContent = ConfigPP -> Content -> Text
ppcContent ConfigPP
defaultConfigPP
showElement :: Element -> Text
showElement :: Element -> Text
showElement = ConfigPP -> Element -> Text
ppcElement ConfigPP
defaultConfigPP
showCData :: CData -> Text
showCData :: CData -> Text
showCData = ConfigPP -> CData -> Text
ppcCData ConfigPP
defaultConfigPP
showCRefS :: Text -> Builder
showCRefS :: Text -> Builder
showCRefS Text
r = Char -> Builder
singleton Char
'&' forall a. Semigroup a => a -> a -> a
<> Text -> Builder
fromText Text
r forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
';'
showCDataS :: CData -> Builder
showCDataS :: CData -> Builder
showCDataS CData
cd =
case CData -> CDataKind
cdVerbatim CData
cd of
CDataKind
CDataText -> Text -> Builder
escStr (CData -> Text
cdData CData
cd)
CDataKind
CDataVerbatim -> Text -> Builder
fromText Text
"<![CDATA[" forall a. Semigroup a => a -> a -> a
<> Text -> Builder
escCData (CData -> Text
cdData CData
cd) forall a. Semigroup a => a -> a -> a
<>
Text -> Builder
fromText Text
"]]>"
CDataKind
CDataRaw -> Text -> Builder
fromText (CData -> Text
cdData CData
cd)
escCData :: Text -> Builder
escCData :: Text -> Builder
escCData Text
t
| Text
"]]>" Text -> Text -> Bool
`T.isPrefixOf` Text
t =
Text -> Builder
fromText Text
"]]]]><![CDATA[>" forall a. Semigroup a => a -> a -> a
<> Text -> Builder
fromText (Int -> Text -> Text
T.drop Int
3 Text
t)
escCData Text
t
= case Text -> Maybe (Char, Text)
T.uncons Text
t of
Maybe (Char, Text)
Nothing -> forall a. Monoid a => a
mempty
Just (Char
c,Text
t') -> Char -> Builder
singleton Char
c forall a. Semigroup a => a -> a -> a
<> Text -> Builder
escCData Text
t'
escChar :: Char -> Builder
escChar :: Char -> Builder
escChar Char
c = case Char
c of
Char
'<' -> Text -> Builder
fromText Text
"<"
Char
'>' -> Text -> Builder
fromText Text
">"
Char
'&' -> Text -> Builder
fromText Text
"&"
Char
'"' -> Text -> Builder
fromText Text
"""
Char
'\'' -> Text -> Builder
fromText Text
"'"
Char
_ -> Char -> Builder
singleton Char
c
escStr :: Text -> Builder
escStr :: Text -> Builder
escStr Text
cs = if (Char -> Bool) -> Text -> Bool
T.any Char -> Bool
needsEscape Text
cs
then forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map Char -> Builder
escChar (Text -> String
T.unpack Text
cs))
else Text -> Builder
fromText Text
cs
where
needsEscape :: Char -> Bool
needsEscape Char
'<' = Bool
True
needsEscape Char
'>' = Bool
True
needsEscape Char
'&' = Bool
True
needsEscape Char
'"' = Bool
True
needsEscape Char
'\'' = Bool
True
needsEscape Char
_ = Bool
False
tagEnd :: QName -> Builder
tagEnd :: QName -> Builder
tagEnd QName
qn = Text -> Builder
fromText Text
"</" forall a. Semigroup a => a -> a -> a
<> QName -> Builder
showQName QName
qn forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
'>'
tagStart :: QName -> [Attr] -> Builder
tagStart :: QName -> [Attr] -> Builder
tagStart QName
qn [Attr]
as = Char -> Builder
singleton Char
'<' forall a. Semigroup a => a -> a -> a
<> QName -> Builder
showQName QName
qn forall a. Semigroup a => a -> a -> a
<> Builder
as_str
where as_str :: Builder
as_str = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Attr]
as
then forall a. Monoid a => a
mempty
else forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map Attr -> Builder
showAttr [Attr]
as)
showAttr :: Attr -> Builder
showAttr :: Attr -> Builder
showAttr (Attr QName
qn Text
v) = Char -> Builder
singleton Char
' ' forall a. Semigroup a => a -> a -> a
<> QName -> Builder
showQName QName
qn forall a. Semigroup a => a -> a -> a
<>
Char -> Builder
singleton Char
'=' forall a. Semigroup a => a -> a -> a
<>
Char -> Builder
singleton Char
'"' forall a. Semigroup a => a -> a -> a
<> Text -> Builder
escStr Text
v forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
'"'
showQName :: QName -> Builder
showQName :: QName -> Builder
showQName QName
q =
case QName -> Maybe Text
qPrefix QName
q of
Maybe Text
Nothing -> Text -> Builder
fromText (QName -> Text
qName QName
q)
Just Text
p -> Text -> Builder
fromText Text
p forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
':' forall a. Semigroup a => a -> a -> a
<> Text -> Builder
fromText (QName -> Text
qName QName
q)