{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{- |
   Module      : Text.Pandoc.XML.Light.Output
   Copyright   : Copyright (C) 2007 Galois, Inc., 2021 John MacFarlane
   License     : GNU GPL, version 2 or above


   Maintainer  : John MacFarlane <jgm@berkeley.edu>
   Stability   : alpha
   Portability : portable

   This code is based on code from xml-light, released under the BSD3 license.
   We use a text Builder instead of ShowS.
-}
module Text.Pandoc.XML.Light.Output
  ( -- * Replacement for xml-light's Text.XML.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

--
-- duplicates functinos from Text.XML.Output
--

-- | The XML 1.0 header
xmlHeader :: Text
xmlHeader :: Text
xmlHeader = Text
"<?xml version=\"1.0\" encoding=\"UTF-8\"?>"


--------------------------------------------------------------------------------
data ConfigPP = ConfigPP
  { ConfigPP -> QName -> Bool
shortEmptyTag :: QName -> Bool
  , ConfigPP -> Bool
prettify      :: Bool
  }

-- | Default pretty orinting configuration.
--  * Always use abbreviate empty tags.
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
                           }

-- | The predicate specifies for which empty tags we should use XML's
-- abbreviated notation <TAG />.  This is useful if we are working with
-- some XML-ish standards (such as certain versions of HTML) where some
-- empty tags should always be displayed in the <TAG></TAG> form.
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 }


-- | Specify if we should use extra white-space to make document more readable.
-- WARNING: This adds additional white-space to text elements,
-- and so it may change the meaning of the document.
useExtraWhiteSpace :: Bool -> ConfigPP -> ConfigPP
useExtraWhiteSpace :: Bool -> ConfigPP -> ConfigPP
useExtraWhiteSpace Bool
p ConfigPP
c  = ConfigPP
c { prettify :: Bool
prettify = Bool
p }

-- | A configuration that tries to make things pretty
-- (possibly at the cost of changing the semantics a bit
-- through adding white space.)
prettyConfigPP     :: ConfigPP
prettyConfigPP :: ConfigPP
prettyConfigPP      = Bool -> ConfigPP -> ConfigPP
useExtraWhiteSpace Bool
True ConfigPP
defaultConfigPP


--------------------------------------------------------------------------------


-- | Pretty printing renders XML documents faithfully,
-- with the exception that whitespace may be added\/removed
-- in non-verbatim character data.
ppTopElement       :: Element -> Text
ppTopElement :: Element -> Text
ppTopElement        = ConfigPP -> Element -> Text
ppcTopElement ConfigPP
prettyConfigPP

-- | Pretty printing elements
ppElement          :: Element -> Text
ppElement :: Element -> Text
ppElement           = ConfigPP -> Element -> Text
ppcElement ConfigPP
prettyConfigPP

-- | Pretty printing content
ppContent          :: Content -> Text
ppContent :: Content -> Text
ppContent           = ConfigPP -> Content -> Text
ppcContent ConfigPP
prettyConfigPP

-- | Pretty printing renders XML documents faithfully,
-- with the exception that whitespace may be added\/removed
-- in non-verbatim character data.
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]

-- | Pretty printing elements
ppcElement         :: ConfigPP -> Element -> Text
ppcElement :: ConfigPP -> Element -> Text
ppcElement ConfigPP
c        = Text -> Text
TL.toStrict (Text -> Text) -> (Element -> Text) -> Element -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
toLazyText (Builder -> Text) -> (Element -> Builder) -> Element -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigPP -> Builder -> Element -> Builder
ppElementS ConfigPP
c Builder
forall a. Monoid a => a
mempty

-- | Pretty printing content
ppcContent         :: ConfigPP -> Content -> Text
ppcContent :: ConfigPP -> Content -> Text
ppcContent ConfigPP
c        = Text -> Text
TL.toStrict (Text -> Text) -> (Content -> Text) -> Content -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
toLazyText (Builder -> Text) -> (Content -> Builder) -> Content -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigPP -> Builder -> Content -> Builder
ppContentS ConfigPP
c Builder
forall a. Monoid a => a
mempty

ppcCData           :: ConfigPP -> CData -> Text
ppcCData :: ConfigPP -> CData -> Text
ppcCData ConfigPP
c         = Text -> Text
TL.toStrict (Text -> Text) -> (CData -> Text) -> CData -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
toLazyText (Builder -> Text) -> (CData -> Builder) -> CData -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigPP -> Builder -> CData -> Builder
ppCDataS ConfigPP
c Builder
forall a. Monoid a => a
mempty

type Indent = Builder

-- | Pretty printing content using ShowT
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 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> QName -> [Attr] -> Builder
tagStart (Element -> QName
elName Element
e) (Element -> [Attr]
elAttribs Element
e) Builder -> Builder -> Builder
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
'>' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ConfigPP -> Builder -> CData -> Builder
ppCDataS ConfigPP
c Builder
forall a. Monoid a => a
mempty CData
t Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> QName -> Builder
tagEnd QName
name
    [Content]
cs -> Char -> Builder
singleton Char
'>' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
nl Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
          [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ((Content -> Builder) -> [Content] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map ((Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
nl) (Builder -> Builder) -> (Content -> Builder) -> Content -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigPP -> Builder -> Content -> Builder
ppContentS ConfigPP
c (Builder
sp Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
i)) [Content]
cs) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
          Builder
i Builder -> Builder -> Builder
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 Builder -> Builder -> Builder
forall a. Semigroup 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 -> Builder
showCDataS CData
t
                             else (Char -> Builder -> Builder) -> Builder -> [Char] -> Builder
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Char -> Builder -> Builder
cons Builder
forall a. Monoid a => a
mempty (Text -> [Char]
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' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
i Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
ys
        cons Char
y Builder
ys     = Char -> Builder
singleton Char
y Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
ys



--------------------------------------------------------------------------------

-- | Adds the <?xml?> header.
showTopElement     :: Element -> Text
showTopElement :: Element -> Text
showTopElement Element
c    = Text
xmlHeader Text -> Text -> Text
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

-- Note: crefs should not contain '&', ';', etc.
showCRefS          :: Text -> Builder
showCRefS :: Text -> Builder
showCRefS Text
r         = Char -> Builder
singleton Char
'&' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
fromText Text
r Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
';'

-- | Convert a text element to characters.
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[" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
escCData (CData -> Text
cdData CData
cd) Builder -> Builder -> Builder
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[>" Builder -> Builder -> Builder
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     -> Builder
forall a. Monoid a => a
mempty
      Just (Char
c,Text
t') -> Char -> Builder
singleton Char
c Builder -> Builder -> Builder
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
"&lt;"
  Char
'>'   -> Text -> Builder
fromText Text
"&gt;"
  Char
'&'   -> Text -> Builder
fromText Text
"&amp;"
  Char
'"'   -> Text -> Builder
fromText Text
"&quot;"
  -- we use &#39 instead of &apos; because IE apparently has difficulties
  -- rendering &apos; in xhtml.
  -- Reported by Rohan Drape <rohan.drape@gmail.com>.
  Char
'\''  -> Text -> Builder
fromText Text
"&#39;"
  Char
_     -> Char -> Builder
singleton Char
c

  {- original xml-light version:
  -- NOTE: We escape '\r' explicitly because otherwise they get lost
  -- when parsed back in because of then end-of-line normalization rules.
  _ | isPrint c || c == '\n' -> singleton c
    | otherwise -> showText "&#" . showsT oc . singleton ';'
      where oc = ord c
  -}

escStr             :: Text -> Builder
escStr :: Text -> Builder
escStr Text
cs          = if (Char -> Bool) -> Text -> Bool
T.any Char -> Bool
needsEscape Text
cs
                        then [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ((Char -> Builder) -> [Char] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Builder
escChar (Text -> [Char]
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
"</" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> QName -> Builder
showQName QName
qn Builder -> Builder -> Builder
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
'<' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> QName -> Builder
showQName QName
qn Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
as_str
 where as_str :: Builder
as_str       = if [Attr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Attr]
as
                         then Builder
forall a. Monoid a => a
mempty
                         else [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ((Attr -> Builder) -> [Attr] -> [Builder]
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
' ' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> QName -> Builder
showQName QName
qn Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
                       Char -> Builder
singleton Char
'=' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
                       Char -> Builder
singleton Char
'"' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
escStr Text
v Builder -> Builder -> Builder
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 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
':' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
fromText (QName -> Text
qName QName
q)