{-# 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 = ConduitT () Void (ResourceT IO) Document -> IO Document
forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes (ConduitT () Void (ResourceT IO) Document -> IO Document)
-> ConduitT () Void (ResourceT IO) Document -> IO Document
forall a b. (a -> b) -> a -> b
$ FilePath -> ConduitT () ByteString (ResourceT IO) ()
forall (m :: * -> *) i.
MonadResource m =>
FilePath -> ConduitT i ByteString m ()
CB.sourceFile FilePath
fp ConduitT () ByteString (ResourceT IO) ()
-> ConduitM ByteString Void (ResourceT IO) Document
-> ConduitT () Void (ResourceT IO) Document
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ParseSettings -> ConduitM ByteString Void (ResourceT IO) Document
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 :: ParseSettings -> ConduitT ByteString o m Document
sinkDoc ParseSettings
ps = ParseSettings -> ConduitT ByteString EventPos m ()
forall (m :: * -> *).
MonadThrow m =>
ParseSettings -> ConduitT ByteString EventPos m ()
P.parseBytesPos ParseSettings
ps ConduitT ByteString EventPos m ()
-> ConduitM EventPos o m Document
-> ConduitT ByteString o m Document
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM EventPos o m Document
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 =
    ConduitT () Void (ResourceT IO) () -> IO ()
forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes (ConduitT () Void (ResourceT IO) () -> IO ())
-> ConduitT () Void (ResourceT IO) () -> IO ()
forall a b. (a -> b) -> a -> b
$ RenderSettings
-> Document -> ConduitT () ByteString (ResourceT IO) ()
forall (m :: * -> *) i.
PrimMonad m =>
RenderSettings -> Document -> ConduitT i ByteString m ()
renderBytes RenderSettings
rs Document
doc ConduitT () ByteString (ResourceT IO) ()
-> ConduitM ByteString Void (ResourceT IO) ()
-> ConduitT () Void (ResourceT IO) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| FilePath -> ConduitM ByteString Void (ResourceT IO) ()
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 ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ IO [ByteString] -> [ByteString]
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
                 (IO [ByteString] -> [ByteString])
-> IO [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Source IO ByteString -> IO [ByteString]
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadActive m) =>
Source m a -> m [a]
lazyConsume
                 (Source IO ByteString -> IO [ByteString])
-> Source IO ByteString -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ RenderSettings -> Document -> Source IO ByteString
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 = ConduitT () Void (Either SomeException) Document
-> Either SomeException Document
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void (Either SomeException) Document
 -> Either SomeException Document)
-> ConduitT () Void (Either SomeException) Document
-> Either SomeException Document
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ConduitT () ByteString (Either SomeException) ()
forall (m :: * -> *) a i. Monad m => [a] -> ConduitT i a m ()
CL.sourceList (ByteString -> [ByteString]
L.toChunks ByteString
lbs) ConduitT () ByteString (Either SomeException) ()
-> ConduitM ByteString Void (Either SomeException) Document
-> ConduitT () Void (Either SomeException) Document
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ParseSettings
-> ConduitM ByteString Void (Either SomeException) Document
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 = (SomeException -> Document)
-> (Document -> Document)
-> Either SomeException Document
-> Document
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> Document
forall a e. Exception e => e -> a
throw Document -> Document
forall a. a -> a
id (Either SomeException Document -> Document)
-> Either SomeException Document -> Document
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 FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"Found content after root element: " FilePath -> ShowS
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 FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"Invalid content inside doctype: " FilePath -> ShowS
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: " FilePath -> ShowS
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 FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"Expected end element for: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> FilePath
prettyShowName Name
name FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
", but received: " FilePath -> ShowS
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) = PositionRange -> FilePath
forall a. Show a => a -> FilePath
show PositionRange
pos FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
": "

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

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

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

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

manyTries :: Monad m => m (Maybe a) -> m [a]
manyTries :: m (Maybe a) -> m [a]
manyTries m (Maybe a)
f =
    ([a] -> [a]) -> m [a]
forall c. ([a] -> c) -> m c
go [a] -> [a]
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 -> c -> m c
forall (m :: * -> *) a. Monad m => a -> m a
return (c -> m c) -> c -> m c
forall a b. (a -> b) -> a -> b
$ [a] -> c
front []
            Just a
y  -> ([a] -> c) -> m c
go ([a] -> c
front ([a] -> c) -> ([a] -> [a]) -> [a] -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) a
y)

dropReturn :: Monad m => a -> ConduitM i o m a
dropReturn :: a -> ConduitM i o m a
dropReturn a
x = Int -> ConduitT i o m ()
forall (m :: * -> *) a o. Monad m => Int -> ConduitT a o m ()
CL.drop Int
1 ConduitT i o m () -> ConduitM i o m a -> ConduitM i o m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> ConduitM i o m a
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 :: ConduitT EventPos o m Document
fromEvents = do
    Event -> ConduitT EventPos o m ()
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 (Prologue -> Element -> [Miscellaneous] -> Document)
-> ConduitT EventPos o m Prologue
-> ConduitT EventPos o m (Element -> [Miscellaneous] -> Document)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConduitT EventPos o m Prologue
forall o. ConduitT EventPos o m Prologue
goP ConduitT EventPos o m (Element -> [Miscellaneous] -> Document)
-> ConduitT EventPos o m Element
-> ConduitT EventPos o m ([Miscellaneous] -> Document)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ConduitT EventPos o m (Maybe Element)
-> ConduitT EventPos o m Element
forall (m :: * -> *) o b.
MonadThrow m =>
ConduitT EventPos o m (Maybe b) -> ConduitT EventPos o m b
require ConduitT EventPos o m (Maybe Element)
forall (m :: * -> *) o.
MonadThrow m =>
ConduitT EventPos o m (Maybe Element)
elementFromEvents ConduitT EventPos o m ([Miscellaneous] -> Document)
-> ConduitT EventPos o m [Miscellaneous]
-> ConduitT EventPos o m Document
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ConduitT EventPos o m [Miscellaneous]
forall a o. ConduitT (a, Event) o m [Miscellaneous]
goM
    Event -> ConduitT EventPos o m ()
forall (m :: * -> *) b a o.
(Monad m, Eq b) =>
b -> ConduitT (a, b) o m ()
skip Event
EventEndDocument
    Maybe EventPos
y <- ConduitT EventPos o m (Maybe EventPos)
forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
CL.head
    case Maybe EventPos
y of
        Maybe EventPos
Nothing -> Document -> ConduitT EventPos o m Document
forall (m :: * -> *) a. Monad m => a -> m a
return Document
d
        Just (Maybe PositionRange
_, Event
EventEndDocument) -> m Document -> ConduitT EventPos o m Document
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Document -> ConduitT EventPos o m Document)
-> m Document -> ConduitT EventPos o m Document
forall a b. (a -> b) -> a -> b
$ InvalidEventStream -> m Document
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM InvalidEventStream
MissingRootElement
        Just EventPos
z ->
            m Document -> ConduitT EventPos o m Document
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Document -> ConduitT EventPos o m Document)
-> m Document -> ConduitT EventPos o m Document
forall a b. (a -> b) -> a -> b
$ InvalidEventStream -> m Document
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (InvalidEventStream -> m Document)
-> InvalidEventStream -> m Document
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 <- ConduitT (a, b) o m (Maybe (a, b))
forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
CL.peek
        Bool -> ConduitT (a, b) o m () -> ConduitT (a, b) o m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (((a, b) -> b) -> Maybe (a, b) -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, b) -> b
forall a b. (a, b) -> b
snd Maybe (a, b)
x Maybe b -> Maybe b -> Bool
forall a. Eq a => a -> a -> Bool
== b -> Maybe b
forall a. a -> Maybe a
Just b
e) (Int -> ConduitT (a, b) o m ()
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 -> b -> ConduitT EventPos o m b
forall (m :: * -> *) a. Monad m => a -> m a
return b
y
            Maybe b
Nothing -> do
                Maybe EventPos
my <- ConduitT EventPos o m (Maybe EventPos)
forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
CL.head
                case Maybe EventPos
my of
                    Maybe EventPos
Nothing -> FilePath -> ConduitT EventPos o m b
forall a. HasCallStack => FilePath -> a
error FilePath
"Text.XML.Unresolved:impossible"
                    Just (Maybe PositionRange
_, Event
EventEndDocument) -> m b -> ConduitT EventPos o m b
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m b -> ConduitT EventPos o m b) -> m b -> ConduitT EventPos o m b
forall a b. (a -> b) -> a -> b
$ InvalidEventStream -> m b
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM InvalidEventStream
MissingRootElement
                    Just EventPos
y -> m b -> ConduitT EventPos o m b
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m b -> ConduitT EventPos o m b) -> m b -> ConduitT EventPos o m b
forall a b. (a -> b) -> a -> b
$ InvalidEventStream -> m b
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (InvalidEventStream -> m b) -> InvalidEventStream -> m b
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 ([Miscellaneous] -> Maybe Doctype -> [Miscellaneous] -> Prologue)
-> ConduitT EventPos o m [Miscellaneous]
-> ConduitT
     EventPos o m (Maybe Doctype -> [Miscellaneous] -> Prologue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConduitT EventPos o m [Miscellaneous]
forall a o. ConduitT (a, Event) o m [Miscellaneous]
goM ConduitT
  EventPos o m (Maybe Doctype -> [Miscellaneous] -> Prologue)
-> ConduitT EventPos o m (Maybe Doctype)
-> ConduitT EventPos o m ([Miscellaneous] -> Prologue)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ConduitT EventPos o m (Maybe Doctype)
forall o. ConduitT EventPos o m (Maybe Doctype)
goD ConduitT EventPos o m ([Miscellaneous] -> Prologue)
-> ConduitT EventPos o m [Miscellaneous]
-> ConduitT EventPos o m Prologue
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ConduitT EventPos o m [Miscellaneous]
forall a o. ConduitT (a, Event) o m [Miscellaneous]
goM
    goM :: ConduitT (a, Event) o m [Miscellaneous]
goM = ConduitT (a, Event) o m (Maybe Miscellaneous)
-> ConduitT (a, Event) o m [Miscellaneous]
forall (m :: * -> *) a. Monad m => m (Maybe a) -> m [a]
manyTries ConduitT (a, Event) o m (Maybe Miscellaneous)
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 <- ConduitT (a, Event) o m (Maybe (a, Event))
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) -> Maybe Miscellaneous
-> ConduitT (a, Event) o m (Maybe Miscellaneous)
forall (m :: * -> *) a i o. Monad m => a -> ConduitM i o m a
dropReturn (Maybe Miscellaneous
 -> ConduitT (a, Event) o m (Maybe Miscellaneous))
-> Maybe Miscellaneous
-> ConduitT (a, Event) o m (Maybe Miscellaneous)
forall a b. (a -> b) -> a -> b
$ Miscellaneous -> Maybe Miscellaneous
forall a. a -> Maybe a
Just (Miscellaneous -> Maybe Miscellaneous)
-> Miscellaneous -> Maybe Miscellaneous
forall a b. (a -> b) -> a -> b
$ Instruction -> Miscellaneous
MiscInstruction Instruction
i
            Just (a
_, EventComment Text
t) -> Maybe Miscellaneous
-> ConduitT (a, Event) o m (Maybe Miscellaneous)
forall (m :: * -> *) a i o. Monad m => a -> ConduitM i o m a
dropReturn (Maybe Miscellaneous
 -> ConduitT (a, Event) o m (Maybe Miscellaneous))
-> Maybe Miscellaneous
-> ConduitT (a, Event) o m (Maybe Miscellaneous)
forall a b. (a -> b) -> a -> b
$ Miscellaneous -> Maybe Miscellaneous
forall a. a -> Maybe a
Just (Miscellaneous -> Maybe Miscellaneous)
-> Miscellaneous -> Maybe Miscellaneous
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 -> Int -> ConduitT (a, Event) o m ()
forall (m :: * -> *) a o. Monad m => Int -> ConduitT a o m ()
CL.drop Int
1 ConduitT (a, Event) o m ()
-> ConduitT (a, Event) o m (Maybe Miscellaneous)
-> ConduitT (a, Event) o m (Maybe Miscellaneous)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ConduitT (a, Event) o m (Maybe Miscellaneous)
goM'
            Maybe (a, Event)
_ -> Maybe Miscellaneous
-> ConduitT (a, Event) o m (Maybe Miscellaneous)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Miscellaneous
forall a. Maybe a
Nothing
    goD :: ConduitT EventPos o m (Maybe Doctype)
goD = do
        Maybe EventPos
x <- ConduitT EventPos o m (Maybe EventPos)
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
                Int -> ConduitT EventPos o m ()
forall (m :: * -> *) a o. Monad m => Int -> ConduitT a o m ()
CL.drop Int
1
                ConduitT EventPos o m ()
forall o. ConduitT EventPos o m ()
dropTillDoctype
                Maybe Doctype -> ConduitT EventPos o m (Maybe Doctype)
forall (m :: * -> *) a. Monad m => a -> m a
return (Doctype -> Maybe Doctype
forall a. a -> Maybe a
Just (Doctype -> Maybe Doctype) -> Doctype -> Maybe Doctype
forall a b. (a -> b) -> a -> b
$ Text -> Maybe ExternalID -> Doctype
Doctype Text
name Maybe ExternalID
meid)
            Maybe EventPos
_ -> Maybe Doctype -> ConduitT EventPos o m (Maybe Doctype)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Doctype
forall a. Maybe a
Nothing
    dropTillDoctype :: ConduitT EventPos o m ()
dropTillDoctype = do
        Maybe EventPos
x <- ConduitT EventPos o m (Maybe EventPos)
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) -> () -> ConduitT EventPos o m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just EventPos
epos -> m () -> ConduitT EventPos o m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ConduitT EventPos o m ())
-> m () -> ConduitT EventPos o m ()
forall a b. (a -> b) -> a -> b
$ InvalidEventStream -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (InvalidEventStream -> m ()) -> InvalidEventStream -> m ()
forall a b. (a -> b) -> a -> b
$ EventPos -> InvalidEventStream
InvalidInlineDoctype EventPos
epos
            Maybe EventPos
Nothing -> m () -> ConduitT EventPos o m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ConduitT EventPos o m ())
-> m () -> ConduitT EventPos o m ()
forall a b. (a -> b) -> a -> b
$ InvalidEventStream -> m ()
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 :: ConduitT EventPos o m (Maybe Element)
elementFromEvents = ConduitT EventPos o m (Maybe Element)
forall o. ConduitT EventPos o m (Maybe Element)
goE
  where
    goE :: ConduitT EventPos o m (Maybe Element)
goE = do
        Maybe EventPos
x <- ConduitT EventPos o m (Maybe EventPos)
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) -> Element -> Maybe Element
forall a. a -> Maybe a
Just (Element -> Maybe Element)
-> ConduitT EventPos o m Element
-> ConduitT EventPos o m (Maybe Element)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> [(Name, [Content])] -> ConduitT EventPos o m Element
forall o.
Name -> [(Name, [Content])] -> ConduitT EventPos o m Element
goE' Name
n [(Name, [Content])]
as
            Maybe EventPos
_                                -> Maybe Element -> ConduitT EventPos o m (Maybe Element)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Element
forall a. Maybe a
Nothing
    goE' :: Name -> [(Name, [Content])] -> ConduitT EventPos o m Element
goE' Name
n [(Name, [Content])]
as = do
        Int -> ConduitT EventPos o m ()
forall (m :: * -> *) a o. Monad m => Int -> ConduitT a o m ()
CL.drop Int
1
        [Node]
ns <- ConduitT EventPos o m (Maybe Node) -> ConduitT EventPos o m [Node]
forall (m :: * -> *) a. Monad m => m (Maybe a) -> m [a]
manyTries ConduitT EventPos o m (Maybe Node)
goN
        Maybe EventPos
y <- ConduitT EventPos o m (Maybe EventPos)
forall (m :: * -> *) a o. Monad m => ConduitT a o m (Maybe a)
CL.head
        if (EventPos -> Event) -> Maybe EventPos -> Maybe Event
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap EventPos -> Event
forall a b. (a, b) -> b
snd Maybe EventPos
y Maybe Event -> Maybe Event -> Bool
forall a. Eq a => a -> a -> Bool
== Event -> Maybe Event
forall a. a -> Maybe a
Just (Name -> Event
EventEndElement Name
n)
            then Element -> ConduitT EventPos o m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> ConduitT EventPos o m Element)
-> Element -> ConduitT EventPos o m Element
forall a b. (a -> b) -> a -> b
$ Name -> [(Name, [Content])] -> [Node] -> Element
Element Name
n [(Name, [Content])]
as ([Node] -> Element) -> [Node] -> Element
forall a b. (a -> b) -> a -> b
$ [Node] -> [Node]
compressNodes [Node]
ns
            else m Element -> ConduitT EventPos o m Element
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Element -> ConduitT EventPos o m Element)
-> m Element -> ConduitT EventPos o m Element
forall a b. (a -> b) -> a -> b
$ InvalidEventStream -> m Element
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (InvalidEventStream -> m Element)
-> InvalidEventStream -> m Element
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 <- ConduitT EventPos o m (Maybe EventPos)
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) -> (Node -> Maybe Node
forall a. a -> Maybe a
Just (Node -> Maybe Node) -> (Element -> Node) -> Element -> Maybe Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Node
NodeElement) (Element -> Maybe Node)
-> ConduitT EventPos o m Element
-> ConduitT EventPos o m (Maybe Node)
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) -> Maybe Node -> ConduitT EventPos o m (Maybe Node)
forall (m :: * -> *) a i o. Monad m => a -> ConduitM i o m a
dropReturn (Maybe Node -> ConduitT EventPos o m (Maybe Node))
-> Maybe Node -> ConduitT EventPos o m (Maybe Node)
forall a b. (a -> b) -> a -> b
$ Node -> Maybe Node
forall a. a -> Maybe a
Just (Node -> Maybe Node) -> Node -> Maybe Node
forall a b. (a -> b) -> a -> b
$ Instruction -> Node
NodeInstruction Instruction
i
            Just (Maybe PositionRange
_, EventContent Content
c) -> Maybe Node -> ConduitT EventPos o m (Maybe Node)
forall (m :: * -> *) a i o. Monad m => a -> ConduitM i o m a
dropReturn (Maybe Node -> ConduitT EventPos o m (Maybe Node))
-> Maybe Node -> ConduitT EventPos o m (Maybe Node)
forall a b. (a -> b) -> a -> b
$ Node -> Maybe Node
forall a. a -> Maybe a
Just (Node -> Maybe Node) -> Node -> Maybe Node
forall a b. (a -> b) -> a -> b
$ Content -> Node
NodeContent Content
c
            Just (Maybe PositionRange
_, EventComment Text
t) -> Maybe Node -> ConduitT EventPos o m (Maybe Node)
forall (m :: * -> *) a i o. Monad m => a -> ConduitM i o m a
dropReturn (Maybe Node -> ConduitT EventPos o m (Maybe Node))
-> Maybe Node -> ConduitT EventPos o m (Maybe Node)
forall a b. (a -> b) -> a -> b
$ Node -> Maybe Node
forall a. a -> Maybe a
Just (Node -> Maybe Node) -> Node -> Maybe Node
forall a b. (a -> b) -> a -> b
$ Text -> Node
NodeComment Text
t
            Just (Maybe PositionRange
_, EventCDATA Text
t) -> Maybe Node -> ConduitT EventPos o m (Maybe Node)
forall (m :: * -> *) a i o. Monad m => a -> ConduitM i o m a
dropReturn (Maybe Node -> ConduitT EventPos o m (Maybe Node))
-> Maybe Node -> ConduitT EventPos o m (Maybe Node)
forall a b. (a -> b) -> a -> b
$ Node -> Maybe Node
forall a. a -> Maybe a
Just (Node -> Maybe Node) -> Node -> Maybe Node
forall a b. (a -> b) -> a -> b
$ Content -> Node
NodeContent (Content -> Node) -> Content -> Node
forall a b. (a -> b) -> a -> b
$ Text -> Content
ContentText Text
t
            Maybe EventPos
_ -> Maybe Node -> ConduitT EventPos o m (Maybe Node)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Node
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 Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
:)
    ([Event] -> [Event]) -> ([Event] -> [Event]) -> [Event] -> [Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prologue -> [Event] -> [Event]
goP Prologue
prol ([Event] -> [Event]) -> ([Event] -> [Event]) -> [Event] -> [Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> [Event] -> [Event]
elementToEvents' Element
root ([Event] -> [Event]) -> ([Event] -> [Event]) -> [Event] -> [Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Miscellaneous] -> [Event] -> [Event]
goM [Miscellaneous]
epi ([Event] -> [Event]) -> [Event] -> [Event]
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 ([Event] -> [Event]) -> ([Event] -> [Event]) -> [Event] -> [Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Event] -> [Event])
-> (Doctype -> [Event] -> [Event])
-> Maybe Doctype
-> [Event]
-> [Event]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Event] -> [Event]
forall a. a -> a
id Doctype -> [Event] -> [Event]
goD Maybe Doctype
doctype ([Event] -> [Event]) -> ([Event] -> [Event]) -> [Event] -> [Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Miscellaneous] -> [Event] -> [Event]
goM [Miscellaneous]
after
    goM :: [Miscellaneous] -> [Event] -> [Event]
goM []     = [Event] -> [Event]
forall a. a -> a
id
    goM [Miscellaneous
x]    = (Miscellaneous -> Event
goM' Miscellaneous
x Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
:)
    goM (Miscellaneous
x:[Miscellaneous]
xs) = (Miscellaneous -> Event
goM' Miscellaneous
x Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
:) ([Event] -> [Event]) -> ([Event] -> [Event]) -> [Event] -> [Event]
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)
      ([Event] -> [Event]) -> ([Event] -> [Event]) -> [Event] -> [Event]
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 Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
:)
        ([Event] -> [Event]) -> ([Event] -> [Event]) -> [Event] -> [Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node] -> [Event] -> [Event]
goN [Node]
ns
        ([Event] -> [Event]) -> ([Event] -> [Event]) -> [Event] -> [Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Event
EventEndElement Name
name Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
:)
    goN :: [Node] -> [Event] -> [Event]
goN []     = [Event] -> [Event]
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 ([Event] -> [Event]) -> ([Event] -> [Event]) -> [Event] -> [Event]
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 Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
:)
    goN' (NodeContent Content
c)     = (Content -> Event
EventContent Content
c Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
:)
    goN' (NodeComment Text
t)     = (Text -> Event
EventComment Text
t Event -> [Event] -> [Event]
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) = (Node -> Bool) -> [Node] -> ([Node], [Node])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Text -> Bool) -> (Node -> Maybe Text) -> Node -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> Maybe Text
unContent) (Node
xNode -> [Node] -> [Node]
forall a. a -> [a] -> [a]
:Node
yNode -> [Node] -> [Node]
forall a. a -> [a] -> [a]
:[Node]
z)
        texts :: [Text]
texts = (Node -> Maybe Text) -> [Node] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Node -> Maybe Text
unContent [Node]
textNodes
    in
        [Node] -> [Node]
compressNodes ([Node] -> [Node]) -> [Node] -> [Node]
forall a b. (a -> b) -> a -> b
$ Content -> Node
NodeContent (Text -> Content
ContentText (Text -> Content) -> Text -> Content
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [Text]
texts) Node -> [Node] -> [Node]
forall a. a -> [a] -> [a]
: [Node]
remainder
    where
        unContent :: Node -> Maybe Text
unContent (NodeContent (ContentText Text
text)) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
text
        unContent Node
_                                = Maybe Text
forall a. Maybe a
Nothing
compressNodes (Node
x:[Node]
xs) = Node
x Node -> [Node] -> [Node]
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 =
    ConduitT () Void (Either SomeException) Document
-> Either SomeException Document
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit
  (ConduitT () Void (Either SomeException) Document
 -> Either SomeException Document)
-> ConduitT () Void (Either SomeException) Document
-> Either SomeException Document
forall a b. (a -> b) -> a -> b
$ [Text] -> ConduitT () Text (Either SomeException) ()
forall (m :: * -> *) a i. Monad m => [a] -> ConduitT i a m ()
CL.sourceList (Text -> [Text]
TL.toChunks Text
tl)
 ConduitT () Text (Either SomeException) ()
-> ConduitM Text Void (Either SomeException) Document
-> ConduitT () Void (Either SomeException) Document
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ParseSettings -> ConduitM Text Void (Either SomeException) Document
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 = (SomeException -> Document)
-> (Document -> Document)
-> Either SomeException Document
-> Document
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> Document
forall a e. Exception e => e -> a
throw Document -> Document
forall a. a -> a
id (Either SomeException Document -> Document)
-> (Text -> Either SomeException Document) -> Text -> Document
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 :: ParseSettings -> ConduitT Text o m Document
sinkTextDoc ParseSettings
ps = ParseSettings -> ConduitT Text EventPos m ()
forall (m :: * -> *).
MonadThrow m =>
ParseSettings -> ConduitT Text EventPos m ()
P.parseTextPos ParseSettings
ps ConduitT Text EventPos m ()
-> ConduitM EventPos o m Document -> ConduitT Text o m Document
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM EventPos o m Document
forall (m :: * -> *) o.
MonadThrow m =>
ConduitT EventPos o m Document
fromEvents