hexpat 0.15.1 → 0.16

raw patch · 16 files changed

+1049/−963 lines, 16 filesdep +transformersdep −mtldep ~ListPVP ok

version bump matches the API change (PVP)

Dependencies added: transformers

Dependencies removed: mtl

Dependency ranges changed: List

API changes (from Hackage documentation)

Files

• Text/XML/Expat/Annotated.hs +32/−34
• Text/XML/Expat/Cursor.hs +2/−1
• Text/XML/Expat/Format.hs +1/−1
• Text/XML/Expat/IO.hs +7/−523
• Text/XML/Expat/Internal/IO.hs +525/−0
• Text/XML/Expat/Internal/Namespaced.hs +157/−0
• Text/XML/Expat/Internal/NodeClass.hs +161/−0
• Text/XML/Expat/Internal/Qualified.hs +70/−0
• Text/XML/Expat/Namespaced.hs +6/−164
• Text/XML/Expat/NodeClass.hs +7/−113
• Text/XML/Expat/Proc.hs +2/−16
• Text/XML/Expat/Qualified.hs +6/−78
• Text/XML/Expat/SAX.hs +2/−2
• Text/XML/Expat/Tree.hs +49/−14
• hexpat.cabal +20/−15
• test/hexpat-tests.cabal +2/−2

@@ -14,36 +14,25 @@   ULNode,    -- * Generic node manipulation-  module Text.XML.Expat.NodeClass,+  module Text.XML.Expat.Internal.NodeClass,    -- * Annotation-specific-  unannotate,   modifyAnnotation,   mapAnnotation,    -- * Qualified nodes-  QName(..),   QNode,-  QAttributes,   QLNode,-  toQualified,-  fromQualified,+  module Text.XML.Expat.Internal.Qualified,    -- * Namespaced nodes-  NName (..),   NNode,-  NAttributes,   NLNode,-  mkNName,-  mkAnNName,-  toNamespaced,-  fromNamespaced,-  xmlnsUri,-  xmlns,+  module Text.XML.Expat.Internal.Namespaced,    -- * Parse to tree-  Tree.ParserOptions(..),-  Tree.defaultParserOptions,+  ParserOptions(..),+  defaultParserOptions,   Encoding(..),   parse,   parse',@@ -69,14 +58,16 @@   parseSAXLocationsThrowing,   parseTree,   parseTree',-  parseTreeThrowing-) where+  parseTreeThrowing,+  unannotate+  ) where  import Control.Arrow import qualified Text.XML.Expat.Tree as Tree import Text.XML.Expat.SAX ( Encoding(..)                           , GenericXMLString(..)                           , ParserOptions(..)+                          , defaultParserOptions                           , SAXEvent(..)                           , XMLParseError(..)                           , XMLParseException(..)@@ -86,9 +77,9 @@                           , 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 Text.XML.Expat.Internal.Namespaced+import Text.XML.Expat.Internal.NodeClass+import Text.XML.Expat.Internal.Qualified  import Control.Monad (mplus, mzero) import Control.Parallel.Strategies@@ -102,8 +93,8 @@ -- 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 is usually [],--- except when you are using chunked I\/O with the @hexpat-iteratee@ package.+-- @c@ is the container type for the element's children, which is [] in the+-- @hexpat@ package, and a monadic list type for @hexpat-iteratee@. -- -- @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@@ -128,9 +119,16 @@     } |     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.-type Node a = NodeG a []+--+-- 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     show (Element na at ch an) = "Element "++show na++" "++show at++" "++show ch++" "++show an@@ -206,33 +204,33 @@     mkElement name attrs children = Element name attrs children Nothing  -- | Convert an annotated tree (/Annotated/ module) into a non-annotated--- tree (/Tree/ module).  Needed, for example, when you @format@ your tree to--- XML, since @format@ takes a non-annotated tree.+-- tree (/Tree/ module).  DEPRECATED in favour of 'fromElement'. unannotate :: Functor c => NodeG a c tag text -> Tree.NodeG c tag text+{-# DEPRECATED unannotate "use fromElement instead" #-} unannotate (Element na at ch _) = (Tree.Element na at (fmap unannotate ch)) unannotate (Text t) = Tree.Text t --- | Type shortcut for a single annotated node with unqualified tag names where+-- | Type alias for a single annotated node with unqualified tag names where -- tag and text are the same string type type UNode a text = Node a text text --- | Type shortcut for a single annotated node, annotated with parse location+-- | Type alias for a single annotated node, annotated with parse location type LNode tag text = Node XMLParseLocation tag text --- | Type shortcut for a single node with unqualified tag names where+-- | Type alias for a single 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 shortcut for a single annotated node where qualified names are used for tags+-- | Type alias for a single annotated node where qualified names are used for tags type QNode a text = Node a (QName text) text --- | Type shortcut for a single node where qualified names are used for tags, annotated with parse location+-- | Type alias for a single node where qualified names are used for tags, annotated with parse location type QLNode text = LNode (QName text) text --- | Type shortcut for a single annotated node where namespaced names are used for tags-type NNode text a = Node a (NName text) text+-- | Type alias for a single annotated node where namespaced names are used for tags+type NNode a text = Node a (NName text) text --- | Type shortcut for a single node where namespaced names are used for tags, annotated with parse location+-- | Type alias for a single 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.

@@ -93,9 +93,10 @@   ) where  import Text.XML.Expat.Tree+import Control.Monad (mzero, mplus) import Data.Maybe(isNothing) import Data.Monoid-import Control.Monad.Identity+import Data.Functor.Identity import Data.List.Class  data Tag tag text = Tag { tagName    :: tag

@@ -27,7 +27,7 @@         indent_     ) where -import Text.XML.Expat.NodeClass+import Text.XML.Expat.Internal.NodeClass import Text.XML.Expat.SAX  import Control.Monad

@@ -1,525 +1,9 @@-{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}---- hexpat, a Haskell wrapper for expat--- Copyright (C) 2008 Evan Martin <martine@danga.com>--- Copyright (C) 2009 Stephen Blackheath <http://blacksapphire.com/antispam>---- | Low-level interface to Expat. Unless speed is paramount, this should--- normally be avoided in favour of the interfaces provided by--- 'Text.XML.Expat.SAX' and 'Text.XML.Expat.Tree'.  Basic usage is:------ (1) Make a new parser: 'newParser'.------ (2) Set up callbacks on the parser: 'setStartElementHandler', etc.------ (3) Feed data into the parser: 'parse', 'parse'' or 'parseChunk'.  Some of---     these functions must be wrapped in 'withParser'.--module Text.XML.Expat.IO (-  -- ** Parser Setup-  Parser, newParser,--  -- ** Parsing-  parse, parse',-  withParser,-  ParserPtr, Parser_struct,-  parseChunk,-  Encoding(..),-  XMLParseError(..),-  getParseLocation,-  XMLParseLocation(..),--  -- ** Parser Callbacks-  StartElementHandler,-  EndElementHandler,-  CharacterDataHandler,-  ExternalEntityRefHandler,-  SkippedEntityHandler,-  setStartElementHandler,-  setEndElementHandler,-  setCharacterDataHandler,-  setExternalEntityRefHandler,-  setSkippedEntityHandler,-  setUseForeignDTD,--  -- ** Lower-level interface-  parseExternalEntityReference,-  ExpatHandlers,--  -- ** Helpers-  encodingToString-) where--import Control.Exception (bracket)-import Control.Parallel.Strategies-import Control.Monad-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as BSL-import Data.IORef-import Foreign-import Foreign.C----- |Opaque parser type.-data Parser_struct-type ParserPtr = Ptr Parser_struct-data Parser = Parser-    { _parserObj                :: ForeignPtr Parser_struct-    , _startElementHandler      :: IORef CStartElementHandler-    , _endElementHandler        :: IORef CEndElementHandler-    , _cdataHandler             :: IORef CCharacterDataHandler-    , _externalEntityRefHandler :: IORef (Maybe CExternalEntityRefHandler)-    , _skippedEntityHandler     :: IORef (Maybe CSkippedEntityHandler)-    }--instance Show Parser where-    showsPrec _ (Parser fp _ _ _ _ _) = showsPrec 0 fp---- |Encoding types available for the document encoding.-data Encoding = ASCII | UTF8 | UTF16 | ISO88591-encodingToString :: Encoding -> String-encodingToString ASCII    = "US-ASCII"-encodingToString UTF8     = "UTF-8"-encodingToString UTF16    = "UTF-16"-encodingToString ISO88591 = "ISO-8859-1"--withOptEncoding :: Maybe Encoding -> (CString -> IO a) -> IO a-withOptEncoding Nothing    f = f nullPtr-withOptEncoding (Just enc) f = withCString (encodingToString enc) f---parserCreate :: Maybe Encoding -> IO (ParserPtr)-parserCreate a1 =-  withOptEncoding a1 $ \a1' -> do-      pp <- parserCreate'_ a1'-      xmlSetUserData pp pp-      return pp---- | Create a 'Parser'.-newParser :: Maybe Encoding -> IO Parser-newParser enc = do-  ptr        <- parserCreate enc-  fptr       <- newForeignPtr parserFree ptr-  nullStartH <- newIORef nullCStartElementHandler-  nullEndH   <- newIORef nullCEndElementHandler-  nullCharH  <- newIORef nullCCharacterDataHandler-  extH       <- newIORef Nothing-  skipH      <- newIORef Nothing--  return $ Parser fptr nullStartH nullEndH nullCharH extH skipH--setUseForeignDTD :: Parser -> Bool -> IO ()-setUseForeignDTD p b = withParser p $ \p' -> xmlUseForeignDTD p' b'-  where-    b' = if b then 1 else 0---- ByteString.useAsCStringLen is almost what we need, but C2HS wants a CInt--- instead of an Int.-withBStringLen :: BS.ByteString -> ((CString, CInt) -> IO a) -> IO a-withBStringLen bs f = do-  BS.useAsCStringLen bs $ \(str, len) -> f (str, fromIntegral len)--unStatus :: CInt -> Bool-unStatus 0 = False-unStatus _ = True---- |@parse data@ feeds /lazy/ ByteString data into a 'Parser'. It returns--- Nothing on success, or Just the parse error.-parse :: Parser -> BSL.ByteString -> IO (Maybe XMLParseError)-parse parser bs = withParser parser $ \pp -> do-    let-        doParseChunks [] = doParseChunk pp BS.empty True-        doParseChunks (c:cs) = do-            ok <- doParseChunk pp c False-            if ok-                then doParseChunks cs-                else return False-    ok <- doParseChunks (BSL.toChunks bs)-    if ok-        then return Nothing-        else Just `fmap` getError pp---- |@parse data@ feeds /strict/ ByteString data into a 'Parser'. It returns--- Nothing on success, or Just the parse error.-parse' :: Parser -> BS.ByteString -> IO (Maybe XMLParseError)-parse' parser bs = withParser parser $ \pp -> do-    ok <- doParseChunk pp bs True-    if ok-        then return Nothing-        else Just `fmap` getError pp--parseExternalEntityReference :: Parser-                             -> CString         -- ^ context-                             -> Maybe Encoding  -- ^ encoding-                             -> CStringLen      -- ^ text-                             -> IO Bool-parseExternalEntityReference parser context encoding (text,sz) =-    withParser parser $ \pp -> do-        extp <- withOptEncoding encoding $-                xmlExternalEntityParserCreate pp context-        e <- doParseChunk'_ extp text (fromIntegral sz) 1-        parserFree' extp-        return $ e == 1---- |@parseChunk data False@ feeds /strict/ ByteString data into a--- 'Parser'.  The end of the data is indicated by passing @True@ for the--- final parameter.   It returns Nothing on success, or Just the parse error.-parseChunk :: ParserPtr-           -> BS.ByteString-           -> Bool-           -> IO (Maybe XMLParseError)-parseChunk pp xml final = do-    ok <- doParseChunk pp xml final-    if ok-        then return Nothing-        else Just `fmap` getError pp--getError :: ParserPtr -> IO XMLParseError-getError pp = do-    code <- xmlGetErrorCode pp-    cerr <- xmlErrorString code-    err <- peekCString cerr-    loc <- getParseLocation pp-    return $ XMLParseError err loc--data ExpatHandlers = ExpatHandlers-    (FunPtr CStartElementHandler)-    (FunPtr CEndElementHandler)-    (FunPtr CCharacterDataHandler)-    (Maybe (FunPtr CExternalEntityRefHandler))-    (Maybe (FunPtr CSkippedEntityHandler))---- | Most of the low-level functions take a ParserPtr so are required to be--- called inside @withParser@.-withParser :: Parser-           -> (ParserPtr -> IO a)  -- ^ Computation where parseChunk and other low-level functions may be used-           -> IO a-withParser parser@(Parser fp _ _ _ _ _) code = withForeignPtr fp $ \pp -> do-    bracket-        (unsafeSetHandlers parser pp)-        unsafeReleaseHandlers-        (\_ -> code pp)-  where-    unsafeSetHandlers :: Parser -> ParserPtr -> IO ExpatHandlers-    unsafeSetHandlers (Parser _ startRef endRef charRef extRef skipRef) pp =-      do-        cStartH <- mkCStartElementHandler =<< readIORef startRef-        cEndH   <- mkCEndElementHandler =<< readIORef endRef-        cCharH  <- mkCCharacterDataHandler =<< readIORef charRef-        mExtH   <- readIORef extRef >>=-                       maybe (return Nothing)-                             (\h -> liftM Just $ mkCExternalEntityRefHandler h)-    -        mSkipH  <- readIORef skipRef >>=-                       maybe (return Nothing)-                             (\h -> liftM Just $ mkCSkippedEntityHandler h)-    -        xmlSetstartelementhandler  pp cStartH-        xmlSetendelementhandler    pp cEndH-        xmlSetcharacterdatahandler pp cCharH-        maybe (return ())-              (xmlSetExternalEntityRefHandler pp)-              mExtH-        maybe (return ())-              (xmlSetSkippedEntityHandler pp)-              mSkipH-    -        return $ ExpatHandlers cStartH cEndH cCharH mExtH mSkipH-    -    unsafeReleaseHandlers :: ExpatHandlers -> IO ()-    unsafeReleaseHandlers (ExpatHandlers cStartH cEndH cCharH mcExtH mcSkipH) = do-        freeHaskellFunPtr cStartH-        freeHaskellFunPtr cEndH-        freeHaskellFunPtr cCharH-        maybe (return ()) freeHaskellFunPtr mcExtH-        maybe (return ()) freeHaskellFunPtr mcSkipH----- |Obtain C value from Haskell 'Bool'.----cFromBool :: Num a => Bool -> a-cFromBool  = fromBool--doParseChunk :: ParserPtr -> BS.ByteString -> Bool -> IO (Bool)-doParseChunk a1 a2 a3 =-  withBStringLen a2 $ \(a2'1, a2'2) ->-  let {a3' = cFromBool a3} in-  doParseChunk'_ a1 a2'1  a2'2 a3' >>= \res ->-  let {res' = unStatus res} in-  return (res')---- | Parse error, consisting of message text and error location-data XMLParseError = XMLParseError String XMLParseLocation deriving (Eq, Show)--instance NFData XMLParseError where-    rnf (XMLParseError msg loc) = rnf (msg, loc)---- | Specifies a location of an event within the input text-data XMLParseLocation = XMLParseLocation {-        xmlLineNumber   :: Int64,  -- ^ Line number of the event-        xmlColumnNumber :: Int64,  -- ^ Column number of the event-        xmlByteIndex    :: Int64,  -- ^ Byte index of event from start of document-        xmlByteCount    :: Int64   -- ^ The number of bytes in the event-    }-    deriving (Eq, Show)--instance NFData XMLParseLocation where-    rnf (XMLParseLocation lin col ind cou) = rnf (lin, col, ind, cou)--getParseLocation :: ParserPtr -> IO XMLParseLocation-getParseLocation pp = do-    line <- xmlGetCurrentLineNumber pp-    col <- xmlGetCurrentColumnNumber pp-    index <- xmlGetCurrentByteIndex pp-    count <- xmlGetCurrentByteCount pp-    return $ XMLParseLocation {-            xmlLineNumber = fromIntegral line,-            xmlColumnNumber = fromIntegral col,-            xmlByteIndex = fromIntegral index,-            xmlByteCount = fromIntegral count-        }---- | The type of the \"element started\" callback.  The first parameter is the--- element name; the second are the (attribute, value) pairs. Return True to--- continue parsing as normal, or False to terminate the parse.-type StartElementHandler  = ParserPtr -> CString -> [(CString, CString)] -> IO Bool---- | The type of the \"element ended\" callback.  The parameter is the element--- name. Return True to continue parsing as normal, or False to terminate the--- parse.-type EndElementHandler    = ParserPtr -> CString -> IO Bool---- | The type of the \"character data\" callback.  The parameter is the--- character data processed.  This callback may be called more than once while--- processing a single conceptual block of text. Return True to continue--- parsing as normal, or False to terminate the parse.-type CharacterDataHandler = ParserPtr -> CStringLen -> IO Bool---- | The type of the \"external entity reference\" callback. See the expat--- documentation.-type ExternalEntityRefHandler =  Parser-                              -> CString   -- context-                              -> CString   -- base-                              -> CString   -- systemID-                              -> CString   -- publicID-                              -> IO Bool---- | Set a skipped entity handler. This is called in two situations:------ 1. An entity reference is encountered for which no declaration has been read--- and this is not an error.------ 2. An internal entity reference is read, but not expanded, because--- @XML_SetDefaultHandler@ has been called.-type SkippedEntityHandler =  ParserPtr-                          -> CString   -- entityName-                          -> Int       -- is a parameter entity?-                          -> IO Bool--type CStartElementHandler = ParserPtr -> CString -> Ptr CString -> IO ()--nullCStartElementHandler :: CStartElementHandler-nullCStartElementHandler _ _ _ = return ()--foreign import ccall safe "wrapper"-  mkCStartElementHandler :: CStartElementHandler-                         -> IO (FunPtr CStartElementHandler)--wrapStartElementHandler :: Parser -> StartElementHandler -> CStartElementHandler-wrapStartElementHandler parser handler = h-  where-    h pp cname cattrs = do-        cattrlist <- peekArray0 nullPtr cattrs-        stillRunning <- handler pp cname (pairwise cattrlist)-        unless stillRunning $ stopp parser---- | Attach a StartElementHandler to a Parser.-setStartElementHandler :: Parser -> StartElementHandler -> IO ()-setStartElementHandler parser@(Parser _ startRef _ _ _ _) handler =-    writeIORef startRef $ wrapStartElementHandler parser handler--type CEndElementHandler = ParserPtr -> CString -> IO ()--nullCEndElementHandler :: CEndElementHandler-nullCEndElementHandler _ _ = return ()--foreign import ccall safe "wrapper"-  mkCEndElementHandler :: CEndElementHandler-                       -> IO (FunPtr CEndElementHandler)-wrapEndElementHandler :: Parser -> EndElementHandler -> CEndElementHandler-wrapEndElementHandler parser handler = h-  where-    h pp cname = do-        stillRunning <- handler pp cname-        unless stillRunning $ stopp parser---- | Attach an EndElementHandler to a Parser.-setEndElementHandler :: Parser -> EndElementHandler -> IO ()-setEndElementHandler parser@(Parser _ _ endRef _ _ _) handler =-    writeIORef endRef $ wrapEndElementHandler parser handler--type CCharacterDataHandler = ParserPtr -> CString -> CInt -> IO ()--nullCCharacterDataHandler :: CCharacterDataHandler-nullCCharacterDataHandler _ _ _ = return ()--foreign import ccall safe "wrapper"-  mkCCharacterDataHandler :: CCharacterDataHandler-                          -> IO (FunPtr CCharacterDataHandler)-wrapCharacterDataHandler :: Parser -> CharacterDataHandler -> CCharacterDataHandler-wrapCharacterDataHandler parser handler = h-  where-    h pp cdata len = do-        stillRunning <- handler pp (cdata, fromIntegral len)-        unless stillRunning $ stopp parser---- | Attach an CharacterDataHandler to a Parser.-setCharacterDataHandler :: Parser -> CharacterDataHandler -> IO ()-setCharacterDataHandler parser@(Parser _ _ _ charRef _ _) handler =-    writeIORef charRef $ wrapCharacterDataHandler parser handler--pairwise :: [a] -> [(a,a)]-pairwise (x1:x2:xs) = (x1,x2) : pairwise xs-pairwise _          = []--stopp :: Parser -> IO ()-stopp parser = withParser parser $ \p -> xmlStopParser p 0----------------------------------------------------------------------------------- C imports--foreign import ccall unsafe "XML_ParserCreate"-  parserCreate'_ :: Ptr CChar -> IO ParserPtr-  -foreign import ccall unsafe "XML_SetUserData"-  xmlSetUserData :: ParserPtr -> ParserPtr -> IO ()--foreign import ccall unsafe "XML_SetStartElementHandler"-  xmlSetstartelementhandler :: ParserPtr -> ((FunPtr (ParserPtr -> ((Ptr CChar) -> ((Ptr (Ptr CChar)) -> (IO ())))) -> (IO ())))--foreign import ccall unsafe "XML_SetEndElementHandler"-  xmlSetendelementhandler :: ParserPtr -> ((FunPtr (ParserPtr -> ((Ptr CChar) -> (IO ()))) -> (IO ())))--foreign import ccall unsafe "XML_SetCharacterDataHandler"-  xmlSetcharacterdatahandler :: ParserPtr -> ((FunPtr (ParserPtr -> ((Ptr CChar) -> (CInt -> (IO ())))) -> (IO ())))--foreign import ccall safe "XML_Parse"-  doParseChunk'_ :: ParserPtr -> ((Ptr CChar) -> (CInt -> (CInt -> (IO CInt))))--foreign import ccall unsafe "XML_UseForeignDTD"-  xmlUseForeignDTD :: ParserPtr     -- ^ parser-                   -> CChar         -- ^ use foreign DTD? (external entity ref-                                    -- handler will be called with publicID &-                                    -- systemID set to null-                   -> IO ()--foreign import ccall "&XML_ParserFree" parserFree :: FunPtr (ParserPtr -> IO ())-foreign import ccall "XML_ParserFree" parserFree' :: ParserPtr -> IO ()--type CExternalEntityRefHandler = ParserPtr   -- parser-                              -> Ptr CChar   -- context-                              -> Ptr CChar   -- base-                              -> Ptr CChar   -- systemID-                              -> Ptr CChar   -- publicID-                              -> IO ()--foreign import ccall safe "wrapper"-  mkCExternalEntityRefHandler :: CExternalEntityRefHandler-                              -> IO (FunPtr CExternalEntityRefHandler)---foreign import ccall unsafe "XML_SetExternalEntityRefHandler"-  xmlSetExternalEntityRefHandler :: ParserPtr-                                 -> FunPtr CExternalEntityRefHandler-                                 -> IO ()--foreign import ccall unsafe "XML_SetSkippedEntityHandler"-  xmlSetSkippedEntityHandler :: ParserPtr-                             -> FunPtr CSkippedEntityHandler-                             -> IO ()--foreign import ccall unsafe "XML_ExternalEntityParserCreate"-  xmlExternalEntityParserCreate :: ParserPtr-                                -> CString   -- ^ context-                                -> CString   -- ^ encoding-                                -> IO ParserPtr--type CSkippedEntityHandler =  ParserPtr -- user data pointer-                           -> CString   -- entity name-                           -> CInt      -- is a parameter entity?-                           -> IO ()--foreign import ccall safe "wrapper"-  mkCSkippedEntityHandler :: CSkippedEntityHandler-                          -> IO (FunPtr CSkippedEntityHandler)---wrapExternalEntityRefHandler :: Parser-                             -> ExternalEntityRefHandler-                             -> CExternalEntityRefHandler-wrapExternalEntityRefHandler parser handler = h-  where-    h _ context base systemID publicID = do-        stillRunning <- handler parser context base systemID publicID-        unless stillRunning $ stopp parser---wrapSkippedEntityHandler :: Parser-                         -> SkippedEntityHandler-                         -> CSkippedEntityHandler-wrapSkippedEntityHandler parser handler = h-  where-    h pp entityName i = do-        stillRunning <- handler pp entityName (fromIntegral i)-        unless stillRunning $ stopp parser---setExternalEntityRefHandler :: Parser -> ExternalEntityRefHandler -> IO ()-setExternalEntityRefHandler parser h =-    writeIORef ref $ Just $ wrapExternalEntityRefHandler parser h-  where-    ref = _externalEntityRefHandler parser--setSkippedEntityHandler :: Parser -> SkippedEntityHandler -> IO ()-setSkippedEntityHandler parser h =-    writeIORef ref $ Just $ wrapSkippedEntityHandler parser h-  where-    ref = _skippedEntityHandler parser---- Note on word sizes:------ on expat 2.0:--- XML_GetCurrentLineNumber returns XML_Size--- XML_GetCurrentColumnNumber returns XML_Size--- XML_GetCurrentByteIndex returns XML_Index--- These are defined in expat_external.h------ debian-i386 says XML_Size and XML_Index are 4 bytes.--- ubuntu-amd64 says XML_Size and XML_Index are 8 bytes.--- These two systems do NOT define XML_LARGE_SIZE, which would force these types--- to be 64-bit.------ If we guess the word size too small, it shouldn't matter: We will just discard--- the most significant part.  If we get the word size too large, we will get--- garbage (very bad).------ So - what I will do is use CLong and CULong, which correspond to what expat--- is using when XML_LARGE_SIZE is disabled, and give the correct sizes on the--- two machines mentioned above.  At the absolute worst the word size will be too--- short.+{-# OPTIONS_HADDOCK hide #-}+module Text.XML.Expat.IO+       {-# DEPRECATED "Renamed to Text.XML.Expat.Internal.IO" #-}+    (+        module Text.XML.Expat.Internal.IO+    ) where -foreign import ccall unsafe "expat.h XML_GetErrorCode" xmlGetErrorCode-    :: ParserPtr -> IO CInt-foreign import ccall unsafe "expat.h XML_GetCurrentLineNumber" xmlGetCurrentLineNumber-    :: ParserPtr -> IO CULong-foreign import ccall unsafe "expat.h XML_GetCurrentColumnNumber" xmlGetCurrentColumnNumber-    :: ParserPtr -> IO CULong-foreign import ccall unsafe "expat.h XML_GetCurrentByteIndex" xmlGetCurrentByteIndex-    :: ParserPtr -> IO CLong-foreign import ccall unsafe "expat.h XML_GetCurrentByteCount" xmlGetCurrentByteCount-    :: ParserPtr -> IO CInt-foreign import ccall unsafe "expat.h XML_ErrorString" xmlErrorString-    :: CInt -> IO CString-foreign import ccall unsafe "expat.h XML_StopParser" xmlStopParser-    :: ParserPtr -> CInt -> IO ()+import Text.XML.Expat.Internal.IO 

@@ -0,0 +1,525 @@+{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}++-- hexpat, a Haskell wrapper for expat+-- Copyright (C) 2008 Evan Martin <martine@danga.com>+-- Copyright (C) 2009 Stephen Blackheath <http://blacksapphire.com/antispam>++-- | Low-level interface to Expat. Unless speed is paramount, this should+-- normally be avoided in favour of the interfaces provided by+-- 'Text.XML.Expat.SAX' and 'Text.XML.Expat.Tree'.  Basic usage is:+--+-- (1) Make a new parser: 'newParser'.+--+-- (2) Set up callbacks on the parser: 'setStartElementHandler', etc.+--+-- (3) Feed data into the parser: 'parse', 'parse'' or 'parseChunk'.  Some of+--     these functions must be wrapped in 'withParser'.++module Text.XML.Expat.Internal.IO (+  -- ** Parser Setup+  Parser, newParser,++  -- ** Parsing+  parse, parse',+  withParser,+  ParserPtr, Parser_struct,+  parseChunk,+  Encoding(..),+  XMLParseError(..),+  getParseLocation,+  XMLParseLocation(..),++  -- ** Parser Callbacks+  StartElementHandler,+  EndElementHandler,+  CharacterDataHandler,+  ExternalEntityRefHandler,+  SkippedEntityHandler,+  setStartElementHandler,+  setEndElementHandler,+  setCharacterDataHandler,+  setExternalEntityRefHandler,+  setSkippedEntityHandler,+  setUseForeignDTD,++  -- ** Lower-level interface+  parseExternalEntityReference,+  ExpatHandlers,++  -- ** Helpers+  encodingToString+  ) where++import Control.Exception (bracket)+import Control.Parallel.Strategies+import Control.Monad+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import Data.IORef+import Foreign+import Foreign.C+++-- |Opaque parser type.+data Parser_struct+type ParserPtr = Ptr Parser_struct+data Parser = Parser+    { _parserObj                :: ForeignPtr Parser_struct+    , _startElementHandler      :: IORef CStartElementHandler+    , _endElementHandler        :: IORef CEndElementHandler+    , _cdataHandler             :: IORef CCharacterDataHandler+    , _externalEntityRefHandler :: IORef (Maybe CExternalEntityRefHandler)+    , _skippedEntityHandler     :: IORef (Maybe CSkippedEntityHandler)+    }++instance Show Parser where+    showsPrec _ (Parser fp _ _ _ _ _) = showsPrec 0 fp++-- |Encoding types available for the document encoding.+data Encoding = ASCII | UTF8 | UTF16 | ISO88591+encodingToString :: Encoding -> String+encodingToString ASCII    = "US-ASCII"+encodingToString UTF8     = "UTF-8"+encodingToString UTF16    = "UTF-16"+encodingToString ISO88591 = "ISO-8859-1"++withOptEncoding :: Maybe Encoding -> (CString -> IO a) -> IO a+withOptEncoding Nothing    f = f nullPtr+withOptEncoding (Just enc) f = withCString (encodingToString enc) f+++parserCreate :: Maybe Encoding -> IO (ParserPtr)+parserCreate a1 =+  withOptEncoding a1 $ \a1' -> do+      pp <- parserCreate'_ a1'+      xmlSetUserData pp pp+      return pp++-- | Create a 'Parser'.+newParser :: Maybe Encoding -> IO Parser+newParser enc = do+  ptr        <- parserCreate enc+  fptr       <- newForeignPtr parserFree ptr+  nullStartH <- newIORef nullCStartElementHandler+  nullEndH   <- newIORef nullCEndElementHandler+  nullCharH  <- newIORef nullCCharacterDataHandler+  extH       <- newIORef Nothing+  skipH      <- newIORef Nothing++  return $ Parser fptr nullStartH nullEndH nullCharH extH skipH++setUseForeignDTD :: Parser -> Bool -> IO ()+setUseForeignDTD p b = withParser p $ \p' -> xmlUseForeignDTD p' b'+  where+    b' = if b then 1 else 0++-- ByteString.useAsCStringLen is almost what we need, but C2HS wants a CInt+-- instead of an Int.+withBStringLen :: BS.ByteString -> ((CString, CInt) -> IO a) -> IO a+withBStringLen bs f = do+  BS.useAsCStringLen bs $ \(str, len) -> f (str, fromIntegral len)++unStatus :: CInt -> Bool+unStatus 0 = False+unStatus _ = True++-- |@parse data@ feeds /lazy/ ByteString data into a 'Parser'. It returns+-- Nothing on success, or Just the parse error.+parse :: Parser -> BSL.ByteString -> IO (Maybe XMLParseError)+parse parser bs = withParser parser $ \pp -> do+    let+        doParseChunks [] = doParseChunk pp BS.empty True+        doParseChunks (c:cs) = do+            ok <- doParseChunk pp c False+            if ok+                then doParseChunks cs+                else return False+    ok <- doParseChunks (BSL.toChunks bs)+    if ok+        then return Nothing+        else Just `fmap` getError pp++-- |@parse data@ feeds /strict/ ByteString data into a 'Parser'. It returns+-- Nothing on success, or Just the parse error.+parse' :: Parser -> BS.ByteString -> IO (Maybe XMLParseError)+parse' parser bs = withParser parser $ \pp -> do+    ok <- doParseChunk pp bs True+    if ok+        then return Nothing+        else Just `fmap` getError pp++parseExternalEntityReference :: Parser+                             -> CString         -- ^ context+                             -> Maybe Encoding  -- ^ encoding+                             -> CStringLen      -- ^ text+                             -> IO Bool+parseExternalEntityReference parser context encoding (text,sz) =+    withParser parser $ \pp -> do+        extp <- withOptEncoding encoding $+                xmlExternalEntityParserCreate pp context+        e <- doParseChunk'_ extp text (fromIntegral sz) 1+        parserFree' extp+        return $ e == 1++-- |@parseChunk data False@ feeds /strict/ ByteString data into a+-- 'Parser'.  The end of the data is indicated by passing @True@ for the+-- final parameter.   It returns Nothing on success, or Just the parse error.+parseChunk :: ParserPtr+           -> BS.ByteString+           -> Bool+           -> IO (Maybe XMLParseError)+parseChunk pp xml final = do+    ok <- doParseChunk pp xml final+    if ok+        then return Nothing+        else Just `fmap` getError pp++getError :: ParserPtr -> IO XMLParseError+getError pp = do+    code <- xmlGetErrorCode pp+    cerr <- xmlErrorString code+    err <- peekCString cerr+    loc <- getParseLocation pp+    return $ XMLParseError err loc++data ExpatHandlers = ExpatHandlers+    (FunPtr CStartElementHandler)+    (FunPtr CEndElementHandler)+    (FunPtr CCharacterDataHandler)+    (Maybe (FunPtr CExternalEntityRefHandler))+    (Maybe (FunPtr CSkippedEntityHandler))++-- | Most of the low-level functions take a ParserPtr so are required to be+-- called inside @withParser@.+withParser :: Parser+           -> (ParserPtr -> IO a)  -- ^ Computation where parseChunk and other low-level functions may be used+           -> IO a+withParser parser@(Parser fp _ _ _ _ _) code = withForeignPtr fp $ \pp -> do+    bracket+        (unsafeSetHandlers parser pp)+        unsafeReleaseHandlers+        (\_ -> code pp)+  where+    unsafeSetHandlers :: Parser -> ParserPtr -> IO ExpatHandlers+    unsafeSetHandlers (Parser _ startRef endRef charRef extRef skipRef) pp =+      do+        cStartH <- mkCStartElementHandler =<< readIORef startRef+        cEndH   <- mkCEndElementHandler =<< readIORef endRef+        cCharH  <- mkCCharacterDataHandler =<< readIORef charRef+        mExtH   <- readIORef extRef >>=+                       maybe (return Nothing)+                             (\h -> liftM Just $ mkCExternalEntityRefHandler h)+    +        mSkipH  <- readIORef skipRef >>=+                       maybe (return Nothing)+                             (\h -> liftM Just $ mkCSkippedEntityHandler h)+    +        xmlSetstartelementhandler  pp cStartH+        xmlSetendelementhandler    pp cEndH+        xmlSetcharacterdatahandler pp cCharH+        maybe (return ())+              (xmlSetExternalEntityRefHandler pp)+              mExtH+        maybe (return ())+              (xmlSetSkippedEntityHandler pp)+              mSkipH+    +        return $ ExpatHandlers cStartH cEndH cCharH mExtH mSkipH+    +    unsafeReleaseHandlers :: ExpatHandlers -> IO ()+    unsafeReleaseHandlers (ExpatHandlers cStartH cEndH cCharH mcExtH mcSkipH) = do+        freeHaskellFunPtr cStartH+        freeHaskellFunPtr cEndH+        freeHaskellFunPtr cCharH+        maybe (return ()) freeHaskellFunPtr mcExtH+        maybe (return ()) freeHaskellFunPtr mcSkipH+++-- |Obtain C value from Haskell 'Bool'.+--+cFromBool :: Num a => Bool -> a+cFromBool  = fromBool++doParseChunk :: ParserPtr -> BS.ByteString -> Bool -> IO (Bool)+doParseChunk a1 a2 a3 =+  withBStringLen a2 $ \(a2'1, a2'2) ->+  let {a3' = cFromBool a3} in+  doParseChunk'_ a1 a2'1  a2'2 a3' >>= \res ->+  let {res' = unStatus res} in+  return (res')++-- | Parse error, consisting of message text and error location+data XMLParseError = XMLParseError String XMLParseLocation deriving (Eq, Show)++instance NFData XMLParseError where+    rnf (XMLParseError msg loc) = rnf (msg, loc)++-- | Specifies a location of an event within the input text+data XMLParseLocation = XMLParseLocation {+        xmlLineNumber   :: Int64,  -- ^ Line number of the event+        xmlColumnNumber :: Int64,  -- ^ Column number of the event+        xmlByteIndex    :: Int64,  -- ^ Byte index of event from start of document+        xmlByteCount    :: Int64   -- ^ The number of bytes in the event+    }+    deriving (Eq, Show)++instance NFData XMLParseLocation where+    rnf (XMLParseLocation lin col ind cou) = rnf (lin, col, ind, cou)++getParseLocation :: ParserPtr -> IO XMLParseLocation+getParseLocation pp = do+    line <- xmlGetCurrentLineNumber pp+    col <- xmlGetCurrentColumnNumber pp+    index <- xmlGetCurrentByteIndex pp+    count <- xmlGetCurrentByteCount pp+    return $ XMLParseLocation {+            xmlLineNumber = fromIntegral line,+            xmlColumnNumber = fromIntegral col,+            xmlByteIndex = fromIntegral index,+            xmlByteCount = fromIntegral count+        }++-- | The type of the \"element started\" callback.  The first parameter is the+-- element name; the second are the (attribute, value) pairs. Return True to+-- continue parsing as normal, or False to terminate the parse.+type StartElementHandler  = ParserPtr -> CString -> [(CString, CString)] -> IO Bool++-- | The type of the \"element ended\" callback.  The parameter is the element+-- name. Return True to continue parsing as normal, or False to terminate the+-- parse.+type EndElementHandler    = ParserPtr -> CString -> IO Bool++-- | The type of the \"character data\" callback.  The parameter is the+-- character data processed.  This callback may be called more than once while+-- processing a single conceptual block of text. Return True to continue+-- parsing as normal, or False to terminate the parse.+type CharacterDataHandler = ParserPtr -> CStringLen -> IO Bool++-- | The type of the \"external entity reference\" callback. See the expat+-- documentation.+type ExternalEntityRefHandler =  Parser+                              -> CString   -- context+                              -> CString   -- base+                              -> CString   -- systemID+                              -> CString   -- publicID+                              -> IO Bool++-- | Set a skipped entity handler. This is called in two situations:+--+-- 1. An entity reference is encountered for which no declaration has been read+-- and this is not an error.+--+-- 2. An internal entity reference is read, but not expanded, because+-- @XML_SetDefaultHandler@ has been called.+type SkippedEntityHandler =  ParserPtr+                          -> CString   -- entityName+                          -> Int       -- is a parameter entity?+                          -> IO Bool++type CStartElementHandler = ParserPtr -> CString -> Ptr CString -> IO ()++nullCStartElementHandler :: CStartElementHandler+nullCStartElementHandler _ _ _ = return ()++foreign import ccall safe "wrapper"+  mkCStartElementHandler :: CStartElementHandler+                         -> IO (FunPtr CStartElementHandler)++wrapStartElementHandler :: Parser -> StartElementHandler -> CStartElementHandler+wrapStartElementHandler parser handler = h+  where+    h pp cname cattrs = do+        cattrlist <- peekArray0 nullPtr cattrs+        stillRunning <- handler pp cname (pairwise cattrlist)+        unless stillRunning $ stopp parser++-- | Attach a StartElementHandler to a Parser.+setStartElementHandler :: Parser -> StartElementHandler -> IO ()+setStartElementHandler parser@(Parser _ startRef _ _ _ _) handler =+    writeIORef startRef $ wrapStartElementHandler parser handler++type CEndElementHandler = ParserPtr -> CString -> IO ()++nullCEndElementHandler :: CEndElementHandler+nullCEndElementHandler _ _ = return ()++foreign import ccall safe "wrapper"+  mkCEndElementHandler :: CEndElementHandler+                       -> IO (FunPtr CEndElementHandler)+wrapEndElementHandler :: Parser -> EndElementHandler -> CEndElementHandler+wrapEndElementHandler parser handler = h+  where+    h pp cname = do+        stillRunning <- handler pp cname+        unless stillRunning $ stopp parser++-- | Attach an EndElementHandler to a Parser.+setEndElementHandler :: Parser -> EndElementHandler -> IO ()+setEndElementHandler parser@(Parser _ _ endRef _ _ _) handler =+    writeIORef endRef $ wrapEndElementHandler parser handler++type CCharacterDataHandler = ParserPtr -> CString -> CInt -> IO ()++nullCCharacterDataHandler :: CCharacterDataHandler+nullCCharacterDataHandler _ _ _ = return ()++foreign import ccall safe "wrapper"+  mkCCharacterDataHandler :: CCharacterDataHandler+                          -> IO (FunPtr CCharacterDataHandler)+wrapCharacterDataHandler :: Parser -> CharacterDataHandler -> CCharacterDataHandler+wrapCharacterDataHandler parser handler = h+  where+    h pp cdata len = do+        stillRunning <- handler pp (cdata, fromIntegral len)+        unless stillRunning $ stopp parser++-- | Attach an CharacterDataHandler to a Parser.+setCharacterDataHandler :: Parser -> CharacterDataHandler -> IO ()+setCharacterDataHandler parser@(Parser _ _ _ charRef _ _) handler =+    writeIORef charRef $ wrapCharacterDataHandler parser handler++pairwise :: [a] -> [(a,a)]+pairwise (x1:x2:xs) = (x1,x2) : pairwise xs+pairwise _          = []++stopp :: Parser -> IO ()+stopp parser = withParser parser $ \p -> xmlStopParser p 0++------------------------------------------------------------------------------+-- C imports++foreign import ccall unsafe "XML_ParserCreate"+  parserCreate'_ :: Ptr CChar -> IO ParserPtr+  +foreign import ccall unsafe "XML_SetUserData"+  xmlSetUserData :: ParserPtr -> ParserPtr -> IO ()++foreign import ccall unsafe "XML_SetStartElementHandler"+  xmlSetstartelementhandler :: ParserPtr -> ((FunPtr (ParserPtr -> ((Ptr CChar) -> ((Ptr (Ptr CChar)) -> (IO ())))) -> (IO ())))++foreign import ccall unsafe "XML_SetEndElementHandler"+  xmlSetendelementhandler :: ParserPtr -> ((FunPtr (ParserPtr -> ((Ptr CChar) -> (IO ()))) -> (IO ())))++foreign import ccall unsafe "XML_SetCharacterDataHandler"+  xmlSetcharacterdatahandler :: ParserPtr -> ((FunPtr (ParserPtr -> ((Ptr CChar) -> (CInt -> (IO ())))) -> (IO ())))++foreign import ccall safe "XML_Parse"+  doParseChunk'_ :: ParserPtr -> ((Ptr CChar) -> (CInt -> (CInt -> (IO CInt))))++foreign import ccall unsafe "XML_UseForeignDTD"+  xmlUseForeignDTD :: ParserPtr     -- ^ parser+                   -> CChar         -- ^ use foreign DTD? (external entity ref+                                    -- handler will be called with publicID &+                                    -- systemID set to null+                   -> IO ()++foreign import ccall "&XML_ParserFree" parserFree :: FunPtr (ParserPtr -> IO ())+foreign import ccall "XML_ParserFree" parserFree' :: ParserPtr -> IO ()++type CExternalEntityRefHandler = ParserPtr   -- parser+                              -> Ptr CChar   -- context+                              -> Ptr CChar   -- base+                              -> Ptr CChar   -- systemID+                              -> Ptr CChar   -- publicID+                              -> IO ()++foreign import ccall safe "wrapper"+  mkCExternalEntityRefHandler :: CExternalEntityRefHandler+                              -> IO (FunPtr CExternalEntityRefHandler)+++foreign import ccall unsafe "XML_SetExternalEntityRefHandler"+  xmlSetExternalEntityRefHandler :: ParserPtr+                                 -> FunPtr CExternalEntityRefHandler+                                 -> IO ()++foreign import ccall unsafe "XML_SetSkippedEntityHandler"+  xmlSetSkippedEntityHandler :: ParserPtr+                             -> FunPtr CSkippedEntityHandler+                             -> IO ()++foreign import ccall unsafe "XML_ExternalEntityParserCreate"+  xmlExternalEntityParserCreate :: ParserPtr+                                -> CString   -- ^ context+                                -> CString   -- ^ encoding+                                -> IO ParserPtr++type CSkippedEntityHandler =  ParserPtr -- user data pointer+                           -> CString   -- entity name+                           -> CInt      -- is a parameter entity?+                           -> IO ()++foreign import ccall safe "wrapper"+  mkCSkippedEntityHandler :: CSkippedEntityHandler+                          -> IO (FunPtr CSkippedEntityHandler)+++wrapExternalEntityRefHandler :: Parser+                             -> ExternalEntityRefHandler+                             -> CExternalEntityRefHandler+wrapExternalEntityRefHandler parser handler = h+  where+    h _ context base systemID publicID = do+        stillRunning <- handler parser context base systemID publicID+        unless stillRunning $ stopp parser+++wrapSkippedEntityHandler :: Parser+                         -> SkippedEntityHandler+                         -> CSkippedEntityHandler+wrapSkippedEntityHandler parser handler = h+  where+    h pp entityName i = do+        stillRunning <- handler pp entityName (fromIntegral i)+        unless stillRunning $ stopp parser+++setExternalEntityRefHandler :: Parser -> ExternalEntityRefHandler -> IO ()+setExternalEntityRefHandler parser h =+    writeIORef ref $ Just $ wrapExternalEntityRefHandler parser h+  where+    ref = _externalEntityRefHandler parser++setSkippedEntityHandler :: Parser -> SkippedEntityHandler -> IO ()+setSkippedEntityHandler parser h =+    writeIORef ref $ Just $ wrapSkippedEntityHandler parser h+  where+    ref = _skippedEntityHandler parser++-- Note on word sizes:+--+-- on expat 2.0:+-- XML_GetCurrentLineNumber returns XML_Size+-- XML_GetCurrentColumnNumber returns XML_Size+-- XML_GetCurrentByteIndex returns XML_Index+-- These are defined in expat_external.h+--+-- debian-i386 says XML_Size and XML_Index are 4 bytes.+-- ubuntu-amd64 says XML_Size and XML_Index are 8 bytes.+-- These two systems do NOT define XML_LARGE_SIZE, which would force these types+-- to be 64-bit.+--+-- If we guess the word size too small, it shouldn't matter: We will just discard+-- the most significant part.  If we get the word size too large, we will get+-- garbage (very bad).+--+-- So - what I will do is use CLong and CULong, which correspond to what expat+-- is using when XML_LARGE_SIZE is disabled, and give the correct sizes on the+-- two machines mentioned above.  At the absolute worst the word size will be too+-- short.++foreign import ccall unsafe "expat.h XML_GetErrorCode" xmlGetErrorCode+    :: ParserPtr -> IO CInt+foreign import ccall unsafe "expat.h XML_GetCurrentLineNumber" xmlGetCurrentLineNumber+    :: ParserPtr -> IO CULong+foreign import ccall unsafe "expat.h XML_GetCurrentColumnNumber" xmlGetCurrentColumnNumber+    :: ParserPtr -> IO CULong+foreign import ccall unsafe "expat.h XML_GetCurrentByteIndex" xmlGetCurrentByteIndex+    :: ParserPtr -> IO CLong+foreign import ccall unsafe "expat.h XML_GetCurrentByteCount" xmlGetCurrentByteCount+    :: ParserPtr -> IO CInt+foreign import ccall unsafe "expat.h XML_ErrorString" xmlErrorString+    :: CInt -> IO CString+foreign import ccall unsafe "expat.h XML_StopParser" xmlStopParser+    :: ParserPtr -> CInt -> IO ()+

@@ -0,0 +1,157 @@+{-# LANGUAGE FlexibleContexts #-}+module Text.XML.Expat.Internal.Namespaced+      ( NName (..)+      , NAttributes+      , mkNName+      , mkAnNName+      , toNamespaced+      , fromNamespaced+      , xmlnsUri+      , xmlns+      ) where++import Text.XML.Expat.Internal.NodeClass+import Text.XML.Expat.Internal.Qualified+import Text.XML.Expat.SAX+import Control.Parallel.Strategies+import qualified Data.Map as M+import qualified Data.Maybe as DM+import qualified Data.List as L++-- | A namespace-qualified tag.+--+-- NName has two components, a local part and an optional namespace. The local part is the+-- name of the tag. The namespace is the URI identifying collections of declared tags.+-- Tags with the same local part but from different namespaces are distinct. Unqualified tags+-- are those with no namespace. They are in the default namespace, and all uses of an+-- unqualified tag are equivalent.+data NName text =+    NName {+        nnNamespace :: Maybe text,+        nnLocalPart :: !text+    }+    deriving (Eq,Show)++instance NFData text => NFData (NName text) where+    rnf (NName ns loc) = rnf (ns, loc)++-- | Type shortcut for attributes with namespaced names+type NAttributes text = Attributes (NName text) text++-- | Make a new NName from a prefix and localPart.+mkNName :: text -> text -> NName text+mkNName prefix localPart = NName (Just prefix) localPart++-- | Make a new NName with no prefix.+mkAnNName :: text -> NName text+mkAnNName localPart = NName Nothing localPart++type NsPrefixMap text = M.Map (Maybe text) (Maybe text)+type PrefixNsMap text = M.Map (Maybe text) (Maybe text)++xmlUri :: (GenericXMLString text) => text+xmlUri = gxFromString "http://www.w3.org/XML/1998/namespace"+xml :: (GenericXMLString text) => text+xml = gxFromString "xml"++xmlnsUri :: (GenericXMLString text) => text+xmlnsUri = gxFromString "http://www.w3.org/2000/xmlns/"+xmlns :: (GenericXMLString text) => text+xmlns = gxFromString "xmlns"++baseNsBindings :: (GenericXMLString text, Ord text)+               => NsPrefixMap text+baseNsBindings = M.fromList+  [ (Nothing, Nothing) +  , (Just xml, Just xmlUri)+  , (Just xmlns, Just xmlnsUri)+  ]++basePfBindings :: (GenericXMLString text, Ord text)+               => PrefixNsMap text+basePfBindings = M.fromList+   [ (Nothing, Nothing)+   , (Just xmlUri, Just xml)+   , (Just xmlnsUri, Just xmlns)+   ]++toNamespaced :: (NodeClass n c, GenericXMLString text, Ord text, Show text)+               => n c (QName text) text -> n c (NName text) text+toNamespaced = nodeWithNamespaces baseNsBindings++nodeWithNamespaces :: (NodeClass n c, GenericXMLString text, Ord text, Show text)+                   => NsPrefixMap text -> n c (QName text) text -> n c (NName text) text+nodeWithNamespaces bindings = mapElement namespaceify+  where+    namespaceify (qname, qattrs, qchildren) = (nname, nattrs, nchildren)+      where+        for = flip map+        ffor = flip fmap+        (nsAtts, otherAtts) = L.partition ((== Just xmlns) . qnPrefix . fst) qattrs+        (dfAtt, normalAtts) = L.partition ((== QName Nothing xmlns) . fst) otherAtts+        nsMap  = M.fromList $ for nsAtts $ \((QName _ lp), uri) -> (Just lp, Just uri)+        -- fixme: when snd q is null, use Nothing+        dfMap  = M.fromList $ for dfAtt $ \q -> (Nothing, Just $ snd q)+        chldBs = M.unions [dfMap, nsMap, bindings]+    +        trans bs (QName pref qual) = case pref `M.lookup` bs of+          Nothing -> error +                  $  "Namespace prefix referenced but never bound: '"+                  ++ (show . DM.fromJust) pref+                  ++ "'"+          Just mUri -> NName mUri qual+        nname       = trans chldBs qname+    +        -- attributes with no prefix are in the same namespace as the element+        attBs = M.insert Nothing (nnNamespace nname) chldBs+    +        transAt (qn, v) = (trans attBs qn, v)+    +        nNsAtts     = map transAt nsAtts+        nDfAtt      = map transAt dfAtt+        nNormalAtts = map transAt normalAtts+        nattrs      = concat [nNsAtts, nDfAtt, nNormalAtts]++        nchildren   = ffor qchildren $ nodeWithNamespaces chldBs++fromNamespaced :: (NodeClass n c, GenericXMLString text, Ord text, Functor c) =>+                  n c (NName text) text -> n c (QName text) text+fromNamespaced = nodeWithQualifiers 1 basePfBindings++nodeWithQualifiers :: (NodeClass n c, GenericXMLString text, Ord text, Functor c) =>+                      Int+                   -> PrefixNsMap text+                   -> n c (NName text) text+                   -> n c (QName text) text+nodeWithQualifiers cntr bindings = mapElement namespaceify+  where+    namespaceify (nname, nattrs, nchildren) = (qname, qattrs, qchildren) +      where+        for = flip map+        ffor = flip fmap+        (nsAtts, otherAtts) = L.partition ((== Just xmlnsUri) . nnNamespace . fst) nattrs+        (dfAtt, normalAtts) = L.partition ((== NName Nothing xmlns) . fst) otherAtts+        nsMap = M.fromList $ for nsAtts $ \((NName _ lp), uri) -> (Just uri, Just lp)+        dfMap = M.fromList $ for dfAtt  $ \(_, uri) -> (Just uri, Just xmlns)+        chldBs = M.unions [dfMap, nsMap, bindings]+    +        trans (i, bs, as) (NName nspace qual) =+          case nspace `M.lookup` bs of+               Nothing -> let+                            pfx = gxFromString $ "ns" ++ show i+                            bsN = M.insert nspace (Just pfx) bs+                            asN = (NName (Just xmlnsUri) pfx, DM.fromJust nspace) : as+                          in trans (i+1, bsN, asN) (NName nspace qual)+               Just pfx -> ((i, bs, as), QName pfx qual)+        transAt ibs (nn, v) = let (ibs', qn) = trans ibs nn+                              in  (ibs', (qn, v))+    +        ((i', bs', as'), qname) = trans (cntr, chldBs, []) nname+    +        ((i'',   bs'',   as''),   qNsAtts)     = L.mapAccumL transAt (i',    bs',    as')    nsAtts+        ((i''',  bs''',  as'''),  qDfAtt)      = L.mapAccumL transAt (i'',   bs'',   as'')   dfAtt+        ((i'''', bs'''', as''''), qNormalAtts) = L.mapAccumL transAt (i''',  bs''',  as''')  normalAtts+        (_,                       qas)         = L.mapAccumL transAt (i'''', bs'''', as'''') as''''+        qattrs = concat [qNsAtts, qDfAtt, qNormalAtts, qas]+    +        qchildren = ffor nchildren $ nodeWithQualifiers i'''' bs''''

@@ -0,0 +1,161 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, TypeFamilies #-}+-- | Type classes to allow for XML handling functions to be generalized to+-- work with different node types, including the ones defined in /Tree/ and+-- /Annotated/.+module Text.XML.Expat.Internal.NodeClass where++import Control.Monad (mzero)+import Data.Functor.Identity+import Data.List.Class+import Data.Monoid (Monoid)+import Text.XML.Expat.SAX (GenericXMLString)+++-- | Type shortcut for attributes+type Attributes tag text = [(tag, text)]++-- | Type shortcut for attributes with unqualified names where tag and+-- text are the same string type.+type UAttributes text = Attributes text text++-- | Extract all text content from inside a tag into a single string, including+-- any text contained in children.+textContent :: (NodeClass n [], Monoid text) => n [] tag text -> text+textContent node = runIdentity $ textContentM node++-- | A type function to give the type of a list of nodes, using the appropriate+-- list type for the specified node type, e.g. @ListOf (UNode Text)@+type family ListOf n++class (Functor c, List c) => NodeClass n c where++    -- | Is the given node an element?+    isElement :: n c tag text -> Bool++    -- | Is the given node text?+    isText :: n c tag text -> Bool++    -- | Extract all text content from inside a tag into a single string, including+    -- any text contained in children.+    textContentM :: Monoid text => n c tag text -> ItemM c text++    -- | Is the given node a tag with the given name?+    isNamed :: Eq tag => tag -> n c tag text -> Bool++    -- | Get the name of this node if it's an element, return empty string otherwise.+    getName :: Monoid tag => n c tag text -> tag++    -- | Get the attributes of a node if it's an element, return empty list otherwise.+    getAttributes :: n c tag text -> [(tag,text)]++    -- | Get children of a node if it's an element, return empty list otherwise.+    getChildren :: n c tag text -> c (n c tag text)++    -- | Get this node's text if it's a text node, return empty text otherwise.+    getText :: Monoid text => n c tag text -> text++    -- | Modify name if it's an element, no-op otherwise.+    modifyName :: (tag -> tag)+               -> n c tag text+               -> n c tag text++    -- | Modify attributes if it's an element, no-op otherwise.+    modifyAttributes :: ([(tag, text)] -> [(tag, text)])+                     -> n c tag text+                     -> n c tag text++    -- | Modify children (non-recursively) if it's an element, no-op otherwise.+    modifyChildren :: (c (n c tag text) -> c (n c tag text))+                   -> n c tag text+                   -> n c tag text++    -- | Map all tags (both tag names and attribute names) recursively.+    mapAllTags :: (tag -> tag')+               -> n c tag text+               -> n c tag' text++    -- | Map an element non-recursively, allowing the tag type to be changed.+    mapElement :: ((tag, [(tag, text)], c (n c tag text))+                       -> (tag', [(tag', text)], c (n c tag' text)))+                  -> n c tag text+                  -> n c tag' text++    -- | Change a node from one container type to another.+    mapNodeContainer :: (c (n c tag text) -> ItemM c (c' (n c' tag text)))+                     -> n c tag text+                     -> ItemM c (n c' tag text)++    -- | Generic text node constructor.+    mkText :: text -> n c tag text++-- | A class of node types where an Element can be constructed given a tag,+-- attributes and children.+class NodeClass n c => MkElementClass n c where+    -- | Generic element constructor.+    mkElement :: tag -> Attributes tag text -> c (n c tag text) -> n c tag text++-- | Get the value of the attribute having the specified name.+getAttribute :: (NodeClass n c, GenericXMLString tag) => n c tag text -> tag -> Maybe text+getAttribute n t = lookup t $ getAttributes n++-- | Set the value of the attribute with the specified name to the value, overwriting+-- the first existing attribute with that name if present.+setAttribute :: (Eq tag, NodeClass n c, GenericXMLString tag) => tag -> text -> n c tag text -> n c tag text+setAttribute t newValue = modifyAttributes set+  where+    set [] = [(t, newValue)]+    set ((name, _):atts) | name == t = (name, newValue):atts+    set (att:atts) = att:set atts++-- | Delete the first attribute matching the specified name.+deleteAttribute :: (Eq tag, NodeClass n c, GenericXMLString tag) => tag -> n c tag text -> n c tag text+deleteAttribute t = modifyAttributes del+  where+    del [] = []+    del ((name, _):atts) | name == t = atts+    del (att:atts) = att:del atts++-- | setAttribute if /Just/, deleteAttribute if /Nothing/.+alterAttribute :: (Eq tag, NodeClass n c, GenericXMLString tag) => tag -> Maybe text -> n c tag text -> n c tag text+alterAttribute t (Just newValue) = setAttribute t newValue+alterAttribute t Nothing = deleteAttribute t++-- | Generically convert an element of one node type to another.  Useful for+-- adding or removing annotations.+fromElement :: (NodeClass n c, MkElementClass n' c, Monoid tag, Monoid text) =>+               n c tag text+            -> n' c tag text+fromElement = fromElement_ mkElement++-- | Generically convert an element of one node type to another, using+-- the specified element constructor.  Useful for adding or removing annotations.+fromElement_ :: (NodeClass n c, NodeClass n' c, Monoid tag, Monoid text) =>+                (tag -> Attributes tag text -> c (n' c tag text) -> n' c tag text)  -- ^ Element constructor+             -> n c tag text+             -> n' c tag text+fromElement_ mkElement elt | isElement elt =+    mkElement (getName elt) (getAttributes elt) (fromNodes_ mkElement $ getChildren elt)+fromElement_ _ _ = error "fromElement requires an Element"++-- | Generically convert a list of nodes from one node type to another.  Useful for+-- adding or removing annotations.+fromNodes :: (NodeClass n c, MkElementClass n' c, Monoid tag, Monoid text) =>+             c (n c tag text)+          -> c (n' c tag text)+fromNodes = fromNodes_ mkElement++-- | Generically convert a list of nodes from one node type to another, using+-- the specified element constructor.  Useful for adding or removing annotations.+fromNodes_ :: (NodeClass n c, NodeClass n' c, Monoid tag, Monoid text) =>+              (tag -> Attributes tag text -> c (n' c tag text) -> n' c tag text)  -- ^ Element constructor+           -> c (n c tag text)+           -> c (n' c tag text)+fromNodes_ mkElement l = joinL $ do+    li <- runList l+    return $ case li of+        Nil -> mzero+        Cons elt l' | isElement elt -> fromElement_ mkElement elt `cons` fromNodes_ mkElement l'+        Cons txt l' | isText txt    -> mkText (getText txt) `cons` fromNodes_ mkElement l'+        -- Future node types may include other kinds of nodes, which we discard here.+        Cons _   l'                 -> fromNodes_ mkElement l'+

@@ -0,0 +1,70 @@+-- hexpat, a Haskell wrapper for expat+-- Copyright (C) 2008 Evan Martin <martine@danga.com>+-- Copyright (C) 2009 Stephen Blackheath <http://blacksapphire.com/antispam>++-- | In the default representation, qualified tag and attribute names such as+-- \<abc:hello\> are represented just as a string containing a colon, e.g.+-- \"abc:hello\".+--+-- This module provides functionality to handle these more intelligently, splitting+-- all tag and attribute names into their Prefix and LocalPart components.++module Text.XML.Expat.Internal.Qualified (+        QName(..),+        QAttributes,+        mkQName,+        mkAnQName,+        toQualified,+        fromQualified+    ) where++import Text.XML.Expat.Internal.NodeClass+import Text.XML.Expat.SAX+import Control.Parallel.Strategies+import Data.Monoid++-- | A qualified name.+--+-- Qualified names have two parts, a prefix and a local part. The local part+-- is the name of the tag. The prefix scopes that name to a particular+-- group of legal tags.+--+-- The prefix will usually be associated with a namespace URI. This is usually+-- achieved by using xmlns attributes to bind prefixes to URIs.+data QName text =+    QName {+        qnPrefix    :: Maybe text,+        qnLocalPart :: !text+    }+    deriving (Eq,Show)++instance NFData text => NFData (QName text) where+    rnf (QName pre loc) = rnf (pre, loc)++-- | Type shortcut for attributes with qualified names+type QAttributes text = Attributes (QName text) text++-- | Make a new QName from a prefix and localPart.+mkQName :: text -> text -> QName text+mkQName prefix localPart = QName (Just prefix) localPart++-- | Make a new QName with no prefix.+mkAnQName :: text -> QName text+mkAnQName localPart = QName Nothing localPart++toQualified :: (NodeClass n c, GenericXMLString text) => n c text text -> n c (QName text) text+toQualified = mapAllTags qual+  where+    qual ident =+        case gxBreakOn ':' ident of+             (prefix, _local) | not (gxNullString _local)+                              && gxHead _local == ':'+                                 -> QName (Just prefix) (gxTail _local)+             _                   -> QName Nothing ident++fromQualified :: (NodeClass n c, GenericXMLString text) => n c (QName text) text -> n c text text+fromQualified = mapAllTags tag+  where+    tag (QName (Just prefix) local) = prefix `mappend` gxFromChar ':' `mappend` local+    tag (QName Nothing       local) = local+

@@ -1,167 +1,9 @@-{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_HADDOCK hide #-} module Text.XML.Expat.Namespaced-      ( NName (..)-      , NNode-      , NNodes-      , NAttributes-      , mkNName-      , mkAnNName-      , toNamespaced-      , fromNamespaced-      , xmlnsUri-      , xmlns-      ) where--import Text.XML.Expat.Tree-import Text.XML.Expat.Qualified-import Control.Parallel.Strategies-import qualified Data.Map as M-import qualified Data.Maybe as DM-import qualified Data.List as L---- | A namespace-qualified tag.------ NName has two components, a local part and an optional namespace. The local part is the--- name of the tag. The namespace is the URI identifying collections of declared tags.--- Tags with the same local part but from different namespaces are distinct. Unqualified tags--- are those with no namespace. They are in the default namespace, and all uses of an--- unqualified tag are equivalent.-data NName text =-    NName {-        nnNamespace :: Maybe text,-        nnLocalPart :: !text-    }-    deriving (Eq,Show)--instance NFData text => NFData (NName text) where-    rnf (NName ns loc) = rnf (ns, loc)---- | DEPRECATED: Use [NNode text] instead.------ Type shortcut for nodes where namespaced names are used for tags.-{-# DEPRECATED NNodes "use [NNode text] instead" #-}-type NNodes text = [Node (NName text) text]---- | Type shortcut for a single node where namespaced names are used for tags-type NNode text = Node (NName text) text---- | Type shortcut for attributes with namespaced names-type NAttributes text = Attributes (NName text) text---- | Make a new NName from a prefix and localPart.-mkNName :: text -> text -> NName text-mkNName prefix localPart = NName (Just prefix) localPart---- | Make a new NName with no prefix.-mkAnNName :: text -> NName text-mkAnNName localPart = NName Nothing localPart--type NsPrefixMap text = M.Map (Maybe text) (Maybe text)-type PrefixNsMap text = M.Map (Maybe text) (Maybe text)--xmlUri :: (GenericXMLString text) => text-xmlUri = gxFromString "http://www.w3.org/XML/1998/namespace"-xml :: (GenericXMLString text) => text-xml = gxFromString "xml"--xmlnsUri :: (GenericXMLString text) => text-xmlnsUri = gxFromString "http://www.w3.org/2000/xmlns/"-xmlns :: (GenericXMLString text) => text-xmlns = gxFromString "xmlns"--baseNsBindings :: (GenericXMLString text, Ord text)-               => NsPrefixMap text-baseNsBindings = M.fromList-  [ (Nothing, Nothing) -  , (Just xml, Just xmlUri)-  , (Just xmlns, Just xmlnsUri)-  ]--basePfBindings :: (GenericXMLString text, Ord text)-               => PrefixNsMap text-basePfBindings = M.fromList-   [ (Nothing, Nothing)-   , (Just xmlUri, Just xml)-   , (Just xmlnsUri, Just xmlns)-   ]--toNamespaced :: (NodeClass n c, GenericXMLString text, Ord text, Show text)-               => n c (QName text) text -> n c (NName text) text-toNamespaced = nodeWithNamespaces baseNsBindings--nodeWithNamespaces :: (NodeClass n c, GenericXMLString text, Ord text, Show text)-                   => NsPrefixMap text -> n c (QName text) text -> n c (NName text) text-nodeWithNamespaces bindings = mapElement namespaceify-  where-    namespaceify (qname, qattrs, qchildren) = (nname, nattrs, nchildren)-      where-        for = flip map-        ffor = flip fmap-        (nsAtts, otherAtts) = L.partition ((== Just xmlns) . qnPrefix . fst) qattrs-        (dfAtt, normalAtts) = L.partition ((== QName Nothing xmlns) . fst) otherAtts-        nsMap  = M.fromList $ for nsAtts $ \((QName _ lp), uri) -> (Just lp, Just uri)-        -- fixme: when snd q is null, use Nothing-        dfMap  = M.fromList $ for dfAtt $ \q -> (Nothing, Just $ snd q)-        chldBs = M.unions [dfMap, nsMap, bindings]-    -        trans bs (QName pref qual) = case pref `M.lookup` bs of-          Nothing -> error -                  $  "Namespace prefix referenced but never bound: '"-                  ++ (show . DM.fromJust) pref-                  ++ "'"-          Just mUri -> NName mUri qual-        nname       = trans chldBs qname-    -        -- attributes with no prefix are in the same namespace as the element-        attBs = M.insert Nothing (nnNamespace nname) chldBs-    -        transAt (qn, v) = (trans attBs qn, v)-    -        nNsAtts     = map transAt nsAtts-        nDfAtt      = map transAt dfAtt-        nNormalAtts = map transAt normalAtts-        nattrs      = concat [nNsAtts, nDfAtt, nNormalAtts]--        nchildren   = ffor qchildren $ nodeWithNamespaces chldBs+        {-# DEPRECATED "Use Text.XML.Expat.Text or Text.XML.Expat.Annotated instead" #-}+    (+        module Text.XML.Expat.Internal.Namespaced+    ) where -fromNamespaced :: (NodeClass n c, GenericXMLString text, Ord text, Functor c) =>-                  n c (NName text) text -> n c (QName text) text-fromNamespaced = nodeWithQualifiers 1 basePfBindings+import Text.XML.Expat.Internal.Namespaced -nodeWithQualifiers :: (NodeClass n c, GenericXMLString text, Ord text, Functor c) =>-                      Int-                   -> PrefixNsMap text-                   -> n c (NName text) text-                   -> n c (QName text) text-nodeWithQualifiers cntr bindings = mapElement namespaceify-  where-    namespaceify (nname, nattrs, nchildren) = (qname, qattrs, qchildren) -      where-        for = flip map-        ffor = flip fmap-        (nsAtts, otherAtts) = L.partition ((== Just xmlnsUri) . nnNamespace . fst) nattrs-        (dfAtt, normalAtts) = L.partition ((== NName Nothing xmlns) . fst) otherAtts-        nsMap = M.fromList $ for nsAtts $ \((NName _ lp), uri) -> (Just uri, Just lp)-        dfMap = M.fromList $ for dfAtt  $ \(_, uri) -> (Just uri, Just xmlns)-        chldBs = M.unions [dfMap, nsMap, bindings]-    -        trans (i, bs, as) (NName nspace qual) =-          case nspace `M.lookup` bs of-               Nothing -> let-                            pfx = gxFromString $ "ns" ++ show i-                            bsN = M.insert nspace (Just pfx) bs-                            asN = (NName (Just xmlnsUri) pfx, DM.fromJust nspace) : as-                          in trans (i+1, bsN, asN) (NName nspace qual)-               Just pfx -> ((i, bs, as), QName pfx qual)-        transAt ibs (nn, v) = let (ibs', qn) = trans ibs nn-                              in  (ibs', (qn, v))-    -        ((i', bs', as'), qname) = trans (cntr, chldBs, []) nname-    -        ((i'',   bs'',   as''),   qNsAtts)     = L.mapAccumL transAt (i',    bs',    as')    nsAtts-        ((i''',  bs''',  as'''),  qDfAtt)      = L.mapAccumL transAt (i'',   bs'',   as'')   dfAtt-        ((i'''', bs'''', as''''), qNormalAtts) = L.mapAccumL transAt (i''',  bs''',  as''')  normalAtts-        (_,                       qas)         = L.mapAccumL transAt (i'''', bs'''', as'''') as''''-        qattrs = concat [qNsAtts, qDfAtt, qNormalAtts, qas]-    -        qchildren = ffor nchildren $ nodeWithQualifiers i'''' bs''''

@@ -1,115 +1,9 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, TypeFamilies #-}--- | Type classes to allow for XML handling functions to be generalized to--- work with different node types, including the ones defined in /Tree/ and--- /Annotated/.-module Text.XML.Expat.NodeClass where--import Control.Monad.Identity-import Data.List.Class-import Data.Monoid (Monoid)-import Text.XML.Expat.SAX (GenericXMLString)----- | Type shortcut for attributes-type Attributes tag text = [(tag, text)]---- | Type shortcut for attributes with unqualified names where tag and--- text are the same string type.-type UAttributes text = Attributes text text---- | Extract all text content from inside a tag into a single string, including--- any text contained in children.-textContent :: (NodeClass n [], Monoid text) => n [] tag text -> text-textContent node = runIdentity $ textContentM node--class (Functor c, List c) => NodeClass n c where-    -- | Is the given node an element?-    isElement :: n c tag text -> Bool--    -- | Is the given node text?-    isText :: n c tag text -> Bool--    -- | Extract all text content from inside a tag into a single string, including-    -- any text contained in children.-    textContentM :: Monoid text => n c tag text -> ItemM c text--    -- | Is the given node a tag with the given name?-    isNamed :: Eq tag => tag -> n c tag text -> Bool--    -- | Get the name of this node if it's an element, return empty string otherwise.-    getName :: Monoid tag => n c tag text -> tag--    -- | Get the attributes of a node if it's an element, return empty list otherwise.-    getAttributes :: n c tag text -> [(tag,text)]--    -- | Get children of a node if it's an element, return empty list otherwise.-    getChildren :: n c tag text -> c (n c tag text)--    -- | Get this node's text if it's a text node, return empty text otherwise.-    getText :: Monoid text => n c tag text -> text--    -- | Modify name if it's an element, no-op otherwise.-    modifyName :: (tag -> tag)-               -> n c tag text-               -> n c tag text--    -- | Modify attributes if it's an element, no-op otherwise.-    modifyAttributes :: ([(tag, text)] -> [(tag, text)])-                     -> n c tag text-                     -> n c tag text--    -- | Modify children (non-recursively) if it's an element, no-op otherwise.-    modifyChildren :: (c (n c tag text) -> c (n c tag text))-                   -> n c tag text-                   -> n c tag text--    -- | Map all tags (both tag names and attribute names) recursively.-    mapAllTags :: (tag -> tag')-               -> n c tag text-               -> n c tag' text--    -- | Map an element non-recursively, allowing the tag type to be changed.-    mapElement :: ((tag, [(tag, text)], c (n c tag text))-                       -> (tag', [(tag', text)], c (n c tag' text)))-                  -> n c tag text-                  -> n c tag' text--    -- | Change a node from one container type to another.-    mapNodeContainer :: (c (n c tag text) -> ItemM c (c' (n c' tag text)))-                     -> n c tag text-                     -> ItemM c (n c' tag text)--    -- | Create a text node-    mkText :: text -> n c tag text---- | A class of node types where an Element can be constructed given a tag,--- attributes and children.-class NodeClass n c => MkElementClass n c where-    mkElement :: tag -> Attributes tag text -> c (n c tag text) -> n c tag text---- | Get the value of the attribute having the specified name.-getAttribute :: (NodeClass n c, GenericXMLString tag) => n c tag text -> tag -> Maybe text-getAttribute n t = lookup t $ getAttributes n---- | Set the value of the attribute with the specified name to the value, overwriting--- the first existing attribute with that name if present.-setAttribute :: (Eq tag, NodeClass n c, GenericXMLString tag) => tag -> text -> n c tag text -> n c tag text-setAttribute t newValue = modifyAttributes set-  where-    set [] = [(t, newValue)]-    set ((name, _):atts) | name == t = (name, newValue):atts-    set (att:atts) = att:set atts---- | Delete the first attribute matching the specified name.-deleteAttribute :: (Eq tag, NodeClass n c, GenericXMLString tag) => tag -> n c tag text -> n c tag text-deleteAttribute t = modifyAttributes del-  where-    del [] = []-    del ((name, _):atts) | name == t = atts-    del (att:atts) = att:del atts+{-# OPTIONS_HADDOCK hide #-}+module Text.XML.Expat.NodeClass+       {-# DEPRECATED "Use Text.XML.Expat.Text or Text.XML.Expat.Annotated instead" #-}+    (+        module Text.XML.Expat.Internal.NodeClass+    ) where --- | setAttribute if /Just/, deleteAttribute if /Nothing/.-alterAttribute :: (Eq tag, NodeClass n c, GenericXMLString tag) => tag -> Maybe text -> n c tag text -> n c tag text-alterAttribute t (Just newValue) = setAttribute t newValue-alterAttribute t Nothing = deleteAttribute t+import Text.XML.Expat.Internal.NodeClass 

@@ -2,7 +2,7 @@ -- | This module ported from Text.XML.Light.Proc module Text.XML.Expat.Proc where -import Text.XML.Expat.NodeClass+import Text.XML.Expat.Internal.NodeClass import Text.XML.Expat.SAX  import Control.Monad@@ -70,22 +70,8 @@ filterElements       :: NodeClass n c => (n c tag text -> Bool) -> n c tag text -> c (n c tag text) filterElements p e     | p e         = return e-    | isElement e = concatL $ fmap (filterElements p) $ onlyElems $ getChildren e+    | isElement e = join $ fmap (filterElements p) $ onlyElems $ getChildren e     | otherwise   = mzero-  where-    -- Remove here if this gets added to List package.-    concatL :: List l => l (l a) -> l a-    concatL l1 = joinL $ do-        li1 <- runList l1-        return $ case li1 of-            Nil -> mzero-            Cons l2 l1' ->-                let concat2L l2 = joinL $ do-                        li2 <- runList l2-                        return $ case li2 of-                            Nil -> concatL l1'-                            Cons elt l2' -> cons elt $ concat2L l2'-                in  concat2L l2  -- | Find all non-nested occurences of an element wrt a predicate over element names. -- (i.e., once we have found an element, we do not search

@@ -1,81 +1,9 @@--- hexpat, a Haskell wrapper for expat--- Copyright (C) 2008 Evan Martin <martine@danga.com>--- Copyright (C) 2009 Stephen Blackheath <http://blacksapphire.com/antispam>---- | In the default representation, qualified tag and attribute names such as--- \<abc:hello\> are represented just as a string containing a colon, e.g.--- \"abc:hello\".------ This module provides functionality to handle these more intelligently, splitting--- all tag and attribute names into their Prefix and LocalPart components.--module Text.XML.Expat.Qualified (-        QName(..),-        QNode,-        QNodes,-        QAttributes,-        mkQName,-        mkAnQName,-        toQualified,-        fromQualified+{-# OPTIONS_HADDOCK hide #-}+module Text.XML.Expat.Qualified+       {-# DEPRECATED "Use Text.XML.Expat.Text or Text.XML.Expat.Annotated instead" #-}+    (+        module Text.XML.Expat.Internal.Qualified     ) where -import Text.XML.Expat.NodeClass ()-import Text.XML.Expat.Tree-import Control.Parallel.Strategies-import Data.Monoid---- | A qualified name.------ Qualified names have two parts, a prefix and a local part. The local part--- is the name of the tag. The prefix scopes that name to a particular--- group of legal tags.------ The prefix will usually be associated with a namespace URI. This is usually--- achieved by using xmlns attributes to bind prefixes to URIs.-data QName text =-    QName {-        qnPrefix    :: Maybe text,-        qnLocalPart :: !text-    }-    deriving (Eq,Show)--instance NFData text => NFData (QName text) where-    rnf (QName pre loc) = rnf (pre, loc)---- | DEPRECATED: Use [QNode text] instead.------ Type shortcut for nodes where qualified names are used for tags-{-# DEPRECATED QNodes "use [QNode text] instead" #-}-type QNodes text = [Node (QName text) text]---- | Type shortcut for a single node where qualified names are used for tags-type QNode text = Node (QName text) text---- | Type shortcut for attributes with qualified names-type QAttributes text = Attributes (QName text) text---- | Make a new QName from a prefix and localPart.-mkQName :: text -> text -> QName text-mkQName prefix localPart = QName (Just prefix) localPart---- | Make a new QName with no prefix.-mkAnQName :: text -> QName text-mkAnQName localPart = QName Nothing localPart--toQualified :: (NodeClass n c, GenericXMLString text) => n c text text -> n c (QName text) text-toQualified = mapAllTags qual-  where-    qual ident =-        case gxBreakOn ':' ident of-             (prefix, _local) | not (gxNullString _local)-                              && gxHead _local == ':'-                                 -> QName (Just prefix) (gxTail _local)-             _                   -> QName Nothing ident--fromQualified :: (NodeClass n c, GenericXMLString text) => n c (QName text) text -> n c text text-fromQualified = mapAllTags tag-  where-    tag (QName (Just prefix) local) = prefix `mappend` gxFromChar ':' `mappend` local-    tag (QName Nothing       local) = local+import Text.XML.Expat.Internal.Qualified 

@@ -37,9 +37,9 @@    -- * Abstraction of string types   GenericXMLString(..)-) where+  ) where -import Text.XML.Expat.IO hiding (parse)+import Text.XML.Expat.Internal.IO hiding (parse) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Internal as I

@@ -99,8 +99,16 @@   UNode,    -- * Generic node manipulation-  module Text.XML.Expat.NodeClass,+  module Text.XML.Expat.Internal.NodeClass, +  -- * Qualified nodes+  QNode,+  module Text.XML.Expat.Internal.Qualified,++  -- * Namespaced nodes+  NNode,+  module Text.XML.Expat.Internal.Namespaced,+   -- * Parse to tree   ParserOptions(..),   defaultParserOptions,@@ -125,6 +133,8 @@   eAttrs,   Nodes,   UNodes,+  QNodes,+  NNodes,   parseTree,   parseTree',   parseSAX,@@ -132,11 +142,10 @@   parseTreeThrowing,   parseSAXThrowing,   parseSAXLocationsThrowing-) where+  ) where --------------------------------------------------------------------------------import Text.XML.Expat.IO hiding (parse,parse')-import qualified Text.XML.Expat.IO as IO+import Text.XML.Expat.Internal.IO hiding (parse,parse')+import qualified Text.XML.Expat.Internal.IO as IO import Text.XML.Expat.SAX ( ParserOptions(..)                           , XMLParseException(..)                           , SAXEvent(..)@@ -149,9 +158,10 @@                           , GenericXMLString(..)                           , setEntityDecoder ) import qualified Text.XML.Expat.SAX as SAX-import Text.XML.Expat.NodeClass+import Text.XML.Expat.Internal.Namespaced+import Text.XML.Expat.Internal.NodeClass+import Text.XML.Expat.Internal.Qualified ------------------------------------------------------------------------------- import Control.Arrow import Control.Monad (forM, mplus, mzero) import Data.ByteString (ByteString)@@ -165,8 +175,8 @@  -- | The tree representation of the XML document. ----- @c@ is the container type for the element's children, which is usually [],--- except when you are using chunked I\/O with the @hexpat-iteratee@ package.+-- @c@ is the container type for the element's children, which is [] in the+-- @hexpat@ package, and a monadic list type for @hexpat-iteratee@. -- -- @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@@ -181,6 +191,8 @@     } |     Text !text +type instance ListOf (NodeG c tag text) = c (NodeG c tag text)+ instance (Show tag, Show text) => Show (NodeG [] tag text) where     show (Element na at ch) = "Element "++show na++" "++show at++" "++show ch     show (Text t) = "Text "++show t@@ -194,7 +206,12 @@     _ == _ = False  -- | A pure tree representation that uses a list as its container type.-type Node = NodeG []+--+-- 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 tag text = NodeG [] tag text  eAttrs :: Node tag text -> [(tag, text)] {-# DEPRECATED eAttrs "use eAttributes instead" #-}@@ -206,20 +223,38 @@  -- | DEPRECATED: Use [Node tag text] instead. ----- Type shortcut for nodes.+-- Type alias for nodes. type Nodes tag text = [Node tag text] {-# DEPRECATED Nodes "use [Node tag text] instead" #-}  -- | DEPRECATED: Use [UNode text] instead. ----- Type shortcut for nodes with unqualified tag names where tag and--- text are the same string type. Deprecated+-- Type alias for nodes with unqualified tag names where tag and+-- text are the same string type. DEPRECATED. type UNodes text = Nodes text text {-# DEPRECATED UNodes "use [UNode text] instead" #-} --- | Type shortcut for a single node with unqualified tag names where tag and+-- | Type alias for a single node with unqualified tag names where tag and -- text are the same string type. type UNode text = Node text text++-- | DEPRECATED: Use [QNode text] instead.+--+-- Type alias for nodes where qualified names are used for tags+{-# DEPRECATED QNodes "use [QNode text] instead" #-}+type QNodes text = [Node (QName text) text]++-- | Type alias for a single node where qualified names are used for tags+type QNode text = Node (QName text) text++-- | DEPRECATED: Use [NNode text] instead.+--+-- Type alias for nodes where namespaced names are used for tags.+{-# DEPRECATED NNodes "use [NNode text] instead" #-}+type NNodes text = [Node (NName text) text]++-- | Type alias for a single node where namespaced names are used for tags+type NNode text = Node (NName text) text  instance (Functor c, List c) => NodeClass NodeG c where     textContentM (Element _ _ children) = foldlL mappend mempty $ joinM $ fmap textContentM children

@@ -1,7 +1,7 @@ Cabal-Version: >= 1.6 Name: hexpat-Version: 0.15.1-Synopsis: wrapper for expat, the fast XML parser+Version: 0.16+Synopsis: XML parser/formatter based on expat Description:   This package provides a general purpose Haskell XML library using Expat to   do its parsing (<http://expat.sourceforge.net/> - a fast stream-oriented XML@@ -9,25 +9,25 @@   @ByteString@ and @Text@ provided out of the box.   .   Basic usage: Parsing a tree (/Tree/), formatting a tree (/Format/).-  .   Other features: Helpers for processing XML trees (/Proc/), trees annotated with-  XML source location (/Annotated/), XML cursors (/Cursor/), more intelligent-  handling of qualified tag names (/Qualified/), tags qualified with namespaces-  (/Namespaced/), SAX-style parse (/SAX/), and access to the low-level interface-  in case speed is paramount (/IO/).  And, /NodeClass/ contains type classes for-  generalized tree processing.+  XML source location (/Annotated/), XML cursors (/Cursor/), SAX-style parse (/SAX/),+  and access to the low-level interface in case speed is paramount (/Internal.IO/).   .-  The design goals are speed, speed, speed, interface simplicity and modularity-  (in that order).+  The design goals are speed, speed, speed, interface simplicity and modularity.   .   For introduction and examples, see the /Text.XML.Expat.Tree/ module. For benchmarks,   <http://haskell.org/haskellwiki/Hexpat/>   .-  This package provides pure lazy parsing.  However, Haskell's lazy I\/O is+  If you want to do interactive I\/O, an obvious option is to use lazy parsing+  with one of the lazy I\/O functions such as hGetContents.  However, this can be   problematic in some applications because it doesn't handle I\/O errors properly   and can give no guarantee of timely resource cleanup.  In these cases, chunked   I\/O is a better approach: Take a look at the /hexpat-iteratee/ package.   .+  /IO/ is filed under /Internal/ because it's low-level and most users won't want+  it.  The other /Internal/ modules are re-exported by /Annotated/ and /Tree/,+  so you won't need to import them directly.+  .   Credits to Iavor Diatchki and the @xml@ (XML.Light) package for /Proc/ and /Cursor/.   .   INSTALLATION: Unix install requires an OS package called something like @libexpat-dev@.@@ -40,7 +40,8 @@   Ensure @libexpat.dll@ can be found in your system PATH (or copy it into your executable's directory).   .   ChangeLog: 0.15 changes intended to fix a (rare) \"error: a C finalizer called back into Haskell.\"-    that seemed only to happen only on ghc6.12.X; 0.15.1 Fix broken Annotated parse.+    that seemed only to happen only on ghc6.12.X; 0.15.1 Fix broken Annotated parse;+    0.16 switch from mtl to transformers Category: XML License: BSD3 License-File: LICENSE@@ -77,13 +78,13 @@   Build-Depends:     base >= 3 && < 5,     bytestring,-    mtl,+    transformers,     text >= 0.5,     utf8-string >= 0.3.3,     parallel,     containers,     extensible-exceptions >= 0.1 && < 0.2,-    List >= 0.2+    List >= 0.4   Exposed-Modules:     Text.XML.Expat.Annotated,     Text.XML.Expat.Cursor,@@ -94,6 +95,10 @@     Text.XML.Expat.Proc,     Text.XML.Expat.Qualified,     Text.XML.Expat.SAX,-    Text.XML.Expat.Tree+    Text.XML.Expat.Tree,+    Text.XML.Expat.Internal.IO,+    Text.XML.Expat.Internal.Namespaced,+    Text.XML.Expat.Internal.NodeClass,+    Text.XML.Expat.Internal.Qualified   Extra-Libraries: expat   ghc-options: -Wall -fno-warn-name-shadowing

@@ -17,7 +17,7 @@     containers,     extensible-exceptions >= 0.1 && < 0.2,     haskell98,-    mtl >= 1.1.0.0,+    transformers,     parallel,     QuickCheck == 1.2.0.0,     test-framework < 0.3,@@ -25,7 +25,7 @@     test-framework-quickcheck < 0.3,     text >= 0.5,     utf8-string >= 0.3.3,-    List >= 0.2+    List >= 0.4    ghc-options: -Wall -fhpc   if impl(ghc >= 6.8)