module Text.XML.Expat.Annotated (
Node(..),
Attributes,
UNode,
UAttributes,
LNode,
ULNode,
textContent,
unannotate,
QName(..),
QNode,
QAttributes,
QLNode,
NName (..),
NNode,
NAttributes,
NLNode,
mkNName,
mkAnNName,
xmlnsUri,
xmlns,
parseSAX,
parseSAXThrowing,
parseSAXLocations,
parseSAXLocationsThrowing,
parseTree,
parseTree',
parseTreeThrowing,
Encoding(..),
XMLParseError(..),
XMLParseLocation(..),
parse,
parse',
parseThrowing,
SAXEvent(..),
saxToTree,
XMLParseException(..),
GenericXMLString(..)
) where
import Text.XML.Expat.Tree ( Attributes, UAttributes )
import qualified Text.XML.Expat.Tree as Tree
import Text.XML.Expat.SAX ( Encoding(..)
, GenericXMLString(..)
, ParserOptions(..)
, SAXEvent(..)
, XMLParseError(..)
, XMLParseException(..)
, XMLParseLocation(..)
, parseSAX
, parseSAXThrowing
, parseSAXLocations
, parseSAXLocationsThrowing )
import qualified Text.XML.Expat.SAX as SAX
import Text.XML.Expat.Qualified hiding (QNode, QNodes)
import Text.XML.Expat.Namespaced hiding (NNode, NNodes)
import Control.Monad (mplus)
import Control.Parallel.Strategies
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import Data.Monoid
data Node tag text a =
Element {
eName :: !tag,
eAttrs :: ![(tag,text)],
eChildren :: [Node tag text a],
eAnn :: a
} |
Text !text
deriving (Eq, Show)
instance (NFData tag, NFData text, NFData a) => NFData (Node tag text a) where
rnf (Element nam att chi ann) = rnf (nam, att, chi, ann)
rnf (Text txt) = rnf txt
unannotate :: Node tag text a -> Tree.Node tag text
unannotate (Element na at ch _) = (Tree.Element na at (map unannotate ch))
unannotate (Text t) = Tree.Text t
textContent :: Monoid text => Node tag text a -> text
textContent (Element _ _ children _) = mconcat $ map textContent children
textContent (Text txt) = txt
type UNode text a = Node text text a
type LNode tag text = Node tag text XMLParseLocation
type ULNode text = LNode text text
type QNode text a = Node (QName text) text a
type QLNode text = LNode (QName text) text
type NNode text a = Node (NName text) text a
type NLNode text = LNode (NName text) text
instance Functor (Node tag text) where
f `fmap` Element na at ch an = Element na at (map (f `fmap`) ch) (f an)
f `fmap` Text t = Text t
saxToTree :: GenericXMLString tag =>
[(SAXEvent tag text, a)]
-> (Node tag text a, Maybe XMLParseError)
saxToTree events =
let (nodes, mError, _) = ptl events
in (safeHead nodes, mError)
where
safeHead (a:_) = a
safeHead [] = Element (gxFromString "") [] [] (error "saxToTree null annotation")
ptl ((StartElement name attrs, ann):rem) =
let (children, err1, rem') = ptl rem
elt = Element name attrs children ann
(out, err2, rem'') = ptl rem'
in (elt:out, err1 `mplus` err2, rem'')
ptl ((EndElement name, _):rem) = ([], Nothing, rem)
ptl ((CharacterData txt, _):rem) =
let (out, err, rem') = ptl rem
in (Text txt:out, err, rem')
ptl ((FailDocument err, _):_) = ([], Just err, [])
ptl [] = ([], Nothing, [])
parse :: (GenericXMLString tag, GenericXMLString text) =>
ParserOptions tag text
-> L.ByteString
-> (LNode tag text, Maybe XMLParseError)
parse opts bs = saxToTree $ SAX.parseLocations opts bs
parseTree :: (GenericXMLString tag, GenericXMLString text) =>
Maybe Encoding
-> L.ByteString
-> (LNode tag text, Maybe XMLParseError)
parseTree mEnc = parse (ParserOptions mEnc Nothing)
parseThrowing :: (GenericXMLString tag, GenericXMLString text) =>
ParserOptions tag text
-> L.ByteString
-> LNode tag text
parseThrowing opts bs = fst $ saxToTree $ SAX.parseLocationsThrowing opts bs
parseTreeThrowing :: (GenericXMLString tag, GenericXMLString text) =>
Maybe Encoding
-> L.ByteString
-> LNode tag text
parseTreeThrowing mEnc = parseThrowing (ParserOptions mEnc Nothing)
parse' :: (GenericXMLString tag, GenericXMLString text) =>
ParserOptions tag text
-> B.ByteString
-> Either XMLParseError (LNode tag text)
parse' opts bs = case parse opts (L.fromChunks [bs]) of
(_, Just err) -> Left err
(root, Nothing) -> Right root
parseTree' :: (GenericXMLString tag, GenericXMLString text) =>
Maybe Encoding
-> B.ByteString
-> Either XMLParseError (LNode tag text)
parseTree' mEnc = parse' (ParserOptions mEnc Nothing)