module Text.XML.Expat.Annotated (
Node(..),
Attributes,
Nodes,
UNode,
UNodes,
UAttributes,
LNode,
LNodes,
ULNode,
ULNodes,
textContent,
unannotate,
QName(..),
QNode,
QNodes,
QAttributes,
QLNode,
QLNodes,
NName (..),
NNode,
NNodes,
NAttributes,
NLNode,
NLNodes,
mkNName,
mkAnNName,
xmlnsUri,
xmlns,
parseTree,
parseTree',
Encoding(..),
XMLParseError(..),
XMLParseLocation(..),
parseSAX,
SAXEvent(..),
saxToTree,
parseSAXLocations,
XMLParseException(..),
parseTreeThrowing,
parseSAXThrowing,
parseSAXLocationsThrowing,
GenericXMLString(..)
) where
import Text.XML.Expat.Tree hiding (Node(..), Nodes, UNode, UNodes, saxToTree,
parseTree, parseTree', parseTreeThrowing, textContent)
import qualified Text.XML.Expat.Tree as Tree (Node(..))
import Text.XML.Expat.Qualified hiding (QNode, QNodes)
import Text.XML.Expat.Namespaced hiding (NNode, NNodes)
import Control.Monad (mplus)
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)
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 Nodes tag text a = [Node tag text a]
type UNodes text a = Nodes text text a
type UNode text a = Node text text a
type LNode tag text = Node tag text XMLParseLocation
type LNodes tag text = [Node tag text XMLParseLocation]
type ULNode text = LNode text text
type ULNodes text = LNodes text text
type QNodes text a = Nodes (QName text) text a
type QLNodes text = LNodes (QName text) text
type QNode text a = Node (QName text) text a
type QLNode text = LNode (QName text) text
type NNodes text a = Nodes (NName text) text a
type NLNodes text = LNodes (NName 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, [])
parseTree :: (GenericXMLString tag, GenericXMLString text) =>
Maybe Encoding
-> L.ByteString
-> (LNode tag text, Maybe XMLParseError)
parseTree mEnc bs = saxToTree $ parseSAXLocations mEnc bs
parseTreeThrowing :: (GenericXMLString tag, GenericXMLString text) =>
Maybe Encoding
-> L.ByteString
-> LNode tag text
parseTreeThrowing mEnc bs = fst $ saxToTree $ parseSAXLocationsThrowing mEnc bs
parseTree' :: (GenericXMLString tag, GenericXMLString text) =>
Maybe Encoding
-> B.ByteString
-> Either XMLParseError (LNode tag text)
parseTree' mEnc bs = case parseTree mEnc (L.fromChunks [bs]) of
(_, Just err) -> Left err
(root, Nothing) -> Right root