diff --git a/Text/XML/Expat/Annotated.hs b/Text/XML/Expat/Annotated.hs --- a/Text/XML/Expat/Annotated.hs +++ b/Text/XML/Expat/Annotated.hs @@ -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. diff --git a/Text/XML/Expat/Cursor.hs b/Text/XML/Expat/Cursor.hs --- a/Text/XML/Expat/Cursor.hs +++ b/Text/XML/Expat/Cursor.hs @@ -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 diff --git a/Text/XML/Expat/Format.hs b/Text/XML/Expat/Format.hs --- a/Text/XML/Expat/Format.hs +++ b/Text/XML/Expat/Format.hs @@ -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 diff --git a/Text/XML/Expat/IO.hs b/Text/XML/Expat/IO.hs --- a/Text/XML/Expat/IO.hs +++ b/Text/XML/Expat/IO.hs @@ -1,525 +1,9 @@ -{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} - --- hexpat, a Haskell wrapper for expat --- Copyright (C) 2008 Evan Martin --- Copyright (C) 2009 Stephen Blackheath - --- | 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 diff --git a/Text/XML/Expat/Internal/IO.hs b/Text/XML/Expat/Internal/IO.hs new file mode 100644 --- /dev/null +++ b/Text/XML/Expat/Internal/IO.hs @@ -0,0 +1,525 @@ +{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} + +-- hexpat, a Haskell wrapper for expat +-- Copyright (C) 2008 Evan Martin +-- Copyright (C) 2009 Stephen Blackheath + +-- | 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 () + diff --git a/Text/XML/Expat/Internal/Namespaced.hs b/Text/XML/Expat/Internal/Namespaced.hs new file mode 100644 --- /dev/null +++ b/Text/XML/Expat/Internal/Namespaced.hs @@ -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'''' diff --git a/Text/XML/Expat/Internal/NodeClass.hs b/Text/XML/Expat/Internal/NodeClass.hs new file mode 100644 --- /dev/null +++ b/Text/XML/Expat/Internal/NodeClass.hs @@ -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' + diff --git a/Text/XML/Expat/Internal/Qualified.hs b/Text/XML/Expat/Internal/Qualified.hs new file mode 100644 --- /dev/null +++ b/Text/XML/Expat/Internal/Qualified.hs @@ -0,0 +1,70 @@ +-- hexpat, a Haskell wrapper for expat +-- Copyright (C) 2008 Evan Martin +-- Copyright (C) 2009 Stephen Blackheath + +-- | In the default representation, qualified tag and attribute names such as +-- \ 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 + diff --git a/Text/XML/Expat/Namespaced.hs b/Text/XML/Expat/Namespaced.hs --- a/Text/XML/Expat/Namespaced.hs +++ b/Text/XML/Expat/Namespaced.hs @@ -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'''' diff --git a/Text/XML/Expat/NodeClass.hs b/Text/XML/Expat/NodeClass.hs --- a/Text/XML/Expat/NodeClass.hs +++ b/Text/XML/Expat/NodeClass.hs @@ -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 diff --git a/Text/XML/Expat/Proc.hs b/Text/XML/Expat/Proc.hs --- a/Text/XML/Expat/Proc.hs +++ b/Text/XML/Expat/Proc.hs @@ -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 diff --git a/Text/XML/Expat/Qualified.hs b/Text/XML/Expat/Qualified.hs --- a/Text/XML/Expat/Qualified.hs +++ b/Text/XML/Expat/Qualified.hs @@ -1,81 +1,9 @@ --- hexpat, a Haskell wrapper for expat --- Copyright (C) 2008 Evan Martin --- Copyright (C) 2009 Stephen Blackheath - --- | In the default representation, qualified tag and attribute names such as --- \ 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 diff --git a/Text/XML/Expat/SAX.hs b/Text/XML/Expat/SAX.hs --- a/Text/XML/Expat/SAX.hs +++ b/Text/XML/Expat/SAX.hs @@ -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 diff --git a/Text/XML/Expat/Tree.hs b/Text/XML/Expat/Tree.hs --- a/Text/XML/Expat/Tree.hs +++ b/Text/XML/Expat/Tree.hs @@ -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 diff --git a/hexpat.cabal b/hexpat.cabal --- a/hexpat.cabal +++ b/hexpat.cabal @@ -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 ( - 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, . - 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 diff --git a/test/hexpat-tests.cabal b/test/hexpat-tests.cabal --- a/test/hexpat-tests.cabal +++ b/test/hexpat-tests.cabal @@ -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)