{-# LANGUAGE BangPatterns               #-}

{-# LANGUAGE CPP                        #-}

{-# LANGUAGE DeriveDataTypeable         #-}

{-# LANGUAGE DeriveFunctor              #-}

{-# LANGUAGE FlexibleContexts           #-}

{-# LANGUAGE FlexibleInstances          #-}

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

{-# LANGUAGE OverloadedStrings          #-}

{-# LANGUAGE PatternGuards              #-}

{-# LANGUAGE RankNTypes                 #-}

{-# LANGUAGE StandaloneDeriving         #-}

{-# LANGUAGE TupleSections              #-}

{-# LANGUAGE TypeFamilies               #-}

-- | This module provides both a native Haskell solution for parsing XML

-- documents into a stream of events, and a set of parser combinators for

-- dealing with a stream of events.

--

-- As a simple example, if you have the following XML file:

--

-- > 

-- > <people>

-- >     <person age="25">Michael</person>

-- >     <person age="2">Eliezer</person>

-- > </people>

--

-- Then this code:

--

-- > {-# LANGUAGE OverloadedStrings #-}

-- > import Control.Monad.Trans.Resource

-- > import Data.Conduit (Consumer, Sink, ($$))

-- > import Data.Text (Text, unpack)

-- > import Text.XML.Stream.Parse

-- > import Data.XML.Types (Event)

-- >

-- > data Person = Person Int Text

-- >     deriving Show

-- >

-- > parsePerson :: MonadThrow m => Consumer Event m (Maybe Person)

-- > parsePerson = tag' "person" (requireAttr "age") $ \age -> do

-- >     name <- content

-- >     return $ Person (read $ unpack age) name

-- >

-- > parsePeople :: MonadThrow m => Sink Event m (Maybe [Person])

-- > parsePeople = tagNoAttr "people" $ many parsePerson

-- >

-- > main = do

-- >     people <- runResourceT $

-- >             parseFile def "people.xml" $$ force "people required" parsePeople

-- >     print people

--

-- will produce:

--

-- > [Person 25 "Michael",Person 2 "Eliezer"]

--

-- This module also supports streaming results using 'yield'.

-- This allows parser results to be processed using conduits

-- while a particular parser (e.g. 'many') is still running.

-- Without using streaming results, you have to wait until the parser finished

-- before you can process the result list. Large XML files might be easier

-- to process by using streaming results.

-- See http://stackoverflow.com/q/21367423/2597135 for a related discussion.

--

-- > {-# LANGUAGE OverloadedStrings #-}

-- > import Control.Monad (void)

-- > import Control.Monad.Trans.Class (lift)

-- > import Control.Monad.Trans.Resource

-- > import Data.Conduit

-- > import qualified Data.Conduit.List as CL

-- > import Data.Text (Text, unpack)

-- > import Data.XML.Types (Event)

-- > import Text.XML.Stream.Parse

-- >

-- > data Person = Person Int Text deriving Show

-- >

-- > parsePerson :: MonadThrow m => Consumer Event m (Maybe Person)

-- > parsePerson = tag' "person" (requireAttr "age") $ \age -> do

-- >     name <- content

-- >     return $ Person (read $ unpack age) name

-- >

-- > parsePeople :: MonadThrow m => Conduit Event m Person

-- > parsePeople = void $ tagNoAttr "people" $ manyYield parsePerson

-- >

-- > main = runResourceT $

-- >     parseFile def "people.xml" $$ parsePeople =$ CL.mapM_ (lift . print)

--

-- Previous versions of this module contained a number of more sophisticated

-- functions written by Aristid Breitkreuz and Dmitry Olshansky. To keep this

-- package simpler, those functions are being moved to a separate package. This

-- note will be updated with the name of the package(s) when available.

module Text.XML.Stream.Parse

    ( -- * Parsing XML files

      parseBytes

    , parseBytesPos

    , parseText'

    , parseText

    , parseTextPos

    , detectUtf

    , parseFile

    , parseLBS

      -- ** Parser settings

    , ParseSettings

    , def

    , DecodeEntities

    , psDecodeEntities

    , psRetainNamespaces

      -- *** Entity decoding

    , decodeXmlEntities

    , decodeHtmlEntities

      -- * Event parsing

    , tag

    , tag'

    , tagNoAttr

    , tagIgnoreAttrs

    , content

    , contentMaybe

      -- * Ignoring tags/trees

    , ignoreTag

    , ignoreEmptyTag

    , ignoreTree

    , ignoreTreeContent

    , ignoreAnyTreeContent

    , ignoreAllTreesContent

      -- * Streaming events

    , takeContent

    , takeTree

    , takeTreeContent

    , takeAnyTreeContent

    , takeAllTreesContent

      -- * Tag name matching

    , NameMatcher(..)

    , matching

    , anyOf

    , anyName

      -- * Attribute parsing

    , AttrParser

    , attr

    , requireAttr

    , optionalAttr

    , requireAttrRaw

    , optionalAttrRaw

    , ignoreAttrs

      -- * Combinators

    , orE

    , choose

    , many

    , many_

    , manyIgnore

    , many'

    , force

      -- * Streaming combinators

    , manyYield

    , manyYield'

    , manyIgnoreYield

      -- * Exceptions

    , XmlException (..)

      -- * Other types

    , PositionRange

    , EventPos

    ) where

import           Control.Applicative          (Alternative (empty, (<|>)),

                                               Applicative (..), (<$>))

import qualified Control.Applicative          as A

import           Control.Arrow                ((***))

import           Control.Exception            (Exception (..), SomeException)

import           Control.Monad                (ap, liftM, void)

import           Control.Monad.Fix            (fix)

import           Control.Monad.Trans.Class    (lift)

import           Control.Monad.Trans.Maybe    (MaybeT (..))

import           Control.Monad.Trans.Resource (MonadResource, MonadThrow (..),

                                               monadThrow)

import           Data.Attoparsec.Text         (Parser, anyChar, char, manyTill,

                                               skipWhile, string, takeWhile,

                                               takeWhile1, try)

import qualified Data.Attoparsec.Text         as AT

import qualified Data.ByteString              as S

import qualified Data.ByteString.Lazy         as L

import           Data.Char                    (isSpace)

import           Data.Conduit

import           Data.Conduit.Attoparsec      (PositionRange, conduitParser)

import           Data.Conduit.Binary          (sourceFile)

import qualified Data.Conduit.List            as CL

import qualified Data.Conduit.Text            as CT

import           Data.Default.Class           (Default (..))

import           Data.List                    (intercalate)

import           Data.List                    (foldl')

import qualified Data.Map                     as Map

import           Data.Maybe                   (fromMaybe, isNothing)

import           Data.String                  (IsString (..))

import           Data.Text                    (Text, pack)

import qualified Data.Text                    as T

import           Data.Text.Encoding           (decodeUtf8With)

import           Data.Text.Encoding.Error     (lenientDecode)

import           Data.Typeable                (Typeable)

import           Data.XML.Types               (Content (..), Event (..),

                                               ExternalID (..),

                                               Instruction (..), Name (..))

import           Prelude                      hiding (takeWhile)

import           Text.XML.Stream.Token

type Ents = [(Text, Text)]

tokenToEvent :: ParseSettings -> Ents -> [NSLevel] -> Token -> (Ents, [NSLevel], [Event])

tokenToEvent _ es n (TokenXMLDeclaration _) = (es, n, [])

tokenToEvent _ es n (TokenInstruction i) = (es, n, [EventInstruction i])

tokenToEvent ps es n (TokenBeginElement name as isClosed _) =

    (es, n', if isClosed then [begin, end] else [begin])

  where

    l0 = case n of

            []  -> NSLevel Nothing Map.empty

            x:_ -> x

    (as', l') = foldl' go (id, l0) as

    go (front, l) (TName kpref kname, val) =

        (addNS front, l'')

      where

        isPrefixed = kpref == Just "xmlns"

        isUnprefixed = isNothing kpref && kname == "xmlns"

        addNS

            | not (psRetainNamespaces ps) && (isPrefixed || isUnprefixed) = id

            | otherwise = (((tname, map resolve val):) .)

          where

            tname

                | isPrefixed = TName Nothing ("xmlns:" `T.append` kname)

                | otherwise = TName kpref kname

        l''

            | isPrefixed =

                l { prefixes = Map.insert kname (contentsToText val)

                                     $ prefixes l }

            | isUnprefixed =

                l { defaultNS = if T.null $ contentsToText val

                                            then Nothing

                                            else Just $ contentsToText val }

            | otherwise = l

    resolve (ContentEntity e)

        | Just t <- lookup e es = ContentText t

    resolve c = c

    n' = if isClosed then n else l' : n

    fixAttName (name', val) = (tnameToName True l' name', val)

    elementName = tnameToName False l' name

    begin = EventBeginElement elementName $ map fixAttName $ as' []

    end = EventEndElement elementName

tokenToEvent _ es n (TokenEndElement name) =

    (es, n', [EventEndElement $ tnameToName False l name])

  where

    (l, n') =

        case n of

            []   -> (NSLevel Nothing Map.empty, [])

            x:xs -> (x, xs)

tokenToEvent _ es n (TokenContent (ContentEntity e))

    | Just t <- lookup e es = (es, n, [EventContent $ ContentText t])

tokenToEvent _ es n (TokenContent c) = (es, n, [EventContent c])

tokenToEvent _ es n (TokenComment c) = (es, n, [EventComment c])

tokenToEvent _ es n (TokenDoctype t eid es') = (es ++ es', n, [EventBeginDoctype t eid, EventEndDoctype])

tokenToEvent _ es n (TokenCDATA t) = (es, n, [EventCDATA t])

tnameToName :: Bool -> NSLevel -> TName -> Name

tnameToName _ _ (TName (Just "xml") name) =

    Name name (Just "http://www.w3.org/XML/1998/namespace") (Just "xml")

tnameToName isAttr (NSLevel def' _) (TName Nothing name) =

    Name name (if isAttr then Nothing else def') Nothing

tnameToName _ (NSLevel _ m) (TName (Just pref) name) =

    case Map.lookup pref m of

        Just ns -> Name name (Just ns) (Just pref)

        Nothing -> Name name Nothing (Just pref) -- FIXME is this correct?

-- | Automatically determine which UTF variant is being used. This function

-- first checks for BOMs, removing them as necessary, and then check for the

-- equivalent of 

-- defaults to assuming UTF-8.

detectUtf :: MonadThrow m => Conduit S.ByteString m T.Text

detectUtf =

    conduit id

  where

    conduit front = await >>= maybe (return ()) (push front)

    push front bss =

        either conduit

               (uncurry checkXMLDecl)

               (getEncoding front bss)

    getEncoding front bs'

        | S.length bs < 4 =

            Left (bs `S.append`)

        | otherwise =

            Right (bsOut, mcodec)

      where

        bs = front bs'

        bsOut = S.append (S.drop toDrop x) y

        (x, y) = S.splitAt 4 bs

        (toDrop, mcodec) =

            case S.unpack x of

                [0x00, 0x00, 0xFE, 0xFF] -> (4, Just CT.utf32_be)

                [0xFF, 0xFE, 0x00, 0x00] -> (4, Just CT.utf32_le)

                0xFE : 0xFF: _           -> (2, Just CT.utf16_be)

                0xFF : 0xFE: _           -> (2, Just CT.utf16_le)

                0xEF : 0xBB: 0xBF : _    -> (3, Just CT.utf8)

                [0x00, 0x00, 0x00, 0x3C] -> (0, Just CT.utf32_be)

                [0x3C, 0x00, 0x00, 0x00] -> (0, Just CT.utf32_le)

                [0x00, 0x3C, 0x00, 0x3F] -> (0, Just CT.utf16_be)

                [0x3C, 0x00, 0x3F, 0x00] -> (0, Just CT.utf16_le)

                _                        -> (0, Nothing) -- Assuming UTF-8

checkXMLDecl :: MonadThrow m

             => S.ByteString

             -> Maybe CT.Codec

             -> Conduit S.ByteString m T.Text

checkXMLDecl bs (Just codec) = leftover bs >> CT.decode codec

checkXMLDecl bs0 Nothing =

    loop [] (AT.parse (parseToken decodeXmlEntities)) bs0

  where

    loop chunks0 parser nextChunk =

        case parser $ decodeUtf8With lenientDecode nextChunk of

            AT.Fail{} -> fallback

            AT.Partial f -> await >>= maybe fallback (loop chunks f)

            AT.Done _ (TokenXMLDeclaration attrs) -> findEncoding attrs

            AT.Done{} -> fallback

      where

        chunks = nextChunk : chunks0

        fallback = complete CT.utf8

        complete codec = mapM_ leftover chunks >> CT.decode codec

        findEncoding [] = fallback

        findEncoding ((TName _ "encoding", [ContentText enc]):_) =

            case T.toLower enc of

                "iso-8859-1" -> complete CT.iso8859_1

                "utf-8"      -> complete CT.utf8

                _            -> complete CT.utf8

        findEncoding (_:xs) = findEncoding xs

type EventPos = (Maybe PositionRange, Event)

-- | Parses a byte stream into 'Event's. This function is implemented fully in

-- Haskell using attoparsec-text for parsing. The produced error messages do

-- not give line/column information, so you may prefer to stick with the parser

-- provided by libxml-enumerator. However, this has the advantage of not

-- relying on any C libraries.

--

-- This relies on 'detectUtf' to determine character encoding, and 'parseText''

-- to do the actual parsing.

parseBytes :: MonadThrow m

           => ParseSettings

           -> Conduit S.ByteString m Event

parseBytes = mapOutput snd . parseBytesPos

parseBytesPos :: MonadThrow m

              => ParseSettings

              -> Conduit S.ByteString m EventPos

parseBytesPos ps = detectUtf =$= parseTextPos ps

dropBOM :: Monad m => Conduit T.Text m T.Text

dropBOM =

    await >>= maybe (return ()) push

  where

    push t =

        case T.uncons t of

            Nothing -> dropBOM

            Just (c, cs) ->

                let output

                        | c == '\xfeef' = cs

                        | otherwise = t

                 in yield output >> idConduit

    idConduit = await >>= maybe (return ()) (\x -> yield x >> idConduit)

-- | Parses a character stream into 'Event's. This function is implemented

-- fully in Haskell using attoparsec-text for parsing. The produced error

-- messages do not give line/column information, so you may prefer to stick

-- with the parser provided by libxml-enumerator. However, this has the

-- advantage of not relying on any C libraries.

--

-- Since 1.2.4

parseText' :: MonadThrow m

           => ParseSettings

           -> Conduit T.Text m Event

parseText' = mapOutput snd . parseTextPos

{-# DEPRECATED parseText "Please use 'parseText'' or 'parseTextPos'." #-}

parseText :: MonadThrow m

          => ParseSettings

          -> Conduit T.Text m EventPos

parseText = parseTextPos

-- | Same as 'parseText'', but includes the position of each event.

--

-- Since 1.2.4

parseTextPos :: MonadThrow m

          => ParseSettings

          -> Conduit T.Text m EventPos

parseTextPos de =

    dropBOM

        =$= tokenize

        =$= toEventC de

        =$= addBeginEnd

  where

    tokenize = conduitToken de

    addBeginEnd = yield (Nothing, EventBeginDocument) >> addEnd

    addEnd = await >>= maybe

        (yield (Nothing, EventEndDocument))

        (\e -> yield e >> addEnd)

toEventC :: Monad m => ParseSettings -> Conduit (PositionRange, Token) m EventPos

toEventC ps =

    go [] []

  where

    go !es !levels =

        await >>= maybe (return ()) push

      where

        push (position, token) =

            mapM_ (yield . (,) (Just position)) events >> go es' levels'

          where

            (es', levels', events) = tokenToEvent ps es levels token

data ParseSettings = ParseSettings

    { psDecodeEntities   :: DecodeEntities

    , psRetainNamespaces :: Bool

    -- ^ Whether the original xmlns attributes should be retained in the parsed

    -- values. For more information on motivation, see:

    --

    -- <https://github.com/snoyberg/xml/issues/38>

    --

    -- Default: False

    --

    -- Since 1.2.1

    }

instance Default ParseSettings where

    def = ParseSettings

        { psDecodeEntities = decodeXmlEntities

        , psRetainNamespaces = False

        }

conduitToken :: MonadThrow m => ParseSettings -> Conduit T.Text m (PositionRange, Token)

conduitToken = conduitParser . parseToken . psDecodeEntities

parseToken :: DecodeEntities -> Parser Token

parseToken de = (char '<' >> parseLt) <|> TokenContent <$> parseContent de False False

  where

    parseLt =

        (char '?' >> parseInstr) <|>

        (char '!' >> (parseComment <|> parseCdata <|> parseDoctype)) <|>

        parseBegin <|>

        (char '/' >> parseEnd)

    parseInstr = do

        name <- parseIdent

        if name == "xml"

            then do

                as <- A.many $ parseAttribute de

                skipSpace

                char' '?'

                char' '>'

                newline <|> return ()

                return $ TokenXMLDeclaration as

            else do

                skipSpace

                x <- T.pack <$> manyTill anyChar (try $ string "?>")

                return $ TokenInstruction $ Instruction name x

    parseComment = do

        char' '-'

        char' '-'

        c <- T.pack <$> manyTill anyChar (string "-->") -- FIXME use takeWhile instead

        return $ TokenComment c

    parseCdata = do

        _ <- string "[CDATA["

        t <- T.pack <$> manyTill anyChar (string "]]>") -- FIXME use takeWhile instead

        return $ TokenCDATA t

    parseDoctype = do

        _ <- string "DOCTYPE"

        skipSpace

        name <- parseName

        let i =

                case name of

                    TName Nothing x  -> x

                    TName (Just x) y -> T.concat [x, ":", y]

        skipSpace

        eid <- fmap Just parsePublicID <|>

               fmap Just parseSystemID <|>

               return Nothing

        skipSpace

        ents <- (do

            char' '['

            ents <- parseEntities id

            skipSpace

            return ents) <|> return []

        char' '>'

        newline <|> return ()

        return $ TokenDoctype i eid ents

    parseEntities front =

        (char ']' >> return (front [])) <|>

        (parseEntity >>= \e -> parseEntities (front . (e:))) <|>

        (char '<' >> parseEntities front) <|>

        (skipWhile (\t -> t /= ']' && t /= '<') >> parseEntities front)

    parseEntity = try $ do

        _ <- string "

        skipSpace

        i <- parseIdent

        t <- quotedText

        skipSpace

        char' '>'

        return (i, t)

    parsePublicID = do

        _ <- string "PUBLIC"

        x <- quotedText

        y <- quotedText

        return $ PublicID x y

    parseSystemID = do

        _ <- string "SYSTEM"

        x <- quotedText

        return $ SystemID x

    quotedText = do

        skipSpace

        between '"' <|> between '\''

    between c = do

        char' c

        x <- takeWhile (/=c)

        char' c

        return x

    parseEnd = do

        skipSpace

        n <- parseName

        skipSpace

        char' '>'

        return $ TokenEndElement n

    parseBegin = do

        skipSpace

        n <- parseName

        as <- A.many $ parseAttribute de

        skipSpace

        isClose <- (char '/' >> skipSpace >> return True) <|> return False

        char' '>'

        return $ TokenBeginElement n as isClose 0

parseAttribute :: DecodeEntities -> Parser TAttribute

parseAttribute de = do

    skipSpace

    key <- parseName

    skipSpace

    char' '='

    skipSpace

    val <- squoted <|> dquoted

    return (key, val)

  where

    squoted = char '\'' *> manyTill (parseContent de False True) (char '\'')

    dquoted = char  '"' *> manyTill (parseContent de True False) (char  '"')

parseName :: Parser TName

parseName =

  name <$> parseIdent <*> A.optional (char ':' >> parseIdent)

  where

    name i1 Nothing   = TName Nothing i1

    name i1 (Just i2) = TName (Just i1) i2

parseIdent :: Parser Text

parseIdent =

    takeWhile1 valid

  where

    valid '&'  = False

    valid '<'  = False

    valid '>'  = False

    valid ':'  = False

    valid '?'  = False

    valid '='  = False

    valid '"'  = False

    valid '\'' = False

    valid '/'  = False

    valid ';'  = False

    valid '#'  = False

    valid c    = not $ isXMLSpace c

parseContent :: DecodeEntities

             -> Bool -- break on double quote

             -> Bool -- break on single quote

             -> Parser Content

parseContent de breakDouble breakSingle = parseReference <|> parseTextContent where

  parseReference = do

    char' '&'

    t <- parseEntityRef <|> parseHexCharRef <|> parseDecCharRef

    char' ';'

    return t

  parseEntityRef = do

    TName ma b <- parseName

    let name = maybe "" (`T.append` ":") ma `T.append` b

    return $ case name of

      "lt" -> ContentText "<"

      "gt" -> ContentText ">"

      "amp" -> ContentText "&"

      "quot" -> ContentText "\""

      "apos" -> ContentText "'"

      _ -> de name

  parseHexCharRef = do

    void $ string "#x"

    n <- AT.hexadecimal

    case toValidXmlChar n of

      Nothing -> fail "Invalid character from hexadecimal character reference."

      Just c -> return $ ContentText $ T.singleton c

  parseDecCharRef = do

    void $ string "#"

    n <- AT.decimal

    case toValidXmlChar n of

      Nothing -> fail "Invalid character from decimal character reference."

      Just c -> return $ ContentText $ T.singleton c

  parseTextContent = ContentText <$> takeWhile1 valid

  valid '"'  = not breakDouble

  valid '\'' = not breakSingle

  valid '&'  = False -- amp

  valid '<'  = False -- lt

  valid _    = True

-- | Is this codepoint a valid XML character? See

-- <https://www.w3.org/TR/xml/#charsets>. This is proudly XML 1.0 only.

toValidXmlChar :: Int -> Maybe Char

toValidXmlChar n

  | any checkRange ranges = Just (toEnum n)

  | otherwise = Nothing

  where

    --Inclusive lower bound, inclusive upper bound.

    ranges :: [(Int, Int)]

    ranges =

      [ (0x9, 0xA)

      , (0xD, 0xD)

      , (0x20, 0xD7FF)

      , (0xE000, 0xFFFD)

      , (0x10000, 0x10FFFF)

      ]

    checkRange (lb, ub) = lb <= n && n <= ub

skipSpace :: Parser ()

skipSpace = skipWhile isXMLSpace

-- | Determines whether a character is an XML white space. The list of

-- white spaces is given by

--

-- >  S ::= (#x20 | #x9 | #xD | #xA)+

--

-- in <http://www.w3.org/TR/2008/REC-xml-20081126/#sec-common-syn>.

isXMLSpace :: Char -> Bool

isXMLSpace ' '  = True

isXMLSpace '\t' = True

isXMLSpace '\r' = True

isXMLSpace '\n' = True

isXMLSpace _    = False

newline :: Parser ()

newline = void $ (char '\r' >> char '\n') <|> char '\n'

char' :: Char -> Parser ()

char' = void . char

data ContentType = Ignore | IsContent Text | IsError String | NotContent

-- | Grabs the next piece of content if available. This function skips over any

-- comments and instructions and concatenates all content until the next start

-- or end tag.

contentMaybe :: MonadThrow m => Consumer Event m (Maybe Text)

contentMaybe = do

    x <- CL.peek

    case pc' x of

        Ignore      -> CL.drop 1 >> contentMaybe

        IsContent t -> CL.drop 1 >> fmap Just (takeContents (t:))

        IsError e   -> lift $ monadThrow $ InvalidEntity e x

        NotContent  -> return Nothing

  where

    pc' Nothing  = NotContent

    pc' (Just x) = pc x

    pc (EventContent (ContentText t)) = IsContent t

    pc (EventContent (ContentEntity e)) = IsError $ "Unknown entity: " ++ show e

    pc (EventCDATA t) = IsContent t

    pc EventBeginElement{} = NotContent

    pc EventEndElement{} = NotContent

    pc EventBeginDocument{} = Ignore

    pc EventEndDocument = Ignore

    pc EventBeginDoctype{} = Ignore

    pc EventEndDoctype = Ignore

    pc EventInstruction{} = Ignore

    pc EventComment{} = Ignore

    takeContents front = do

        x <- CL.peek

        case pc' x of

            Ignore      -> CL.drop 1 >> takeContents front

            IsContent t -> CL.drop 1 >> takeContents (front . (:) t)

            IsError e   -> lift $ monadThrow $ InvalidEntity e x

            NotContent  -> return $ T.concat $ front []

-- | Grabs the next piece of content. If none if available, returns 'T.empty'.

-- This is simply a wrapper around 'contentMaybe'.

content :: MonadThrow m => Consumer Event m Text

content = fromMaybe T.empty <$> contentMaybe

isWhitespace :: Event -> Bool

isWhitespace EventBeginDocument             = True

isWhitespace EventEndDocument               = True

isWhitespace EventBeginDoctype{}            = True

isWhitespace EventEndDoctype                = True

isWhitespace EventInstruction{}             = True

isWhitespace (EventContent (ContentText t)) = T.all isSpace t

isWhitespace EventComment{}                 = True

isWhitespace (EventCDATA t)                 = T.all isSpace t

isWhitespace _                              = False

-- | The most generic way to parse a tag. It takes a 'NameMatcher' to check whether

-- this is a correct tag name, an 'AttrParser' to handle attributes, and

-- then a parser to deal with content.

--

-- 'Events' are consumed if and only if the tag name and its attributes match.

--

-- This function automatically absorbs its balancing closing tag, and will

-- throw an exception if not all of the attributes or child elements are

-- consumed. If you want to allow extra attributes, see 'ignoreAttrs'.

--

-- This function automatically ignores comments, instructions and whitespace.

tag :: MonadThrow m

    => NameMatcher a -- ^ Check if this is a correct tag name

                     --   and return a value that can be used to get an @AttrParser@.

                     --   If this fails, the function will return @Nothing@

    -> (a -> AttrParser b) -- ^ Given the value returned by the name checker, this function will

                           --   be used to get an @AttrParser@ appropriate for the specific tag.

                           --   If the @AttrParser@ fails, the function will also return @Nothing@

    -> (b -> ConduitM Event o m c) -- ^ Handler function to handle the attributes and children

                                   --   of a tag, given the value return from the @AttrParser@

    -> ConduitM Event o m (Maybe c)

tag nameMatcher attrParser f = do

  (x, leftovers) <- dropWS []

  res <- case x of

    Just (EventBeginElement name as) -> case runNameMatcher nameMatcher name of

      Just y -> case runAttrParser' (attrParser y) as of

        Left _ -> return Nothing

        Right z -> do

          z' <- f z

          (a, _leftovers') <- dropWS []

          case a of

            Just (EventEndElement name')

              | name == name' -> return (Just z')

            _ -> lift $ monadThrow $ InvalidEndElement name a

      Nothing -> return Nothing

    _ -> return Nothing

  case res of

    -- Did not parse, put back all of the leading whitespace events and the

    -- final observed event generated by dropWS

    Nothing -> mapM_ leftover leftovers

    -- Parse succeeded, discard all of those whitespace events and the

    -- first parsed event

    Just _  -> return ()

  return res

  where

    -- Drop Events until we encounter a non-whitespace element. Return all of

    -- the events consumed here (including the first non-whitespace event) so

    -- that the calling function can treat them as leftovers if the parse fails

    dropWS leftovers = do

        x <- await

        let leftovers' = maybe id (:) x leftovers

        case isWhitespace <$> x of

          Just True -> dropWS leftovers'

          _         -> return (x, leftovers')

    runAttrParser' p as =

        case runAttrParser p as of

            Left e          -> Left e

            Right ([], x)   -> Right x

            Right (attr, _) -> Left $ toException $ UnparsedAttributes attr

-- | A simplified version of 'tag' where the 'NameMatcher' result isn't forwarded to the attributes parser.

--

-- Since 1.5.0

tag' :: MonadThrow m

     => NameMatcher a -> AttrParser b -> (b -> ConduitM Event o m c)

     -> ConduitM Event o m (Maybe c)

tag' a b = tag a (const b)

-- | A further simplified tag parser, which requires that no attributes exist.

tagNoAttr :: MonadThrow m

          => NameMatcher a -- ^ Check if this is a correct tag name

          -> ConduitM Event o m b -- ^ Handler function to handle the children of the matched tag

          -> ConduitM Event o m (Maybe b)

tagNoAttr name f = tag' name (return ()) $ const f

-- | A further simplified tag parser, which ignores all attributes, if any exist

tagIgnoreAttrs :: MonadThrow m

               => NameMatcher a -- ^ Check if this is a correct tag name

               -> ConduitM Event o m b -- ^ Handler function to handle the children of the matched tag

               -> ConduitM Event o m (Maybe b)

tagIgnoreAttrs name f = tag' name ignoreAttrs $ const f

-- | Ignore an empty tag and all of its attributes.

--   This does not ignore the tag recursively

--   (i.e. it assumes there are no child elements).

--   This function returns @Just ()@ if the tag matched.

--

-- Since 1.5.0

ignoreEmptyTag :: MonadThrow m

          => NameMatcher a -- ^ Check if this is a correct tag name

          -> ConduitM Event o m (Maybe ())

ignoreEmptyTag nameMatcher = tagIgnoreAttrs nameMatcher (return ())

{-# DEPRECATED ignoreTag "Please use 'ignoreEmptyTag'." #-}

ignoreTag :: MonadThrow m

          => NameMatcher a -- ^ Check if this is a correct tag name

          -> ConduitM Event o m (Maybe ())

ignoreTag = ignoreEmptyTag

-- | Ignore a tag, its attributes and its children subtrees recursively.

--   Both content and text events are ignored.

--   This function returns @Just ()@ if the tag matched.

--

-- Since 1.5.0

ignoreTreeContent :: MonadThrow m

                  => NameMatcher a -- ^ Check if this is a correct tag name

                  -> ConduitM Event o m (Maybe ())

ignoreTreeContent namePred = tagIgnoreAttrs namePred (void $ many ignoreAnyTreeContent)

{-# DEPRECATED ignoreTree "Please use 'ignoreTreeContent'." #-}

ignoreTree :: MonadThrow m

           => NameMatcher a -- ^ Check if this is a correct tag name

           -> ConduitM Event o m (Maybe ())

ignoreTree = ignoreTreeContent

-- | Like 'ignoreTreeContent', but matches any name and also ignores content events.

ignoreAnyTreeContent :: MonadThrow m => ConduitM Event o m (Maybe ())

ignoreAnyTreeContent = (void <$> contentMaybe) `orE` ignoreTreeContent anyName

{-# DEPRECATED ignoreAllTreesContent "Please use 'ignoreAnyTreeContent'." #-}

ignoreAllTreesContent :: MonadThrow m => ConduitM Event o m (Maybe ())

ignoreAllTreesContent = ignoreAnyTreeContent

-- | Get the value of the first parser which returns 'Just'. If no parsers

-- succeed (i.e., return @Just@), this function returns 'Nothing'.

--

-- > orE a b = choose [a, b]

orE :: Monad m

    => Consumer Event m (Maybe a) -- ^ The first (preferred) parser

    -> Consumer Event m (Maybe a) -- ^ The second parser, only executed if the first parser fails

    -> Consumer Event m (Maybe a)

orE a b = a >>= \x -> maybe b (const $ return x) x

-- | Get the value of the first parser which returns 'Just'. If no parsers

-- succeed (i.e., return 'Just'), this function returns 'Nothing'.

choose :: Monad m

       => [ConduitM Event o m (Maybe a)] -- ^ List of parsers that will be tried in order.

       -> ConduitM Event o m (Maybe a)   -- ^ Result of the first parser to succeed, or @Nothing@

                                         --   if no parser succeeded

choose []     = return Nothing

choose (i:is) = i >>= maybe (choose is) (return . Just)

-- | Force an optional parser into a required parser. All of the 'tag'

-- functions, 'attr', 'choose' and 'many' deal with 'Maybe' parsers. Use this when you

-- want to finally force something to happen.

force :: MonadThrow m

      => String -- ^ Error message

      -> m (Maybe a) -- ^ Optional parser to be forced

      -> m a

force msg i = i >>= maybe (throwM $ XmlException msg Nothing) return

-- | A helper function which reads a file from disk using 'enumFile', detects

-- character encoding using 'detectUtf', parses the XML using 'parseBytes', and

-- then hands off control to your supplied parser.

parseFile :: MonadResource m

          => ParseSettings

          -> FilePath

          -> Producer m Event

parseFile ps fp = sourceFile fp =$= parseBytes ps

-- | Parse an event stream from a lazy 'L.ByteString'.

parseLBS :: MonadThrow m

         => ParseSettings

         -> L.ByteString

         -> Producer m Event

parseLBS ps lbs = CL.sourceList (L.toChunks lbs) =$= parseBytes ps

data XmlException = XmlException

    { xmlErrorMessage :: String

    , xmlBadInput     :: Maybe Event

    }