module Text.XML.Expat.Annotated (
Node,
NodeG(..),
UNode,
LNode,
ULNode,
module Text.XML.Expat.NodeClass,
unannotate,
modifyAnnotation,
mapAnnotation,
QName(..),
QNode,
QAttributes,
QLNode,
toQualified,
fromQualified,
NName (..),
NNode,
NAttributes,
NLNode,
mkNName,
mkAnNName,
toNamespaced,
fromNamespaced,
xmlnsUri,
xmlns,
Tree.ParserOptions(..),
Tree.defaultParserOptions,
Encoding(..),
parse,
parse',
XMLParseError(..),
XMLParseLocation(..),
parseThrowing,
XMLParseException(..),
SAXEvent(..),
saxToTree,
GenericXMLString(..),
eAttrs,
parseSAX,
parseSAXThrowing,
parseSAXLocations,
parseSAXLocationsThrowing,
parseTree,
parseTree',
parseTreeThrowing
) where
import Control.Arrow
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 Text.XML.Expat.NodeClass
import Control.Monad (mplus, mzero)
import Control.Parallel.Strategies
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import Data.List.Class
import Data.Monoid
data NodeG a c tag text =
Element {
eName :: !tag,
eAttributes :: ![(tag,text)],
eChildren :: c (NodeG a c tag text),
eAnn :: a
} |
Text !text
type Node a = NodeG a []
instance (Show tag, Show text, Show a) => Show (NodeG a [] tag text) where
show (Element na at ch an) = "Element "++show na++" "++show at++" "++show ch++" "++show an
show (Text t) = "Text "++show t
instance (Eq tag, Eq text, Eq a) => Eq (NodeG a [] tag text) where
Element na1 at1 ch1 an1 == Element na2 at2 ch2 an2 =
na1 == na2 &&
at1 == at2 &&
ch1 == ch2 &&
an1 == an2
Text t1 == Text t2 = t1 == t2
_ == _ = False
eAttrs :: Node a tag text -> [(tag, text)]
eAttrs = eAttributes
instance (NFData tag, NFData text, NFData a) => NFData (NodeG a [] tag text) where
rnf (Element nam att chi ann) = rnf (nam, att, chi, ann)
rnf (Text txt) = rnf txt
instance (Functor c, List c) => NodeClass (NodeG a) c where
textContentM (Element _ _ children _) = foldlL mappend mempty $ joinM $ fmap textContentM children
textContentM (Text txt) = return txt
isElement (Element _ _ _ _) = True
isElement _ = False
isText (Text _) = True
isText _ = False
isNamed _ (Text _) = False
isNamed nm (Element nm' _ _ _) = nm == nm'
getName (Text _) = mempty
getName (Element name _ _ _) = name
getAttributes (Text _) = []
getAttributes (Element _ attrs _ _) = attrs
getChildren (Text _) = mzero
getChildren (Element _ _ ch _) = ch
getText (Text txt) = txt
getText (Element _ _ _ _) = mempty
modifyName _ node@(Text _) = node
modifyName f (Element n a c ann) = Element (f n) a c ann
modifyAttributes _ node@(Text _) = node
modifyAttributes f (Element n a c ann) = Element n (f a) c ann
modifyChildren _ node@(Text _) = node
modifyChildren f (Element n a c ann) = Element n a (f c) ann
mapAllTags _ (Text t) = Text t
mapAllTags f (Element n a c ann) = Element (f n) (map (first f) a) (fmap (mapAllTags f) c) ann
mapElement _ (Text t) = Text t
mapElement f (Element n a c ann) =
let (n', a', c') = f (n, a, c)
in Element n' a' c' ann
mapNodeContainer f (Element n a ch an) = do
ch' <- f ch
return $ Element n a ch' an
mapNodeContainer _ (Text t) = return $ Text t
mkText = Text
instance (Functor c, List c) => MkElementClass (NodeG (Maybe a)) c where
mkElement name attrs children = Element name attrs children Nothing
unannotate :: Functor c => NodeG a c tag text -> Tree.NodeG c tag text
unannotate (Element na at ch _) = (Tree.Element na at (fmap unannotate ch))
unannotate (Text t) = Tree.Text t
type UNode a text = Node a text text
type LNode tag text = Node XMLParseLocation tag text
type ULNode text = LNode text text
type QNode a text = Node a (QName text) text
type QLNode text = LNode (QName text) text
type NNode text a = Node a (NName text) text
type NLNode text = LNode (NName text) text
modifyAnnotation :: (a -> a) -> Node a tag text -> Node a tag text
f `modifyAnnotation` Element na at ch an = Element na at ch (f an)
_ `modifyAnnotation` Text t = Text t
mapAnnotation :: (a -> b) -> Node a tag text -> Node b tag text
f `mapAnnotation` Element na at ch an = Element na at (map (f `mapAnnotation`) ch) (f an)
_ `mapAnnotation` Text t = Text t
saxToTree :: GenericXMLString tag =>
[(SAXEvent tag text, a)]
-> (Node a tag text, 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):rema) =
let (children, err1, rema') = ptl rema
elt = Element name attrs children ann
(out, err2, rema'') = ptl rema'
in (elt:out, err1 `mplus` err2, rema'')
ptl ((EndElement _, _):rema) = ([], Nothing, rema)
ptl ((CharacterData txt, _):rema) =
let (out, err, rema') = ptl rema
in (Text txt:out, err, rema')
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)