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

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

xml-light, which we used in pandoc's the XML-based readers, has
some limitations: in particular, it produces nodes with String
instead of Text, and the parser falls over on processing instructions
(see #7091).

This module exports much of the API of xml-light, but using Text instead
of String. In addition, the xml-light parsers are replaced by xml-conduit's
well-tested parser.  (The xml-conduit types are mapped to types
isomorphic to xml-light's, to avoid the need for massive code modifications
elsewhere.)  Bridge functions to map xml-light types to this module's
types are also provided (since libraries like texmath still use xml-light).

Another advantage of the xml-conduit parser is that it gives us
detailed information on xml parse errors.

In the future we may want to move to using xml-conduit or another
xml library in the code base, but this change gives us
better performance and accuracy without much change in the
code that used xml-light.
-}
module Text.Pandoc.XML.Light
  ( module Text.Pandoc.XML.Light.Types
  , module Text.Pandoc.XML.Light.Proc
  , module Text.Pandoc.XML.Light.Output
    -- * Replacement for xml-light's Text.XML.Input
  , parseXMLElement
  , parseXMLContents
    --  * Versions that allow passing in a custom entity table
  , parseXMLElementWithEntities
  , parseXMLContentsWithEntities
  ) where

import qualified Control.Exception as E
import qualified Text.XML.Stream.Parse as P
import Data.Conduit (runConduit, (.|))
import qualified Data.Conduit.List as CL
import Data.Char (isSpace)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Map as M
import Text.Pandoc.XML.Light.Types
import Text.Pandoc.XML.Light.Proc
import Text.Pandoc.XML.Light.Output
import qualified Data.XML.Types as XML

-- Drop in replacement for parseXMLDoc in xml-light.
parseXMLElement :: TL.Text -> Either T.Text Element
parseXMLElement :: Text -> Either Text Element
parseXMLElement = Map Text Text -> Text -> Either Text Element
parseXMLElementWithEntities Map Text Text
forall a. Monoid a => a
mempty

-- Drop in replacement for parseXMLDoc in xml-light.
-- Like 'parseXMLContentsWithEntities', but requires the document to
-- consist of a single root element.
parseXMLElementWithEntities :: M.Map T.Text T.Text
                            -> TL.Text -> Either T.Text Element
parseXMLElementWithEntities :: Map Text Text -> Text -> Either Text Element
parseXMLElementWithEntities Map Text Text
entityMap Text
t =
  Map Text Text -> Text -> Either Text [Content]
parseXMLContentsWithEntities Map Text Text
entityMap Text
t Either Text [Content]
-> ([Content] -> Either Text Element) -> Either Text Element
forall a b. Either Text a -> (a -> Either Text b) -> Either Text b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Content] -> Either Text Element
forall {a}. IsString a => [Content] -> Either a Element
documentElement
 where
  -- 'parseXMLContentsWithEntities' has already dropped whitespace
  -- around a lone root element, so anything else left here is either
  -- a missing root or content outside of it.
  documentElement :: [Content] -> Either a Element
documentElement [Elem Element
e] = Element -> Either a Element
forall a b. b -> Either a b
Right Element
e
  documentElement [Content]
cs
    | [Element] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Element
e | Elem Element
e <- [Content]
cs] = a -> Either a Element
forall a b. a -> Either a b
Left a
"XML document has no root element"
    | Bool
otherwise = a -> Either a Element
forall a b. a -> Either a b
Left a
"unexpected content after the root XML element"

parseXMLContents :: TL.Text -> Either T.Text [Content]
parseXMLContents :: Text -> Either Text [Content]
parseXMLContents = Map Text Text -> Text -> Either Text [Content]
parseXMLContentsWithEntities Map Text Text
forall a. Monoid a => a
mempty

-- | Parse a list of XML contents.  Unlike 'parseXMLElementWithEntities',
-- this does not require a single root element: multiple sibling
-- elements and top-level text are accepted.  An XML declaration,
-- DOCTYPE, comments, and processing instructions are skipped.
parseXMLContentsWithEntities :: M.Map T.Text T.Text
                             -> TL.Text -> Either T.Text [Content]
parseXMLContentsWithEntities :: Map Text Text -> Text -> Either Text [Content]
parseXMLContentsWithEntities Map Text Text
entityMap Text
t =
  case ConduitT () Void (Either SomeException) BuildState
-> Either SomeException BuildState
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit ([Text] -> ConduitT () Text (Either SomeException) ()
forall (m :: * -> *) a i. Monad m => [a] -> ConduitT i a m ()
CL.sourceList (Text -> [Text]
TL.toChunks Text
t) ConduitT () Text (Either SomeException) ()
-> ConduitT Text Void (Either SomeException) BuildState
-> ConduitT () Void (Either SomeException) BuildState
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT Text EventPos (Either SomeException) ()
parser
                    ConduitT Text EventPos (Either SomeException) ()
-> ConduitT EventPos Void (Either SomeException) BuildState
-> ConduitT Text Void (Either SomeException) BuildState
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (BuildState -> EventPos -> BuildState)
-> BuildState
-> ConduitT EventPos Void (Either SomeException) BuildState
forall (m :: * -> *) b a o.
Monad m =>
(b -> a -> b) -> b -> ConduitT a o m b
CL.fold BuildState -> EventPos -> BuildState
step (([Content], [Frame]) -> BuildState
forall a b. b -> Either a b
Right ([], []))) of
    Left SomeException
err -> Text -> Either Text [Content]
forall a b. a -> Either a b
Left (Text -> Either Text [Content])
-> (SomeException -> Text)
-> SomeException
-> Either Text [Content]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text)
-> (SomeException -> String) -> SomeException -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall e. Exception e => e -> String
E.displayException (SomeException -> Either Text [Content])
-> SomeException -> Either Text [Content]
forall a b. (a -> b) -> a -> b
$ (SomeException
err :: E.SomeException)
    Right BuildState
st -> [Content] -> [Content]
normalizeTop ([Content] -> [Content])
-> Either Text [Content] -> Either Text [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BuildState -> Either Text [Content]
finishContents BuildState
st
 where
   parser :: ConduitT Text EventPos (Either SomeException) ()
parser = ParseSettings -> ConduitT Text EventPos (Either SomeException) ()
forall (m :: * -> *).
MonadThrow m =>
ParseSettings -> ConduitT Text EventPos m ()
P.parseTextPos ParseSettings
forall a. Default a => a
P.def{ P.psRetainNamespaces = True
                                , P.psDecodeEntities =
                                    entityResolver entityMap }

entityResolver :: M.Map T.Text T.Text -> T.Text -> XML.Content
entityResolver :: Map Text Text -> Text -> Content
entityResolver Map Text Text
entityMap Text
ref =
  case Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
ref Map Text Text
entityMap of
    Maybe Text
Nothing -> Text -> Content
XML.ContentEntity Text
ref
    Just Text
t' -> Text -> Content
XML.ContentText Text
t'

-- An element that is being built, with its children so far in reverse order.
data Frame = Frame QName [Attr] [Content]

-- The top-level contents built so far (reversed) and the stack of
-- open elements (innermost first); or an error.
type BuildState = Either T.Text ([Content], [Frame])

-- Fold one parse event into the content forest being built, checking
-- that start and end tags are balanced.
step :: BuildState -> P.EventPos -> BuildState
step :: BuildState -> EventPos -> BuildState
step st :: BuildState
st@(Left Text
_) EventPos
_ = BuildState
st
step (Right ([Content]
cs, [Frame]
stack)) (Maybe PositionRange
pos, Event
event) =
  case Event
event of
    XML.EventBeginElement Name
name [(Name, [Content])]
attribs ->
      case ((Name, [Content]) -> Either Text Attr)
-> [(Name, [Content])] -> Either Text [Attr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Name, [Content]) -> Either Text Attr
toAttr [(Name, [Content])]
attribs of
        Left Text
e -> Text -> BuildState
forall a b. a -> Either a b
Left Text
e
        Right [Attr]
attrs -> ([Content], [Frame]) -> BuildState
forall a b. b -> Either a b
Right ([Content]
cs, QName -> [Attr] -> [Content] -> Frame
Frame (Name -> QName
nameToQName Name
name) [Attr]
attrs [] Frame -> [Frame] -> [Frame]
forall a. a -> [a] -> [a]
: [Frame]
stack)
    XML.EventEndElement Name
name ->
      case [Frame]
stack of
        Frame QName
fname [Attr]
attrs [Content]
children : [Frame]
stack'
          | Name -> QName
nameToQName Name
name QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== QName
fname ->
              Content -> [Frame] -> BuildState
forall {a}. Content -> [Frame] -> Either a ([Content], [Frame])
emit (Element -> Content
Elem (QName -> [Attr] -> [Content] -> Maybe Line -> Element
Element QName
fname [Attr]
attrs ([Content] -> [Content]
mergeText ([Content] -> [Content]
forall a. [a] -> [a]
reverse [Content]
children))
                           Maybe Line
forall a. Maybe a
Nothing)) [Frame]
stack'
        [Frame]
_ -> Text -> BuildState
forall a b. a -> Either a b
Left (Text -> BuildState) -> Text -> BuildState
forall a b. (a -> b) -> a -> b
$ Text -> Text
atPos (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
"Unexpected close tag " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                      QName -> Text
showQ (Name -> QName
nameToQName Name
name)
    XML.EventContent Content
c ->
      case Content -> Either Text Text
contentToText Content
c of
        Left Text
e -> Text -> BuildState
forall a b. a -> Either a b
Left Text
e
        Right Text
txt -> Content -> [Frame] -> BuildState
forall {a}. Content -> [Frame] -> Either a ([Content], [Frame])
emit (Text -> Content
textContent Text
txt) [Frame]
stack
    XML.EventCDATA Text
txt -> Content -> [Frame] -> BuildState
forall {a}. Content -> [Frame] -> Either a ([Content], [Frame])
emit (Text -> Content
textContent Text
txt) [Frame]
stack
    Event
_ -> ([Content], [Frame]) -> BuildState
forall a b. b -> Either a b
Right ([Content]
cs, [Frame]
stack)
      -- skip begin/end document, doctype, comments, and PIs
 where
  -- add finished content to the enclosing element (or the top level)
  emit :: Content -> [Frame] -> Either a ([Content], [Frame])
emit Content
c [] = ([Content], [Frame]) -> Either a ([Content], [Frame])
forall a b. b -> Either a b
Right (Content
c Content -> [Content] -> [Content]
forall a. a -> [a] -> [a]
: [Content]
cs, [])
  emit Content
c (Frame QName
name [Attr]
attrs [Content]
children : [Frame]
stack') =
    ([Content], [Frame]) -> Either a ([Content], [Frame])
forall a b. b -> Either a b
Right ([Content]
cs, QName -> [Attr] -> [Content] -> Frame
Frame QName
name [Attr]
attrs (Content
c Content -> [Content] -> [Content]
forall a. a -> [a] -> [a]
: [Content]
children) Frame -> [Frame] -> [Frame]
forall a. a -> [a] -> [a]
: [Frame]
stack')

  textContent :: Text -> Content
textContent Text
txt = CData -> Content
Text (CDataKind -> Text -> Maybe Line -> CData
CData CDataKind
CDataText Text
txt Maybe Line
forall a. Maybe a
Nothing)

  toAttr :: (Name, [Content]) -> Either Text Attr
toAttr (Name
name, [Content]
vals) =
    QName -> Text -> Attr
Attr (Name -> QName
nameToQName Name
name) (Text -> Attr) -> ([Text] -> Text) -> [Text] -> Attr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.concat ([Text] -> Attr) -> Either Text [Text] -> Either Text Attr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Content -> Either Text Text) -> [Content] -> Either Text [Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Content -> Either Text Text
contentToText [Content]
vals

  contentToText :: Content -> Either Text Text
contentToText (XML.ContentText Text
txt) = Text -> Either Text Text
forall a b. b -> Either a b
Right Text
txt
  contentToText (XML.ContentEntity Text
ref) =
    Text -> Either Text Text
forall a b. a -> Either a b
Left (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
atPos (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
"Unresolved entity &" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ref Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
";"

  atPos :: Text -> Text
atPos Text
msg = case Maybe PositionRange
pos of
                Just PositionRange
pr -> String -> Text
T.pack (PositionRange -> String
forall a. Show a => a -> String
show PositionRange
pr) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg
                Maybe PositionRange
Nothing -> Text
msg

finishContents :: BuildState -> Either T.Text [Content]
finishContents :: BuildState -> Either Text [Content]
finishContents (Left Text
e) = Text -> Either Text [Content]
forall a b. a -> Either a b
Left Text
e
finishContents (Right ([Content]
cs, [])) = [Content] -> Either Text [Content]
forall a b. b -> Either a b
Right ([Content] -> [Content]
mergeText ([Content] -> [Content]
forall a. [a] -> [a]
reverse [Content]
cs))
finishContents (Right ([Content]
_, Frame QName
name [Attr]
_ [Content]
_ : [Frame]
_)) =
  Text -> Either Text [Content]
forall a b. a -> Either a b
Left (Text -> Either Text [Content]) -> Text -> Either Text [Content]
forall a b. (a -> b) -> a -> b
$ Text
"Missing close tag for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> QName -> Text
showQ QName
name

showQ :: QName -> T.Text
showQ :: QName -> Text
showQ (QName Text
name Maybe Text
_ Maybe Text
Nothing)    = Text
name
showQ (QName Text
name Maybe Text
_ (Just Text
pre)) = Text
pre Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name

-- Merge adjacent text nodes (the stream parser splits text at
-- entity and CDATA boundaries).
mergeText :: [Content] -> [Content]
mergeText :: [Content] -> [Content]
mergeText (Text CData
cd : [Content]
cs) =
  case (Content -> Bool) -> [Content] -> ([Content], [Content])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Content -> Bool
isText [Content]
cs of
    ([], [Content]
_)    -> CData -> Content
Text CData
cd Content -> [Content] -> [Content]
forall a. a -> [a] -> [a]
: [Content] -> [Content]
mergeText [Content]
cs
    ([Content]
ts, [Content]
rest) -> CData -> Content
Text CData
cd{ cdData = T.concat (cdData cd :
                                      [d | Text (CData _ d _) <- ts]) }
                  Content -> [Content] -> [Content]
forall a. a -> [a] -> [a]
: [Content] -> [Content]
mergeText [Content]
rest
 where
  isText :: Content -> Bool
isText Text{} = Bool
True
  isText Content
_      = Bool
False
mergeText (Content
c : [Content]
cs) = Content
c Content -> [Content] -> [Content]
forall a. a -> [a] -> [a]
: [Content] -> [Content]
mergeText [Content]
cs
mergeText [] = []

-- If the content is a single element surrounded only by whitespace
-- (as in a complete XML document, where there may be newlines after
-- an XML declaration or DOCTYPE), drop the whitespace.
normalizeTop :: [Content] -> [Content]
normalizeTop :: [Content] -> [Content]
normalizeTop [Content]
cs =
  case (Content -> Bool) -> [Content] -> [Content]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Content -> Bool) -> Content -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Content -> Bool
isWhitespaceText) [Content]
cs of
    cs' :: [Content]
cs'@[Elem Element
_] -> [Content]
cs'
    [Content]
_            -> [Content]
cs
 where
  isWhitespaceText :: Content -> Bool
isWhitespaceText (Text CData
cd) = (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isSpace (CData -> Text
cdData CData
cd)
  isWhitespaceText Content
_         = Bool
False

nameToQName :: XML.Name -> QName
nameToQName :: Name -> QName
nameToQName (XML.Name Text
localName Maybe Text
mbns Maybe Text
mbpref) =
  case Maybe Text
mbpref of
    Maybe Text
Nothing ->
      case Text -> Text -> Maybe Text
T.stripPrefix Text
"xmlns:" Text
localName of
        Just Text
rest -> Text -> Maybe Text -> Maybe Text -> QName
QName Text
rest Maybe Text
mbns (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"xmlns")
        Maybe Text
Nothing   -> Text -> Maybe Text -> Maybe Text -> QName
QName Text
localName Maybe Text
mbns Maybe Text
mbpref
    Maybe Text
_ -> Text -> Maybe Text -> Maybe Text -> QName
QName Text
localName Maybe Text
mbns Maybe Text
mbpref