{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeFamilies,
        FlexibleContexts, ScopedTypeVariables #-}
-- | A variant of /Node/ in which Element nodes have an annotation of any type,
-- and some concrete functions that annotate with the XML parse location.
--
-- The names conflict with those in /Tree/ so you must use qualified import
-- if you want to use both modules.
module Text.XML.Expat.Annotated (
  -- * Tree structure
  Node,
  NodeG(..),
  UNode,
  LNode,
  ULNode,

  -- * Generic node manipulation
  module Text.XML.Expat.Internal.NodeClass,

  -- * Annotation-specific
  modifyAnnotation,
  mapAnnotation,

  -- * Qualified nodes
  QNode,
  QLNode,
  module Text.XML.Expat.Internal.Qualified,

  -- * Namespaced nodes
  NNode,
  NLNode,
  module Text.XML.Expat.Internal.Namespaced,

  -- * Parse to tree
  ParseOptions(..),
  defaultParseOptions,
  Encoding(..),
  parse,
  parse',
  parseG,
  XMLParseError(..),
  XMLParseLocation(..),

  -- * Variant that throws exceptions
  parseThrowing,
  XMLParseException(..),

  -- * Convert from SAX
  saxToTree,
  saxToTreeG,

  -- * Abstraction of string types
  GenericXMLString(..)
  ) where

import Control.Arrow (first)
import Text.XML.Expat.SAX ( Encoding(..)
                          , GenericXMLString(..)
                          , ParseOptions(..)
                          , defaultParseOptions
                          , SAXEvent(..)
                          , XMLParseError(..)
                          , XMLParseException(..)
                          , XMLParseLocation(..) )
import qualified Text.XML.Expat.SAX as SAX
import Text.XML.Expat.Internal.Namespaced
import Text.XML.Expat.Internal.NodeClass
import Text.XML.Expat.Internal.Qualified

import Control.Monad (mplus, mzero)
import Control.DeepSeq
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import Data.List.Class (List(..), ListItem(..), cons, foldlL, joinM)
import Data.Monoid


-- | Annotated variant of the tree representation of the XML document, meaning
-- that it has an extra piece of information of your choice attached to each
-- Element.
--
-- @c@ is the container type for the element's children, which would normally be [],
-- but could potentially be a monadic list type to allow for chunked I/O.
--
-- @tag@ is the tag type, which can either be one of several string types,
-- or a special type from the @Text.XML.Expat.Namespaced@ or
-- @Text.XML.Expat.Qualified@ modules.
--
-- @text@ is the string type for text content.
--
-- @a@ is the type of the annotation.  One of the things this can be used for
-- is to store the XML parse location, which is useful for error handling.
--
-- Note that some functions in the @Text.XML.Expat.Cursor@ module need to create
-- new nodes through the 'MkElementClass' type class. Normally this can only be done
-- if @a@ is a Maybe type or () (so it can provide the Nothing value for the annotation
-- on newly created nodes).  Or, you can write your own 'MkElementClass' instance.
-- Apart from that, there is no requirement for @a@ to be a Maybe type.
data NodeG a c tag text =
    Element {
        forall a (c :: * -> *) tag text. NodeG a c tag text -> tag
eName       :: !tag,
        forall a (c :: * -> *) tag text.
NodeG a c tag text -> [(tag, text)]
eAttributes :: ![(tag,text)],
        forall a (c :: * -> *) tag text.
NodeG a c tag text -> c (NodeG a c tag text)
eChildren   :: c (NodeG a c tag text),
        forall a (c :: * -> *) tag text. NodeG a c tag text -> a
eAnn        :: a
    } |
    Text !text

type instance ListOf (NodeG a c tag text) = c (NodeG a c tag text)

-- | A pure tree representation that uses a list as its container type,
-- annotated variant.
--
-- In the @hexpat@ package, a list of nodes has the type @[Node tag text]@, but note
-- that you can also use the more general type function 'ListOf' to give a list of
-- any node type, using that node's associated list type, e.g.
-- @ListOf (UNode Text)@.
type Node a tag text = NodeG a [] tag text

instance (Show tag, Show text, Show a) => Show (NodeG a [] tag text) where
    showsPrec :: Int -> NodeG a [] tag text -> ShowS
showsPrec Int
d (Element tag
na [(tag, text)]
at [NodeG a [] tag text]
ch a
an) = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
        (String
"Element "String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> tag -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 tag
na ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
" "String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                         Int -> [(tag, text)] -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 [(tag, text)]
at ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
" "String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                         Int -> [NodeG a [] tag text] -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 [NodeG a [] tag text]
ch ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
" "String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                         Int -> a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 a
an
    showsPrec Int
d (Text text
t) = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (String
"Text "String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> text -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 text
t

instance (Eq tag, Eq text, Eq a) => Eq (NodeG a [] tag text) where
    Element tag
na1 [(tag, text)]
at1 [NodeG a [] tag text]
ch1 a
an1 == :: NodeG a [] tag text -> NodeG a [] tag text -> Bool
== Element tag
na2 [(tag, text)]
at2 [NodeG a [] tag text]
ch2 a
an2 =
        tag
na1 tag -> tag -> Bool
forall a. Eq a => a -> a -> Bool
== tag
na2 Bool -> Bool -> Bool
&&
        [(tag, text)]
at1 [(tag, text)] -> [(tag, text)] -> Bool
forall a. Eq a => a -> a -> Bool
== [(tag, text)]
at2 Bool -> Bool -> Bool
&&
        [NodeG a [] tag text]
ch1 [NodeG a [] tag text] -> [NodeG a [] tag text] -> Bool
forall a. Eq a => a -> a -> Bool
== [NodeG a [] tag text]
ch2 Bool -> Bool -> Bool
&&
        a
an1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
an2
    Text text
t1 == Text text
t2 = text
t1 text -> text -> Bool
forall a. Eq a => a -> a -> Bool
== text
t2
    NodeG a [] tag text
_ == NodeG a [] tag text
_ = Bool
False

instance (NFData tag, NFData text, NFData a) => NFData (NodeG a [] tag text) where
    rnf :: NodeG a [] tag text -> ()
rnf (Element tag
nam [(tag, text)]
att [NodeG a [] tag text]
chi a
ann) = (tag, [(tag, text)], [NodeG a [] tag text], a) -> ()
forall a. NFData a => a -> ()
rnf (tag
nam, [(tag, text)]
att, [NodeG a [] tag text]
chi, a
ann)
    rnf (Text text
txt) = text -> ()
forall a. NFData a => a -> ()
rnf text
txt

instance (Functor c, List c) => NodeClass (NodeG a) c where
    textContentM :: forall text tag. Monoid text => NodeG a c tag text -> ItemM c text
textContentM (Element tag
_ [(tag, text)]
_ c (NodeG a c tag text)
children a
_) = (text -> text -> text) -> text -> c text -> ItemM c text
forall (l :: * -> *) a b.
List l =>
(a -> b -> a) -> a -> l b -> ItemM l a
foldlL text -> text -> text
forall a. Monoid a => a -> a -> a
mappend text
forall a. Monoid a => a
mempty (c text -> ItemM c text) -> c text -> ItemM c text
forall a b. (a -> b) -> a -> b
$ c (ItemM c text) -> c text
forall (l :: * -> *) a. List l => l (ItemM l a) -> l a
joinM (c (ItemM c text) -> c text) -> c (ItemM c text) -> c text
forall a b. (a -> b) -> a -> b
$ (NodeG a c tag text -> ItemM c text)
-> c (NodeG a c tag text) -> c (ItemM c text)
forall a b. (a -> b) -> c a -> c b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NodeG a c tag text -> ItemM c text
forall text tag. Monoid text => NodeG a c tag text -> ItemM c text
forall (n :: (* -> *) -> * -> * -> *) (c :: * -> *) text tag.
(NodeClass n c, Monoid text) =>
n c tag text -> ItemM c text
textContentM c (NodeG a c tag text)
children
    textContentM (Text text
txt) = text -> ItemM c text
forall a. a -> ItemM c a
forall (m :: * -> *) a. Monad m => a -> m a
return text
txt
    
    isElement :: forall tag text. NodeG a c tag text -> Bool
isElement (Element tag
_ [(tag, text)]
_ c (NodeG a c tag text)
_ a
_) = Bool
True
    isElement NodeG a c tag text
_                 = Bool
False
    
    isText :: forall tag text. NodeG a c tag text -> Bool
isText (Text text
_) = Bool
True
    isText NodeG a c tag text
_        = Bool
False

    isCData :: forall tag text. NodeG a c tag text -> Bool
isCData NodeG a c tag text
_ = Bool
False
    isProcessingInstruction :: forall tag text. NodeG a c tag text -> Bool
isProcessingInstruction NodeG a c tag text
_ = Bool
False
    isComment :: forall tag text. NodeG a c tag text -> Bool
isComment NodeG a c tag text
_ = Bool
False

    isNamed :: forall tag text. Eq tag => tag -> NodeG a c tag text -> Bool
isNamed tag
_  (Text text
_) = Bool
False
    isNamed tag
nm (Element tag
nm' [(tag, text)]
_ c (NodeG a c tag text)
_ a
_) = tag
nm tag -> tag -> Bool
forall a. Eq a => a -> a -> Bool
== tag
nm'

    getName :: forall tag text. Monoid tag => NodeG a c tag text -> tag
getName (Text text
_)             = tag
forall a. Monoid a => a
mempty
    getName (Element tag
name [(tag, text)]
_ c (NodeG a c tag text)
_ a
_) = tag
name

    hasTarget :: forall text tag. Eq text => text -> NodeG a c tag text -> Bool
hasTarget text
_ NodeG a c tag text
_ = Bool
False
    getTarget :: forall text tag. Monoid text => NodeG a c tag text -> text
getTarget NodeG a c tag text
_ = text
forall a. Monoid a => a
mempty

    getAttributes :: forall tag text. NodeG a c tag text -> [(tag, text)]
getAttributes (Text text
_)              = []
    getAttributes (Element tag
_ [(tag, text)]
attrs c (NodeG a c tag text)
_ a
_) = [(tag, text)]
attrs

    getChildren :: forall tag text. NodeG a c tag text -> c (NodeG a c tag text)
getChildren (Text text
_)           = c (NodeG a c tag text)
forall a. c a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    getChildren (Element tag
_ [(tag, text)]
_ c (NodeG a c tag text)
ch a
_) = c (NodeG a c tag text)
ch

    getText :: forall text tag. Monoid text => NodeG a c tag text -> text
getText (Text text
txt) = text
txt
    getText (Element tag
_ [(tag, text)]
_ c (NodeG a c tag text)
_ a
_) = text
forall a. Monoid a => a
mempty

    modifyName :: forall tag text.
(tag -> tag) -> NodeG a c tag text -> NodeG a c tag text
modifyName tag -> tag
_ node :: NodeG a c tag text
node@(Text text
_) = NodeG a c tag text
node
    modifyName tag -> tag
f (Element tag
n [(tag, text)]
a c (NodeG a c tag text)
c a
ann) = tag
-> [(tag, text)]
-> c (NodeG a c tag text)
-> a
-> NodeG a c tag text
forall a (c :: * -> *) tag text.
tag
-> [(tag, text)]
-> c (NodeG a c tag text)
-> a
-> NodeG a c tag text
Element (tag -> tag
f tag
n) [(tag, text)]
a c (NodeG a c tag text)
c a
ann

    modifyAttributes :: forall tag text.
([(tag, text)] -> [(tag, text)])
-> NodeG a c tag text -> NodeG a c tag text
modifyAttributes [(tag, text)] -> [(tag, text)]
_ node :: NodeG a c tag text
node@(Text text
_) = NodeG a c tag text
node
    modifyAttributes [(tag, text)] -> [(tag, text)]
f (Element tag
n [(tag, text)]
a c (NodeG a c tag text)
c a
ann) = tag
-> [(tag, text)]
-> c (NodeG a c tag text)
-> a
-> NodeG a c tag text
forall a (c :: * -> *) tag text.
tag
-> [(tag, text)]
-> c (NodeG a c tag text)
-> a
-> NodeG a c tag text
Element tag
n ([(tag, text)] -> [(tag, text)]
f [(tag, text)]
a) c (NodeG a c tag text)
c a
ann

    modifyChildren :: forall tag text.
(c (NodeG a c tag text) -> c (NodeG a c tag text))
-> NodeG a c tag text -> NodeG a c tag text
modifyChildren c (NodeG a c tag text) -> c (NodeG a c tag text)
_ node :: NodeG a c tag text
node@(Text text
_) = NodeG a c tag text
node
    modifyChildren c (NodeG a c tag text) -> c (NodeG a c tag text)
f (Element tag
n [(tag, text)]
a c (NodeG a c tag text)
c a
ann) = tag
-> [(tag, text)]
-> c (NodeG a c tag text)
-> a
-> NodeG a c tag text
forall a (c :: * -> *) tag text.
tag
-> [(tag, text)]
-> c (NodeG a c tag text)
-> a
-> NodeG a c tag text
Element tag
n [(tag, text)]
a (c (NodeG a c tag text) -> c (NodeG a c tag text)
f c (NodeG a c tag text)
c) a
ann

    mapAllTags :: forall tag tag' text.
(tag -> tag') -> NodeG a c tag text -> NodeG a c tag' text
mapAllTags tag -> tag'
_ (Text text
t) = text -> NodeG a c tag' text
forall a (c :: * -> *) tag text. text -> NodeG a c tag text
Text text
t
    mapAllTags tag -> tag'
f (Element tag
n [(tag, text)]
a c (NodeG a c tag text)
c a
ann) = tag'
-> [(tag', text)]
-> c (NodeG a c tag' text)
-> a
-> NodeG a c tag' text
forall a (c :: * -> *) tag text.
tag
-> [(tag, text)]
-> c (NodeG a c tag text)
-> a
-> NodeG a c tag text
Element (tag -> tag'
f tag
n) (((tag, text) -> (tag', text)) -> [(tag, text)] -> [(tag', text)]
forall a b. (a -> b) -> [a] -> [b]
map ((tag -> tag') -> (tag, text) -> (tag', text)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first tag -> tag'
f) [(tag, text)]
a) ((NodeG a c tag text -> NodeG a c tag' text)
-> c (NodeG a c tag text) -> c (NodeG a c tag' text)
forall a b. (a -> b) -> c a -> c b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((tag -> tag') -> NodeG a c tag text -> NodeG a c tag' text
forall tag tag' text.
(tag -> tag') -> NodeG a c tag text -> NodeG a c tag' text
forall (n :: (* -> *) -> * -> * -> *) (c :: * -> *) tag tag' text.
NodeClass n c =>
(tag -> tag') -> n c tag text -> n c tag' text
mapAllTags tag -> tag'
f) c (NodeG a c tag text)
c) a
ann

    modifyElement :: forall tag text tag'.
((tag, [(tag, text)], c (NodeG a c tag text))
 -> (tag', [(tag', text)], c (NodeG a c tag' text)))
-> NodeG a c tag text -> NodeG a c tag' text
modifyElement (tag, [(tag, text)], c (NodeG a c tag text))
-> (tag', [(tag', text)], c (NodeG a c tag' text))
_ (Text text
t) = text -> NodeG a c tag' text
forall a (c :: * -> *) tag text. text -> NodeG a c tag text
Text text
t
    modifyElement (tag, [(tag, text)], c (NodeG a c tag text))
-> (tag', [(tag', text)], c (NodeG a c tag' text))
f (Element tag
n [(tag, text)]
a c (NodeG a c tag text)
c a
ann) =
        let (tag'
n', [(tag', text)]
a', c (NodeG a c tag' text)
c') = (tag, [(tag, text)], c (NodeG a c tag text))
-> (tag', [(tag', text)], c (NodeG a c tag' text))
f (tag
n, [(tag, text)]
a, c (NodeG a c tag text)
c)
        in  tag'
-> [(tag', text)]
-> c (NodeG a c tag' text)
-> a
-> NodeG a c tag' text
forall a (c :: * -> *) tag text.
tag
-> [(tag, text)]
-> c (NodeG a c tag text)
-> a
-> NodeG a c tag text
Element tag'
n' [(tag', text)]
a' c (NodeG a c tag' text)
c' a
ann

    mapNodeContainer :: forall (c' :: * -> *) tag text.
List c' =>
(forall a. c a -> ItemM c (c' a))
-> NodeG a c tag text -> ItemM c (NodeG a c' tag text)
mapNodeContainer forall a. c a -> ItemM c (c' a)
f (Element tag
n [(tag, text)]
a c (NodeG a c tag text)
ch a
an) = do
        c' (NodeG a c' tag text)
ch' <- (forall a. c a -> ItemM c (c' a))
-> c (NodeG a c tag text) -> ItemM c (c' (NodeG a c' tag text))
forall (n :: (* -> *) -> * -> * -> *) (c :: * -> *) (c' :: * -> *)
       tag text.
(NodeClass n c, List c') =>
(forall a. c a -> ItemM c (c' a))
-> c (n c tag text) -> ItemM c (c' (n c' tag text))
mapNodeListContainer c a -> ItemM c (c' a)
forall a. c a -> ItemM c (c' a)
f c (NodeG a c tag text)
ch
        NodeG a c' tag text -> ItemM c (NodeG a c' tag text)
forall a. a -> ItemM c a
forall (m :: * -> *) a. Monad m => a -> m a
return (NodeG a c' tag text -> ItemM c (NodeG a c' tag text))
-> NodeG a c' tag text -> ItemM c (NodeG a c' tag text)
forall a b. (a -> b) -> a -> b
$ tag
-> [(tag, text)]
-> c' (NodeG a c' tag text)
-> a
-> NodeG a c' tag text
forall a (c :: * -> *) tag text.
tag
-> [(tag, text)]
-> c (NodeG a c tag text)
-> a
-> NodeG a c tag text
Element tag
n [(tag, text)]
a c' (NodeG a c' tag text)
ch' a
an
    mapNodeContainer forall a. c a -> ItemM c (c' a)
_ (Text text
t) = NodeG a c' tag text -> ItemM c (NodeG a c' tag text)
forall a. a -> ItemM c a
forall (m :: * -> *) a. Monad m => a -> m a
return (NodeG a c' tag text -> ItemM c (NodeG a c' tag text))
-> NodeG a c' tag text -> ItemM c (NodeG a c' tag text)
forall a b. (a -> b) -> a -> b
$ text -> NodeG a c' tag text
forall a (c :: * -> *) tag text. text -> NodeG a c tag text
Text text
t

    mkText :: forall text tag. text -> NodeG a c tag text
mkText = text -> NodeG a c tag text
forall a (c :: * -> *) tag text. text -> NodeG a c tag text
Text

instance (Functor c, List c) => MkElementClass (NodeG (Maybe a)) c where
    mkElement :: forall tag text.
tag
-> Attributes tag text
-> c (NodeG (Maybe a) c tag text)
-> NodeG (Maybe a) c tag text
mkElement tag
name Attributes tag text
attrs c (NodeG (Maybe a) c tag text)
children = tag
-> Attributes tag text
-> c (NodeG (Maybe a) c tag text)
-> Maybe a
-> NodeG (Maybe a) c tag text
forall a (c :: * -> *) tag text.
tag
-> [(tag, text)]
-> c (NodeG a c tag text)
-> a
-> NodeG a c tag text
Element tag
name Attributes tag text
attrs c (NodeG (Maybe a) c tag text)
children Maybe a
forall a. Maybe a
Nothing

instance (Functor c, List c) => MkElementClass (NodeG ()) c where
    mkElement :: forall tag text.
tag
-> Attributes tag text
-> c (NodeG () c tag text)
-> NodeG () c tag text
mkElement tag
name Attributes tag text
attrs c (NodeG () c tag text)
children = tag
-> Attributes tag text
-> c (NodeG () c tag text)
-> ()
-> NodeG () c tag text
forall a (c :: * -> *) tag text.
tag
-> [(tag, text)]
-> c (NodeG a c tag text)
-> a
-> NodeG a c tag text
Element tag
name Attributes tag text
attrs c (NodeG () c tag text)
children ()

-- | Type alias for an annotated node with unqualified tag names where
-- tag and text are the same string type
type UNode a text = Node a text text

-- | Type alias for an annotated node, annotated with parse location
type LNode tag text = Node XMLParseLocation tag text

-- | Type alias for an annotated node with unqualified tag names where
-- tag and text are the same string type, annotated with parse location
type ULNode text = LNode text text 

-- | Type alias for an annotated node where qualified names are used for tags
type QNode a text = Node a (QName text) text

-- | Type alias for an annotated node where qualified names are used for tags, annotated with parse location
type QLNode text = LNode (QName text) text

-- | Type alias for an annotated node where namespaced names are used for tags
type NNode a text = Node a (NName text) text

-- | Type alias for an annotated node where namespaced names are used for tags, annotated with parse location
type NLNode text = LNode (NName text) text

-- | Modify this node's annotation (non-recursively) if it's an element, otherwise no-op.
modifyAnnotation :: (a -> a) -> Node a tag text -> Node a tag text
a -> a
f modifyAnnotation :: forall a tag text. (a -> a) -> Node a tag text -> Node a tag text
`modifyAnnotation` Element tag
na [(tag, text)]
at [NodeG a [] tag text]
ch a
an = tag
-> [(tag, text)]
-> [NodeG a [] tag text]
-> a
-> NodeG a [] tag text
forall a (c :: * -> *) tag text.
tag
-> [(tag, text)]
-> c (NodeG a c tag text)
-> a
-> NodeG a c tag text
Element tag
na [(tag, text)]
at [NodeG a [] tag text]
ch (a -> a
f a
an)
a -> a
_ `modifyAnnotation` Text text
t = text -> NodeG a [] tag text
forall a (c :: * -> *) tag text. text -> NodeG a c tag text
Text text
t

-- | Modify this node's annotation and all its children recursively if it's an element, otherwise no-op.
mapAnnotation :: (a -> b) -> Node a tag text -> Node b tag text
a -> b
f mapAnnotation :: forall a b tag text. (a -> b) -> Node a tag text -> Node b tag text
`mapAnnotation` Element tag
na [(tag, text)]
at [NodeG a [] tag text]
ch a
an = tag
-> [(tag, text)]
-> [NodeG b [] tag text]
-> b
-> NodeG b [] tag text
forall a (c :: * -> *) tag text.
tag
-> [(tag, text)]
-> c (NodeG a c tag text)
-> a
-> NodeG a c tag text
Element tag
na [(tag, text)]
at ((NodeG a [] tag text -> NodeG b [] tag text)
-> [NodeG a [] tag text] -> [NodeG b [] tag text]
forall a b. (a -> b) -> [a] -> [b]
map (a -> b
f (a -> b) -> NodeG a [] tag text -> NodeG b [] tag text
forall a b tag text. (a -> b) -> Node a tag text -> Node b tag text
`mapAnnotation`) [NodeG a [] tag text]
ch) (a -> b
f a
an)
a -> b
_ `mapAnnotation` Text text
t = text -> NodeG b [] tag text
forall a (c :: * -> *) tag text. text -> NodeG a c tag text
Text text
t

-- | A lower level function that lazily converts a SAX stream into a tree structure.
-- Variant that takes annotations for start tags.
saxToTree :: GenericXMLString tag =>
             [(SAXEvent tag text, a)]
          -> (Node a tag text, Maybe XMLParseError)
saxToTree :: forall tag text a.
GenericXMLString tag =>
[(SAXEvent tag text, a)] -> (Node a tag text, Maybe XMLParseError)
saxToTree [(SAXEvent tag text, a)]
events =
    let ([NodeG a [] tag text]
nodes, Maybe XMLParseError
mError, [(SAXEvent tag text, a)]
_) = [(SAXEvent tag text, a)]
-> ([NodeG a [] tag text], Maybe XMLParseError,
    [(SAXEvent tag text, a)])
forall {tag} {text} {a}.
[(SAXEvent tag text, a)]
-> ([NodeG a [] tag text], Maybe XMLParseError,
    [(SAXEvent tag text, a)])
ptl [(SAXEvent tag text, a)]
events
    in  ([NodeG a [] tag text] -> NodeG a [] tag text
forall {tag} {a} {text}.
GenericXMLString tag =>
[NodeG a [] tag text] -> NodeG a [] tag text
findRoot [NodeG a [] tag text]
nodes, Maybe XMLParseError
mError)
  where
    findRoot :: [NodeG a [] tag text] -> NodeG a [] tag text
findRoot (elt :: NodeG a [] tag text
elt@(Element tag
_ [(tag, text)]
_ [NodeG a [] tag text]
_ a
_):[NodeG a [] tag text]
_) = NodeG a [] tag text
elt
    findRoot (NodeG a [] tag text
_:[NodeG a [] tag text]
nodes) = [NodeG a [] tag text] -> NodeG a [] tag text
findRoot [NodeG a [] tag text]
nodes
    findRoot [] = tag
-> [(tag, text)]
-> [NodeG a [] tag text]
-> a
-> NodeG a [] tag text
forall a (c :: * -> *) tag text.
tag
-> [(tag, text)]
-> c (NodeG a c tag text)
-> a
-> NodeG a c tag text
Element (String -> tag
forall s. GenericXMLString s => String -> s
gxFromString String
"") [] [] (String -> a
forall a. HasCallStack => String -> a
error String
"saxToTree null annotation")
    ptl :: [(SAXEvent tag text, a)]
-> ([NodeG a [] tag text], Maybe XMLParseError,
    [(SAXEvent tag text, a)])
ptl ((StartElement tag
name [(tag, text)]
attrs, a
ann):[(SAXEvent tag text, a)]
rema) =
        let ([NodeG a [] tag text]
children, Maybe XMLParseError
err1, [(SAXEvent tag text, a)]
rema') = [(SAXEvent tag text, a)]
-> ([NodeG a [] tag text], Maybe XMLParseError,
    [(SAXEvent tag text, a)])
ptl [(SAXEvent tag text, a)]
rema
            elt :: NodeG a [] tag text
elt = tag
-> [(tag, text)]
-> [NodeG a [] tag text]
-> a
-> NodeG a [] tag text
forall a (c :: * -> *) tag text.
tag
-> [(tag, text)]
-> c (NodeG a c tag text)
-> a
-> NodeG a c tag text
Element tag
name [(tag, text)]
attrs [NodeG a [] tag text]
children a
ann
            ([NodeG a [] tag text]
out, Maybe XMLParseError
err2, [(SAXEvent tag text, a)]
rema'') = [(SAXEvent tag text, a)]
-> ([NodeG a [] tag text], Maybe XMLParseError,
    [(SAXEvent tag text, a)])
ptl [(SAXEvent tag text, a)]
rema'
        in  (NodeG a [] tag text
eltNodeG a [] tag text
-> [NodeG a [] tag text] -> [NodeG a [] tag text]
forall a. a -> [a] -> [a]
:[NodeG a [] tag text]
out, Maybe XMLParseError
err1 Maybe XMLParseError -> Maybe XMLParseError -> Maybe XMLParseError
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe XMLParseError
err2, [(SAXEvent tag text, a)]
rema'')
    ptl ((EndElement tag
_, a
_):[(SAXEvent tag text, a)]
rema) = ([], Maybe XMLParseError
forall a. Maybe a
Nothing, [(SAXEvent tag text, a)]
rema)
    ptl ((CharacterData text
txt, a
_):[(SAXEvent tag text, a)]
rema) =
        let ([NodeG a [] tag text]
out, Maybe XMLParseError
err, [(SAXEvent tag text, a)]
rema') = [(SAXEvent tag text, a)]
-> ([NodeG a [] tag text], Maybe XMLParseError,
    [(SAXEvent tag text, a)])
ptl [(SAXEvent tag text, a)]
rema
        in  (text -> NodeG a [] tag text
forall a (c :: * -> *) tag text. text -> NodeG a c tag text
Text text
txtNodeG a [] tag text
-> [NodeG a [] tag text] -> [NodeG a [] tag text]
forall a. a -> [a] -> [a]
:[NodeG a [] tag text]
out, Maybe XMLParseError
err, [(SAXEvent tag text, a)]
rema')
    ptl ((FailDocument XMLParseError
err, a
_):[(SAXEvent tag text, a)]
_) = ([], XMLParseError -> Maybe XMLParseError
forall a. a -> Maybe a
Just XMLParseError
err, [])
    ptl ((SAXEvent tag text, a)
_:[(SAXEvent tag text, a)]
rema) = [(SAXEvent tag text, a)]
-> ([NodeG a [] tag text], Maybe XMLParseError,
    [(SAXEvent tag text, a)])
ptl [(SAXEvent tag text, a)]
rema  -- extended node types not supported in this tree type
    ptl [] = ([], Maybe XMLParseError
forall a. Maybe a
Nothing, [])

-- | A lower level function that converts a generalized SAX stream into a tree structure.
-- Ignores parse errors.
saxToTreeG :: forall l a tag text . (GenericXMLString tag, List l, Monad (ItemM l)) =>
              l (SAXEvent tag text, a)
           -> ItemM l (NodeG a l tag text)
saxToTreeG :: forall (l :: * -> *) a tag text.
(GenericXMLString tag, List l, Monad (ItemM l)) =>
l (SAXEvent tag text, a) -> ItemM l (NodeG a l tag text)
saxToTreeG l (SAXEvent tag text, a)
events = do
    (l (NodeG a l tag text)
elts, l (SAXEvent tag text, a)
_) <- l (SAXEvent tag text, a)
-> ItemM l (l (NodeG a l tag text), l (SAXEvent tag text, a))
process l (SAXEvent tag text, a)
events
    l (NodeG a l tag text) -> ItemM l (NodeG a l tag text)
findRoot l (NodeG a l tag text)
elts
  where
    findRoot :: l (NodeG a l tag text) -> ItemM l (NodeG a l tag text)
    findRoot :: l (NodeG a l tag text) -> ItemM l (NodeG a l tag text)
findRoot l (NodeG a l tag text)
elts = do
        ListItem l (NodeG a l tag text)
li <- l (NodeG a l tag text) -> ItemM l (ListItem l (NodeG a l tag text))
forall a. l a -> ItemM l (ListItem l a)
forall (l :: * -> *) a. List l => l a -> ItemM l (ListItem l a)
runList l (NodeG a l tag text)
elts
        case ListItem l (NodeG a l tag text)
li of
            Cons elt :: NodeG a l tag text
elt@(Element tag
_ [(tag, text)]
_ l (NodeG a l tag text)
_ a
_) l (NodeG a l tag text)
_ -> NodeG a l tag text -> ItemM l (NodeG a l tag text)
forall a. a -> ItemM l a
forall (m :: * -> *) a. Monad m => a -> m a
return NodeG a l tag text
elt
            Cons NodeG a l tag text
_ l (NodeG a l tag text)
rema -> l (NodeG a l tag text) -> ItemM l (NodeG a l tag text)
findRoot l (NodeG a l tag text)
rema
            ListItem l (NodeG a l tag text)
Nil -> NodeG a l tag text -> ItemM l (NodeG a l tag text)
forall a. a -> ItemM l a
forall (m :: * -> *) a. Monad m => a -> m a
return (NodeG a l tag text -> ItemM l (NodeG a l tag text))
-> NodeG a l tag text -> ItemM l (NodeG a l tag text)
forall a b. (a -> b) -> a -> b
$ tag
-> [(tag, text)]
-> l (NodeG a l tag text)
-> a
-> NodeG a l tag text
forall a (c :: * -> *) tag text.
tag
-> [(tag, text)]
-> c (NodeG a c tag text)
-> a
-> NodeG a c tag text
Element (String -> tag
forall s. GenericXMLString s => String -> s
gxFromString String
"") [(tag, text)]
forall a. [a]
forall (m :: * -> *) a. MonadPlus m => m a
mzero l (NodeG a l tag text)
forall a. l a
forall (m :: * -> *) a. MonadPlus m => m a
mzero (String -> a
forall a. HasCallStack => String -> a
error String
"saxToTree null annotation")
    process :: l (SAXEvent tag text, a)
            -> ItemM l (l (NodeG a l tag text), l (SAXEvent tag text, a))
    process :: l (SAXEvent tag text, a)
-> ItemM l (l (NodeG a l tag text), l (SAXEvent tag text, a))
process l (SAXEvent tag text, a)
events = do
        ListItem l (SAXEvent tag text, a)
li <- l (SAXEvent tag text, a)
-> ItemM l (ListItem l (SAXEvent tag text, a))
forall a. l a -> ItemM l (ListItem l a)
forall (l :: * -> *) a. List l => l a -> ItemM l (ListItem l a)
runList l (SAXEvent tag text, a)
events
        case ListItem l (SAXEvent tag text, a)
li of
            ListItem l (SAXEvent tag text, a)
Nil -> (l (NodeG a l tag text), l (SAXEvent tag text, a))
-> ItemM l (l (NodeG a l tag text), l (SAXEvent tag text, a))
forall a. a -> ItemM l a
forall (m :: * -> *) a. Monad m => a -> m a
return (l (NodeG a l tag text)
forall a. l a
forall (m :: * -> *) a. MonadPlus m => m a
mzero, l (SAXEvent tag text, a)
forall a. l a
forall (m :: * -> *) a. MonadPlus m => m a
mzero)
            Cons (StartElement tag
name [(tag, text)]
attrs, a
ann) l (SAXEvent tag text, a)
rema -> do
                (l (NodeG a l tag text)
children, l (SAXEvent tag text, a)
rema') <- l (SAXEvent tag text, a)
-> ItemM l (l (NodeG a l tag text), l (SAXEvent tag text, a))
process l (SAXEvent tag text, a)
rema
                (l (NodeG a l tag text)
out, l (SAXEvent tag text, a)
rema'') <- l (SAXEvent tag text, a)
-> ItemM l (l (NodeG a l tag text), l (SAXEvent tag text, a))
process l (SAXEvent tag text, a)
rema'
                (l (NodeG a l tag text), l (SAXEvent tag text, a))
-> ItemM l (l (NodeG a l tag text), l (SAXEvent tag text, a))
forall a. a -> ItemM l a
forall (m :: * -> *) a. Monad m => a -> m a
return (tag
-> [(tag, text)]
-> l (NodeG a l tag text)
-> a
-> NodeG a l tag text
forall a (c :: * -> *) tag text.
tag
-> [(tag, text)]
-> c (NodeG a c tag text)
-> a
-> NodeG a c tag text
Element tag
name [(tag, text)]
attrs l (NodeG a l tag text)
children a
ann NodeG a l tag text
-> l (NodeG a l tag text) -> l (NodeG a l tag text)
forall a. a -> l a -> l a
forall (l :: * -> *) a. List l => a -> l a -> l a
`cons` l (NodeG a l tag text)
out, l (SAXEvent tag text, a)
rema'')
            Cons (EndElement tag
_, a
_) l (SAXEvent tag text, a)
rema -> (l (NodeG a l tag text), l (SAXEvent tag text, a))
-> ItemM l (l (NodeG a l tag text), l (SAXEvent tag text, a))
forall a. a -> ItemM l a
forall (m :: * -> *) a. Monad m => a -> m a
return (l (NodeG a l tag text)
forall a. l a
forall (m :: * -> *) a. MonadPlus m => m a
mzero, l (SAXEvent tag text, a)
rema)
            Cons (CharacterData text
txt, a
_) l (SAXEvent tag text, a)
rema -> do
                (l (NodeG a l tag text)
out, l (SAXEvent tag text, a)
rema') <- l (SAXEvent tag text, a)
-> ItemM l (l (NodeG a l tag text), l (SAXEvent tag text, a))
process l (SAXEvent tag text, a)
rema
                (l (NodeG a l tag text), l (SAXEvent tag text, a))
-> ItemM l (l (NodeG a l tag text), l (SAXEvent tag text, a))
forall a. a -> ItemM l a
forall (m :: * -> *) a. Monad m => a -> m a
return (text -> NodeG a l tag text
forall a (c :: * -> *) tag text. text -> NodeG a c tag text
Text text
txt NodeG a l tag text
-> l (NodeG a l tag text) -> l (NodeG a l tag text)
forall a. a -> l a -> l a
forall (l :: * -> *) a. List l => a -> l a -> l a
`cons` l (NodeG a l tag text)
out, l (SAXEvent tag text, a)
rema')
            --Cons (FailDocument err) rema = (mzero, mzero)
            Cons (SAXEvent tag text, a)
_ l (SAXEvent tag text, a)
rema -> l (SAXEvent tag text, a)
-> ItemM l (l (NodeG a l tag text), l (SAXEvent tag text, a))
process l (SAXEvent tag text, a)
rema

-- | Lazily parse XML to tree. Note that forcing the XMLParseError return value
-- will force the entire parse.  Therefore, to ensure lazy operation, don't
-- check the error status until you have processed the tree.
parse :: (GenericXMLString tag, GenericXMLString text) =>
         ParseOptions tag text    -- ^ Parse options
      -> L.ByteString             -- ^ Input text (a lazy ByteString)
      -> (LNode tag text, Maybe XMLParseError)
parse :: forall tag text.
(GenericXMLString tag, GenericXMLString text) =>
ParseOptions tag text
-> ByteString -> (LNode tag text, Maybe XMLParseError)
parse ParseOptions tag text
opts ByteString
bs = [(SAXEvent tag text, XMLParseLocation)]
-> (Node XMLParseLocation tag text, Maybe XMLParseError)
forall tag text a.
GenericXMLString tag =>
[(SAXEvent tag text, a)] -> (Node a tag text, Maybe XMLParseError)
saxToTree ([(SAXEvent tag text, XMLParseLocation)]
 -> (Node XMLParseLocation tag text, Maybe XMLParseError))
-> [(SAXEvent tag text, XMLParseLocation)]
-> (Node XMLParseLocation tag text, Maybe XMLParseError)
forall a b. (a -> b) -> a -> b
$ ParseOptions tag text
-> ByteString -> [(SAXEvent tag text, XMLParseLocation)]
forall tag text.
(GenericXMLString tag, GenericXMLString text) =>
ParseOptions tag text
-> ByteString -> [(SAXEvent tag text, XMLParseLocation)]
SAX.parseLocations ParseOptions tag text
opts ByteString
bs

-- | Parse a generalized list to a tree, ignoring parse errors.
-- This function allows for a parse from an enumerator/iteratee to a "lazy"
-- tree structure using the @List-enumerator@ package.
parseG :: (GenericXMLString tag, GenericXMLString text, List l) =>
          ParseOptions tag text  -- ^ Parse options
       -> l ByteString           -- ^ Input text as a generalized list of blocks
       -> ItemM l (NodeG XMLParseLocation l tag text)
parseG :: forall tag text (l :: * -> *).
(GenericXMLString tag, GenericXMLString text, List l) =>
ParseOptions tag text
-> l ByteString -> ItemM l (NodeG XMLParseLocation l tag text)
parseG ParseOptions tag text
opts = l (SAXEvent tag text, XMLParseLocation)
-> ItemM l (NodeG XMLParseLocation l tag text)
forall (l :: * -> *) a tag text.
(GenericXMLString tag, List l, Monad (ItemM l)) =>
l (SAXEvent tag text, a) -> ItemM l (NodeG a l tag text)
saxToTreeG (l (SAXEvent tag text, XMLParseLocation)
 -> ItemM l (NodeG XMLParseLocation l tag text))
-> (l ByteString -> l (SAXEvent tag text, XMLParseLocation))
-> l ByteString
-> ItemM l (NodeG XMLParseLocation l tag text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseOptions tag text
-> l ByteString -> l (SAXEvent tag text, XMLParseLocation)
forall tag text (l :: * -> *).
(GenericXMLString tag, GenericXMLString text, List l) =>
ParseOptions tag text
-> l ByteString -> l (SAXEvent tag text, XMLParseLocation)
SAX.parseLocationsG ParseOptions tag text
opts

-- | Lazily parse XML to tree. In the event of an error, throw 'XMLParseException'.
--
-- @parseThrowing@ can throw an exception from pure code, which is generally a bad
-- way to handle errors, because Haskell\'s lazy evaluation means it\'s hard to
-- predict where it will be thrown from.  However, it may be acceptable in
-- situations where it's not expected during normal operation, depending on the
-- design of your program.
parseThrowing :: (GenericXMLString tag, GenericXMLString text) =>
                 ParseOptions tag text    -- ^ Parse options
              -> L.ByteString             -- ^ Input text (a lazy ByteString)
              -> LNode tag text
parseThrowing :: forall tag text.
(GenericXMLString tag, GenericXMLString text) =>
ParseOptions tag text -> ByteString -> LNode tag text
parseThrowing ParseOptions tag text
opts ByteString
bs = (LNode tag text, Maybe XMLParseError) -> LNode tag text
forall a b. (a, b) -> a
fst ((LNode tag text, Maybe XMLParseError) -> LNode tag text)
-> (LNode tag text, Maybe XMLParseError) -> LNode tag text
forall a b. (a -> b) -> a -> b
$ [(SAXEvent tag text, XMLParseLocation)]
-> (LNode tag text, Maybe XMLParseError)
forall tag text a.
GenericXMLString tag =>
[(SAXEvent tag text, a)] -> (Node a tag text, Maybe XMLParseError)
saxToTree ([(SAXEvent tag text, XMLParseLocation)]
 -> (LNode tag text, Maybe XMLParseError))
-> [(SAXEvent tag text, XMLParseLocation)]
-> (LNode tag text, Maybe XMLParseError)
forall a b. (a -> b) -> a -> b
$ ParseOptions tag text
-> ByteString -> [(SAXEvent tag text, XMLParseLocation)]
forall tag text.
(GenericXMLString tag, GenericXMLString text) =>
ParseOptions tag text
-> ByteString -> [(SAXEvent tag text, XMLParseLocation)]
SAX.parseLocationsThrowing ParseOptions tag text
opts ByteString
bs

-- | Strictly parse XML to tree. Returns error message or valid parsed tree.
parse' :: (GenericXMLString tag, GenericXMLString text) =>
          ParseOptions tag text   -- ^ Parse options
       -> B.ByteString            -- ^ Input text (a strict ByteString)
       -> Either XMLParseError (LNode tag text)
parse' :: forall tag text.
(GenericXMLString tag, GenericXMLString text) =>
ParseOptions tag text
-> ByteString -> Either XMLParseError (LNode tag text)
parse' ParseOptions tag text
opts ByteString
doc = case ParseOptions tag text
-> ByteString -> (LNode tag text, Maybe XMLParseError)
forall tag text.
(GenericXMLString tag, GenericXMLString text) =>
ParseOptions tag text
-> ByteString -> (LNode tag text, Maybe XMLParseError)
parse ParseOptions tag text
opts ([ByteString] -> ByteString
L.fromChunks [ByteString
doc]) of
    (LNode tag text
xml, Maybe XMLParseError
Nothing) -> LNode tag text -> Either XMLParseError (LNode tag text)
forall a b. b -> Either a b
Right LNode tag text
xml
    (LNode tag text
_, Just XMLParseError
err)  -> XMLParseError -> Either XMLParseError (LNode tag text)
forall a b. a -> Either a b
Left XMLParseError
err