module Text.XML.Expat.Annotated (
Node,
NodeG(..),
UNode,
LNode,
ULNode,
module Text.XML.Expat.Internal.NodeClass,
modifyAnnotation,
mapAnnotation,
QNode,
QLNode,
module Text.XML.Expat.Internal.Qualified,
NNode,
NLNode,
module Text.XML.Expat.Internal.Namespaced,
ParseOptions(..),
defaultParseOptions,
Encoding(..),
parse,
parse',
XMLParseError(..),
XMLParseLocation(..),
parseThrowing,
XMLParseException(..),
saxToTree,
GenericXMLString(..),
eAttrs,
parseSAX,
parseSAXThrowing,
parseSAXLocations,
parseSAXLocationsThrowing,
parseTree,
parseTree',
parseTreeThrowing,
unannotate,
ParserOptions,
defaultParserOptions
) where
import Control.Arrow
import qualified Text.XML.Expat.Tree as Tree
import Text.XML.Expat.SAX ( Encoding(..)
, GenericXMLString(..)
, ParseOptions(..)
, defaultParseOptions
, SAXEvent(..)
, XMLParseError(..)
, XMLParseException(..)
, XMLParseLocation(..)
, parseSAX
, parseSAXThrowing
, parseSAXLocations
, parseSAXLocationsThrowing
, ParserOptions
, defaultParserOptions )
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 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 instance ListOf (NodeG a c tag text) = c (NodeG a c tag text)
type Node a tag text = NodeG a [] tag text
instance (Show tag, Show text, Show a) => Show (NodeG a [] tag text) where
showsPrec d (Element na at ch an) = showParen (d > 10) $
("Element "++) . showsPrec 11 na . (" "++) .
showsPrec 11 at . (" "++) .
showsPrec 11 ch . (" "++) .
showsPrec 11 an
showsPrec d (Text t) = showParen (d > 10) $ ("Text "++) . showsPrec 11 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
isCData _ = False
isProcessingInstruction _ = False
isComment _ = False
isNamed _ (Text _) = False
isNamed nm (Element nm' _ _ _) = nm == nm'
getName (Text _) = mempty
getName (Element name _ _ _) = name
hasTarget _ _ = False
getTarget _ = mempty
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
modifyElement _ (Text t) = Text t
modifyElement 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' <- mapNodeListContainer 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
instance (Functor c, List c) => MkElementClass (NodeG ()) c where
mkElement name attrs children = Element name attrs children ()
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 a text = 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 (findRoot nodes, mError)
where
findRoot (elt@(Element _ _ _ _):_) = elt
findRoot (_:nodes) = findRoot nodes
findRoot [] = 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 (_:rema) = ptl rema
ptl [] = ([], Nothing, [])
parse :: (GenericXMLString tag, GenericXMLString text) =>
ParseOptions 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 (ParseOptions mEnc Nothing)
parseThrowing :: (GenericXMLString tag, GenericXMLString text) =>
ParseOptions 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 (ParseOptions mEnc Nothing)
parse' :: (GenericXMLString tag, GenericXMLString text) =>
ParseOptions 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' (ParseOptions mEnc Nothing)