{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts   #-}
{-# LANGUAGE RankNTypes         #-}
-- | DOM-based XML parsing and rendering.
--
-- In this module, attribute values and content nodes can contain either raw
-- text or entities. In most cases, these can be fully resolved at parsing. If
-- that is the case for your documents, the "Text.XML" module provides
-- simplified datatypes that only contain raw text.
module Text.XML.Unresolved
    ( -- * Non-streaming functions
      writeFile
    , readFile
      -- * Lazy bytestrings
    , renderLBS
    , parseLBS
    , parseLBS_
      -- * Text
    , parseText
    , parseText_
    , sinkTextDoc
      -- * Byte streams
    , sinkDoc
      -- * Streaming functions
    , toEvents
    , elementToEvents
    , fromEvents
    , elementFromEvents
    , renderBuilder
    , renderBytes
    , renderText
      -- * Exceptions
    , InvalidEventStream (..)
      -- * Settings
    , P.def
      -- ** Parse
    , P.ParseSettings
    , P.psDecodeEntities
    , P.psRetainNamespaces
      -- ** Render
    , R.RenderSettings
    , R.rsPretty
    , R.rsNamespaces
    ) where

import           Conduit
import           Control.Applicative          ((<$>), (<*>))
import           Control.Exception            (Exception, SomeException, throw)
import           Control.Monad                (when)
import           Control.Monad.Trans.Class    (lift)
import           Data.ByteString              (ByteString)
import           Data.ByteString.Builder      (Builder)
import qualified Data.ByteString.Lazy         as L
import           Data.Char                    (isSpace)
import qualified Data.Conduit.Binary          as CB
import           Data.Conduit.Lazy            (lazyConsume)
import qualified Data.Conduit.List            as CL
import           Data.Maybe                   (isJust, mapMaybe)
import           Data.Monoid                  (mconcat)
import           Data.Text                    (Text)
import qualified Data.Text                    as T
import qualified Data.Text.Lazy               as TL
import           Data.Typeable                (Typeable)
import           Data.XML.Types
import           Prelude                      hiding (readFile, writeFile)
import           System.IO.Unsafe             (unsafePerformIO)
import           Text.XML.Stream.Parse        (ParseSettings)
import qualified Text.XML.Stream.Parse        as P
import qualified Text.XML.Stream.Render       as R

readFile :: P.ParseSettings -> FilePath -> IO Document
readFile :: ParseSettings -> FilePath -> IO Document
readFile ParseSettings
ps FilePath
fp = forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) i.
MonadResource m =>
FilePath -> ConduitT i ByteString m ()
CB.sourceFile FilePath
fp forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) o.
MonadThrow m =>
ParseSettings -> ConduitT ByteString o m Document
sinkDoc ParseSettings
ps

sinkDoc :: MonadThrow m
        => P.ParseSettings
        -> ConduitT ByteString o m Document
sinkDoc :: forall (m :: * -> *) o.
MonadThrow m =>
ParseSettings -> ConduitT ByteString o m Document
sinkDoc ParseSettings
ps = forall (m :: * -> *).
MonadThrow m =>
ParseSettings -> ConduitT ByteString EventPos m ()
P.parseBytesPos ParseSettings
ps forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) o.
MonadThrow m =>
ConduitT EventPos o m Document
fromEvents

writeFile :: R.RenderSettings -> FilePath -> Document -> IO ()
writeFile :: RenderSettings -> FilePath -> Document -> IO ()
writeFile RenderSettings
rs FilePath
fp Document
doc =
    forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) i.
PrimMonad m =>
RenderSettings -> Document -> ConduitT i ByteString m ()
renderBytes RenderSettings
rs Document
doc forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) o.
MonadResource m =>
FilePath -> ConduitT ByteString o m ()
CB.sinkFile FilePath
fp

renderLBS :: R.RenderSettings -> Document -> L.ByteString
renderLBS :: RenderSettings -> Document -> ByteString
renderLBS RenderSettings
rs Document
doc =
    [ByteString] -> ByteString
L.fromChunks forall a b. (a -> b) -> a -> b
$ forall a. IO a -> a
unsafePerformIO
                 -- not generally safe, but we know that runResourceT
                 -- will not deallocate any of the resources being used
                 -- by the process
                 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadUnliftIO m, MonadActive m) =>
Source m a -> m [a]
lazyConsume
                 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) i.
PrimMonad m =>
RenderSettings -> Document -> ConduitT i ByteString m ()
renderBytes RenderSettings
rs Document
doc

parseLBS :: P.ParseSettings -> L.ByteString -> Either SomeException Document
parseLBS :: ParseSettings -> ByteString -> Either SomeException Document
parseLBS ParseSettings
ps ByteString
lbs = forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a i. Monad m => [a] -> ConduitT i a m ()
CL.sourceList (ByteString -> [ByteString]
L.toChunks ByteString
lbs) forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) o.
MonadThrow m =>
ParseSettings -> ConduitT ByteString o m Document
sinkDoc ParseSettings
ps

parseLBS_ :: P.ParseSettings -> L.ByteString -> Document
parseLBS_ :: ParseSettings -> ByteString -> Document
parseLBS_ ParseSettings
ps ByteString
lbs = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a e. Exception e => e -> a
throw forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ ParseSettings -> ByteString -> Either SomeException Document
parseLBS ParseSettings
ps ByteString
lbs

data InvalidEventStream = ContentAfterRoot P.EventPos
                        | MissingRootElement
                        | InvalidInlineDoctype P.EventPos
                        | MissingEndElement Name (Maybe P.EventPos)
                        | UnterminatedInlineDoctype
    deriving Typeable
instance Exception InvalidEventStream
instance Show InvalidEventStream where
    show :: InvalidEventStream -> FilePath
show (ContentAfterRoot (Maybe PositionRange
pos, Event
e)) = Maybe PositionRange -> FilePath
mShowPos Maybe PositionRange
pos forall a. [a] -> [a] -> [a]
++ FilePath
"Found content after root element: " forall a. [a] -> [a] -> [a]
++ Event -> FilePath
prettyShowE Event
e
    show InvalidEventStream
MissingRootElement = FilePath
"Missing root element"
    show (InvalidInlineDoctype (Maybe PositionRange
pos, Event
e)) = Maybe PositionRange -> FilePath
mShowPos Maybe PositionRange
pos forall a. [a] -> [a] -> [a]
++ FilePath
"Invalid content inside doctype: " forall a. [a] -> [a] -> [a]
++ Event -> FilePath
prettyShowE Event
e
    show (MissingEndElement Name
name Maybe EventPos
Nothing) = FilePath
"Documented ended while expected end element for: " forall a. [a] -> [a] -> [a]
++ Name -> FilePath
prettyShowName Name
name
    show (MissingEndElement Name
name (Just (Maybe PositionRange
pos, Event
e))) = Maybe PositionRange -> FilePath
mShowPos Maybe PositionRange
pos forall a. [a] -> [a] -> [a]
++ FilePath
"Expected end element for: " forall a. [a] -> [a] -> [a]
++ Name -> FilePath
prettyShowName Name
name forall a. [a] -> [a] -> [a]
++ FilePath
", but received: " forall a. [a] -> [a] -> [a]
++ Event -> FilePath
prettyShowE Event
e
    show InvalidEventStream
UnterminatedInlineDoctype = FilePath
"Unterminated doctype declaration"

mShowPos :: Maybe P.PositionRange -> String
mShowPos :: Maybe PositionRange -> FilePath
mShowPos Maybe PositionRange
Nothing    = FilePath
""
mShowPos (Just PositionRange
pos) = forall a. Show a => a -> FilePath
show PositionRange
pos forall a. [a] -> [a] -> [a]
++ FilePath
": "

prettyShowE :: Event -> String
prettyShowE :: Event -> FilePath
prettyShowE = forall a. Show a => a -> FilePath
show -- FIXME

prettyShowName :: Name -> String
prettyShowName :: Name -> FilePath
prettyShowName = forall a. Show a => a -> FilePath
show -- FIXME

renderBuilder :: Monad m => R.RenderSettings -> Document -> ConduitT i Builder m ()
renderBuilder :: forall (m :: * -> *) i.
Monad m =>
RenderSettings -> Document -> ConduitT i Builder m ()
renderBuilder RenderSettings
rs Document
doc = forall (m :: * -> *) a i. Monad m => [a] -> ConduitT i a m ()
CL.sourceList (Document -> [Event]
toEvents Document
doc) forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *).
Monad m =>
RenderSettings -> ConduitT Event Builder m ()
R.renderBuilder RenderSettings
rs

renderBytes :: PrimMonad m => R.RenderSettings -> Document -> ConduitT i ByteString m ()
renderBytes :: forall (m :: * -> *) i.
PrimMonad m =>
RenderSettings -> Document -> ConduitT i ByteString m ()
renderBytes RenderSettings
rs Document
doc = forall (m :: * -> *) a i. Monad m => [a] -> ConduitT i a m ()
CL.sourceList (Document -> [Event]
toEvents Document
doc) forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *).
PrimMonad m =>
RenderSettings -> ConduitT Event ByteString m ()
R.renderBytes RenderSettings
rs

renderText :: (MonadThrow m, PrimMonad m) => R.RenderSettings -> Document -> ConduitT i Text m ()
renderText :: forall (m :: * -> *) i.
(MonadThrow m, PrimMonad m) =>
RenderSettings -> Document -> ConduitT i Text m ()
renderText RenderSettings
rs Document
doc = forall (m :: * -> *) a i. Monad m => [a] -> ConduitT i a m ()
CL.sourceList (Document -> [Event]
toEvents Document
doc) forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *).
(PrimMonad m, MonadThrow m) =>
RenderSettings -> ConduitT Event Text m ()
R.renderText RenderSettings
rs

manyTries :: Monad m => m (Maybe a) -> m [a]
manyTries :: forall (m :: * -> *) a. Monad m => m (Maybe a) -> m [a]
manyTries m (Maybe a)
f =
    forall {c}. ([a] -> c) -> m c
go forall a. a -> a
id
  where
    go :: ([a] -> c) -> m c
go [a] -> c
front = do
        Maybe a
x <- m (Maybe a)
f
        case Maybe a
x of
            Maybe a
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [a] -> c
front []
            Just a
y  -> ([a] -> c) -> m c
go ([a] -> c
front forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) a
y)

dropReturn :: Monad m => a -> ConduitM i o m a
dropReturn :: forall (m :: * -> *) a i o. Monad m => a -> ConduitM i o m a
dropReturn a
x = forall (m :: * -> *) a o. Monad m => Int -> ConduitT a o m ()
CL.drop Int
1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return a
x

-- | Parse a document from a stream of events.
fromEvents :: MonadThrow m => ConduitT P.EventPos o m Document
fromEvents :: forall (m :: * -> *) o.
MonadThrow m =>
ConduitT EventPos o m Document
fromEvents = do
    forall {m :: * -> *} {b} {a} {o}.
(Monad m, Eq b) =>
b -> ConduitT (a, b) o m ()
skip Event
EventBeginDocument
    Document
d <- Prologue -> Element -> [Miscellaneous] -> Document
Document forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {o}. ConduitT EventPos o m Prologue
goP forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {m :: * -> *} {o} {b}.
MonadThrow m =>
ConduitT EventPos o m (Maybe b) -> ConduitT EventPos o m b
require forall (m :: * -> *) o.
MonadThrow m =>
ConduitT EventPos o m (Maybe Element)
elementFromEvents forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {a} {o}. ConduitT (a, Event) o m [Miscellaneous]
goM
    forall {m :: * -> *} {b} {a} {o}.
(Monad m, Eq b) =>
b -> ConduitT (a, b) o m ()
skip Event
EventEndDocument
    Maybe EventPos
y <- forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
CL.head
    case Maybe EventPos
y of
        Maybe EventPos
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Document
d
        Just (Maybe PositionRange
_, Event
EventEndDocument) -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM InvalidEventStream
MissingRootElement
        Just EventPos
z ->
            forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ EventPos -> InvalidEventStream
ContentAfterRoot EventPos
z
  where
    skip :: b -> ConduitT (a, b) o m ()
skip b
e = do
        Maybe (a, b)
x <- forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
CL.peek
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd Maybe (a, b)
x forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just b
e) (forall (m :: * -> *) a o. Monad m => Int -> ConduitT a o m ()
CL.drop Int
1)
    require :: ConduitT EventPos o m (Maybe b) -> ConduitT EventPos o m b
require ConduitT EventPos o m (Maybe b)
f = do
        Maybe b
x <- ConduitT EventPos o m (Maybe b)
f
        case Maybe b
x of
            Just b
y -> forall (m :: * -> *) a. Monad m => a -> m a
return b
y
            Maybe b
Nothing -> do
                Maybe EventPos
my <- forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
CL.head
                case Maybe EventPos
my of
                    Maybe EventPos
Nothing -> forall a. HasCallStack => FilePath -> a
error FilePath
"Text.XML.Unresolved:impossible"
                    Just (Maybe PositionRange
_, Event
EventEndDocument) -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM InvalidEventStream
MissingRootElement
                    Just EventPos
y -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ EventPos -> InvalidEventStream
ContentAfterRoot EventPos
y
    goP :: ConduitT EventPos o m Prologue
goP = [Miscellaneous] -> Maybe Doctype -> [Miscellaneous] -> Prologue
Prologue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a} {o}. ConduitT (a, Event) o m [Miscellaneous]
goM forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {o}. ConduitT EventPos o m (Maybe Doctype)
goD forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {a} {o}. ConduitT (a, Event) o m [Miscellaneous]
goM
    goM :: ConduitT (a, Event) o m [Miscellaneous]
goM = forall (m :: * -> *) a. Monad m => m (Maybe a) -> m [a]
manyTries forall {a} {o}. ConduitT (a, Event) o m (Maybe Miscellaneous)
goM'
    goM' :: ConduitT (a, Event) o m (Maybe Miscellaneous)
goM' = do
        Maybe (a, Event)
x <- forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
CL.peek
        case Maybe (a, Event)
x of
            Just (a
_, EventInstruction Instruction
i) -> forall (m :: * -> *) a i o. Monad m => a -> ConduitM i o m a
dropReturn forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Instruction -> Miscellaneous
MiscInstruction Instruction
i
            Just (a
_, EventComment Text
t) -> forall (m :: * -> *) a i o. Monad m => a -> ConduitM i o m a
dropReturn forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> Miscellaneous
MiscComment Text
t
            Just (a
_, EventContent (ContentText Text
t))
                | (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isSpace Text
t -> forall (m :: * -> *) a o. Monad m => Int -> ConduitT a o m ()
CL.drop Int
1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ConduitT (a, Event) o m (Maybe Miscellaneous)
goM'
            Maybe (a, Event)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    goD :: ConduitT EventPos o m (Maybe Doctype)
goD = do
        Maybe EventPos
x <- forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
CL.peek
        case Maybe EventPos
x of
            Just (Maybe PositionRange
_, EventBeginDoctype Text
name Maybe ExternalID
meid) -> do
                forall (m :: * -> *) a o. Monad m => Int -> ConduitT a o m ()
CL.drop Int
1
                forall {o}. ConduitT EventPos o m ()
dropTillDoctype
                forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> Maybe ExternalID -> Doctype
Doctype Text
name Maybe ExternalID
meid)
            Maybe EventPos
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    dropTillDoctype :: ConduitT EventPos o m ()
dropTillDoctype = do
        Maybe EventPos
x <- forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
CL.head
        case Maybe EventPos
x of
            -- Leaving the following line commented so that the intention of
            -- this function stays clear. I figure in the future xml-types will
            -- be expanded again to support some form of EventDeclaration
            --
            -- Just (EventDeclaration _) -> dropTillDoctype
            Just (Maybe PositionRange
_, Event
EventEndDoctype) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just EventPos
epos -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ EventPos -> InvalidEventStream
InvalidInlineDoctype EventPos
epos
            Maybe EventPos
Nothing -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM InvalidEventStream
UnterminatedInlineDoctype

-- | Try to parse a document element (as defined in XML) from a stream of events.
--
-- @since 1.3.5
elementFromEvents :: MonadThrow m => ConduitT P.EventPos o m (Maybe Element)
elementFromEvents :: forall (m :: * -> *) o.
MonadThrow m =>
ConduitT EventPos o m (Maybe Element)
elementFromEvents = forall {o}. ConduitT EventPos o m (Maybe Element)
goE
  where
    goE :: ConduitT EventPos o m (Maybe Element)
goE = do
        Maybe EventPos
x <- forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
CL.peek
        case Maybe EventPos
x of
            Just (Maybe PositionRange
_, EventBeginElement Name
n [(Name, [Content])]
as) -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {o}.
Name -> [(Name, [Content])] -> ConduitT EventPos o m Element
goE' Name
n [(Name, [Content])]
as
            Maybe EventPos
_                                -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    goE' :: Name -> [(Name, [Content])] -> ConduitT EventPos o m Element
goE' Name
n [(Name, [Content])]
as = do
        forall (m :: * -> *) a o. Monad m => Int -> ConduitT a o m ()
CL.drop Int
1
        [Node]
ns <- forall (m :: * -> *) a. Monad m => m (Maybe a) -> m [a]
manyTries ConduitT EventPos o m (Maybe Node)
goN
        Maybe EventPos
y <- forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
CL.head
        if forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd Maybe EventPos
y forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just (Name -> Event
EventEndElement Name
n)
            then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> [(Name, [Content])] -> [Node] -> Element
Element Name
n [(Name, [Content])]
as forall a b. (a -> b) -> a -> b
$ [Node] -> [Node]
compressNodes [Node]
ns
            else forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Name -> Maybe EventPos -> InvalidEventStream
MissingEndElement Name
n Maybe EventPos
y
    goN :: ConduitT EventPos o m (Maybe Node)
goN = do
        Maybe EventPos
x <- forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
CL.peek
        case Maybe EventPos
x of
            Just (Maybe PositionRange
_, EventBeginElement Name
n [(Name, [Content])]
as) -> (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Node
NodeElement) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> [(Name, [Content])] -> ConduitT EventPos o m Element
goE' Name
n [(Name, [Content])]
as
            Just (Maybe PositionRange
_, EventInstruction Instruction
i) -> forall (m :: * -> *) a i o. Monad m => a -> ConduitM i o m a
dropReturn forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Instruction -> Node
NodeInstruction Instruction
i
            Just (Maybe PositionRange
_, EventContent Content
c) -> forall (m :: * -> *) a i o. Monad m => a -> ConduitM i o m a
dropReturn forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Content -> Node
NodeContent Content
c
            Just (Maybe PositionRange
_, EventComment Text
t) -> forall (m :: * -> *) a i o. Monad m => a -> ConduitM i o m a
dropReturn forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> Node
NodeComment Text
t
            Just (Maybe PositionRange
_, EventCDATA Text
t) -> forall (m :: * -> *) a i o. Monad m => a -> ConduitM i o m a
dropReturn forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Content -> Node
NodeContent forall a b. (a -> b) -> a -> b
$ Text -> Content
ContentText Text
t
            Maybe EventPos
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

-- | Render a document into events.
toEvents :: Document -> [Event]
toEvents :: Document -> [Event]
toEvents (Document Prologue
prol Element
root [Miscellaneous]
epi) =
      (Event
EventBeginDocument forall a. a -> [a] -> [a]
:)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prologue -> [Event] -> [Event]
goP Prologue
prol forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> [Event] -> [Event]
elementToEvents' Element
root forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Miscellaneous] -> [Event] -> [Event]
goM [Miscellaneous]
epi forall a b. (a -> b) -> a -> b
$ [Event
EventEndDocument]
  where
    goP :: Prologue -> [Event] -> [Event]
goP (Prologue [Miscellaneous]
before Maybe Doctype
doctype [Miscellaneous]
after) =
        [Miscellaneous] -> [Event] -> [Event]
goM [Miscellaneous]
before forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id Doctype -> [Event] -> [Event]
goD Maybe Doctype
doctype forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Miscellaneous] -> [Event] -> [Event]
goM [Miscellaneous]
after
    goM :: [Miscellaneous] -> [Event] -> [Event]
goM []     = forall a. a -> a
id
    goM [Miscellaneous
x]    = (Miscellaneous -> Event
goM' Miscellaneous
x forall a. a -> [a] -> [a]
:)
    goM (Miscellaneous
x:[Miscellaneous]
xs) = (Miscellaneous -> Event
goM' Miscellaneous
x forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Miscellaneous] -> [Event] -> [Event]
goM [Miscellaneous]
xs
    goM' :: Miscellaneous -> Event
goM' (MiscInstruction Instruction
i) = Instruction -> Event
EventInstruction Instruction
i
    goM' (MiscComment Text
t)     = Text -> Event
EventComment Text
t
    goD :: Doctype -> [Event] -> [Event]
goD (Doctype Text
name Maybe ExternalID
meid) =
        (:) (Text -> Maybe ExternalID -> Event
EventBeginDoctype Text
name Maybe ExternalID
meid)
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) Event
EventEndDoctype

-- | Render a document element into events.
--
-- @since 1.3.5
elementToEvents :: Element -> [Event]
elementToEvents :: Element -> [Event]
elementToEvents Element
e = Element -> [Event] -> [Event]
elementToEvents' Element
e []

elementToEvents' :: Element -> [Event] -> [Event]
elementToEvents' :: Element -> [Event] -> [Event]
elementToEvents' = Element -> [Event] -> [Event]
goE
  where
    goE :: Element -> [Event] -> [Event]
goE (Element Name
name [(Name, [Content])]
as [Node]
ns) =
          (Name -> [(Name, [Content])] -> Event
EventBeginElement Name
name [(Name, [Content])]
as forall a. a -> [a] -> [a]
:)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node] -> [Event] -> [Event]
goN [Node]
ns
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Event
EventEndElement Name
name forall a. a -> [a] -> [a]
:)
    goN :: [Node] -> [Event] -> [Event]
goN []     = forall a. a -> a
id
    goN [Node
x]    = Node -> [Event] -> [Event]
goN' Node
x
    goN (Node
x:[Node]
xs) = Node -> [Event] -> [Event]
goN' Node
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node] -> [Event] -> [Event]
goN [Node]
xs
    goN' :: Node -> [Event] -> [Event]
goN' (NodeElement Element
e)     = Element -> [Event] -> [Event]
goE Element
e
    goN' (NodeInstruction Instruction
i) = (Instruction -> Event
EventInstruction Instruction
i forall a. a -> [a] -> [a]
:)
    goN' (NodeContent Content
c)     = (Content -> Event
EventContent Content
c forall a. a -> [a] -> [a]
:)
    goN' (NodeComment Text
t)     = (Text -> Event
EventComment Text
t forall a. a -> [a] -> [a]
:)

compressNodes :: [Node] -> [Node]
compressNodes :: [Node] -> [Node]
compressNodes []     = []
compressNodes [Node
x]    = [Node
x]
compressNodes (x :: Node
x@(NodeContent (ContentText Text
_)) : y :: Node
y@(NodeContent (ContentText Text
_)) : [Node]
z) =
    let ([Node]
textNodes, [Node]
remainder) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> Maybe Text
unContent) (Node
xforall a. a -> [a] -> [a]
:Node
yforall a. a -> [a] -> [a]
:[Node]
z)
        texts :: [Text]
texts = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Node -> Maybe Text
unContent [Node]
textNodes
    in
        [Node] -> [Node]
compressNodes forall a b. (a -> b) -> a -> b
$ Content -> Node
NodeContent (Text -> Content
ContentText forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [Text]
texts) forall a. a -> [a] -> [a]
: [Node]
remainder
    where
        unContent :: Node -> Maybe Text
unContent (NodeContent (ContentText Text
text)) = forall a. a -> Maybe a
Just Text
text
        unContent Node
_                                = forall a. Maybe a
Nothing
compressNodes (Node
x:[Node]
xs) = Node
x forall a. a -> [a] -> [a]
: [Node] -> [Node]
compressNodes [Node]
xs

parseText :: ParseSettings -> TL.Text -> Either SomeException Document
parseText :: ParseSettings -> Text -> Either SomeException Document
parseText ParseSettings
ps Text
tl =
    forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit
  forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a i. Monad m => [a] -> ConduitT i a m ()
CL.sourceList (Text -> [Text]
TL.toChunks Text
tl)
 forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) o.
MonadThrow m =>
ParseSettings -> ConduitT Text o m Document
sinkTextDoc ParseSettings
ps

parseText_ :: ParseSettings -> TL.Text -> Document
parseText_ :: ParseSettings -> Text -> Document
parseText_ ParseSettings
ps = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a e. Exception e => e -> a
throw forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseSettings -> Text -> Either SomeException Document
parseText ParseSettings
ps

sinkTextDoc :: MonadThrow m
            => ParseSettings
            -> ConduitT Text o m Document
sinkTextDoc :: forall (m :: * -> *) o.
MonadThrow m =>
ParseSettings -> ConduitT Text o m Document
sinkTextDoc ParseSettings
ps = forall (m :: * -> *).
MonadThrow m =>
ParseSettings -> ConduitT Text EventPos m ()
P.parseTextPos ParseSettings
ps forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) o.
MonadThrow m =>
ConduitT EventPos o m Document
fromEvents