{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{- |
   Module      : Text.Pandoc.XML.Light.Output
   Copyright   : Copyright (C) 2007 Galois, Inc., 2021-2022 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 = "<?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 p :: QName -> Bool
p c :: 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 p :: Bool
p c :: 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 c :: ConfigPP
c e :: 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 c :: 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 c :: 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 c :: 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 c :: ConfigPP
c i :: Builder
i x :: Content
x = case Content
x of
                     Elem e :: Element
e -> ConfigPP -> Builder -> Element -> Builder
ppElementS ConfigPP
c Builder
i Element
e
                     Text t :: CData
t -> ConfigPP -> Builder -> CData -> Builder
ppCDataS ConfigPP
c Builder
i CData
t
                     CRef r :: Text
r -> Text -> Builder
showCRefS Text
r

ppElementS         :: ConfigPP -> Indent -> Element -> Builder
ppElementS :: ConfigPP -> Builder -> Element -> Builder
ppElementS c :: ConfigPP
c i :: Builder
i e :: 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 -> Bool
`T.isPrefixOf` QName -> Text
qName QName
name -> Text -> Builder
fromText " ?>"
       | ConfigPP -> QName -> Bool
shortEmptyTag ConfigPP
c QName
name  -> Text -> Builder
fromText " />"
    [Text t :: CData
t] -> Char -> Builder
singleton '>' 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
    cs :: [Content]
cs -> Char -> Builder
singleton '>' 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 (nl :: Builder
nl,sp :: Builder
sp)  = if ConfigPP -> Bool
prettify ConfigPP
c then ("\n","  ") else ("","")
  )
  where name :: QName
name = Element -> QName
elName Element
e

ppCDataS           :: ConfigPP -> Indent -> CData -> Builder
ppCDataS :: ConfigPP -> Builder -> CData -> Builder
ppCDataS c :: ConfigPP
c i :: Builder
i t :: 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 '\n' ys :: Builder
ys  = Char -> Builder
singleton '\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 y :: Char
y ys :: 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 c :: 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 r :: Text
r         = Char -> Builder
singleton '&' 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 ';'

-- | Convert a text element to characters.
showCDataS         :: CData -> Builder
showCDataS :: CData -> Builder
showCDataS cd :: CData
cd =
 case CData -> CDataKind
cdVerbatim CData
cd of
   CDataText     -> Text -> Builder
escStr (CData -> Text
cdData CData
cd)
   CDataVerbatim -> Text -> Builder
fromText "<![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 "]]>"
   CDataRaw      -> Text -> Builder
fromText (CData -> Text
cdData CData
cd)

--------------------------------------------------------------------------------
escCData           :: Text -> Builder
escCData :: Text -> Builder
escCData t :: Text
t
  | "]]>" Text -> Text -> Bool
`T.isPrefixOf` Text
t =
     Text -> Builder
fromText "]]]]><![CDATA[>" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
fromText (Int -> Text -> Text
T.drop 3 Text
t)
escCData t :: Text
t
  = case Text -> Maybe (Char, Text)
T.uncons Text
t of
      Nothing     -> Builder
forall a. Monoid a => a
mempty
      Just (c :: Char
c,t' :: 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 c :: Char
c = case Char
c of
  '<'   -> Text -> Builder
fromText "&lt;"
  '>'   -> Text -> Builder
fromText "&gt;"
  '&'   -> Text -> Builder
fromText "&amp;"
  '"'   -> Text -> Builder
fromText "&quot;"
  -- we use &#39 instead of &apos; because IE apparently has difficulties
  -- rendering &apos; in xhtml.
  -- Reported by Rohan Drape <rohan.drape@gmail.com>.
  '\''  -> Text -> Builder
fromText "&#39;"
  _     -> 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 cs :: 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 '<' = Bool
True
  needsEscape '>' = Bool
True
  needsEscape '&' = Bool
True
  needsEscape '"' = Bool
True
  needsEscape '\'' = Bool
True
  needsEscape _ = Bool
False

tagEnd             :: QName -> Builder
tagEnd :: QName -> Builder
tagEnd qn :: QName
qn           = Text -> Builder
fromText "</" 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 '>'

tagStart           :: QName -> [Attr] -> Builder
tagStart :: QName -> [Attr] -> Builder
tagStart qn :: QName
qn as :: [Attr]
as      = Char -> Builder
singleton '<' 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 qn :: QName
qn v :: Text
v) = Char -> Builder
singleton ' ' 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 '=' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
                       Char -> Builder
singleton '"' 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 '"'

showQName          :: QName -> Builder
showQName :: QName -> Builder
showQName q :: QName
q         =
  case QName -> Maybe Text
qPrefix QName
q of
    Nothing -> Text -> Builder
fromText (QName -> Text
qName QName
q)
    Just p :: Text
p  -> Text -> Builder
fromText Text
p Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton ':' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
fromText (QName -> Text
qName QName
q)