xml-enumerator 0.3.4 → 0.4.0
raw patch · 16 files changed
+2273/−2175 lines, 16 filesdep +data-defaultdep +xml-enumeratordep ~HUnitdep ~basedep ~enumerator
Dependencies added: data-default, xml-enumerator
Dependency ranges changed: HUnit, base, enumerator, hspec, text
Files
- Text/XML.hs +219/−0
- Text/XML/Cursor.hs +223/−0
- Text/XML/Cursor/Generic.hs +164/−0
- Text/XML/Enumerator/Cursor.hs +0/−315
- Text/XML/Enumerator/Document.hs +0/−254
- Text/XML/Enumerator/Parse.hs +0/−672
- Text/XML/Enumerator/Render.hs +0/−268
- Text/XML/Enumerator/Resolved.hs +0/−221
- Text/XML/Enumerator/Token.hs +0/−151
- Text/XML/Stream/Parse.hs +691/−0
- Text/XML/Stream/Render.hs +271/−0
- Text/XML/Stream/Token.hs +151/−0
- Text/XML/Unresolved.hs +242/−0
- runtests.hs +0/−276
- test/main.hs +272/−0
- xml-enumerator.cabal +40/−18
+ Text/XML.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE DeriveDataTypeable #-}+-- | DOM-based parsing and rendering.+--+-- This module requires that all entities be resolved at parsing. If you need+-- to interact with unresolved entities, please use "Text.XML.Unresolved". This+-- is the recommended module for most uses cases.+--+-- While many of the datatypes in this module are simply re-exported from+-- @Data.XML.Types@, 'Document', 'Node' and 'Element' are all redefined here to+-- disallow the possibility of unresolved entities. Conversion functions are+-- provided to switch between the two sets of datatypes.+--+-- For simpler, bidirectional traversal of the DOM tree, see the+-- "Text.XML.Cursor" module.+module Text.XML+ ( -- * Data types+ Document (..)+ , Prologue (..)+ , Instruction (..)+ , Miscellaneous (..)+ , Node (..)+ , Element (..)+ , Name (..)+ , Doctype (..)+ , ExternalID (..)+ -- * Parsing+ , readFile+ , readFile_+ , parseLBS+ , parseLBS_+ , parseEnum+ , parseEnum_+ , fromEvents+ , UnresolvedEntityException (..)+ -- * Rendering+ , writeFile+ , renderLBS+ , renderText+ , renderBytes+ -- * Settings+ , def+ -- ** Parsing+ , ParseSettings+ , psDecodeEntities+ -- ** Rendering+ , R.RenderSettings+ , R.rsPretty+ -- * Conversion+ , toXMLDocument+ , fromXMLDocument+ , toXMLNode+ , fromXMLNode+ , toXMLElement+ , fromXMLElement+ ) where++import qualified Data.XML.Types as X+import Data.XML.Types+ ( Prologue (..)+ , Miscellaneous (..)+ , Instruction (..)+ , Name (..)+ , Doctype (..)+ , ExternalID (..)+ )+import Data.Typeable (Typeable)+import Data.Text (Text)+import qualified Text.XML.Stream.Parse as P+import qualified Text.XML.Unresolved as D+import qualified Text.XML.Stream.Render as R+import qualified Data.Text as T+import Data.Either (partitionEithers)+import Prelude hiding (readFile, writeFile)+import Control.Exception (SomeException, Exception)+import Data.Enumerator.Binary (enumFile, iterHandle)+import Control.Monad.IO.Class (MonadIO)+import Text.XML.Stream.Parse (ParseSettings, def, psDecodeEntities)+import Data.Enumerator+ ( Enumerator, Iteratee, throwError, ($$), run, run_, joinI, enumList+ , joinE+ )+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as L+import Data.Functor.Identity (runIdentity)+import qualified System.IO as SIO+import System.IO.Unsafe (unsafePerformIO)+import Text.XML.Unresolved (lazyConsume)+import qualified Data.Set as Set+import Data.Set (Set)++import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TLE++data Document = Document+ { documentPrologue :: Prologue+ , documentRoot :: Element+ , documentEpilogue :: [Miscellaneous]+ }+ deriving (Show, Eq, Typeable)++data Node+ = NodeElement Element+ | NodeInstruction Instruction+ | NodeContent Text+ | NodeComment Text+ deriving (Show, Eq, Typeable)++data Element = Element+ { elementName :: Name+ , elementAttributes :: [(Name, Text)]+ , elementNodes :: [Node]+ }+ deriving (Show, Eq, Typeable)++{-+readFile :: FilePath -> ParseSettings -> IO (Either SomeException Document)+readFile_ :: FIlePath -> ParseSettings -> IO Document+-}++toXMLDocument :: Document -> X.Document+toXMLDocument (Document a b c) = X.Document a (toXMLElement b) c++toXMLElement :: Element -> X.Element+toXMLElement (Element name as nodes) =+ X.Element name as' nodes'+ where+ as' = map (\(x, y) -> (x, [X.ContentText y])) as+ nodes' = map toXMLNode nodes++toXMLNode :: Node -> X.Node+toXMLNode (NodeElement e) = X.NodeElement $ toXMLElement e+toXMLNode (NodeContent t) = X.NodeContent $ X.ContentText t+toXMLNode (NodeComment c) = X.NodeComment c+toXMLNode (NodeInstruction i) = X.NodeInstruction i++fromXMLDocument :: X.Document -> Either (Set Text) Document+fromXMLDocument (X.Document a b c) =+ case fromXMLElement b of+ Left es -> Left es+ Right b' -> Right $ Document a b' c++fromXMLElement :: X.Element -> Either (Set Text) Element+fromXMLElement (X.Element name as nodes) =+ case (lnodes, las) of+ ([], []) -> Right $ Element name ras rnodes+ (x, []) -> Left $ Set.unions x+ ([], y) -> Left $ Set.unions y+ (x, y) -> Left $ Set.unions x `Set.union` Set.unions y+ where+ enodes = map fromXMLNode nodes+ (lnodes, rnodes) = partitionEithers enodes+ eas = map go as+ (las, ras) = partitionEithers eas+ go (x, y) =+ case go' [] id y of+ Left es -> Left es+ Right y' -> Right (x, y')+ go' [] front [] = Right $ T.concat $ front []+ go' errs _ [] = Left $ Set.fromList errs+ go' errs front (X.ContentText t:ys) = go' errs (front . (:) t) ys+ go' errs front (X.ContentEntity t:ys) = go' (t : errs) front ys++fromXMLNode :: X.Node -> Either (Set Text) Node+fromXMLNode (X.NodeElement e) =+ either Left (Right . NodeElement) $ fromXMLElement e+fromXMLNode (X.NodeContent (X.ContentText t)) = Right $ NodeContent t+fromXMLNode (X.NodeContent (X.ContentEntity t)) = Left $ Set.singleton t+fromXMLNode (X.NodeComment c) = Right $ NodeComment c+fromXMLNode (X.NodeInstruction i) = Right $ NodeInstruction i++readFile :: ParseSettings -> FilePath -> IO (Either SomeException Document)+readFile ps fn = parseEnum ps $ enumFile fn++readFile_ :: ParseSettings -> FilePath -> IO Document+readFile_ ps fn = parseEnum_ ps $ enumFile fn++lbsEnum :: Monad m => L.ByteString -> Enumerator ByteString m a+lbsEnum = enumList 8 . L.toChunks++parseLBS :: ParseSettings -> L.ByteString -> Either SomeException Document+parseLBS ps = runIdentity . parseEnum ps . lbsEnum++parseLBS_ :: ParseSettings -> L.ByteString -> Document+parseLBS_ ps = runIdentity . parseEnum_ ps . lbsEnum++parseEnum :: Monad m+ => ParseSettings+ -> Enumerator ByteString m Document+ -> m (Either SomeException Document)+parseEnum de enum = run $ enum $$ joinI $ P.parseBytes de $$ fromEvents++parseEnum_ :: Monad m+ => ParseSettings+ -> Enumerator ByteString m Document+ -> m Document+parseEnum_ de enum = run_ $ enum $$ joinI $ P.parseBytes de $$ fromEvents++fromEvents :: Monad m => Iteratee X.Event m Document+fromEvents = do+ d <- D.fromEvents+ either (throwError . UnresolvedEntityException) return $ fromXMLDocument d++data UnresolvedEntityException = UnresolvedEntityException (Set Text)+ deriving (Show, Typeable)+instance Exception UnresolvedEntityException++renderBytes :: MonadIO m => R.RenderSettings -> Document -> Enumerator ByteString m a+renderBytes rs doc = enumList 8 (D.toEvents $ toXMLDocument doc) `joinE` R.renderBytes rs++writeFile :: R.RenderSettings -> FilePath -> Document -> IO ()+writeFile rs fn doc = SIO.withBinaryFile fn SIO.WriteMode $ \h ->+ run_ $ renderBytes rs doc $$ iterHandle h++renderLBS :: R.RenderSettings -> Document -> L.ByteString+renderLBS rs doc =+ L.fromChunks $ unsafePerformIO $ lazyConsume $ renderBytes rs doc++renderText :: R.RenderSettings -> Document -> TL.Text+renderText rs = TLE.decodeUtf8 . renderLBS rs
+ Text/XML/Cursor.hs view
@@ -0,0 +1,223 @@+-- | This module provides for simple DOM traversal. It is inspired by XPath. There are two central concepts here:+--+-- * A 'Cursor' represents a node in the DOM. It also contains information on the node's /location/. While the 'Node' datatype will only know of its children, a @Cursor@ knows about its parent and siblings as well. (The underlying mechanism allowing this is called a zipper, see <http://www.haskell.org/haskellwiki/Zipper> and <http://www.haskell.org/haskellwiki/Tying_the_Knot>.)+--+-- * An 'Axis', in its simplest form, takes a @Cursor@ and returns a list of @Cursor@s. It is used for selections, such as finding children, ancestors, etc. Axes can be chained together to express complex rules, such as all children named /foo/.+--+-- The terminology used in this module is taken directly from the XPath+-- specification: <http://www.w3.org/TR/xpath/>. For those familiar with XPath,+-- the one major difference is that attributes are not considered nodes in this+-- module.+module Text.XML.Cursor+ (+ -- * Data types+ Cursor+ , Axis+ -- * Production+ , fromDocument+ , fromNode+ , cut+ -- * Axes+ , parent+ , CG.precedingSibling+ , CG.followingSibling+ , child+ , node+ , CG.preceding+ , CG.following+ , CG.ancestor+ , descendant+ , orSelf+ -- ** Filters+ , check+ , checkNode+ , checkElement+ , checkName+ , anyElement+ , element+ , laxElement+ , content+ , attribute+ , laxAttribute+ , hasAttribute+ , attributeIs+ -- * Operators+ , (CG.&|)+ , (CG.&/)+ , (CG.&//)+ , (CG.&.//)+ , (CG.$|)+ , (CG.$/)+ , (CG.$//)+ , (CG.$.//)+ , (CG.>=>)+ -- * Type classes+ , Boolean(..)+ -- * Error handling+ , force+ , forceM+ ) where++import Control.Monad+import Data.Function (on)+import Text.XML+import qualified Control.Failure as F+import qualified Data.Text as T+import qualified Text.XML.Cursor.Generic as CG+import Text.XML.Cursor.Generic (node, child, parent, descendant, orSelf)+import Data.Maybe (maybeToList)++-- TODO: Consider [Cursor] -> [Cursor]?+-- | The type of an Axis that returns a list of Cursors.+-- They are roughly modeled after <http://www.w3.org/TR/xpath/#axes>.+-- +-- Axes can be composed with '>=>', where e.g. @f >=> g@ means that on all results of+-- the @f@ axis, the @g@ axis will be applied, and all results joined together. +-- Because Axis is just a type synonym for @Cursor -> [Cursor]@, it is possible to use+-- other standard functions like '>>=' or 'concatMap' similarly.+-- +-- The operators '&|', '&/', '&//' and '&.//' can be used to combine axes so that the second+-- axis works on the context nodes, children, descendants, respectively the context node as +-- well as its descendants of the results of the first axis.+-- +-- The operators '$|', '$/', '$//' and '$.//' can be used to apply an axis (right-hand side)+-- to a cursor so that it is applied on the cursor itself, its children, its descendants,+-- respectively itself and its descendants.+-- +-- Note that many of these operators also work on /generalised Axes/ that can return +-- lists of something other than Cursors, for example Content elements.+type Axis = Cursor -> [Cursor]++-- XPath axes as in http://www.w3.org/TR/xpath/#axes++-- TODO: Decide whether to use an existing package for this+-- | Something that can be used in a predicate check as a boolean.+class Boolean a where+ bool :: a -> Bool++instance Boolean Bool where + bool = id+instance Boolean [a] where + bool = not . null+instance Boolean (Maybe a) where + bool (Just _) = True+ bool _ = False+instance Boolean (Either a b) where+ bool (Left _) = False+ bool (Right _) = True++-- | A cursor: contains an XML 'Node' and pointers to its children, ancestors and siblings.+type Cursor = CG.Cursor Node++-- | Cut a cursor off from its parent. The idea is to allow restricting the scope of queries on it.+cut :: Cursor -> Cursor+cut = fromNode . CG.node++-- | Convert a 'Document' to a 'Cursor'. It will point to the document root.+fromDocument :: Document -> Cursor+fromDocument = fromNode . NodeElement . documentRoot++-- | Convert a 'Node' to a 'Cursor' (without parents).+fromNode :: Node -> Cursor+fromNode =+ CG.toCursor cs+ where+ cs (NodeElement (Element _ _ x)) = x+ cs _ = []++-- | Filter cursors that don't pass a check.+check :: Boolean b => (Cursor -> b) -> Axis+check f c = case bool $ f c of+ False -> []+ True -> [c]++-- | Filter nodes that don't pass a check.+checkNode :: Boolean b => (Node -> b) -> Axis+checkNode f c = check (f . node) c++-- | Filter elements that don't pass a check, and remove all non-elements.+checkElement :: Boolean b => (Element -> b) -> Axis+checkElement f c = case node c of+ NodeElement e -> case bool $ f e of+ True -> [c]+ False -> []+ _ -> []++-- | Filter elements that don't pass a name check, and remove all non-elements.+checkName :: Boolean b => (Name -> b) -> Axis+checkName f c = checkElement (f . elementName) c++-- | Remove all non-elements. Compare roughly to XPath:+-- /A node test * is true for any node of the principal node type. For example, child::* will select all element children of the context node [...]/.+anyElement :: Axis+anyElement = checkElement (const True)++-- | Select only those elements with a matching tag name. XPath:+-- /A node test that is a QName is true if and only if the type of the node (see [5 Data Model]) is the principal node type and has an expanded-name equal to the expanded-name specified by the QName./+element :: Name -> Axis+element n = checkName (== n)++-- | Select only those elements with a loosely matching tag name. Namespace and case are ignored. XPath:+-- /A node test that is a QName is true if and only if the type of the node (see [5 Data Model]) is the principal node type and has an expanded-name equal to the expanded-name specified by the QName./+laxElement :: T.Text -> Axis+laxElement n = checkName (on (==) T.toCaseFold n . nameLocalName)++-- | Select only text nodes, and directly give the 'Content' values. XPath:+-- /The node test text() is true for any text node./+-- +-- Note that this is not strictly an 'Axis', but will work with most combinators.+content :: Cursor -> [T.Text]+content c = case node c of+ (NodeContent v) -> [v]+ _ -> []++-- | Select attributes on the current element (or nothing if it is not an element). XPath:+-- /the attribute axis contains the attributes of the context node; the axis will be empty unless the context node is an element/+-- +-- Note that this is not strictly an 'Axis', but will work with most combinators.+-- +-- The return list of the generalised axis contains as elements lists of 'Content' +-- elements, each full list representing an attribute value.+attribute :: Name -> Cursor -> [T.Text]+attribute n c =+ case node c of+ NodeElement e -> maybeToList $ lookup n $ elementAttributes e+ _ -> []++-- | Select attributes on the current element (or nothing if it is not an element). Namespace and case are ignored. XPath:+-- /the attribute axis contains the attributes of the context node; the axis will be empty unless the context node is an element/+-- +-- Note that this is not strictly an 'Axis', but will work with most combinators.+-- +-- The return list of the generalised axis contains as elements lists of 'Content' +-- elements, each full list representing an attribute value.+laxAttribute :: T.Text -> Cursor -> [T.Text]+laxAttribute n c =+ case node c of+ NodeElement e -> do+ (n', v) <- elementAttributes e+ guard $ (on (==) T.toCaseFold) n (nameLocalName n')+ return v+ _ -> []++-- | Select only those element nodes with the given attribute.+hasAttribute :: Name -> Axis+hasAttribute n c =+ case node c of+ NodeElement (Element _ as _) -> maybe [] (const [c]) $ lookup n as+ _ -> []++-- | Select only those element nodes containing the given attribute key/value pair.+attributeIs :: Name -> T.Text -> Axis+attributeIs n v c =+ case node c of+ NodeElement (Element _ as _) -> if Just v == lookup n as then [c] else []+ _ -> []++force :: F.Failure e f => e -> [a] -> f a+force e [] = F.failure e+force _ (x:_) = return x++forceM :: F.Failure e f => e -> [f a] -> f a+forceM e [] = F.failure e+forceM _ (x:_) = x
+ Text/XML/Cursor/Generic.hs view
@@ -0,0 +1,164 @@+-- | Generalized cursors to be applied to different nodes.+module Text.XML.Cursor.Generic+ ( -- * Core+ Cursor+ , Axis+ , toCursor+ , node+ -- * Axes+ , child+ , parent+ , precedingSibling+ , followingSibling+ , ancestor+ , descendant+ , orSelf+ , preceding+ , following+ -- * Operators+ , (&|)+ , (&/)+ , (&//)+ , (&.//)+ , ($|)+ , ($/)+ , ($//)+ , ($.//)+ , (>=>)+ ) where++import Data.Maybe (maybeToList)+import Data.List (foldl')+import Control.Monad ((>=>))++type DiffCursor node = [Cursor node] -> [Cursor node]+type Axis node = Cursor node -> [Cursor node]++-- | A cursor: contains an XML 'Node' and pointers to its children, ancestors and siblings.+data Cursor node = Cursor+ { parent' :: Maybe (Cursor node)+ , precedingSibling' :: DiffCursor node+ , followingSibling' :: DiffCursor node+ -- | The child axis. XPath:+ -- /the child axis contains the children of the context node/.+ , child :: [Cursor node]+ -- | The current node.+ , node :: node+ }++instance Show node => Show (Cursor node) where+ show Cursor { node = n } = "Cursor @ " ++ show n++toCursor :: (node -> [node]) -- ^ get children+ -> node+ -> Cursor node+toCursor cs = toCursor' cs Nothing id id++toCursor' :: (node -> [node])+ -> Maybe (Cursor node) -> DiffCursor node -> DiffCursor node -> node -> Cursor node+toCursor' cs par pre fol n =+ me+ where+ me = Cursor par pre fol chi n+ chi' = cs n+ chi = go id chi' []+ go _ [] = id+ go pre' (n':ns') =+ (:) me' . fol'+ where+ me' = toCursor' cs (Just me) pre' fol' n'+ fol' = go (pre' . (:) me') ns'++-- | The parent axis. As described in XPath:+-- /the parent axis contains the parent of the context node, if there is one/.+--+-- Every node but the root element of the document has a parent. Parent nodes+-- will always be 'NodeElement's.+parent :: Axis node+parent = maybeToList . parent'++-- | The preceding-sibling axis. XPath:+-- /the preceding-sibling axis contains all the preceding siblings of the context node [...]/.+precedingSibling :: Axis node+precedingSibling = ($ []) . precedingSibling'++-- | The following-sibling axis. XPath:+-- /the following-sibling axis contains all the following siblings of the context node [...]/.+followingSibling :: Axis node+followingSibling = ($ []) . followingSibling'++-- | The preceding axis. XPath:+-- /the preceding axis contains all nodes in the same document as the context node that are before the context node in document order, excluding any ancestors and excluding attribute nodes and namespace nodes/.+preceding :: Axis node+preceding c =+ go (precedingSibling' c []) (parent c >>= preceding)+ where+ go x y = foldl' (flip go') y x+ go' x rest = foldl' (flip go') (x : rest) (child x)++-- | The following axis. XPath:+-- /the following axis contains all nodes in the same document as the context node that are after the context node in document order, excluding any descendants and excluding attribute nodes and namespace nodes/.+following :: Axis node+following c =+ go (followingSibling' c) (parent c >>= following)+ where+ go x z = foldr go' z (x [])+ go' x rest = x : foldr go' rest (child x)++-- | The ancestor axis. XPath:+-- /the ancestor axis contains the ancestors of the context node; the ancestors of the context node consist of the parent of context node and the parent's parent and so on; thus, the ancestor axis will always include the root node, unless the context node is the root node/.+ancestor :: Axis node+ancestor = parent >=> (\p -> p : ancestor p)++-- | The descendant axis. XPath:+-- /the descendant axis contains the descendants of the context node; a descendant is a child or a child of a child and so on; thus the descendant axis never contains attribute or namespace nodes/.+descendant :: Axis node+descendant = child >=> (\c -> c : descendant c)++-- | Modify an axis by adding the context node itself as the first element of the result list.+orSelf :: Axis node -> Axis node+orSelf ax c = c : ax c++infixr 1 &|+infixr 1 &/ +infixr 1 &// +infixr 1 &.// +infixr 1 $|+infixr 1 $/+infixr 1 $//+infixr 1 $.//++-- | Apply a function to the result of an axis.+(&|) :: (Cursor node -> [a]) -> (a -> b) -> (Cursor node -> [b])+f &| g = map g . f++-- | Combine two axes so that the second works on the children of the results+-- of the first.+(&/) :: Axis node -> (Cursor node -> [a]) -> (Cursor node -> [a])+f &/ g = f >=> child >=> g++-- | Combine two axes so that the second works on the descendants of the results+-- of the first.+(&//) :: Axis node -> (Cursor node -> [a]) -> (Cursor node -> [a])+f &// g = f >=> descendant >=> g++-- | Combine two axes so that the second works on both the result nodes, and their+-- descendants.+(&.//) :: Axis node -> (Cursor node -> [a]) -> (Cursor node -> [a])+f &.// g = f >=> orSelf descendant >=> g++-- | Apply an axis to a 'Cursor node'.+($|) :: Cursor node -> (Cursor node -> a) -> a+v $| f = f v++-- | Apply an axis to the children of a 'Cursor node'.+($/) :: Cursor node -> (Cursor node -> [a]) -> [a]+v $/ f = child v >>= f++-- | Apply an axis to the descendants of a 'Cursor node'.+($//) :: Cursor node -> (Cursor node -> [a]) -> [a]+v $// f = descendant v >>= f++-- | Apply an axis to a 'Cursor node' as well as its descendants.+($.//) :: Cursor node -> (Cursor node -> [a]) -> [a]+v $.// f = orSelf descendant v >>= f
− Text/XML/Enumerator/Cursor.hs
@@ -1,315 +0,0 @@-module Text.XML.Enumerator.Cursor- (- -- * Type classes - Boolean(..)- -- * Cursor and Axis - , Axis- , Cursor- , fromDocument- , fromNode- , cut- -- * Axes- , parent- , precedingSibling- , followingSibling- , child- , node- , preceding- , following- , ancestor- , descendant- , orSelf- , check- , checkNode- , checkElement- , checkName- , anyElement- , element- , laxElement- , content- , attribute- , laxAttribute- -- * Operators- , (&|)- , (&/)- , (&//)- , (&.//)- , ($|)- , ($/)- , ($//)- , ($.//)- , (>=>)- -- * Error handling- , force- , forceM- ) where--import Control.Monad-import Data.Function (on)-import Data.List (foldl')-import Text.XML.Enumerator.Resolved-import qualified Control.Failure as F-import qualified Data.Text as T---- TODO: Consider [Cursor] -> [Cursor]?--- | The type of an Axis that returns a list of Cursors.--- They are roughly modeled after <http://www.w3.org/TR/xpath/#axes>.--- --- Axes can be composed with '>=>', where e.g. @f >=> g@ means that on all results of--- the @f@ axis, the @g@ axis will be applied, and all results joined together. --- Because Axis is just a type synonym for @Cursor -> [Cursor]@, it is possible to use--- other standard functions like '>>=' or 'concatMap' similarly.--- --- The operators '&|', '&/', '&//' and '&.//' can be used to combine axes so that the second--- axis works on the context nodes, children, descendants, respectively the context node as --- well as its descendants of the results of the first axis.--- --- The operators '$|', '$/', '$//' and '$.//' can be used to apply an axis (right-hand side)--- to a cursor so that it is applied on the cursor itself, its children, its descendants,--- respectively itself and its descendants.--- --- Note that many of these operators also work on /generalised Axes/ that can return --- lists of something other than Cursors, for example Content elements.-type Axis = Cursor -> [Cursor]---- XPath axes as in http://www.w3.org/TR/xpath/#axes--type DiffCursor = [Cursor] -> [Cursor]---- TODO: Decide whether to use an existing package for this--- | Something that can be used in a predicate check as a "boolean".-class Boolean a where- bool :: a -> Bool--instance Boolean Bool where - bool = id-instance Boolean [a] where - bool = not . null-instance Boolean (Maybe a) where - bool (Just _) = True- bool _ = False-instance Boolean (Either a b) where- bool (Left _) = False- bool (Right _) = True---- | A cursor: contains an XML 'Node' and pointers to its children, ancestors and siblings.-data Cursor = Cursor- { parent' :: Maybe Cursor- , precedingSibling' :: DiffCursor- , followingSibling' :: DiffCursor- -- | The child axis. XPath:- -- /the child axis contains the children of the context node/.- , child :: [Cursor]- -- | The current node.- , node :: Node- }--instance Show Cursor where- show Cursor { node = n } = "Cursor @ " ++ show n---- | Cut a cursor off from its parent. The idea is to allow restricting the scope of queries on it.-cut :: Cursor -> Cursor-cut = fromNode . node---- | The parent axis. As described in XPath:--- /the parent axis contains the parent of the context node, if there is one/.-parent :: Axis-parent c = case parent' c of- Nothing -> []- Just p -> [p]---- | The preceding-sibling axis. XPath:--- /the preceding-sibling axis contains all the preceding siblings of the context node [...]/.-precedingSibling :: Axis-precedingSibling = ($ []) . precedingSibling'---- | The following-sibling axis. XPath:--- /the following-sibling axis contains all the following siblings of the context node [...]/.-followingSibling :: Axis-followingSibling = ($ []) . followingSibling'---- | Convert a 'Document' to a 'Cursor'. It will point to the document root.-fromDocument :: Document -> Cursor-fromDocument = fromNode . NodeElement . documentRoot---- | Convert a 'Node' to a 'Cursor' (without parents).-fromNode :: Node -> Cursor-fromNode = toCursor' Nothing id id--toCursor' :: Maybe Cursor -> DiffCursor -> DiffCursor -> Node -> Cursor-toCursor' par pre fol n =- me- where- me = Cursor par pre fol chi n- chi' =- case n of- NodeElement (Element _ _ x) -> x- _ -> []- chi = go id chi' []- go _ [] = id- go pre' (n':ns') =- (:) me' . fol'- where- me' = toCursor' (Just me) pre' fol' n'- fol' = go (pre' . (:) me') ns'---- | The preceding axis. XPath:--- /the preceding axis contains all nodes in the same document as the context node that are before the context node in document order, excluding any ancestors and excluding attribute nodes and namespace nodes/.-preceding :: Axis-preceding c =- go (precedingSibling' c []) (parent c >>= preceding)- where- go x y = foldl' (\b a -> go' a b) y x- go' :: Cursor -> DiffCursor- go' x rest = foldl' (\b a -> go' a b) (x : rest) (child x)---- | The following axis. XPath:--- /the following axis contains all nodes in the same document as the context node that are after the context node in document order, excluding any descendants and excluding attribute nodes and namespace nodes/.-following :: Axis-following c =- go (followingSibling' c) (parent c >>= following)- where- go x z =- foldr (\a b -> go' a b) z y- where- y = x []- go' :: Cursor -> DiffCursor- go' x rest = x : foldr (\a b -> go' a b) rest (child x)---- | The ancestor axis. XPath:--- /the ancestor axis contains the ancestors of the context node; the ancestors of the context node consist of the parent of context node and the parent's parent and so on; thus, the ancestor axis will always include the root node, unless the context node is the root node/.-ancestor :: Axis-ancestor = parent >=> (\p -> p : ancestor p)---- | The descendant axis. XPath:--- /the descendant axis contains the descendants of the context node; a descendant is a child or a child of a child and so on; thus the descendant axis never contains attribute or namespace nodes/.-descendant :: Axis-descendant = child >=> (\c -> c : descendant c)---- | Modify an axis by adding the context node itself as the first element of the result list.-orSelf :: Axis -> Axis-orSelf ax c = c : ax c--infixr 1 &|-infixr 1 &/ -infixr 1 &// -infixr 1 &.// -infixr 1 $|-infixr 1 $/-infixr 1 $//-infixr 1 $.//---- | Apply a function to the result of an axis.-(&|) :: (Cursor -> [a]) -> (a -> b) -> (Cursor -> [b])-f &| g = map g . f---- | Combine two axes so that the second works on the children of the results--- of the first.-(&/) :: Axis -> (Cursor -> [a]) -> (Cursor -> [a])-f &/ g = f >=> child >=> g---- | Combine two axes so that the second works on the descendants of the results--- of the first.-(&//) :: Axis -> (Cursor -> [a]) -> (Cursor -> [a])-f &// g = f >=> descendant >=> g---- | Combine two axes so that the second works on both the result nodes, and their--- descendants.-(&.//) :: Axis -> (Cursor -> [a]) -> (Cursor -> [a])-f &.// g = f >=> orSelf descendant >=> g---- | Apply an axis to a 'Cursor'.-($|) :: Cursor -> (Cursor -> a) -> a-v $| f = f v---- | Apply an axis to the children of a 'Cursor'.-($/) :: Cursor -> (Cursor -> [a]) -> [a]-v $/ f = child v >>= f---- | Apply an axis to the descendants of a 'Cursor'.-($//) :: Cursor -> (Cursor -> [a]) -> [a]-v $// f = descendant v >>= f---- | Apply an axis to a 'Cursor' as well as its descendants.-($.//) :: Cursor -> (Cursor -> [a]) -> [a]-v $.// f = orSelf descendant v >>= f---- | Filter cursors that don't pass a check.-check :: Boolean b => (Cursor -> b) -> Axis-check f c = case bool $ f c of- False -> []- True -> [c]---- | Filter nodes that don't pass a check.-checkNode :: Boolean b => (Node -> b) -> Axis-checkNode f c = check (f . node) c---- | Filter elements that don't pass a check, and remove all non-elements.-checkElement :: Boolean b => (Element -> b) -> Axis-checkElement f c = case node c of- NodeElement e -> case bool $ f e of- True -> [c]- False -> []- _ -> []---- | Filter elements that don't pass a name check, and remove all non-elements.-checkName :: Boolean b => (Name -> b) -> Axis-checkName f c = checkElement (f . elementName) c---- | Remove all non-elements. Compare roughly to XPath:--- /A node test * is true for any node of the principal node type. For example, child::* will select all element children of the context node [...]/.-anyElement :: Axis-anyElement = checkElement (const True)---- | Select only those elements with a matching tag name. XPath:--- /A node test that is a QName is true if and only if the type of the node (see [5 Data Model]) is the principal node type and has an expanded-name equal to the expanded-name specified by the QName./-element :: Name -> Axis-element n = checkName (== n)---- | Select only those elements with a loosely matching tag name. Namespace and case are ignored. XPath:--- /A node test that is a QName is true if and only if the type of the node (see [5 Data Model]) is the principal node type and has an expanded-name equal to the expanded-name specified by the QName./-laxElement :: T.Text -> Axis-laxElement n = checkName (on (==) T.toCaseFold n . nameLocalName)---- | Select only text nodes, and directly give the 'Content' values. XPath:--- /The node test text() is true for any text node./--- --- Note that this is not strictly an 'Axis', but will work with most combinators.-content :: Cursor -> [T.Text]-content c = case node c of- (NodeContent v) -> [v]- _ -> []---- | Select attributes on the current element (or nothing if it is not an element). XPath:--- /the attribute axis contains the attributes of the context node; the axis will be empty unless the context node is an element/--- --- Note that this is not strictly an 'Axis', but will work with most combinators.--- --- The return list of the generalised axis contains as elements lists of 'Content' --- elements, each full list representing an attribute value.-attribute :: Name -> Cursor -> [T.Text]-attribute n Cursor{node=NodeElement e} = do (n', v) <- elementAttributes e- guard $ n == n'- return v-attribute _ _ = []---- | Select attributes on the current element (or nothing if it is not an element). Namespace and case are ignored. XPath:--- /the attribute axis contains the attributes of the context node; the axis will be empty unless the context node is an element/--- --- Note that this is not strictly an 'Axis', but will work with most combinators.--- --- The return list of the generalised axis contains as elements lists of 'Content' --- elements, each full list representing an attribute value.-laxAttribute :: T.Text -> Cursor -> [T.Text]-laxAttribute n Cursor{node=NodeElement e} = do (n', v) <- elementAttributes e- guard $ (on (==) T.toCaseFold) n (nameLocalName n')- return v-laxAttribute _ _ = []--force :: F.Failure e f => e -> [a] -> f a-force e [] = F.failure e-force _ (x:_) = return x--forceM :: F.Failure e f => e -> [f a] -> f a-forceM e [] = F.failure e-forceM _ (x:_) = x
− Text/XML/Enumerator/Document.hs
@@ -1,254 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-module Text.XML.Enumerator.Document- ( -- * Non-streaming functions- writeFile- , writePrettyFile- , readFile- , readFile_- -- * Lazy bytestrings- , renderLBS- , prettyLBS- , parseLBS- , parseLBS_- -- * Streaming functions- , toEvents- , fromEvents- , renderBuilder- , renderBytes- , renderText- -- ** Pretty versions- , prettyBuilder- , prettyBytes- , prettyText- -- * Exceptions- , InvalidEventStream (InvalidEventStream)- -- * Internal- , lazyConsume- ) where--import Prelude hiding (writeFile, readFile)-import Data.XML.Types-import Data.Enumerator- ( ($$), enumList, joinE, Enumerator, Iteratee, peek, returnI- , throwError, joinI, run, run_, Step (Continue), Stream (Chunks)- )-import Control.Exception (Exception, SomeException)-import Data.Typeable (Typeable)-import qualified Data.Enumerator.List as EL-import Blaze.ByteString.Builder (Builder)-import Control.Monad.IO.Class (MonadIO)-import qualified Text.XML.Enumerator.Render as R-import qualified Text.XML.Enumerator.Parse as P-import Data.ByteString (ByteString)-import Data.Text (Text)-import Control.Applicative ((<$>), (<*>))-import qualified System.IO as SIO-import Data.Enumerator.Binary (enumFile, iterHandle)-import qualified Data.Text as T-import Data.Char (isSpace)-import qualified Data.ByteString.Lazy as L-import System.IO.Unsafe (unsafePerformIO)-import qualified Control.Concurrent.MVar as M-import System.IO.Unsafe (unsafeInterleaveIO)-import Control.Monad.IO.Class (liftIO)-import Control.Concurrent (forkIO)-import Data.Functor.Identity (runIdentity)--readFile :: FilePath -> P.DecodeEntities -> IO (Either SomeException Document)-readFile fn de = run $ enumFile fn $$ joinI $ P.parseBytes de $$ fromEvents--readFile_ :: FilePath -> P.DecodeEntities -> IO Document-readFile_ fn de = run_ $ enumFile fn $$ joinI $ P.parseBytes de $$ fromEvents--writeFile :: FilePath -> Document -> IO ()-writeFile fn doc = SIO.withBinaryFile fn SIO.WriteMode $ \h ->- run_ $ renderBytes doc $$ iterHandle h---- | Pretty prints via 'prettyBytes'.-writePrettyFile :: FilePath -> Document -> IO ()-writePrettyFile fn doc = SIO.withBinaryFile fn SIO.WriteMode $ \h ->- run_ $ prettyBytes doc $$ iterHandle h--renderLBS :: Document -> L.ByteString-renderLBS doc =- L.fromChunks $ unsafePerformIO $ lazyConsume $ renderBytes doc---- | Pretty prints via 'prettyBytes'.-prettyLBS :: Document -> L.ByteString-prettyLBS doc =- L.fromChunks $ unsafePerformIO $ lazyConsume $ prettyBytes doc--parseLBS :: L.ByteString -> P.DecodeEntities -> Either SomeException Document-parseLBS lbs de = runIdentity- $ run $ enumSingle (L.toChunks lbs)- $$ joinI $ P.parseBytes de $$ fromEvents--parseLBS_ :: L.ByteString -> P.DecodeEntities -> Document-parseLBS_ lbs de = runIdentity- $ run_ $ enumSingle (L.toChunks lbs)- $$ joinI $ P.parseBytes de $$ fromEvents--enumSingle :: Monad m => [a] -> Enumerator a m b-enumSingle as (Continue k) = k $ Chunks as-enumSingle _ step = returnI step--lazyConsume :: Enumerator a IO () -> IO [a]-lazyConsume enum = do- toGrabber <- M.newEmptyMVar- toFiller <- M.newMVar True- _ <- forkIO $ run_ $ enum $$ filler toGrabber toFiller- grabber toGrabber toFiller- where- grabber toGrabber toFiller = do- x <- M.takeMVar toGrabber- case x of- Nothing -> return []- Just x' -> do- M.putMVar toFiller True- xs <- unsafeInterleaveIO $ grabber toGrabber toFiller- return $ x' : xs- filler toGrabber toFiller = do- cont <- liftIO $ M.takeMVar toFiller- if cont- then do- x <- EL.head- liftIO $ M.putMVar toGrabber x- case x of- Nothing -> return ()- Just _ -> filler toGrabber toFiller- else liftIO $ M.putMVar toGrabber Nothing--data InvalidEventStream = InvalidEventStream String- deriving (Show, Typeable)-instance Exception InvalidEventStream--prettyBuilder :: MonadIO m => Document -> Enumerator Builder m a-prettyBuilder doc = enumList 8 (toEvents doc) `joinE` R.prettyBuilder--prettyBytes :: MonadIO m => Document -> Enumerator ByteString m a-prettyBytes doc = enumList 8 (toEvents doc) `joinE` R.prettyBytes--prettyText :: MonadIO m => Document -> Enumerator Text m a-prettyText doc = enumList 8 (toEvents doc) `joinE` R.prettyText--renderBuilder :: MonadIO m => Document -> Enumerator Builder m a-renderBuilder doc = enumList 8 (toEvents doc) `joinE` R.renderBuilder--renderBytes :: MonadIO m => Document -> Enumerator ByteString m a-renderBytes doc = enumList 8 (toEvents doc) `joinE` R.renderBytes--renderText :: MonadIO m => Document -> Enumerator Text m a-renderText doc = enumList 8 (toEvents doc) `joinE` R.renderText--fromEvents :: Monad m => Iteratee Event m Document-fromEvents = do- skip EventBeginDocument- d <- Document <$> goP <*> require goE <*> goM- skip EventEndDocument- y <- EL.head- if y == Nothing- then return d- else throwError $ InvalidEventStream $ "Trailing matter after epilogue: " ++ show y- where- skip e = do- x <- peek- if x == Just e then EL.drop 1 else return ()- many f =- go id- where- go front = do- x <- f- case x of- Nothing -> return $ front []- Just y -> go (front . (:) y)- dropReturn x = EL.drop 1 >> return x- require f = do- x <- f- case x of- Just y -> return y- Nothing -> do- y <- EL.head- throwError $ InvalidEventStream $ "Document must have a single root element, got: " ++ show y- goP = Prologue <$> goM <*> goD <*> goM- goM = many goM'- goM' = do- x <- peek- case x of- Just (EventInstruction i) -> dropReturn $ Just $ MiscInstruction i- Just (EventComment t) -> dropReturn $ Just $ MiscComment t- Just (EventContent (ContentText t))- | T.all isSpace t -> EL.drop 1 >> goM'- _ -> return Nothing- goD = do- x <- peek- case x of- Just (EventBeginDoctype name meid) -> do- EL.drop 1- dropTillDoctype- return (Just $ Doctype name meid)- _ -> return Nothing- dropTillDoctype = do- x <- EL.head- case x of- -- Leaving the following line commented so that the intention of- -- this function stays clear. I figure in the future xml-types will- -- be expanded again to support some form of EventDeclaration- --- -- Just (EventDeclaration _) -> dropTillDoctype- Just EventEndDoctype -> return ()- _ -> throwError $ InvalidEventStream $ "Invalid event during doctype, got: " ++ show x- goE = do- x <- peek- case x of- Just (EventBeginElement n as) -> Just <$> goE' n as- _ -> return Nothing- goE' n as = do- EL.drop 1- ns <- many goN- y <- EL.head- if y == Just (EventEndElement n)- then return $ Element n as $ compressNodes ns- else throwError $ InvalidEventStream $ "Missing end element for " ++ show n ++ ", got: " ++ show y- goN = do- x <- peek- case x of- Just (EventBeginElement n as) -> (Just . NodeElement) <$> goE' n as- Just (EventInstruction i) -> dropReturn $ Just $ NodeInstruction i- Just (EventContent c) -> dropReturn $ Just $ NodeContent c- Just (EventComment t) -> dropReturn $ Just $ NodeComment t- Just (EventCDATA t) -> dropReturn $ Just $ NodeContent $ ContentText t- _ -> return Nothing--toEvents :: Document -> [Event]-toEvents (Document prol root epi) =- (EventBeginDocument :)- . goP prol . goE root . goM epi $ [EventEndDocument]- where- goP (Prologue before doctype after) =- goM before . maybe id goD doctype . goM after- goM [] = id- goM [x] = (goM' x :)- goM (x:xs) = (goM' x :) . goM xs- goM' (MiscInstruction i) = EventInstruction i- goM' (MiscComment t) = EventComment t- goD (Doctype name meid) =- (:) (EventBeginDoctype name meid)- . (:) EventEndDoctype- goE (Element name as ns) =- (EventBeginElement name as :)- . goN ns- . (EventEndElement name :)- goN [] = id- goN [x] = goN' x- goN (x:xs) = goN' x . goN xs- goN' (NodeElement e) = goE e- goN' (NodeInstruction i) = (EventInstruction i :)- goN' (NodeContent c) = (EventContent c :)- goN' (NodeComment t) = (EventComment t :)--compressNodes :: [Node] -> [Node]-compressNodes [] = []-compressNodes [x] = [x]-compressNodes (NodeContent (ContentText x) : NodeContent (ContentText y) : z) =- compressNodes $ NodeContent (ContentText $ x `T.append` y) : z-compressNodes (x:xs) = x : compressNodes xs
− Text/XML/Enumerator/Parse.hs
@@ -1,672 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE RankNTypes #-}--- | This module provides both a native Haskell solution for parsing XML--- documents into a stream of events, and a set of parser combinators for--- dealing with a stream of events.------ As a simple example, if you have the following XML file:------ > <?xml version="1.0" encoding="utf-8"?>--- > <people>--- > <person age="25">Michael</person>--- > <person age="2">Eliezer</person>--- > </people>------ Then this code:------ > {-# LANGUAGE OverloadedStrings #-}--- > import Text.XML.Enumerator.Parse--- > import Data.Text.Lazy (Text, unpack)--- > --- > data Person = Person { age :: Int, name :: Text }--- > deriving Show--- > --- > parsePerson = tagName "person" (requireAttr "age") $ \age -> do--- > name <- content--- > return $ Person (read $ unpack age) name--- > --- > parsePeople = tagNoAttr "people" $ many parsePerson--- > --- > main = parseFile_ "people.xml" decodeEntities $ force "people required" parsePeople------ will produce:------ > [Person {age = 25, name = "Michael"},Person {age = 2, name = "Eliezer"}]------ Previous versions of this module contained a number of more sophisticated--- functions written by Aristid Breitkreuz and Dmitry Olshansky. To keep this--- package simpler, those functions are being moved to a separate package. This--- note will be updated with the name of the package(s) when available.-module Text.XML.Enumerator.Parse- ( -- * Parsing XML files- parseBytes- , parseText- , detectUtf- , parseFile- , parseFile_- , parseLBS- , parseLBS_- -- ** Entity decoding- , DecodeEntities- , decodeEntities- -- * Event parsing- , tag- , tagPredicate- , tagName- , tagNoAttr- , content- , contentMaybe- -- * Attribute parsing- , AttrParser- , requireAttr- , optionalAttr- , requireAttrRaw- , optionalAttrRaw- , ignoreAttrs- -- * Combinators- , orE- , choose- , many- , force- -- * Exceptions- , XmlException (..)- ) where-import Data.Attoparsec.Text- ( char, Parser, takeWhile1, skipWhile, string- , manyTill, takeWhile, try, anyChar, endOfInput- )-import qualified Data.Attoparsec.Text as A-import Data.Attoparsec.Text.Enumerator (iterParser)-import Data.XML.Types- ( Name (..), Event (..), Content (..)- , Instruction (..), ExternalID (..)- )-import Control.Applicative ((<|>), (<$>))-import Data.Text (Text)-import qualified Data.Text as T-import Data.Text.Read (Reader, decimal, hexadecimal)-import Data.Text.Encoding (decodeUtf32BEWith)-import Data.Text.Encoding.Error (ignore)-import Data.Word (Word32)-import Blaze.ByteString.Builder (fromWord32be, toByteString)-import Text.XML.Enumerator.Token-import Prelude hiding (takeWhile)-import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as L-import qualified Data.Map as Map-import Data.Enumerator- ( Iteratee, Enumeratee, (>>==), Stream (..), run_, Enumerator, Step (..)- , checkDone, yield, ($$), joinI, run, throwError, returnI- )-import qualified Data.Enumerator as E-import qualified Data.Enumerator.List as EL-import qualified Data.Enumerator.Text as ET-import qualified Data.Enumerator.Binary as EB-import Control.Monad (unless, ap, liftM)-import qualified Data.Text as TS-import Data.List (foldl')-import Control.Applicative (Applicative (..))-import Data.Typeable (Typeable)-import Control.Exception (Exception, throwIO, SomeException)-import Data.Enumerator.Binary (enumFile)-import Control.Monad.IO.Class (liftIO)-import Data.Char (isSpace)--tokenToEvent :: [NSLevel] -> Token -> ([NSLevel], [Event])-tokenToEvent n (TokenBeginDocument _) = (n, [])-tokenToEvent n (TokenInstruction i) = (n, [EventInstruction i])-tokenToEvent n (TokenBeginElement name as isClosed _) =- (n', if isClosed then [begin, end] else [begin])- where- l0 = case n of- [] -> NSLevel Nothing Map.empty- x:_ -> x- (as', l') = foldl' go (id, l0) as- go (front, l) a@(TName kpref kname, val)- | kpref == Just "xmlns" =- (front, l { prefixes = Map.insert kname (contentsToText val)- $ prefixes l })- | kpref == Nothing && kname == "xmlns" =- (front, l { defaultNS = if T.null $ contentsToText val- then Nothing- else Just $ contentsToText val })- | otherwise = (front . (:) a, l)- n' = if isClosed then n else l' : n- fixAttName level (name', val) = (tnameToName True level name', val)- begin = EventBeginElement (tnameToName False l' name)- $ map (fixAttName l')- $ as' []- end = EventEndElement $ tnameToName False l' name-tokenToEvent n (TokenEndElement name) =- (n', [EventEndElement $ tnameToName False l name])- where- (l, n') =- case n of- [] -> (NSLevel Nothing Map.empty, [])- x:xs -> (x, xs)-tokenToEvent n (TokenContent c) = (n, [EventContent c])-tokenToEvent n (TokenComment c) = (n, [EventComment c])-tokenToEvent n (TokenDoctype t eid) = (n, [EventBeginDoctype t eid, EventEndDoctype])-tokenToEvent n (TokenCDATA t) = (n, [EventCDATA t])--tnameToName :: Bool -> NSLevel -> TName -> Name-tnameToName _ _ (TName (Just "xml") name) =- Name name (Just "http://www.w3.org/XML/1998/namespace") (Just "xml")-tnameToName isAttr (NSLevel def _) (TName Nothing name) =- Name name (if isAttr then Nothing else def) Nothing-tnameToName _ (NSLevel _ m) (TName (Just pref) name) =- case Map.lookup pref m of- Just ns -> Name name (Just ns) (Just pref)- Nothing -> Name name Nothing (Just pref) -- FIXME is this correct?---- | Automatically determine which UTF variant is being used. This function--- first checks for BOMs, removing them as necessary, and then check for the--- equivalent of <?xml for each of UTF-8, UTF-16LE/BE, and UTF-32LE/BE. It--- defaults to assuming UTF-8.-detectUtf :: Monad m => Enumeratee S.ByteString TS.Text m a-detectUtf step = do- x <- EB.take 4- let (toDrop, codec) =- case L.unpack x of- [0x00, 0x00, 0xFE, 0xFF] -> (4, ET.utf32_be)- [0xFF, 0xFE, 0x00, 0x00] -> (4, ET.utf32_le)- 0xFE : 0xFF: _ -> (2, ET.utf16_be)- 0xFF : 0xFE: _ -> (2, ET.utf16_le)- 0xEF : 0xBB: 0xBF : _ -> (3, ET.utf8)- [0x00, 0x00, 0x00, 0x3C] -> (0, ET.utf32_be)- [0x3C, 0x00, 0x00, 0x00] -> (0, ET.utf32_le)- [0x00, 0x3C, 0x00, 0x3F] -> (0, ET.utf16_be)- [0x3C, 0x00, 0x3F, 0x00] -> (0, ET.utf16_le)- _ -> (0, ET.utf8) -- Assuming UTF-8- unless (toDrop == 4) $ yield () $ Chunks $ L.toChunks $ L.drop toDrop x- ET.decode codec step---- | Parses a byte stream into 'Event's. This function is implemented fully in--- Haskell using attoparsec-text for parsing. The produced error messages do--- not give line/column information, so you may prefer to stick with the parser--- provided by libxml-enumerator. However, this has the advantage of not--- relying on any C libraries.------ This relies on 'detectUtf' to determine character encoding, and 'parseText'--- to do the actual parsing.-parseBytes :: Monad m => DecodeEntities -> Enumeratee S.ByteString Event m a-parseBytes de step = joinI $ detectUtf $$ parseText de step---- | Parses a character stream into 'Event's. This function is implemented--- fully in Haskell using attoparsec-text for parsing. The produced error--- messages do not give line/column information, so you may prefer to stick--- with the parser provided by libxml-enumerator. However, this has the--- advantage of not relying on any C libraries.-parseText :: Monad m => DecodeEntities -> Enumeratee TS.Text Event m a-parseText de =- checkDone $ \k -> k (Chunks [EventBeginDocument]) >>== loop []- where- loop levels = checkDone $ go levels- go levels k = do- mtoken <- iterToken de- case mtoken of- Nothing -> k (Chunks [EventEndDocument]) >>== return- Just token ->- let (levels', events) = tokenToEvent levels token- in k (Chunks events) >>== loop levels'--iterToken :: Monad m => DecodeEntities -> Iteratee TS.Text m (Maybe Token)-iterToken de = iterParser ((endOfInput >> return Nothing) <|> fmap Just (parseToken de))--parseToken :: DecodeEntities -> Parser Token-parseToken de = do- (char '<' >> parseLt) <|> fmap TokenContent (parseContent de False False)- where- parseLt =- (char '?' >> parseInstr) <|>- (char '!' >> (parseComment <|> parseCdata <|> parseDoctype)) <|>- (char '/' >> parseEnd) <|>- parseBegin- parseInstr = do- name <- parseIdent- if name == "xml"- then do- as <- A.many $ parseAttribute de- skipSpace- char' '?'- char' '>'- newline <|> return ()- return $ TokenBeginDocument as- else do- skipSpace- x <- T.pack <$> manyTill anyChar (try $ string "?>")- return $ TokenInstruction $ Instruction name x- parseComment = do- char' '-'- char' '-'- c <- T.pack <$> manyTill anyChar (string "-->") -- FIXME use takeWhile instead- return $ TokenComment c- parseCdata = do- _ <- string "[CDATA["- t <- T.pack <$> manyTill anyChar (string "]]>") -- FIXME use takeWhile instead- return $ TokenCDATA t- parseDoctype = do- _ <- string "DOCTYPE"- skipSpace- i <- parseIdent- skipSpace- eid <- fmap Just parsePublicID <|>- fmap Just parseSystemID <|>- return Nothing- skipSpace- (do- char' '['- skipWhile (/= ']')- char' ']'- skipSpace) <|> return ()- char' '>'- newline <|> return ()- return $ TokenDoctype i eid- parsePublicID = do- _ <- string "PUBLIC"- x <- quotedText- y <- quotedText- return $ PublicID x y- parseSystemID = do- _ <- string "SYSTEM"- x <- quotedText- return $ SystemID x- quotedText = do- skipSpace- between '"' <|> between '\''- between c = do- char' c- x <- takeWhile (/=c)- char' c- return x- parseEnd = do- skipSpace- n <- parseName- skipSpace- char' '>'- return $ TokenEndElement n- parseBegin = do- skipSpace- n <- parseName- as <- A.many $ parseAttribute de- skipSpace- isClose <- (char '/' >> skipSpace >> return True) <|> return False- char' '>'- return $ TokenBeginElement n as isClose 0--parseAttribute :: DecodeEntities -> Parser TAttribute-parseAttribute de = do- skipSpace- key <- parseName- skipSpace- char' '='- skipSpace- val <- squoted <|> dquoted- return (key, val)- where- squoted = do- char' '\''- manyTill (parseContent de False True) (char '\'')- dquoted = do- char' '"'- manyTill (parseContent de True False) (char '"')--parseName :: Parser TName-parseName = do- i1 <- parseIdent- mi2 <- (char ':' >> fmap Just parseIdent) <|> return Nothing- return $- case mi2 of- Nothing -> TName Nothing i1- Just i2 -> TName (Just i1) i2--parseIdent :: Parser Text-parseIdent =- takeWhile1 valid- where- valid '&' = False- valid '<' = False- valid '>' = False- valid ':' = False- valid '?' = False- valid '=' = False- valid '"' = False- valid '\'' = False- valid '/' = False- valid c = not $ isSpace c--parseContent :: DecodeEntities- -> Bool -- break on double quote- -> Bool -- break on single quote- -> Parser Content-parseContent de breakDouble breakSingle =- parseEntity <|> parseText'- where- parseEntity = do- char' '&'- t <- takeWhile1 (/= ';')- char' ';'- return $ de t- parseText' = do- bs <- takeWhile1 valid- return $ ContentText bs- valid '"' = not breakDouble- valid '\'' = not breakSingle- valid '&' = False -- amp- valid '<' = False -- lt- valid _ = True--skipSpace :: Parser ()-skipSpace = skipWhile isSpace--newline :: Parser ()-newline = ((char '\r' >> char '\n') <|> char '\n') >> return ()--char' :: Char -> Parser ()-char' c = char c >> return ()--data ContentType =- Ignore | IsContent Text | IsError String | NotContent---- | Grabs the next piece of content if available. This function skips over any--- comments and instructions and concatenates all content until the next start--- or end tag.-contentMaybe :: Monad m => Iteratee Event m (Maybe Text)-contentMaybe = do- x <- E.peek- case pc' x of- Ignore -> EL.drop 1 >> contentMaybe- IsContent t -> EL.drop 1 >> fmap Just (takeContents (t:))- IsError e -> throwError $ XmlException e x- NotContent -> return Nothing- where- pc' Nothing = NotContent- pc' (Just x) = pc x- pc (EventContent (ContentText t)) = IsContent t- pc (EventContent (ContentEntity e)) = IsError $ "Unknown entity: " ++ show e- pc (EventCDATA t) = IsContent t- pc EventBeginElement{} = NotContent- pc EventEndElement{} = NotContent- pc EventBeginDocument{} = Ignore- pc EventEndDocument = Ignore- pc EventBeginDoctype{} = Ignore- pc EventEndDoctype = Ignore- pc EventInstruction{} = Ignore- pc EventComment{} = Ignore- takeContents front = do- x <- E.peek- case pc' x of- Ignore -> EL.drop 1 >> takeContents front- IsContent t -> EL.drop 1 >> takeContents (front . (:) t)- IsError e -> throwError $ XmlException e x- NotContent -> return $ T.concat $ front []---- | Grabs the next piece of content. If none if available, returns 'T.empty'.--- This is simply a wrapper around 'contentMaybe'.-content :: Monad m => Iteratee Event m Text-content = do- x <- contentMaybe- case x of- Nothing -> return T.empty- Just y -> return y---- | The most generic way to parse a tag. It takes a predicate for checking if--- this is the correct tag name, an 'AttrParser' for handling attributes, and--- then a parser for dealing with content.------ This function automatically absorbs its balancing closing tag, and will--- throw an exception if not all of the attributes or child elements are--- consumed. If you want to allow extra attributes, see 'ignoreAttrs'.------ This function automatically ignores comments, instructions and whitespace.-tag :: Monad m- => (Name -> Maybe a)- -> (a -> AttrParser b)- -> (b -> Iteratee Event m c)- -> Iteratee Event m (Maybe c)-tag checkName attrParser f = do- x <- dropWS- case x of- Just (EventBeginElement name as) ->- case checkName name of- Just y ->- case runAttrParser' (attrParser y) as of- Left e -> throwError e- Right z -> do- EL.drop 1- z' <- f z- a <- dropWS- case a of- Just (EventEndElement name')- | name == name' -> EL.drop 1 >> return (Just z')- _ -> throwError $ XmlException ("Expected end tag for: " ++ show name) a- Nothing -> return Nothing- _ -> return Nothing- where- dropWS = do- x <- E.peek- let isWS =- case x of- Just EventBeginDocument -> True- Just EventEndDocument -> True- Just EventBeginDoctype{} -> True- Just EventEndDoctype -> True- Just EventInstruction{} -> True- Just EventBeginElement{} -> False- Just EventEndElement{} -> False- Just (EventContent (ContentText t))- | T.all isSpace t -> True- | otherwise -> False- Just (EventContent ContentEntity{}) -> False- Just EventComment{} -> True- Just EventCDATA{} -> False- Nothing -> False- if isWS then EL.drop 1 >> dropWS else return x- runAttrParser' p as =- case runAttrParser p as of- Left e -> Left e- Right ([], x) -> Right x- Right (attr, _) -> Left $ UnparsedAttributes attr---- | A simplified version of 'tag' which matches against boolean predicates.-tagPredicate :: Monad m => (Name -> Bool) -> AttrParser a -> (a -> Iteratee Event m b) -> Iteratee Event m (Maybe b)-tagPredicate p attrParser = tag (\x -> if p x then Just () else Nothing) (const attrParser)---- | A simplified version of 'tag' which matches for specific tag names instead--- of taking a predicate function. This is often sufficient, and when combined--- with OverloadedStrings and the IsString instance of 'Name', can prove to be--- very concise.-tagName :: Monad m- => Name- -> AttrParser a- -> (a -> Iteratee Event m b)- -> Iteratee Event m (Maybe b)-tagName name = tagPredicate (== name)---- | A further simplified tag parser, which requires that no attributes exist.-tagNoAttr :: Monad m => Name -> Iteratee Event m a -> Iteratee Event m (Maybe a)-tagNoAttr name f = tagName name (return ()) $ const f---- | Get the value of the first parser which returns 'Just'. If no parsers--- succeed (i.e., return 'Just'), this function returns 'Nothing'.------ > orE a b = choose [a, b]-orE :: Monad m => Iteratee Event m (Maybe a) -> Iteratee Event m (Maybe a) -> Iteratee Event m (Maybe a)-orE a b = do- x <- a- case x of- Nothing -> b- _ -> return x---- | Get the value of the first parser which returns 'Just'. If no parsers--- succeed (i.e., return 'Just'), this function returns 'Nothing'.-choose :: Monad m- => [Iteratee Event m (Maybe a)]- -> Iteratee Event m (Maybe a)-choose [] = return Nothing-choose (i:is) = do- x <- i- case x of- Nothing -> choose is- Just a -> return $ Just a---- | Force an optional parser into a required parser. All of the 'tag'--- functions, 'choose' and 'many' deal with 'Maybe' parsers. Use this when you--- want to finally force something to happen.-force :: Monad m- => String -- ^ Error message- -> Iteratee Event m (Maybe a)- -> Iteratee Event m a-force msg i = do- x <- i- case x of- Nothing -> throwError $ XmlException msg Nothing- Just a -> return a---- | The same as 'parseFile', but throws any exceptions.-parseFile_ :: FilePath -> DecodeEntities -> Iteratee Event IO a -> IO a-parseFile_ fn de p =- parseFile fn de p >>= go- where- go (Left e) = liftIO $ throwIO e- go (Right a) = return a---- | A helper function which reads a file from disk using 'enumFile', detects--- character encoding using 'detectUtf', parses the XML using 'parseBytes', and--- then hands off control to your supplied parser.-parseFile :: FilePath- -> DecodeEntities- -> Iteratee Event IO a- -> IO (Either SomeException a)-parseFile fn de p =- run $ enumFile fn $$ joinI- $ parseBytes de $$ p---- | Parse an event stream from a lazy 'L.ByteString'.-parseLBS :: L.ByteString -> DecodeEntities -> Iteratee Event IO a -> IO (Either SomeException a)-parseLBS lbs de p =- run $ enumSingle (L.toChunks lbs) $$ joinI- $ parseBytes de $$ p---- | Same as 'parseLBS', but throws exceptions.-parseLBS_ :: L.ByteString -> DecodeEntities -> Iteratee Event IO a -> IO a-parseLBS_ lbs de p =- run_ $ enumSingle (L.toChunks lbs) $$ joinI- $ parseBytes de $$ p--enumSingle :: Monad m => [a] -> Enumerator a m b-enumSingle as (Continue k) = k $ Chunks as-enumSingle _ step = returnI step--data XmlException = XmlException- { xmlErrorMessage :: String- , xmlBadInput :: Maybe Event- }- | InvalidEndElement Name- | InvalidEntity Text- | UnparsedAttributes [(Name, [Content])]- deriving (Show, Typeable)-instance Exception XmlException---- | A monad for parsing attributes. By default, it requires you to deal with--- all attributes present on an element, and will throw an exception if there--- are unhandled attributes. Use the 'requireAttr', 'optionalAttr' et al--- functions for handling an attribute, and 'ignoreAttrs' if you would like to--- skip the rest of the attributes on an element.-newtype AttrParser a = AttrParser { runAttrParser :: [(Name, [Content])] -> Either XmlException ([(Name, [Content])], a) }--instance Monad AttrParser where- return a = AttrParser $ \as -> Right (as, a)- (AttrParser f) >>= g = AttrParser $ \as ->- case f as of- Left e -> Left e- Right (as', f') -> runAttrParser (g f') as'-instance Functor AttrParser where- fmap = liftM-instance Applicative AttrParser where- pure = return- (<*>) = ap--optionalAttrRaw :: ((Name, [Content]) -> Maybe b) -> AttrParser (Maybe b)-optionalAttrRaw f =- AttrParser $ go id- where- go front [] = Right (front [], Nothing)- go front (a:as) =- case f a of- Nothing -> go (front . (:) a) as- Just b -> Right (front as, Just b)--requireAttrRaw :: String -> ((Name, [Content]) -> Maybe b) -> AttrParser b-requireAttrRaw msg f = do- x <- optionalAttrRaw f- case x of- Just b -> return b- Nothing -> AttrParser $ const $ Left $ XmlException msg Nothing---- | Require that a certain attribute be present and return its value.-requireAttr :: Name -> AttrParser Text-requireAttr n = requireAttrRaw- ("Missing attribute: " ++ show n)- (\(x, y) -> if x == n then Just (contentsToText y) else Nothing)---- | Return the value for an attribute if present.-optionalAttr :: Name -> AttrParser (Maybe Text)-optionalAttr n = optionalAttrRaw- (\(x, y) -> if x == n then Just (contentsToText y) else Nothing)--contentsToText :: [Content] -> Text-contentsToText =- T.concat . map toText- where- toText (ContentText t) = t- toText (ContentEntity e) = T.concat ["&", e, ";"]---- | Skip the remaining attributes on an element. Since this will clear the--- list of attributes, you must call this /after/ any calls to 'requireAttr',--- 'optionalAttr', etc.-ignoreAttrs :: AttrParser ()-ignoreAttrs = AttrParser $ \_ -> Right ([], ())---- | Keep parsing elements as long as the parser returns 'Just'.-many :: Monad m => Iteratee Event m (Maybe a) -> Iteratee Event m [a]-many i =- go id- where- go front = do- x <- i- case x of- Nothing -> return $ front []- Just y -> go $ front . (:) y--type DecodeEntities = Text -> Content---- | Default implementation of 'DecodeEntities': handles numeric entities and--- the five standard character entities (lt, gt, amp, quot, apos).-decodeEntities :: DecodeEntities-decodeEntities "lt" = ContentText "<"-decodeEntities "gt" = ContentText ">"-decodeEntities "amp" = ContentText "&"-decodeEntities "quot" = ContentText "\""-decodeEntities "apos" = ContentText "'"-decodeEntities t = let backup = ContentEntity t in- case T.uncons t of- Just ('#', t') ->- case T.uncons t' of- Just ('x', t'')- | T.length t'' > 6 -> backup- | otherwise -> decodeChar hexadecimal backup t''- _- | T.length t' > 7 -> backup- | otherwise -> decodeChar decimal backup t'- _ -> backup--decodeChar :: Reader Word32 -> Content -> Text -> Content-decodeChar readNum backup = either (const backup) toContent . readNum- where- toContent (num, extra) | T.null extra =- case decodeUtf32BEWith ignore . toByteString $ fromWord32be num of- char | T.length char == 1 -> ContentText char- | otherwise -> backup- toContent _ = backup
− Text/XML/Enumerator/Render.hs
@@ -1,268 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- | 'Enumeratee's to render XML 'Event's. Unlike libxml-enumerator and--- expat-enumerator, this module does not provide IO and ST variants, since the--- underlying rendering operations are pure functions.-module Text.XML.Enumerator.Render- ( renderBuilder- , renderBytes- , renderText- , prettyBuilder- , prettyBytes- , prettyText- ) where--import Data.XML.Types (Event (..), Content (..), Name (..))-import Text.XML.Enumerator.Token-import qualified Data.Enumerator as E-import qualified Data.Enumerator.List as EL-import qualified Data.Enumerator.Text as ET-import Data.Enumerator ((>>==), ($$), Iteratee, Step (..))-import qualified Data.Text as T-import Data.Text (Text)-import Blaze.ByteString.Builder-import Blaze.ByteString.Builder.Enumerator (builderToByteString)-import qualified Data.Map as Map-import Data.Map (Map)-import Data.Maybe (fromMaybe)-import Data.ByteString (ByteString)-import Control.Monad.IO.Class (MonadIO)-import Data.Char (isSpace)---- | Pretty prints a stream of 'Event's into a stream of 'Builder's. This--- changes the meaning of some documents, by inserting/modifying whitespace.-prettyBuilder :: Monad m => E.Enumeratee Event Builder m b-prettyBuilder step0 =- E.joinI $ prettify 0 [] $$ loop [] step0- where- loop stack = E.checkDone $ step stack- step stack k = do- x <- EL.head- case x of- Nothing -> E.yield (E.Continue k) E.EOF- Just (EventBeginElement name as) -> do- x' <- E.peek- if x' == Just (EventEndElement name)- then do- EL.drop 1- go $ mkBeginToken True True stack name as- else go $ mkBeginToken True False stack name as- Just e -> go $ eventToToken stack e- where- go (ts, stack') = k (E.Chunks $ map tokenToBuilder $ ts []) >>== loop stack'---- | Same as 'prettyBuilder', but produces a stream of 'ByteString's.-prettyBytes :: MonadIO m => E.Enumeratee Event ByteString m b-prettyBytes s = E.joinI $ prettyBuilder $$ builderToByteString s---- | Same as 'prettyBuilder', but produces a stream of 'Text's.-prettyText :: MonadIO m => E.Enumeratee Event Text m b-prettyText s = E.joinI $ prettyBytes $$ ET.decode ET.utf8 s---- | Render a stream of 'Event's into a stream of 'ByteString's. This function--- wraps around 'renderBuilder' and 'builderToByteString', so it produces--- optimally sized 'ByteString's with minimal buffer copying.------ The output is UTF8 encoded.-renderBytes :: MonadIO m => E.Enumeratee Event ByteString m b-renderBytes s = E.joinI $ renderBuilder $$ builderToByteString s---- | Render a stream of 'Event's into a stream of 'ByteString's. This function--- wraps around 'renderBuilder', 'builderToByteString' and 'renderBytes', so it--- produces optimally sized 'ByteString's with minimal buffer copying.-renderText :: MonadIO m => E.Enumeratee Event Text m b-renderText s = E.joinI $ renderBytes $$ ET.decode ET.utf8 s---- | Render a stream of 'Event's into a stream of 'Builder's. Builders are from--- the blaze-builder package, and allow the create of optimally sized--- 'ByteString's with minimal buffer copying.-renderBuilder :: Monad m => E.Enumeratee Event Builder m b-renderBuilder =- loop []- where- loop stack = E.checkDone $ step stack- step stack k = do- x <- EL.head- case x of- Nothing -> E.yield (E.Continue k) E.EOF- Just (EventBeginElement name as) -> do- x' <- E.peek- if x' == Just (EventEndElement name)- then do- EL.drop 1- go $ mkBeginToken False True stack name as- else go $ mkBeginToken False False stack name as- Just e -> go $ eventToToken stack e- where- go (ts, stack') = k (E.Chunks $ map tokenToBuilder $ ts []) >>== loop stack'--eventToToken :: Stack -> Event -> ([Token] -> [Token], [NSLevel])-eventToToken s EventBeginDocument =- ((:) (TokenBeginDocument- [ ("version", [ContentText "1.0"])- , ("encoding", [ContentText "UTF-8"])- ])- , s)-eventToToken s EventEndDocument = (id, s)-eventToToken s (EventInstruction i) = ((:) (TokenInstruction i), s)-eventToToken s (EventBeginDoctype n meid) = ((:) (TokenDoctype n meid), s)-eventToToken s EventEndDoctype = (id, s)-eventToToken s (EventCDATA t) = ((:) (TokenCDATA t), s)-eventToToken s (EventEndElement name) =- ((:) (TokenEndElement $ nameToTName sl name), s')- where- (sl:s') = s-eventToToken s (EventContent c) = ((:) (TokenContent c), s)-eventToToken s (EventComment t) = ((:) (TokenComment t), s)-eventToToken _ EventBeginElement{} = error "eventToToken on EventBeginElement" -- mkBeginToken False s name attrs--type Stack = [NSLevel]--nameToTName :: NSLevel -> Name -> TName-nameToTName _ (Name name _ (Just pref))- | pref == "xml" = TName (Just "xml") name-nameToTName _ (Name name Nothing _) = TName Nothing name -- invariant that this is true-nameToTName (NSLevel def sl) (Name name (Just ns) _)- | def == Just ns = TName Nothing name- | otherwise =- case Map.lookup ns sl of- Nothing -> error "nameToTName"- Just pref -> TName (Just pref) name--mkBeginToken :: Bool -- ^ pretty print attributes?- -> Bool -> Stack -> Name -> [(Name, [Content])]- -> ([Token] -> [Token], Stack)-mkBeginToken isPretty isClosed s name attrs =- ((:) (TokenBeginElement tname tattrs2 isClosed indent),- if isClosed then s else sl2 : s)- where- indent = if isPretty then 2 + 4 * length s else 0- prevsl = case s of- [] -> NSLevel Nothing Map.empty- sl':_ -> sl'- (sl1, tname, tattrs1) = newElemStack prevsl name- (sl2, tattrs2) = foldr newAttrStack (sl1, tattrs1) attrs--newElemStack :: NSLevel -> Name -> (NSLevel, TName, [TAttribute])-newElemStack nsl@(NSLevel def _) (Name local ns _)- | def == ns = (nsl, TName Nothing local, [])-newElemStack (NSLevel _ nsmap) (Name local Nothing _) =- (NSLevel Nothing nsmap, TName Nothing local, [(TName Nothing "xmlns", [])])-newElemStack (NSLevel _ nsmap) (Name local (Just ns) Nothing) =- (NSLevel (Just ns) nsmap, TName Nothing local, [(TName Nothing "xmlns", [ContentText ns])])-newElemStack (NSLevel def nsmap) (Name local (Just ns) (Just pref)) =- case Map.lookup ns nsmap of- Just pref'- | pref == pref' ->- ( NSLevel def nsmap- , TName (Just pref) local- , []- )- _ -> ( NSLevel def nsmap'- , TName (Just pref) local- , [(TName (Just "xmlns") pref, [ContentText ns])]- )- where- nsmap' = Map.insert ns pref nsmap--newAttrStack :: (Name, [Content]) -> (NSLevel, [TAttribute]) -> (NSLevel, [TAttribute])-newAttrStack (name, value) (NSLevel def nsmap, attrs) =- (NSLevel def nsmap', addNS $ (tname, value) : attrs)- where- (nsmap', tname, addNS) =- case name of- Name local Nothing _ -> (nsmap, TName Nothing local, id)- Name local (Just ns) mpref ->- let ppref = fromMaybe "ns" mpref- (pref, addNS') = getPrefix ppref nsmap ns- in (Map.insert ns pref nsmap, TName (Just pref) local, addNS')--getPrefix :: Text -> Map Text Text -> Text -> (Text, [TAttribute] -> [TAttribute])-getPrefix _ _ "http://www.w3.org/XML/1998/namespace" = ("xml", id)-getPrefix ppref nsmap ns =- case Map.lookup ns nsmap of- Just pref -> (pref, id)- Nothing ->- let pref = findUnused ppref $ Map.elems nsmap- in (pref, (:) (TName (Just "xmlns") pref, [ContentText ns]))- where- findUnused x xs- | x `elem` xs = findUnused (x `T.snoc` '_') xs- | otherwise = x--prettify :: Monad m => Int -> [Name] -> E.Enumeratee Event Event m a-prettify level names (Continue k) = do- mx <- eventHead- case mx of- Nothing -> return $ Continue k- Just x -> do- y <- E.peek- (chunks, level', names') <-- case (x, y) of- (Left contents, _) -> do- let es = map EventContent $ cleanWhite contents- let es' = if null es- then []- else before level : es ++ [after]- return (es', level, names)- (Right (EventBeginElement name attrs), Just (EventEndElement _)) -> do- EL.drop 1- return ([before level, EventBeginElement name attrs, EventEndElement name, after], level, names)- (Right (EventBeginElement name attrs), _) -> do- return ([before level, EventBeginElement name attrs, after], level + 1, name : names)- (Right (EventEndElement _), _) -> do- let newLevel = level - 1- return ([before newLevel, EventEndElement $ head names, after], newLevel, tail names)- (Right EventBeginDocument, _) -> do- _ <- takeContents id- return ([EventBeginDocument], level, names)- (Right EventEndDocument, _) -> do- _ <- takeContents id- return ([EventEndDocument, after], level, names)- (Right (EventComment t), _) -> do- _ <- takeContents id- return ([before level, EventComment $ T.map normalSpace t, after], level, names)- (Right e, _) -> do- _ <- takeContents id- return ([before level, e, after], level, names)- k (E.Chunks chunks) >>== prettify level' names'- where- before l = EventContent $ ContentText $ T.replicate l " "- after = EventContent $ ContentText "\n"-prettify _ _ step = return step--eventHead :: Monad m => Iteratee Event m (Maybe (Either [Content] Event))-eventHead = do- x <- EL.head- case x of- Just (EventContent e) -> do- es <- takeContents id- return $ Just $ Left $ e : es- Nothing -> return Nothing- Just e -> return $ Just $ Right e--takeContents :: Monad m => ([Content] -> [Content]) -> Iteratee Event m [Content]-takeContents front = do- x <- E.peek- case x of- Just (EventContent e) -> do- EL.drop 1- takeContents $ front . (:) e- _ -> return $ front []--normalSpace :: Char -> Char-normalSpace c- | isSpace c = ' '- | otherwise = c--cleanWhite :: [Content] -> [Content]-cleanWhite x =- go True [] $ go True [] x- where- go _ end (ContentEntity e:rest) = go False (ContentEntity e : end) rest- go isFront end (ContentText t:rest) =- if T.null t'- then go isFront end rest- else go False (ContentText t' : end) rest- where- t' = (if isFront then T.dropWhile isSpace else id) $ T.map normalSpace t- go _ end [] = end
− Text/XML/Enumerator/Resolved.hs
@@ -1,221 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-module Text.XML.Enumerator.Resolved- ( -- * Data types- Document (..)- , Prologue (..)- , Instruction (..)- , Miscellaneous (..)- , Node (..)- , Element (..)- , Name (..)- , Doctype (..)- , ExternalID (..)- -- * Parsing- , DecodeEntities- , decodeEntities- , readFile- , readFile_- , parseLBS- , parseLBS_- , parseEnum- , parseEnum_- , fromEvents- , UnresolvedEntityException (..)- -- * Rendering- , writeFile- , writePrettyFile- , renderLBS- , prettyLBS- , renderText- , prettyText- , renderBytes- , prettyBytes- -- * Conversion- , toXMLDocument- , fromXMLDocument- , toXMLNode- , fromXMLNode- , toXMLElement- , fromXMLElement- ) where--import qualified Data.XML.Types as X-import Data.XML.Types- ( Prologue (..)- , Miscellaneous (..)- , Instruction (..)- , Name (..)- , Doctype (..)- , ExternalID (..)- )-import Data.Typeable (Typeable)-import Data.Text (Text)-import Text.XML.Enumerator.Parse (DecodeEntities, decodeEntities)-import qualified Text.XML.Enumerator.Parse as P-import qualified Text.XML.Enumerator.Document as D-import qualified Text.XML.Enumerator.Render as R-import qualified Data.Text as T-import Data.Either (partitionEithers)-import Prelude hiding (readFile, writeFile)-import Control.Exception (SomeException, Exception)-import Data.Enumerator.Binary (enumFile, iterHandle)-import Control.Monad.IO.Class (MonadIO)-import Data.Enumerator- ( Enumerator, Iteratee, throwError, ($$), run, run_, joinI, enumList- , joinE- )-import Data.ByteString (ByteString)-import qualified Data.ByteString.Lazy as L-import Data.Functor.Identity (runIdentity)-import qualified System.IO as SIO-import System.IO.Unsafe (unsafePerformIO)-import Text.XML.Enumerator.Document (lazyConsume)-import qualified Data.Set as Set-import Data.Set (Set)--import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Encoding as TLE--data Document = Document- { documentPrologue :: Prologue- , documentRoot :: Element- , documentEpilogue :: [Miscellaneous]- }- deriving (Show, Eq, Typeable)--data Node- = NodeElement Element- | NodeInstruction Instruction- | NodeContent Text- | NodeComment Text- deriving (Show, Eq, Typeable)--data Element = Element- { elementName :: Name- , elementAttributes :: [(Name, Text)]- , elementNodes :: [Node]- }- deriving (Show, Eq, Typeable)--{--readFile :: FilePath -> DecodeEntities -> IO (Either SomeException Document)-readFile_ :: FIlePath -> DecodeEntities -> IO Document--}--toXMLDocument :: Document -> X.Document-toXMLDocument (Document a b c) = X.Document a (toXMLElement b) c--toXMLElement :: Element -> X.Element-toXMLElement (Element name as nodes) =- X.Element name as' nodes'- where- as' = map (\(x, y) -> (x, [X.ContentText y])) as- nodes' = map toXMLNode nodes--toXMLNode :: Node -> X.Node-toXMLNode (NodeElement e) = X.NodeElement $ toXMLElement e-toXMLNode (NodeContent t) = X.NodeContent $ X.ContentText t-toXMLNode (NodeComment c) = X.NodeComment c-toXMLNode (NodeInstruction i) = X.NodeInstruction i--fromXMLDocument :: X.Document -> Either (Set Text) Document-fromXMLDocument (X.Document a b c) =- case fromXMLElement b of- Left es -> Left es- Right b' -> Right $ Document a b' c--fromXMLElement :: X.Element -> Either (Set Text) Element-fromXMLElement (X.Element name as nodes) =- case (lnodes, las) of- ([], []) -> Right $ Element name ras rnodes- (x, []) -> Left $ Set.unions x- ([], y) -> Left $ Set.unions y- (x, y) -> Left $ Set.unions x `Set.union` Set.unions y- where- enodes = map fromXMLNode nodes- (lnodes, rnodes) = partitionEithers enodes- eas = map go as- (las, ras) = partitionEithers eas- go (x, y) =- case go' [] id y of- Left es -> Left es- Right y' -> Right (x, y')- go' [] front [] = Right $ T.concat $ front []- go' errs _ [] = Left $ Set.fromList errs- go' errs front (X.ContentText t:ys) = go' errs (front . (:) t) ys- go' errs front (X.ContentEntity t:ys) = go' (t : errs) front ys--fromXMLNode :: X.Node -> Either (Set Text) Node-fromXMLNode (X.NodeElement e) =- either Left (Right . NodeElement) $ fromXMLElement e-fromXMLNode (X.NodeContent (X.ContentText t)) = Right $ NodeContent t-fromXMLNode (X.NodeContent (X.ContentEntity t)) = Left $ Set.singleton t-fromXMLNode (X.NodeComment c) = Right $ NodeComment c-fromXMLNode (X.NodeInstruction i) = Right $ NodeInstruction i--readFile :: FilePath -> DecodeEntities -> IO (Either SomeException Document)-readFile fn = parseEnum $ enumFile fn--readFile_ :: FilePath -> DecodeEntities -> IO Document-readFile_ fn = parseEnum_ $ enumFile fn--lbsEnum :: Monad m => L.ByteString -> Enumerator ByteString m a-lbsEnum = enumList 8 . L.toChunks--parseLBS :: L.ByteString -> DecodeEntities -> Either SomeException Document-parseLBS lbs = runIdentity . parseEnum (lbsEnum lbs)--parseLBS_ :: L.ByteString -> DecodeEntities -> Document-parseLBS_ lbs = runIdentity . parseEnum_ (lbsEnum lbs)--parseEnum :: Monad m- => Enumerator ByteString m Document- -> DecodeEntities- -> m (Either SomeException Document)-parseEnum enum de = run $ enum $$ joinI $ P.parseBytes de $$ fromEvents--parseEnum_ :: Monad m- => Enumerator ByteString m Document- -> DecodeEntities- -> m Document-parseEnum_ enum de = run_ $ enum $$ joinI $ P.parseBytes de $$ fromEvents--fromEvents :: Monad m => Iteratee X.Event m Document-fromEvents = do- d <- D.fromEvents- either (throwError . UnresolvedEntityException) return $ fromXMLDocument d--data UnresolvedEntityException = UnresolvedEntityException (Set Text)- deriving (Show, Typeable)-instance Exception UnresolvedEntityException--renderBytes :: MonadIO m => Document -> Enumerator ByteString m a-renderBytes doc = enumList 8 (D.toEvents $ toXMLDocument doc) `joinE` R.renderBytes--prettyBytes :: MonadIO m => Document -> Enumerator ByteString m a-prettyBytes doc = enumList 8 (D.toEvents $ toXMLDocument doc) `joinE` R.prettyBytes--writeFile :: FilePath -> Document -> IO ()-writeFile fn doc = SIO.withBinaryFile fn SIO.WriteMode $ \h ->- run_ $ renderBytes doc $$ iterHandle h---- | Pretty prints via 'prettyBytes'.-writePrettyFile :: FilePath -> Document -> IO ()-writePrettyFile fn doc = SIO.withBinaryFile fn SIO.WriteMode $ \h ->- run_ $ prettyBytes doc $$ iterHandle h--renderLBS :: Document -> L.ByteString-renderLBS doc =- L.fromChunks $ unsafePerformIO $ lazyConsume $ renderBytes doc---- | Pretty prints via 'prettyBytes'.-prettyLBS :: Document -> L.ByteString-prettyLBS doc =- L.fromChunks $ unsafePerformIO $ lazyConsume $ prettyBytes doc--renderText :: Document -> TL.Text-renderText = TLE.decodeUtf8 . renderLBS---- | Pretty prints via 'prettyBytes'.-prettyText :: Document -> TL.Text-prettyText = TLE.decodeUtf8 . prettyLBS
− Text/XML/Enumerator/Token.hs
@@ -1,151 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Text.XML.Enumerator.Token- ( tokenToBuilder- , TName (..)- , Token (..)- , TAttribute- , NSLevel (..)- ) where--import Data.XML.Types (Instruction (..), Content (..), ExternalID (..))-import qualified Data.Text as T-import Data.Text (Text)-import Data.String (IsString (fromString))-import Blaze.ByteString.Builder- (Builder, fromByteString, writeByteString, copyByteString)-import Blaze.ByteString.Builder.Internal.Write (fromWriteList)-import Blaze.ByteString.Builder.Char.Utf8 (writeChar, fromText)-import Data.Monoid (mconcat, mempty, mappend)-import Data.ByteString.Char8 ()-import Data.Map (Map)-import qualified Blaze.ByteString.Builder.Char8 as BC8--oneSpace :: Builder-oneSpace = copyByteString " "--data Token = TokenBeginDocument [TAttribute]- | TokenInstruction Instruction- | TokenBeginElement TName [TAttribute] Bool Int -- ^ indent- | TokenEndElement TName- | TokenContent Content- | TokenComment Text- | TokenDoctype Text (Maybe ExternalID)- | TokenCDATA Text- deriving Show-tokenToBuilder :: Token -> Builder-tokenToBuilder (TokenBeginDocument attrs) =- fromByteString "<?xml"- `mappend` foldAttrs oneSpace attrs (fromByteString "?>\n")-tokenToBuilder (TokenInstruction (Instruction target data_)) = mconcat- [ fromByteString "<?"- , fromText target- , fromByteString " "- , fromText data_- , fromByteString "?>"- ]-tokenToBuilder (TokenBeginElement name attrs isEmpty indent) =- copyByteString "<"- `mappend` tnameToText name- `mappend` foldAttrs- (if indent == 0 || lessThan3 attrs- then oneSpace- else BC8.fromString ('\n' : replicate indent ' '))- attrs- (if isEmpty then fromByteString "/>" else fromByteString ">")- where- lessThan3 [] = True- lessThan3 [_] = True- lessThan3 [_, _] = True- lessThan3 _ = False-tokenToBuilder (TokenEndElement name) = mconcat- [ fromByteString "</"- , tnameToText name- , fromByteString ">"- ]-tokenToBuilder (TokenContent c) = contentToText c-tokenToBuilder (TokenCDATA t) =- copyByteString "<![CDATA["- `mappend` fromText t- `mappend` copyByteString "]]>"-tokenToBuilder (TokenComment t) = mconcat [fromByteString "<!--", fromText t, fromByteString "-->"]-tokenToBuilder (TokenDoctype name eid) = mconcat- [ fromByteString "<!DOCTYPE "- , fromText name- , go eid- , fromByteString ">\n"- ]- where- go Nothing = mempty- go (Just (SystemID uri)) = mconcat- [ fromByteString " SYSTEM \""- , fromText uri- , fromByteString "\""- ]- go (Just (PublicID pid uri)) = mconcat- [ fromByteString " PUBLIC \""- , fromText pid- , fromByteString "\" \""- , fromText uri- , fromByteString "\""- ]--data TName = TName (Maybe Text) Text- deriving Show--tnameToText :: TName -> Builder-tnameToText (TName Nothing name) = fromText name-tnameToText (TName (Just prefix) name) = mconcat [fromText prefix, fromByteString ":", fromText name]--contentToText :: Content -> Builder-contentToText (ContentText t) =- fromWriteList go $ T.unpack t- where- go '<' = writeByteString "<"- go '>' = writeByteString ">"- go '&' = writeByteString "&"- -- Not escaping quotes, since this is only called outside of attributes- go c = writeChar c-contentToText (ContentEntity e) = mconcat- [ fromByteString "&"- , fromText e- , fromByteString ";"- ]--type TAttribute = (TName, [Content])--foldAttrs :: Builder -- ^ before- -> [TAttribute]- -> Builder- -> Builder-foldAttrs before attrs rest' =- foldr go rest' attrs- where- go (key, val) rest =- before- `mappend` tnameToText key- `mappend` copyByteString "=\""- `mappend` foldr go' (fromByteString "\"" `mappend` rest) val- go' (ContentText t) rest =- fromWriteList h (T.unpack t) `mappend` rest- where- h '<' = writeByteString "<"- h '>' = writeByteString ">"- h '&' = writeByteString "&"- h '"' = writeByteString """- -- Not escaping single quotes, since our attributes are always double- -- quoted- h c = writeChar c- go' (ContentEntity t) rest =- fromByteString "&"- `mappend` fromText t- `mappend` fromByteString ";"- `mappend` rest--instance IsString TName where- fromString = TName Nothing . T.pack--data NSLevel = NSLevel- { defaultNS :: Maybe Text- , prefixes :: Map Text Text- }- deriving Show
+ Text/XML/Stream/Parse.hs view
@@ -0,0 +1,691 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RankNTypes #-}+-- | This module provides both a native Haskell solution for parsing XML+-- documents into a stream of events, and a set of parser combinators for+-- dealing with a stream of events.+--+-- As a simple example, if you have the following XML file:+--+-- > <?xml version="1.0" encoding="utf-8"?>+-- > <people>+-- > <person age="25">Michael</person>+-- > <person age="2">Eliezer</person>+-- > </people>+--+-- Then this code:+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > import Text.XML.Enumerator.Parse+-- > import Data.Text.Lazy (Text, unpack)+-- > +-- > data Person = Person { age :: Int, name :: Text }+-- > deriving Show+-- > +-- > parsePerson = tagName "person" (requireAttr "age") $ \age -> do+-- > name <- content+-- > return $ Person (read $ unpack age) name+-- > +-- > parsePeople = tagNoAttr "people" $ many parsePerson+-- > +-- > main = parseFile_ "people.xml" decodeEntities $ force "people required" parsePeople+--+-- will produce:+--+-- > [Person {age = 25, name = "Michael"},Person {age = 2, name = "Eliezer"}]+--+-- Previous versions of this module contained a number of more sophisticated+-- functions written by Aristid Breitkreuz and Dmitry Olshansky. To keep this+-- package simpler, those functions are being moved to a separate package. This+-- note will be updated with the name of the package(s) when available.+module Text.XML.Stream.Parse+ ( -- * Parsing XML files+ parseBytes+ , parseText+ , detectUtf+ , parseFile+ , parseFile_+ , parseLBS+ , parseLBS_+ -- ** Parser settings+ , ParseSettings+ , def+ , DecodeEntities+ , psDecodeEntities+ -- * Event parsing+ , tag+ , tagPredicate+ , tagName+ , tagNoAttr+ , content+ , contentMaybe+ -- * Attribute parsing+ , AttrParser+ , requireAttr+ , optionalAttr+ , requireAttrRaw+ , optionalAttrRaw+ , ignoreAttrs+ -- * Combinators+ , orE+ , choose+ , many+ , force+ -- * Exceptions+ , XmlException (..)+ ) where+import Data.Attoparsec.Text+ ( char, Parser, takeWhile1, skipWhile, string+ , manyTill, takeWhile, try, anyChar, endOfInput+ )+import qualified Data.Attoparsec.Text as A+import Data.Attoparsec.Text.Enumerator (iterParser)+import Data.XML.Types+ ( Name (..), Event (..), Content (..)+ , Instruction (..), ExternalID (..)+ )+import Control.Applicative (Applicative(..), Alternative(empty,(<|>)), (<$>))+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Read (Reader, decimal, hexadecimal)+import Data.Text.Encoding (decodeUtf32BEWith)+import Data.Text.Encoding.Error (ignore)+import Data.Word (Word32)+import Blaze.ByteString.Builder (fromWord32be, toByteString)+import Text.XML.Stream.Token+import Prelude hiding (takeWhile)+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import qualified Data.Map as Map+import Data.Enumerator+ ( Iteratee, Enumeratee, (>>==), Stream (..), run_, Enumerator, Step (..)+ , checkDone, yield, ($$), joinI, run, throwError, returnI+ )+import qualified Data.Enumerator as E+import qualified Data.Enumerator.List as EL+import qualified Data.Enumerator.Text as ET+import qualified Data.Enumerator.Binary as EB+import Control.Monad (unless, ap, liftM)+import qualified Data.Text as TS+import Data.List (foldl')+import Data.Typeable (Typeable)+import Control.Exception (Exception, throwIO, SomeException)+import Data.Enumerator.Binary (enumFile)+import Control.Monad.IO.Class (liftIO)+import Data.Char (isSpace)+import Data.Default (Default (..))++tokenToEvent :: [NSLevel] -> Token -> ([NSLevel], [Event])+tokenToEvent n (TokenBeginDocument _) = (n, [])+tokenToEvent n (TokenInstruction i) = (n, [EventInstruction i])+tokenToEvent n (TokenBeginElement name as isClosed _) =+ (n', if isClosed then [begin, end] else [begin])+ where+ l0 = case n of+ [] -> NSLevel Nothing Map.empty+ x:_ -> x+ (as', l') = foldl' go (id, l0) as+ go (front, l) a@(TName kpref kname, val)+ | kpref == Just "xmlns" =+ (front, l { prefixes = Map.insert kname (contentsToText val)+ $ prefixes l })+ | kpref == Nothing && kname == "xmlns" =+ (front, l { defaultNS = if T.null $ contentsToText val+ then Nothing+ else Just $ contentsToText val })+ | otherwise = (front . (:) a, l)+ n' = if isClosed then n else l' : n+ fixAttName level (name', val) = (tnameToName True level name', val)+ begin = EventBeginElement (tnameToName False l' name)+ $ map (fixAttName l')+ $ as' []+ end = EventEndElement $ tnameToName False l' name+tokenToEvent n (TokenEndElement name) =+ (n', [EventEndElement $ tnameToName False l name])+ where+ (l, n') =+ case n of+ [] -> (NSLevel Nothing Map.empty, [])+ x:xs -> (x, xs)+tokenToEvent n (TokenContent c) = (n, [EventContent c])+tokenToEvent n (TokenComment c) = (n, [EventComment c])+tokenToEvent n (TokenDoctype t eid) = (n, [EventBeginDoctype t eid, EventEndDoctype])+tokenToEvent n (TokenCDATA t) = (n, [EventCDATA t])++tnameToName :: Bool -> NSLevel -> TName -> Name+tnameToName _ _ (TName (Just "xml") name) =+ Name name (Just "http://www.w3.org/XML/1998/namespace") (Just "xml")+tnameToName isAttr (NSLevel def' _) (TName Nothing name) =+ Name name (if isAttr then Nothing else def') Nothing+tnameToName _ (NSLevel _ m) (TName (Just pref) name) =+ case Map.lookup pref m of+ Just ns -> Name name (Just ns) (Just pref)+ Nothing -> Name name Nothing (Just pref) -- FIXME is this correct?++-- | Automatically determine which UTF variant is being used. This function+-- first checks for BOMs, removing them as necessary, and then check for the+-- equivalent of <?xml for each of UTF-8, UTF-16LE/BE, and UTF-32LE/BE. It+-- defaults to assuming UTF-8.+detectUtf :: Monad m => Enumeratee S.ByteString TS.Text m a+detectUtf step = do+ x <- EB.take 4+ let (toDrop, codec) =+ case L.unpack x of+ [0x00, 0x00, 0xFE, 0xFF] -> (4, ET.utf32_be)+ [0xFF, 0xFE, 0x00, 0x00] -> (4, ET.utf32_le)+ 0xFE : 0xFF: _ -> (2, ET.utf16_be)+ 0xFF : 0xFE: _ -> (2, ET.utf16_le)+ 0xEF : 0xBB: 0xBF : _ -> (3, ET.utf8)+ [0x00, 0x00, 0x00, 0x3C] -> (0, ET.utf32_be)+ [0x3C, 0x00, 0x00, 0x00] -> (0, ET.utf32_le)+ [0x00, 0x3C, 0x00, 0x3F] -> (0, ET.utf16_be)+ [0x3C, 0x00, 0x3F, 0x00] -> (0, ET.utf16_le)+ _ -> (0, ET.utf8) -- Assuming UTF-8+ unless (toDrop == 4) $ yield () $ Chunks $ L.toChunks $ L.drop toDrop x+ ET.decode codec step++-- | Parses a byte stream into 'Event's. This function is implemented fully in+-- Haskell using attoparsec-text for parsing. The produced error messages do+-- not give line/column information, so you may prefer to stick with the parser+-- provided by libxml-enumerator. However, this has the advantage of not+-- relying on any C libraries.+--+-- This relies on 'detectUtf' to determine character encoding, and 'parseText'+-- to do the actual parsing.+parseBytes :: Monad m => ParseSettings -> Enumeratee S.ByteString Event m a+parseBytes de step = joinI $ detectUtf $$ parseText de step++-- | Parses a character stream into 'Event's. This function is implemented+-- fully in Haskell using attoparsec-text for parsing. The produced error+-- messages do not give line/column information, so you may prefer to stick+-- with the parser provided by libxml-enumerator. However, this has the+-- advantage of not relying on any C libraries.+parseText :: Monad m => ParseSettings -> Enumeratee TS.Text Event m a+parseText de =+ checkDone $ \k -> k (Chunks [EventBeginDocument]) >>== loop []+ where+ loop levels = checkDone $ go levels+ go levels k = do+ mtoken <- iterToken de+ case mtoken of+ Nothing -> k (Chunks [EventEndDocument]) >>== return+ Just token ->+ let (levels', events) = tokenToEvent levels token+ in k (Chunks events) >>== loop levels'++data ParseSettings = ParseSettings+ { psDecodeEntities :: DecodeEntities+ }++instance Default ParseSettings where+ def = ParseSettings+ { psDecodeEntities = decodeEntities+ }++iterToken :: Monad m => ParseSettings -> Iteratee TS.Text m (Maybe Token)+iterToken de = iterParser ((endOfInput >> return Nothing) <|> fmap Just (parseToken $ psDecodeEntities de))++parseToken :: DecodeEntities -> Parser Token+parseToken de = (char '<' >> parseLt) <|> TokenContent <$> parseContent de False False+ where+ parseLt =+ (char '?' >> parseInstr) <|>+ (char '!' >> (parseComment <|> parseCdata <|> parseDoctype)) <|>+ (char '/' >> parseEnd) <|>+ parseBegin+ parseInstr = do+ name <- parseIdent+ if name == "xml"+ then do+ as <- A.many $ parseAttribute de+ skipSpace+ char' '?'+ char' '>'+ newline <|> return ()+ return $ TokenBeginDocument as+ else do+ skipSpace+ x <- T.pack <$> manyTill anyChar (try $ string "?>")+ return $ TokenInstruction $ Instruction name x+ parseComment = do+ char' '-'+ char' '-'+ c <- T.pack <$> manyTill anyChar (string "-->") -- FIXME use takeWhile instead+ return $ TokenComment c+ parseCdata = do+ _ <- string "[CDATA["+ t <- T.pack <$> manyTill anyChar (string "]]>") -- FIXME use takeWhile instead+ return $ TokenCDATA t+ parseDoctype = do+ _ <- string "DOCTYPE"+ skipSpace+ i <- parseIdent+ skipSpace+ eid <- fmap Just parsePublicID <|>+ fmap Just parseSystemID <|>+ return Nothing+ skipSpace+ (do+ char' '['+ skipWhile (/= ']')+ char' ']'+ skipSpace) <|> return ()+ char' '>'+ newline <|> return ()+ return $ TokenDoctype i eid+ parsePublicID = do+ _ <- string "PUBLIC"+ x <- quotedText+ y <- quotedText+ return $ PublicID x y+ parseSystemID = do+ _ <- string "SYSTEM"+ x <- quotedText+ return $ SystemID x+ quotedText = do+ skipSpace+ between '"' <|> between '\''+ between c = do+ char' c+ x <- takeWhile (/=c)+ char' c+ return x+ parseEnd = do+ skipSpace+ n <- parseName+ skipSpace+ char' '>'+ return $ TokenEndElement n+ parseBegin = do+ skipSpace+ n <- parseName+ as <- A.many $ parseAttribute de+ skipSpace+ isClose <- (char '/' >> skipSpace >> return True) <|> return False+ char' '>'+ return $ TokenBeginElement n as isClose 0++parseAttribute :: DecodeEntities -> Parser TAttribute+parseAttribute de = do+ skipSpace+ key <- parseName+ skipSpace+ char' '='+ skipSpace+ val <- squoted <|> dquoted+ return (key, val)+ where+ squoted = do+ char' '\''+ manyTill (parseContent de False True) (char '\'')+ dquoted = do+ char' '"'+ manyTill (parseContent de True False) (char '"')++parseName :: Parser TName+parseName = do+ i1 <- parseIdent+ mi2 <- (char ':' >> fmap Just parseIdent) <|> return Nothing+ return $+ case mi2 of+ Nothing -> TName Nothing i1+ Just i2 -> TName (Just i1) i2++parseIdent :: Parser Text+parseIdent =+ takeWhile1 valid+ where+ valid '&' = False+ valid '<' = False+ valid '>' = False+ valid ':' = False+ valid '?' = False+ valid '=' = False+ valid '"' = False+ valid '\'' = False+ valid '/' = False+ valid c = not $ isSpace c++parseContent :: DecodeEntities+ -> Bool -- break on double quote+ -> Bool -- break on single quote+ -> Parser Content+parseContent de breakDouble breakSingle =+ parseEntity <|> parseText'+ where+ parseEntity = do+ char' '&'+ t <- takeWhile1 (/= ';')+ char' ';'+ return $ de t+ parseText' = do+ bs <- takeWhile1 valid+ return $ ContentText bs+ valid '"' = not breakDouble+ valid '\'' = not breakSingle+ valid '&' = False -- amp+ valid '<' = False -- lt+ valid _ = True++skipSpace :: Parser ()+skipSpace = skipWhile isSpace++newline :: Parser ()+newline = ((char '\r' >> char '\n') <|> char '\n') >> return ()++char' :: Char -> Parser ()+char' c = char c >> return ()++data ContentType =+ Ignore | IsContent Text | IsError String | NotContent++-- | Grabs the next piece of content if available. This function skips over any+-- comments and instructions and concatenates all content until the next start+-- or end tag.+contentMaybe :: Monad m => Iteratee Event m (Maybe Text)+contentMaybe = do+ x <- E.peek+ case pc' x of+ Ignore -> EL.drop 1 >> contentMaybe+ IsContent t -> EL.drop 1 >> fmap Just (takeContents (t:))+ IsError e -> throwError $ XmlException e x+ NotContent -> return Nothing+ where+ pc' Nothing = NotContent+ pc' (Just x) = pc x+ pc (EventContent (ContentText t)) = IsContent t+ pc (EventContent (ContentEntity e)) = IsError $ "Unknown entity: " ++ show e+ pc (EventCDATA t) = IsContent t+ pc EventBeginElement{} = NotContent+ pc EventEndElement{} = NotContent+ pc EventBeginDocument{} = Ignore+ pc EventEndDocument = Ignore+ pc EventBeginDoctype{} = Ignore+ pc EventEndDoctype = Ignore+ pc EventInstruction{} = Ignore+ pc EventComment{} = Ignore+ takeContents front = do+ x <- E.peek+ case pc' x of+ Ignore -> EL.drop 1 >> takeContents front+ IsContent t -> EL.drop 1 >> takeContents (front . (:) t)+ IsError e -> throwError $ XmlException e x+ NotContent -> return $ T.concat $ front []++-- | Grabs the next piece of content. If none if available, returns 'T.empty'.+-- This is simply a wrapper around 'contentMaybe'.+content :: Monad m => Iteratee Event m Text+content = do+ x <- contentMaybe+ case x of+ Nothing -> return T.empty+ Just y -> return y++-- | The most generic way to parse a tag. It takes a predicate for checking if+-- this is the correct tag name, an 'AttrParser' for handling attributes, and+-- then a parser for dealing with content.+--+-- This function automatically absorbs its balancing closing tag, and will+-- throw an exception if not all of the attributes or child elements are+-- consumed. If you want to allow extra attributes, see 'ignoreAttrs'.+--+-- This function automatically ignores comments, instructions and whitespace.+tag :: Monad m+ => (Name -> Maybe a)+ -> (a -> AttrParser b)+ -> (b -> Iteratee Event m c)+ -> Iteratee Event m (Maybe c)+tag checkName attrParser f = do+ x <- dropWS+ case x of+ Just (EventBeginElement name as) ->+ case checkName name of+ Just y ->+ case runAttrParser' (attrParser y) as of+ Left e -> throwError e+ Right z -> do+ EL.drop 1+ z' <- f z+ a <- dropWS+ case a of+ Just (EventEndElement name')+ | name == name' -> EL.drop 1 >> return (Just z')+ _ -> throwError $ XmlException ("Expected end tag for: " ++ show name) a+ Nothing -> return Nothing+ _ -> return Nothing+ where+ dropWS = do+ x <- E.peek+ let isWS =+ case x of+ Just EventBeginDocument -> True+ Just EventEndDocument -> True+ Just EventBeginDoctype{} -> True+ Just EventEndDoctype -> True+ Just EventInstruction{} -> True+ Just EventBeginElement{} -> False+ Just EventEndElement{} -> False+ Just (EventContent (ContentText t))+ | T.all isSpace t -> True+ | otherwise -> False+ Just (EventContent ContentEntity{}) -> False+ Just EventComment{} -> True+ Just EventCDATA{} -> False+ Nothing -> False+ if isWS then EL.drop 1 >> dropWS else return x+ runAttrParser' p as =+ case runAttrParser p as of+ Left e -> Left e+ Right ([], x) -> Right x+ Right (attr, _) -> Left $ UnparsedAttributes attr++-- | A simplified version of 'tag' which matches against boolean predicates.+tagPredicate :: Monad m => (Name -> Bool) -> AttrParser a -> (a -> Iteratee Event m b) -> Iteratee Event m (Maybe b)+tagPredicate p attrParser = tag (\x -> if p x then Just () else Nothing) (const attrParser)++-- | A simplified version of 'tag' which matches for specific tag names instead+-- of taking a predicate function. This is often sufficient, and when combined+-- with OverloadedStrings and the IsString instance of 'Name', can prove to be+-- very concise.+tagName :: Monad m+ => Name+ -> AttrParser a+ -> (a -> Iteratee Event m b)+ -> Iteratee Event m (Maybe b)+tagName name = tagPredicate (== name)++-- | A further simplified tag parser, which requires that no attributes exist.+tagNoAttr :: Monad m => Name -> Iteratee Event m a -> Iteratee Event m (Maybe a)+tagNoAttr name f = tagName name (return ()) $ const f++-- | Get the value of the first parser which returns 'Just'. If no parsers+-- succeed (i.e., return 'Just'), this function returns 'Nothing'.+--+-- > orE a b = choose [a, b]+orE :: Monad m => Iteratee Event m (Maybe a) -> Iteratee Event m (Maybe a) -> Iteratee Event m (Maybe a)+orE a b = do+ x <- a+ case x of+ Nothing -> b+ _ -> return x++-- | Get the value of the first parser which returns 'Just'. If no parsers+-- succeed (i.e., return 'Just'), this function returns 'Nothing'.+choose :: Monad m+ => [Iteratee Event m (Maybe a)]+ -> Iteratee Event m (Maybe a)+choose [] = return Nothing+choose (i:is) = do+ x <- i+ case x of+ Nothing -> choose is+ Just a -> return $ Just a++-- | Force an optional parser into a required parser. All of the 'tag'+-- functions, 'choose' and 'many' deal with 'Maybe' parsers. Use this when you+-- want to finally force something to happen.+force :: Monad m+ => String -- ^ Error message+ -> Iteratee Event m (Maybe a)+ -> Iteratee Event m a+force msg i = do+ x <- i+ case x of+ Nothing -> throwError $ XmlException msg Nothing+ Just a -> return a++-- | The same as 'parseFile', but throws any exceptions.+parseFile_ :: ParseSettings -> FilePath -> Iteratee Event IO a -> IO a+parseFile_ de fn p =+ parseFile de fn p >>= go+ where+ go (Left e) = liftIO $ throwIO e+ go (Right a) = return a++-- | A helper function which reads a file from disk using 'enumFile', detects+-- character encoding using 'detectUtf', parses the XML using 'parseBytes', and+-- then hands off control to your supplied parser.+parseFile :: ParseSettings+ -> FilePath+ -> Iteratee Event IO a+ -> IO (Either SomeException a)+parseFile de fn p =+ run $ enumFile fn $$ joinI+ $ parseBytes de $$ p++-- | Parse an event stream from a lazy 'L.ByteString'.+parseLBS :: ParseSettings -> L.ByteString -> Iteratee Event IO a -> IO (Either SomeException a)+parseLBS de lbs p =+ run $ enumSingle (L.toChunks lbs) $$ joinI+ $ parseBytes de $$ p++-- | Same as 'parseLBS', but throws exceptions.+parseLBS_ :: ParseSettings -> L.ByteString -> Iteratee Event IO a -> IO a+parseLBS_ de lbs p =+ run_ $ enumSingle (L.toChunks lbs) $$ joinI+ $ parseBytes de $$ p++enumSingle :: Monad m => [a] -> Enumerator a m b+enumSingle as (Continue k) = k $ Chunks as+enumSingle _ step = returnI step++data XmlException = XmlException+ { xmlErrorMessage :: String+ , xmlBadInput :: Maybe Event+ }+ | InvalidEndElement Name+ | InvalidEntity Text+ | UnparsedAttributes [(Name, [Content])]+ deriving (Show, Typeable)+instance Exception XmlException++-- | A monad for parsing attributes. By default, it requires you to deal with+-- all attributes present on an element, and will throw an exception if there+-- are unhandled attributes. Use the 'requireAttr', 'optionalAttr' et al+-- functions for handling an attribute, and 'ignoreAttrs' if you would like to+-- skip the rest of the attributes on an element.+--+-- 'Alternative' instance behave like 'First' monoid. It chooses first+-- parser which doesn't fail.+newtype AttrParser a = AttrParser { runAttrParser :: [(Name, [Content])] -> Either XmlException ([(Name, [Content])], a) }++instance Monad AttrParser where+ return a = AttrParser $ \as -> Right (as, a)+ (AttrParser f) >>= g = AttrParser $ \as ->+ case f as of+ Left e -> Left e+ Right (as', f') -> runAttrParser (g f') as'+instance Functor AttrParser where+ fmap = liftM+instance Applicative AttrParser where+ pure = return+ (<*>) = ap+instance Alternative AttrParser where+ empty = AttrParser $ const $ Left $ XmlException "AttrParser.empty" Nothing+ AttrParser f <|> AttrParser g = AttrParser $ \x ->+ case f x of+ Left _ -> g x+ res -> res++optionalAttrRaw :: ((Name, [Content]) -> Maybe b) -> AttrParser (Maybe b)+optionalAttrRaw f =+ AttrParser $ go id+ where+ go front [] = Right (front [], Nothing)+ go front (a:as) =+ case f a of+ Nothing -> go (front . (:) a) as+ Just b -> Right (front as, Just b)++requireAttrRaw :: String -> ((Name, [Content]) -> Maybe b) -> AttrParser b+requireAttrRaw msg f = do+ x <- optionalAttrRaw f+ case x of+ Just b -> return b+ Nothing -> AttrParser $ const $ Left $ XmlException msg Nothing++-- | Require that a certain attribute be present and return its value.+requireAttr :: Name -> AttrParser Text+requireAttr n = requireAttrRaw+ ("Missing attribute: " ++ show n)+ (\(x, y) -> if x == n then Just (contentsToText y) else Nothing)++-- | Return the value for an attribute if present.+optionalAttr :: Name -> AttrParser (Maybe Text)+optionalAttr n = optionalAttrRaw+ (\(x, y) -> if x == n then Just (contentsToText y) else Nothing)++contentsToText :: [Content] -> Text+contentsToText =+ T.concat . map toText+ where+ toText (ContentText t) = t+ toText (ContentEntity e) = T.concat ["&", e, ";"]++-- | Skip the remaining attributes on an element. Since this will clear the+-- list of attributes, you must call this /after/ any calls to 'requireAttr',+-- 'optionalAttr', etc.+ignoreAttrs :: AttrParser ()+ignoreAttrs = AttrParser $ \_ -> Right ([], ())++-- | Keep parsing elements as long as the parser returns 'Just'.+many :: Monad m => Iteratee Event m (Maybe a) -> Iteratee Event m [a]+many i =+ go id+ where+ go front = do+ x <- i+ case x of+ Nothing -> return $ front []+ Just y -> go $ front . (:) y++type DecodeEntities = Text -> Content++-- | Default implementation of 'DecodeEntities': handles numeric entities and+-- the five standard character entities (lt, gt, amp, quot, apos).+decodeEntities :: DecodeEntities+decodeEntities "lt" = ContentText "<"+decodeEntities "gt" = ContentText ">"+decodeEntities "amp" = ContentText "&"+decodeEntities "quot" = ContentText "\""+decodeEntities "apos" = ContentText "'"+decodeEntities t = let backup = ContentEntity t in+ case T.uncons t of+ Just ('#', t') ->+ case T.uncons t' of+ Just ('x', t'')+ | T.length t'' > 6 -> backup+ | otherwise -> decodeChar hexadecimal backup t''+ _+ | T.length t' > 7 -> backup+ | otherwise -> decodeChar decimal backup t'+ _ -> backup++decodeChar :: Reader Word32 -> Content -> Text -> Content+decodeChar readNum backup = either (const backup) toContent . readNum+ where+ toContent (num, extra) | T.null extra =+ case decodeUtf32BEWith ignore . toByteString $ fromWord32be num of+ c | T.length c == 1 -> ContentText c+ | otherwise -> backup+ toContent _ = backup
+ Text/XML/Stream/Render.hs view
@@ -0,0 +1,271 @@+{-# LANGUAGE OverloadedStrings #-}+-- | 'Enumeratee's to render XML 'Event's. Unlike libxml-enumerator and+-- expat-enumerator, this module does not provide IO and ST variants, since the+-- underlying rendering operations are pure functions.+module Text.XML.Stream.Render+ ( renderBuilder+ , renderBytes+ , renderText+ , RenderSettings+ , def+ , rsPretty+ ) where++import Data.XML.Types (Event (..), Content (..), Name (..))+import Text.XML.Stream.Token+import qualified Data.Enumerator as E+import qualified Data.Enumerator.List as EL+import qualified Data.Enumerator.Text as ET+import Data.Enumerator ((>>==), ($$), Iteratee, Step (..))+import qualified Data.Text as T+import Data.Text (Text)+import Blaze.ByteString.Builder+import Blaze.ByteString.Builder.Enumerator (builderToByteString)+import qualified Data.Map as Map+import Data.Map (Map)+import Data.Maybe (fromMaybe)+import Data.ByteString (ByteString)+import Control.Monad.IO.Class (MonadIO)+import Data.Char (isSpace)+import Data.Default (Default (def))++-- | Pretty prints a stream of 'Event's into a stream of 'Builder's. This+-- changes the meaning of some documents, by inserting/modifying whitespace.+prettyBuilder :: Monad m => E.Enumeratee Event Builder m b+prettyBuilder step0 =+ E.joinI $ prettify 0 [] $$ loop [] step0+ where+ loop stack = E.checkDone $ step stack+ step stack k = do+ x <- EL.head+ case x of+ Nothing -> E.yield (E.Continue k) E.EOF+ Just (EventBeginElement name as) -> do+ x' <- E.peek+ if x' == Just (EventEndElement name)+ then do+ EL.drop 1+ go $ mkBeginToken True True stack name as+ else go $ mkBeginToken True False stack name as+ Just e -> go $ eventToToken stack e+ where+ go (ts, stack') = k (E.Chunks $ map tokenToBuilder $ ts []) >>== loop stack'++-- | Render a stream of 'Event's into a stream of 'ByteString's. This function+-- wraps around 'renderBuilder' and 'builderToByteString', so it produces+-- optimally sized 'ByteString's with minimal buffer copying.+--+-- The output is UTF8 encoded.+renderBytes :: MonadIO m => RenderSettings -> E.Enumeratee Event ByteString m b+renderBytes rs s = E.joinI $ renderBuilder rs $$ builderToByteString s++-- | Render a stream of 'Event's into a stream of 'ByteString's. This function+-- wraps around 'renderBuilder', 'builderToByteString' and 'renderBytes', so it+-- produces optimally sized 'ByteString's with minimal buffer copying.+renderText :: MonadIO m => RenderSettings -> E.Enumeratee Event Text m b+renderText rs s = E.joinI $ renderBytes rs $$ ET.decode ET.utf8 s++data RenderSettings = RenderSettings+ { rsPretty :: Bool+ }++instance Default RenderSettings where+ def = RenderSettings+ { rsPretty = False+ }++-- | Render a stream of 'Event's into a stream of 'Builder's. Builders are from+-- the blaze-builder package, and allow the create of optimally sized+-- 'ByteString's with minimal buffer copying.+renderBuilder :: Monad m => RenderSettings -> E.Enumeratee Event Builder m b+renderBuilder RenderSettings { rsPretty = True } = prettyBuilder+renderBuilder RenderSettings { rsPretty = False } =+ loop []+ where+ loop stack = E.checkDone $ step stack+ step stack k = do+ x <- EL.head+ case x of+ Nothing -> E.yield (E.Continue k) E.EOF+ Just (EventBeginElement name as) -> do+ x' <- E.peek+ if x' == Just (EventEndElement name)+ then do+ EL.drop 1+ go $ mkBeginToken False True stack name as+ else go $ mkBeginToken False False stack name as+ Just e -> go $ eventToToken stack e+ where+ go (ts, stack') = k (E.Chunks $ map tokenToBuilder $ ts []) >>== loop stack'++eventToToken :: Stack -> Event -> ([Token] -> [Token], [NSLevel])+eventToToken s EventBeginDocument =+ ((:) (TokenBeginDocument+ [ ("version", [ContentText "1.0"])+ , ("encoding", [ContentText "UTF-8"])+ ])+ , s)+eventToToken s EventEndDocument = (id, s)+eventToToken s (EventInstruction i) = ((:) (TokenInstruction i), s)+eventToToken s (EventBeginDoctype n meid) = ((:) (TokenDoctype n meid), s)+eventToToken s EventEndDoctype = (id, s)+eventToToken s (EventCDATA t) = ((:) (TokenCDATA t), s)+eventToToken s (EventEndElement name) =+ ((:) (TokenEndElement $ nameToTName sl name), s')+ where+ (sl:s') = s+eventToToken s (EventContent c) = ((:) (TokenContent c), s)+eventToToken s (EventComment t) = ((:) (TokenComment t), s)+eventToToken _ EventBeginElement{} = error "eventToToken on EventBeginElement" -- mkBeginToken False s name attrs++type Stack = [NSLevel]++nameToTName :: NSLevel -> Name -> TName+nameToTName _ (Name name _ (Just pref))+ | pref == "xml" = TName (Just "xml") name+nameToTName _ (Name name Nothing _) = TName Nothing name -- invariant that this is true+nameToTName (NSLevel def' sl) (Name name (Just ns) _)+ | def' == Just ns = TName Nothing name+ | otherwise =+ case Map.lookup ns sl of+ Nothing -> error "nameToTName"+ Just pref -> TName (Just pref) name++mkBeginToken :: Bool -- ^ pretty print attributes?+ -> Bool -> Stack -> Name -> [(Name, [Content])]+ -> ([Token] -> [Token], Stack)+mkBeginToken isPretty isClosed s name attrs =+ ((:) (TokenBeginElement tname tattrs2 isClosed indent),+ if isClosed then s else sl2 : s)+ where+ indent = if isPretty then 2 + 4 * length s else 0+ prevsl = case s of+ [] -> NSLevel Nothing Map.empty+ sl':_ -> sl'+ (sl1, tname, tattrs1) = newElemStack prevsl name+ (sl2, tattrs2) = foldr newAttrStack (sl1, tattrs1) attrs++newElemStack :: NSLevel -> Name -> (NSLevel, TName, [TAttribute])+newElemStack nsl@(NSLevel def' _) (Name local ns _)+ | def' == ns = (nsl, TName Nothing local, [])+newElemStack (NSLevel _ nsmap) (Name local Nothing _) =+ (NSLevel Nothing nsmap, TName Nothing local, [(TName Nothing "xmlns", [])])+newElemStack (NSLevel _ nsmap) (Name local (Just ns) Nothing) =+ (NSLevel (Just ns) nsmap, TName Nothing local, [(TName Nothing "xmlns", [ContentText ns])])+newElemStack (NSLevel def' nsmap) (Name local (Just ns) (Just pref)) =+ case Map.lookup ns nsmap of+ Just pref'+ | pref == pref' ->+ ( NSLevel def' nsmap+ , TName (Just pref) local+ , []+ )+ _ -> ( NSLevel def' nsmap'+ , TName (Just pref) local+ , [(TName (Just "xmlns") pref, [ContentText ns])]+ )+ where+ nsmap' = Map.insert ns pref nsmap++newAttrStack :: (Name, [Content]) -> (NSLevel, [TAttribute]) -> (NSLevel, [TAttribute])+newAttrStack (name, value) (NSLevel def' nsmap, attrs) =+ (NSLevel def' nsmap', addNS $ (tname, value) : attrs)+ where+ (nsmap', tname, addNS) =+ case name of+ Name local Nothing _ -> (nsmap, TName Nothing local, id)+ Name local (Just ns) mpref ->+ let ppref = fromMaybe "ns" mpref+ (pref, addNS') = getPrefix ppref nsmap ns+ in (Map.insert ns pref nsmap, TName (Just pref) local, addNS')++getPrefix :: Text -> Map Text Text -> Text -> (Text, [TAttribute] -> [TAttribute])+getPrefix _ _ "http://www.w3.org/XML/1998/namespace" = ("xml", id)+getPrefix ppref nsmap ns =+ case Map.lookup ns nsmap of+ Just pref -> (pref, id)+ Nothing ->+ let pref = findUnused ppref $ Map.elems nsmap+ in (pref, (:) (TName (Just "xmlns") pref, [ContentText ns]))+ where+ findUnused x xs+ | x `elem` xs = findUnused (x `T.snoc` '_') xs+ | otherwise = x++prettify :: Monad m => Int -> [Name] -> E.Enumeratee Event Event m a+prettify level names (Continue k) = do+ mx <- eventHead+ case mx of+ Nothing -> return $ Continue k+ Just x -> do+ y <- E.peek+ (chunks, level', names') <-+ case (x, y) of+ (Left contents, _) -> do+ let es = map EventContent $ cleanWhite contents+ let es' = if null es+ then []+ else before level : es ++ [after]+ return (es', level, names)+ (Right (EventBeginElement name attrs), Just (EventEndElement _)) -> do+ EL.drop 1+ return ([before level, EventBeginElement name attrs, EventEndElement name, after], level, names)+ (Right (EventBeginElement name attrs), _) ->+ return ([before level, EventBeginElement name attrs, after], level + 1, name : names)+ (Right (EventEndElement _), _) -> do+ let newLevel = level - 1+ return ([before newLevel, EventEndElement $ head names, after], newLevel, tail names)+ (Right EventBeginDocument, _) -> do+ _ <- takeContents id+ return ([EventBeginDocument], level, names)+ (Right EventEndDocument, _) -> do+ _ <- takeContents id+ return ([EventEndDocument, after], level, names)+ (Right (EventComment t), _) -> do+ _ <- takeContents id+ return ([before level, EventComment $ T.map normalSpace t, after], level, names)+ (Right e, _) -> do+ _ <- takeContents id+ return ([before level, e, after], level, names)+ k (E.Chunks chunks) >>== prettify level' names'+ where+ before l = EventContent $ ContentText $ T.replicate l " "+ after = EventContent $ ContentText "\n"+prettify _ _ step = return step++eventHead :: Monad m => Iteratee Event m (Maybe (Either [Content] Event))+eventHead = do+ x <- EL.head+ case x of+ Just (EventContent e) -> do+ es <- takeContents id+ return $ Just $ Left $ e : es+ Nothing -> return Nothing+ Just e -> return $ Just $ Right e++takeContents :: Monad m => ([Content] -> [Content]) -> Iteratee Event m [Content]+takeContents front = do+ x <- E.peek+ case x of+ Just (EventContent e) -> do+ EL.drop 1+ takeContents $ front . (:) e+ _ -> return $ front []++normalSpace :: Char -> Char+normalSpace c+ | isSpace c = ' '+ | otherwise = c++cleanWhite :: [Content] -> [Content]+cleanWhite x =+ go True [] $ go True [] x+ where+ go _ end (ContentEntity e:rest) = go False (ContentEntity e : end) rest+ go isFront end (ContentText t:rest) =+ if T.null t'+ then go isFront end rest+ else go False (ContentText t' : end) rest+ where+ t' = (if isFront then T.dropWhile isSpace else id) $ T.map normalSpace t+ go _ end [] = end
+ Text/XML/Stream/Token.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE OverloadedStrings #-}+module Text.XML.Stream.Token+ ( tokenToBuilder+ , TName (..)+ , Token (..)+ , TAttribute+ , NSLevel (..)+ ) where++import Data.XML.Types (Instruction (..), Content (..), ExternalID (..))+import qualified Data.Text as T+import Data.Text (Text)+import Data.String (IsString (fromString))+import Blaze.ByteString.Builder+ (Builder, fromByteString, writeByteString, copyByteString)+import Blaze.ByteString.Builder.Internal.Write (fromWriteList)+import Blaze.ByteString.Builder.Char.Utf8 (writeChar, fromText)+import Data.Monoid (mconcat, mempty, mappend)+import Data.ByteString.Char8 ()+import Data.Map (Map)+import qualified Blaze.ByteString.Builder.Char8 as BC8++oneSpace :: Builder+oneSpace = copyByteString " "++data Token = TokenBeginDocument [TAttribute]+ | TokenInstruction Instruction+ | TokenBeginElement TName [TAttribute] Bool Int -- ^ indent+ | TokenEndElement TName+ | TokenContent Content+ | TokenComment Text+ | TokenDoctype Text (Maybe ExternalID)+ | TokenCDATA Text+ deriving Show+tokenToBuilder :: Token -> Builder+tokenToBuilder (TokenBeginDocument attrs) =+ fromByteString "<?xml"+ `mappend` foldAttrs oneSpace attrs (fromByteString "?>\n")+tokenToBuilder (TokenInstruction (Instruction target data_)) = mconcat+ [ fromByteString "<?"+ , fromText target+ , fromByteString " "+ , fromText data_+ , fromByteString "?>"+ ]+tokenToBuilder (TokenBeginElement name attrs isEmpty indent) =+ copyByteString "<"+ `mappend` tnameToText name+ `mappend` foldAttrs+ (if indent == 0 || lessThan3 attrs+ then oneSpace+ else BC8.fromString ('\n' : replicate indent ' '))+ attrs+ (if isEmpty then fromByteString "/>" else fromByteString ">")+ where+ lessThan3 [] = True+ lessThan3 [_] = True+ lessThan3 [_, _] = True+ lessThan3 _ = False+tokenToBuilder (TokenEndElement name) = mconcat+ [ fromByteString "</"+ , tnameToText name+ , fromByteString ">"+ ]+tokenToBuilder (TokenContent c) = contentToText c+tokenToBuilder (TokenCDATA t) =+ copyByteString "<![CDATA["+ `mappend` fromText t+ `mappend` copyByteString "]]>"+tokenToBuilder (TokenComment t) = mconcat [fromByteString "<!--", fromText t, fromByteString "-->"]+tokenToBuilder (TokenDoctype name eid) = mconcat+ [ fromByteString "<!DOCTYPE "+ , fromText name+ , go eid+ , fromByteString ">\n"+ ]+ where+ go Nothing = mempty+ go (Just (SystemID uri)) = mconcat+ [ fromByteString " SYSTEM \""+ , fromText uri+ , fromByteString "\""+ ]+ go (Just (PublicID pid uri)) = mconcat+ [ fromByteString " PUBLIC \""+ , fromText pid+ , fromByteString "\" \""+ , fromText uri+ , fromByteString "\""+ ]++data TName = TName (Maybe Text) Text+ deriving Show++tnameToText :: TName -> Builder+tnameToText (TName Nothing name) = fromText name+tnameToText (TName (Just prefix) name) = mconcat [fromText prefix, fromByteString ":", fromText name]++contentToText :: Content -> Builder+contentToText (ContentText t) =+ fromWriteList go $ T.unpack t+ where+ go '<' = writeByteString "<"+ go '>' = writeByteString ">"+ go '&' = writeByteString "&"+ -- Not escaping quotes, since this is only called outside of attributes+ go c = writeChar c+contentToText (ContentEntity e) = mconcat+ [ fromByteString "&"+ , fromText e+ , fromByteString ";"+ ]++type TAttribute = (TName, [Content])++foldAttrs :: Builder -- ^ before+ -> [TAttribute]+ -> Builder+ -> Builder+foldAttrs before attrs rest' =+ foldr go rest' attrs+ where+ go (key, val) rest =+ before+ `mappend` tnameToText key+ `mappend` copyByteString "=\""+ `mappend` foldr go' (fromByteString "\"" `mappend` rest) val+ go' (ContentText t) rest =+ fromWriteList h (T.unpack t) `mappend` rest+ where+ h '<' = writeByteString "<"+ h '>' = writeByteString ">"+ h '&' = writeByteString "&"+ h '"' = writeByteString """+ -- Not escaping single quotes, since our attributes are always double+ -- quoted+ h c = writeChar c+ go' (ContentEntity t) rest =+ fromByteString "&"+ `mappend` fromText t+ `mappend` fromByteString ";"+ `mappend` rest++instance IsString TName where+ fromString = TName Nothing . T.pack++data NSLevel = NSLevel+ { defaultNS :: Maybe Text+ , prefixes :: Map Text Text+ }+ deriving Show
+ Text/XML/Unresolved.hs view
@@ -0,0 +1,242 @@+{-# LANGUAGE DeriveDataTypeable #-}+-- | DOM-based XML parsing and rendering.+--+-- In this module, attribute values and content nodes can contain either raw+-- text or entities. In most cases, these can be fully resolved at parsing. If+-- that is the case for your documents, the "Text.XML" module provides+-- simplified datatypes that only contain raw text.+module Text.XML.Unresolved+ ( -- * Non-streaming functions+ writeFile+ , readFile+ , readFile_+ -- * Lazy bytestrings+ , renderLBS+ , parseLBS+ , parseLBS_+ -- * Streaming functions+ , toEvents+ , fromEvents+ , renderBuilder+ , renderBytes+ , renderText+ -- * Exceptions+ , InvalidEventStream (InvalidEventStream)+ -- * Internal+ , lazyConsume+ -- * Settings+ , P.def+ -- ** Parse+ , P.ParseSettings+ , P.psDecodeEntities+ -- ** Render+ , R.RenderSettings+ , R.rsPretty+ ) where++import Prelude hiding (writeFile, readFile)+import Data.XML.Types+import Data.Enumerator+ ( ($$), enumList, joinE, Enumerator, Iteratee, peek, returnI+ , throwError, joinI, run, run_, Step (Continue), Stream (Chunks)+ )+import Control.Exception (Exception, SomeException)+import Data.Typeable (Typeable)+import qualified Data.Enumerator.List as EL+import Blaze.ByteString.Builder (Builder)+import Control.Monad.IO.Class (MonadIO, liftIO)+import qualified Text.XML.Stream.Render as R+import qualified Text.XML.Stream.Parse as P+import Data.ByteString (ByteString)+import Data.Text (Text)+import Control.Applicative ((<$>), (<*>))+import Control.Monad (when)+import qualified System.IO as SIO+import Data.Enumerator.Binary (enumFile, iterHandle)+import qualified Data.Text as T+import Data.Char (isSpace)+import qualified Data.ByteString.Lazy as L+import qualified Control.Concurrent.MVar as M+import System.IO.Unsafe (unsafeInterleaveIO, unsafePerformIO)+import Control.Concurrent (forkIO)+import Data.Functor.Identity (runIdentity)++readFile :: P.ParseSettings -> FilePath -> IO (Either SomeException Document)+readFile de fn = run $ enumFile fn $$ joinI $ P.parseBytes de $$ fromEvents++readFile_ :: P.ParseSettings -> FilePath -> IO Document+readFile_ de fn = run_ $ enumFile fn $$ joinI $ P.parseBytes de $$ fromEvents++writeFile :: R.RenderSettings -> FilePath -> Document -> IO ()+writeFile rs fn doc = SIO.withBinaryFile fn SIO.WriteMode $ \h ->+ run_ $ renderBytes rs doc $$ iterHandle h++renderLBS :: R.RenderSettings -> Document -> L.ByteString+renderLBS rs doc =+ L.fromChunks $ unsafePerformIO $ lazyConsume $ renderBytes rs doc++parseLBS :: P.ParseSettings -> L.ByteString -> Either SomeException Document+parseLBS de lbs = runIdentity+ $ run $ enumSingle (L.toChunks lbs)+ $$ joinI $ P.parseBytes de $$ fromEvents++parseLBS_ :: P.ParseSettings -> L.ByteString -> Document+parseLBS_ de lbs = runIdentity+ $ run_ $ enumSingle (L.toChunks lbs)+ $$ joinI $ P.parseBytes de $$ fromEvents++enumSingle :: Monad m => [a] -> Enumerator a m b+enumSingle as (Continue k) = k $ Chunks as+enumSingle _ step = returnI step++lazyConsume :: Enumerator a IO () -> IO [a]+lazyConsume enum = do+ toGrabber <- M.newEmptyMVar+ toFiller <- M.newMVar True+ _ <- forkIO $ run_ $ enum $$ filler toGrabber toFiller+ grabber toGrabber toFiller+ where+ grabber toGrabber toFiller = do+ x <- M.takeMVar toGrabber+ case x of+ Nothing -> return []+ Just x' -> do+ M.putMVar toFiller True+ xs <- unsafeInterleaveIO $ grabber toGrabber toFiller+ return $ x' : xs+ filler toGrabber toFiller = do+ cont <- liftIO $ M.takeMVar toFiller+ if cont+ then do+ x <- EL.head+ liftIO $ M.putMVar toGrabber x+ case x of+ Nothing -> return ()+ Just _ -> filler toGrabber toFiller+ else liftIO $ M.putMVar toGrabber Nothing++data InvalidEventStream = InvalidEventStream String+ deriving (Show, Typeable)+instance Exception InvalidEventStream++renderBuilder :: MonadIO m => R.RenderSettings -> Document -> Enumerator Builder m a+renderBuilder rs doc = enumList 8 (toEvents doc) `joinE` R.renderBuilder rs++renderBytes :: MonadIO m => R.RenderSettings -> Document -> Enumerator ByteString m a+renderBytes rs doc = enumList 8 (toEvents doc) `joinE` R.renderBytes rs++renderText :: MonadIO m => R.RenderSettings -> Document -> Enumerator Text m a+renderText rs doc = enumList 8 (toEvents doc) `joinE` R.renderText rs++fromEvents :: Monad m => Iteratee Event m Document+fromEvents = do+ skip EventBeginDocument+ d <- Document <$> goP <*> require goE <*> goM+ skip EventEndDocument+ y <- EL.head+ if y == Nothing+ then return d+ else throwError $ InvalidEventStream $ "Trailing matter after epilogue: " ++ show y+ where+ skip e = do+ x <- peek+ when (x == Just e) (EL.drop 1)+ many f =+ go id+ where+ go front = do+ x <- f+ case x of+ Nothing -> return $ front []+ Just y -> go (front . (:) y)+ dropReturn x = EL.drop 1 >> return x+ require f = do+ x <- f+ case x of+ Just y -> return y+ Nothing -> do+ y <- EL.head+ throwError $ InvalidEventStream $ "Document must have a single root element, got: " ++ show y+ goP = Prologue <$> goM <*> goD <*> goM+ goM = many goM'+ goM' = do+ x <- peek+ case x of+ Just (EventInstruction i) -> dropReturn $ Just $ MiscInstruction i+ Just (EventComment t) -> dropReturn $ Just $ MiscComment t+ Just (EventContent (ContentText t))+ | T.all isSpace t -> EL.drop 1 >> goM'+ _ -> return Nothing+ goD = do+ x <- peek+ case x of+ Just (EventBeginDoctype name meid) -> do+ EL.drop 1+ dropTillDoctype+ return (Just $ Doctype name meid)+ _ -> return Nothing+ dropTillDoctype = do+ x <- EL.head+ case x of+ -- Leaving the following line commented so that the intention of+ -- this function stays clear. I figure in the future xml-types will+ -- be expanded again to support some form of EventDeclaration+ --+ -- Just (EventDeclaration _) -> dropTillDoctype+ Just EventEndDoctype -> return ()+ _ -> throwError $ InvalidEventStream $ "Invalid event during doctype, got: " ++ show x+ goE = do+ x <- peek+ case x of+ Just (EventBeginElement n as) -> Just <$> goE' n as+ _ -> return Nothing+ goE' n as = do+ EL.drop 1+ ns <- many goN+ y <- EL.head+ if y == Just (EventEndElement n)+ then return $ Element n as $ compressNodes ns+ else throwError $ InvalidEventStream $ "Missing end element for " ++ show n ++ ", got: " ++ show y+ goN = do+ x <- peek+ case x of+ Just (EventBeginElement n as) -> (Just . NodeElement) <$> goE' n as+ Just (EventInstruction i) -> dropReturn $ Just $ NodeInstruction i+ Just (EventContent c) -> dropReturn $ Just $ NodeContent c+ Just (EventComment t) -> dropReturn $ Just $ NodeComment t+ Just (EventCDATA t) -> dropReturn $ Just $ NodeContent $ ContentText t+ _ -> return Nothing++toEvents :: Document -> [Event]+toEvents (Document prol root epi) =+ (EventBeginDocument :)+ . goP prol . goE root . goM epi $ [EventEndDocument]+ where+ goP (Prologue before doctype after) =+ goM before . maybe id goD doctype . goM after+ goM [] = id+ goM [x] = (goM' x :)+ goM (x:xs) = (goM' x :) . goM xs+ goM' (MiscInstruction i) = EventInstruction i+ goM' (MiscComment t) = EventComment t+ goD (Doctype name meid) =+ (:) (EventBeginDoctype name meid)+ . (:) EventEndDoctype+ goE (Element name as ns) =+ (EventBeginElement name as :)+ . goN ns+ . (EventEndElement name :)+ goN [] = id+ goN [x] = goN' x+ goN (x:xs) = goN' x . goN xs+ goN' (NodeElement e) = goE e+ goN' (NodeInstruction i) = (EventInstruction i :)+ goN' (NodeContent c) = (EventContent c :)+ goN' (NodeComment t) = (EventComment t :)++compressNodes :: [Node] -> [Node]+compressNodes [] = []+compressNodes [x] = [x]+compressNodes (NodeContent (ContentText x) : NodeContent (ContentText y) : z) =+ compressNodes $ NodeContent (ContentText $ x `T.append` y) : z+compressNodes (x:xs) = x : compressNodes xs
− runtests.hs
@@ -1,276 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE OverloadedStrings #-}--import Control.Monad (guard)-import Control.Monad.IO.Class (liftIO)-import Data.Char (chr,ord)-import Data.String (fromString)-import Data.Text (toLower)-import Data.XML.Types-import Test.HUnit hiding (Test)-import Test.Hspec-import Test.Hspec.HUnit-import Text.XML.Enumerator.Parse (decodeEntities)-import qualified Control.Exception as C-import qualified Data.ByteString.Lazy.Char8 as L-import qualified Data.Map as Map-import qualified Text.XML.Enumerator.Document as D-import qualified Text.XML.Enumerator.Parse as P-import qualified Text.XML.Enumerator.Resolved as Res--import Text.XML.Enumerator.Parse (decodeEntities)-import qualified Text.XML.Enumerator.Parse as P-import qualified Text.XML.Enumerator.Render as R-import qualified Text.XML.Enumerator.Cursor as Cu-import Text.XML.Enumerator.Cursor ((&|), (&/), (&//), (&.//), ($|), ($/), ($//), ($.//))-import qualified Data.Map as Map-import qualified Data.ByteString.Lazy.Char8 as L-import Control.Monad.IO.Class (liftIO)-import qualified Data.Enumerator as E-import Data.Enumerator(($$))-import qualified Data.Enumerator.List as EL-import Data.Monoid-import Data.Text(Text)-import Control.Monad.IO.Class(MonadIO)-import Control.Monad-import Control.Applicative((<$>), (<*>))-import qualified Data.Text as T-import qualified Data.Set as Set-import Control.Exception (toException)----main :: IO [Spec]-main = hspec $ descriptions $- [ describe "XML parsing and rendering"- [ it "is idempotent to parse and render a document" documentParseRender- , it "has valid parser combinators" combinators- , it "has working choose function" testChoose- , it "has working many function" testMany- , it "has working orE" testOrE- ]- , describe "XML Cursors"- [ it "has correct parent" cursorParent- , it "has correct ancestor" cursorAncestor- , it "has correct orSelf" cursorOrSelf- , it "has correct preceding" cursorPreceding- , it "has correct following" cursorFollowing- , it "has correct precedingSibling" cursorPrecedingSib- , it "has correct followingSibling" cursorFollowingSib- , it "has correct descendant" cursorDescendant- , it "has correct check" cursorCheck- , it "has correct check with lists" cursorPredicate- , it "has correct checkNode" cursorCheckNode- , it "has correct checkElement" cursorCheckElement- , it "has correct checkName" cursorCheckName- , it "has correct anyElement" cursorAnyElement- , it "has correct element" cursorElement- , it "has correct laxElement" cursorLaxElement- , it "has correct content" cursorContent- , it "has correct attribute" cursorAttribute- , it "has correct laxAttribute" cursorLaxAttribute- , it "has correct &* and $* operators" cursorDeep- , it "has correct force" cursorForce- , it "has correct forceM" cursorForceM- ]- , describe "resolved"- [ it "identifies unresolved entities" resolvedIdentifies- , it "works for resolvable entities" resolvedAllGood- , it "merges adjacent content nodes" resolvedMergeContent- ]- ]--documentParseRender =- mapM_ go docs- where- go x = x @=? D.parseLBS_ (D.renderLBS x) decodeEntities- docs =- [ Document (Prologue [] Nothing [])- (Element "foo" [] [])- []- , D.parseLBS_- "<?xml version=\"1.0\"?>\n<!DOCTYPE foo>\n<foo/>"- decodeEntities- , D.parseLBS_- "<?xml version=\"1.0\"?>\n<!DOCTYPE foo>\n<foo><nested>&ignore;</nested></foo>"- decodeEntities- , D.parseLBS_- "<foo><![CDATA[this is some<CDATA content>]]></foo>"- decodeEntities- , D.parseLBS_- "<foo bar='baz&bin'/>"- decodeEntities- , D.parseLBS_- "<foo><?instr this is a processing instruction?></foo>"- decodeEntities- , D.parseLBS_- "<foo><!-- this is a comment --></foo>"- decodeEntities- ]--combinators = P.parseLBS_ input decodeEntities $ do- P.force "need hello" $ P.tagName "hello" (P.requireAttr "world") $ \world -> do- liftIO $ world @?= "true"- P.force "need child1" $ P.tagNoAttr "{mynamespace}child1" $ return ()- P.force "need child2" $ P.tagNoAttr "child2" $ return ()- P.force "need child3" $ P.tagNoAttr "child3" $ do- x <- P.contentMaybe- liftIO $ x @?= Just "combine <all> &content"- where- input = L.concat- [ "<?xml version='1.0'?>\n"- , "<!DOCTYPE foo []>\n"- , "<hello world='true'>"- , "<?this should be ignored?>"- , "<child1 xmlns='mynamespace'/>"- , "<!-- this should be ignored -->"- , "<child2> </child2>"- , "<child3>combine <all> <![CDATA[&content]]></child3>\n"- , "</hello>"- ]--testChoose = P.parseLBS_ input decodeEntities $ do- P.force "need hello" $ P.tagNoAttr "hello" $ do- x <- P.choose- [ P.tagNoAttr "failure" $ return 1- , P.tagNoAttr "success" $ return 2- ]- liftIO $ x @?= Just 2- where- input = L.concat- [ "<?xml version='1.0'?>\n"- , "<!DOCTYPE foo []>\n"- , "<hello>"- , "<success/>"- , "</hello>"- ]--testMany = P.parseLBS_ input decodeEntities $ do- P.force "need hello" $ P.tagNoAttr "hello" $ do- x <- P.many $ P.tagNoAttr "success" $ return ()- liftIO $ length x @?= 5- where- input = L.concat- [ "<?xml version='1.0'?>\n"- , "<!DOCTYPE foo []>\n"- , "<hello>"- , "<success/>"- , "<success/>"- , "<success/>"- , "<success/>"- , "<success/>"- , "</hello>"- ]--testOrE = P.parseLBS_ input decodeEntities $ do- P.force "need hello" $ P.tagNoAttr "hello" $ do- x <- P.tagNoAttr "failure" (return 1) `P.orE`- P.tagNoAttr "success" (return 2)- liftIO $ x @?= Just 2- where- input = L.concat- [ "<?xml version='1.0'?>\n"- , "<!DOCTYPE foo []>\n"- , "<hello>"- , "<success/>"- , "</hello>"- ]---name :: [Cu.Cursor] -> [Text]-name [] = []-name (c:cs) = ($ name cs) $ case Cu.node c of- Res.NodeElement e -> ((Res.nameLocalName $ Res.elementName e) :)- _ -> id--cursor =- Cu.fromDocument $ Res.parseLBS_ input decodeEntities- where- input = L.concat- [ "<foo attr=\"x\">"- , "<bar1/>"- , "<bar2>"- , "<baz1/>"- , "<baz2 attr=\"y\"/>"- , "<baz3>a</baz3>"- , "</bar2>"- , "<bar3>"- , "<bin1/>"- , "b"- , "<bin2/>"- , "<bin3/>"- , "</bar3>"- , "<Bar1 xmlns=\"http://example.com\" Attr=\"q\"/>"- , "</foo>"- ]--bar2 = Cu.child cursor !! 1-baz2 = Cu.child bar2 !! 1--bar3 = Cu.child cursor !! 2-bin2 = Cu.child bar3 !! 1--cursorParent = name (Cu.parent bar2) @?= ["foo"]-cursorAncestor = name (Cu.ancestor baz2) @?= ["bar2", "foo"]-cursorOrSelf = name (Cu.orSelf Cu.ancestor baz2) @?= ["baz2", "bar2", "foo"]-cursorPreceding = do- name (Cu.preceding baz2) @?= ["baz1", "bar1"]- name (Cu.preceding bin2) @?= ["bin1", "baz3", "baz2", "baz1", "bar2", "bar1"]-cursorFollowing = do- name (Cu.following baz2) @?= ["baz3", "bar3", "bin1", "bin2", "bin3", "Bar1"]- name (Cu.following bar2) @?= ["bar3", "bin1", "bin2", "bin3", "Bar1"]-cursorPrecedingSib = name (Cu.precedingSibling baz2) @?= ["baz1"]-cursorFollowingSib = name (Cu.followingSibling baz2) @?= ["baz3"]-cursorDescendant = (name $ Cu.descendant cursor) @?= T.words "bar1 bar2 baz1 baz2 baz3 bar3 bin1 bin2 bin3 Bar1"-cursorCheck = null (cursor $.// Cu.check (const False)) @?= True-cursorPredicate = (name $ cursor $.// Cu.check Cu.descendant) @?= T.words "foo bar2 baz3 bar3"-cursorCheckNode = (name $ cursor $// Cu.checkNode f) @?= T.words "bar1 bar2 bar3"- where f (Res.NodeElement e) = "bar" `T.isPrefixOf` Res.nameLocalName (Res.elementName e)- f _ = False-cursorCheckElement = (name $ cursor $// Cu.checkElement f) @?= T.words "bar1 bar2 bar3"- where f e = "bar" `T.isPrefixOf` Res.nameLocalName (Res.elementName e)-cursorCheckName = (name $ cursor $// Cu.checkName f) @?= T.words "bar1 bar2 bar3"- where f n = "bar" `T.isPrefixOf` nameLocalName n-cursorAnyElement = (name $ cursor $// Cu.anyElement) @?= T.words "bar1 bar2 baz1 baz2 baz3 bar3 bin1 bin2 bin3 Bar1"-cursorElement = (name $ cursor $// Cu.element "bar1") @?= ["bar1"]-cursorLaxElement = (name $ cursor $// Cu.laxElement "bar1") @?= ["bar1", "Bar1"]-cursorContent = do- Cu.content cursor @?= []- (cursor $.// Cu.content) @?= ["a", "b"]-cursorAttribute = Cu.attribute "attr" cursor @?= ["x"]-cursorLaxAttribute = (cursor $.// Cu.laxAttribute "Attr") @?= ["x", "y", "q"]-cursorDeep = do- (Cu.element "foo" &/ Cu.element "bar2" &// Cu.attribute "attr") cursor @?= ["y"]- (return &.// Cu.attribute "attr") cursor @?= ["x", "y"]- (cursor $.// Cu.attribute "attr") @?= ["x", "y"]- (cursor $/ Cu.element "bar2" &// Cu.attribute "attr") @?= ["y"]- (cursor $/ Cu.element "bar2" &/ Cu.element "baz2" >=> Cu.attribute "attr") @?= ["y"]- null (cursor $| Cu.element "foo") @?= False-cursorForce = do- Cu.force () [] @?= (Nothing :: Maybe Integer)- Cu.force () [1] @?= Just 1- Cu.force () [1,2] @?= Just 1-cursorForceM = do- Cu.forceM () [] @?= (Nothing :: Maybe Integer)- Cu.forceM () [Just 1, Nothing] @?= Just 1- Cu.forceM () [Nothing, Just 1] @?= Nothing--showEq :: (Show a, Show b) => Either a b -> Either a b -> Assertion-showEq x y = show x @=? show y--resolvedIdentifies =- Left (toException $ Res.UnresolvedEntityException $ Set.fromList ["foo", "bar", "baz"]) `showEq`- Res.parseLBS- "<root attr='&bar;'>&foo; --- &baz; &foo;</root>"- Res.decodeEntities--resolvedAllGood =- D.parseLBS_ xml P.decodeEntities @=?- Res.toXMLDocument (Res.parseLBS_ xml P.decodeEntities)- where- xml = "<foo><bar/><baz/></foo>"--resolvedMergeContent =- Res.documentRoot (Res.parseLBS_ xml P.decodeEntities) @=?- Res.Element "foo" [] [Res.NodeContent "bar&baz"]- where- xml = "<foo>bar&baz</foo>"
+ test/main.hs view
@@ -0,0 +1,272 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}++import Control.Monad.IO.Class (liftIO)+import Data.XML.Types+import Test.HUnit hiding (Test)+import Test.Hspec+import qualified Data.ByteString.Lazy.Char8 as L+import qualified Text.XML.Unresolved as D+import qualified Text.XML.Stream.Parse as P+import qualified Text.XML as Res+import qualified Text.XML.Cursor as Cu+import Text.XML.Stream.Parse (def)++import Text.XML.Cursor ((&/), (&//), (&.//), ($|), ($/), ($//), ($.//))+import Data.Text(Text)+import Control.Monad+import qualified Data.Text as T+import qualified Data.Set as Set+import Control.Exception (toException)+import Test.Hspec.HUnit ()++main :: IO [Spec]+main = hspec $ descriptions $+ [ describe "XML parsing and rendering"+ [ it "is idempotent to parse and render a document" documentParseRender+ , it "has valid parser combinators" combinators+ , it "has working choose function" testChoose+ , it "has working many function" testMany+ , it "has working orE" testOrE+ ]+ , describe "XML Cursors"+ [ it "has correct parent" cursorParent+ , it "has correct ancestor" cursorAncestor+ , it "has correct orSelf" cursorOrSelf+ , it "has correct preceding" cursorPreceding+ , it "has correct following" cursorFollowing+ , it "has correct precedingSibling" cursorPrecedingSib+ , it "has correct followingSibling" cursorFollowingSib+ , it "has correct descendant" cursorDescendant+ , it "has correct check" cursorCheck+ , it "has correct check with lists" cursorPredicate+ , it "has correct checkNode" cursorCheckNode+ , it "has correct checkElement" cursorCheckElement+ , it "has correct checkName" cursorCheckName+ , it "has correct anyElement" cursorAnyElement+ , it "has correct element" cursorElement+ , it "has correct laxElement" cursorLaxElement+ , it "has correct content" cursorContent+ , it "has correct attribute" cursorAttribute+ , it "has correct laxAttribute" cursorLaxAttribute+ , it "has correct &* and $* operators" cursorDeep+ , it "has correct force" cursorForce+ , it "has correct forceM" cursorForceM+ , it "has correct hasAttribute" cursorHasAttribute+ , it "has correct attributeIs" cursorAttributeIs+ ]+ , describe "resolved"+ [ it "identifies unresolved entities" resolvedIdentifies+ , it "works for resolvable entities" resolvedAllGood+ , it "merges adjacent content nodes" resolvedMergeContent+ ]+ ]++documentParseRender :: IO ()+documentParseRender =+ mapM_ go docs+ where+ go x = x @=? D.parseLBS_ def (D.renderLBS def x)+ docs =+ [ Document (Prologue [] Nothing [])+ (Element "foo" [] [])+ []+ , D.parseLBS_ def+ "<?xml version=\"1.0\"?>\n<!DOCTYPE foo>\n<foo/>"+ , D.parseLBS_ def+ "<?xml version=\"1.0\"?>\n<!DOCTYPE foo>\n<foo><nested>&ignore;</nested></foo>"+ , D.parseLBS_ def+ "<foo><![CDATA[this is some<CDATA content>]]></foo>"+ , D.parseLBS_ def+ "<foo bar='baz&bin'/>"+ , D.parseLBS_ def+ "<foo><?instr this is a processing instruction?></foo>"+ , D.parseLBS_ def+ "<foo><!-- this is a comment --></foo>"+ ]++combinators :: Assertion+combinators = P.parseLBS_ def input $ do+ P.force "need hello" $ P.tagName "hello" (P.requireAttr "world") $ \world -> do+ liftIO $ world @?= "true"+ P.force "need child1" $ P.tagNoAttr "{mynamespace}child1" $ return ()+ P.force "need child2" $ P.tagNoAttr "child2" $ return ()+ P.force "need child3" $ P.tagNoAttr "child3" $ do+ x <- P.contentMaybe+ liftIO $ x @?= Just "combine <all> &content"+ where+ input = L.concat+ [ "<?xml version='1.0'?>\n"+ , "<!DOCTYPE foo []>\n"+ , "<hello world='true'>"+ , "<?this should be ignored?>"+ , "<child1 xmlns='mynamespace'/>"+ , "<!-- this should be ignored -->"+ , "<child2> </child2>"+ , "<child3>combine <all> <![CDATA[&content]]></child3>\n"+ , "</hello>"+ ]++testChoose :: Assertion+testChoose = P.parseLBS_ def input $ do+ P.force "need hello" $ P.tagNoAttr "hello" $ do+ x <- P.choose+ [ P.tagNoAttr "failure" $ return 1+ , P.tagNoAttr "success" $ return 2+ ]+ liftIO $ x @?= Just (2 :: Int)+ where+ input = L.concat+ [ "<?xml version='1.0'?>\n"+ , "<!DOCTYPE foo []>\n"+ , "<hello>"+ , "<success/>"+ , "</hello>"+ ]++testMany :: Assertion+testMany = P.parseLBS_ def input $ do+ P.force "need hello" $ P.tagNoAttr "hello" $ do+ x <- P.many $ P.tagNoAttr "success" $ return ()+ liftIO $ length x @?= 5+ where+ input = L.concat+ [ "<?xml version='1.0'?>\n"+ , "<!DOCTYPE foo []>\n"+ , "<hello>"+ , "<success/>"+ , "<success/>"+ , "<success/>"+ , "<success/>"+ , "<success/>"+ , "</hello>"+ ]++testOrE :: IO ()+testOrE = P.parseLBS_ def input $ do+ P.force "need hello" $ P.tagNoAttr "hello" $ do+ x <- P.tagNoAttr "failure" (return 1) `P.orE`+ P.tagNoAttr "success" (return 2)+ liftIO $ x @?= Just (2 :: Int)+ where+ input = L.concat+ [ "<?xml version='1.0'?>\n"+ , "<!DOCTYPE foo []>\n"+ , "<hello>"+ , "<success/>"+ , "</hello>"+ ]+++name :: [Cu.Cursor] -> [Text]+name [] = []+name (c:cs) = ($ name cs) $ case Cu.node c of+ Res.NodeElement e -> ((Res.nameLocalName $ Res.elementName e) :)+ _ -> id++cursor :: Cu.Cursor+cursor =+ Cu.fromDocument $ Res.parseLBS_ def input+ where+ input = L.concat+ [ "<foo attr=\"x\">"+ , "<bar1/>"+ , "<bar2>"+ , "<baz1/>"+ , "<baz2 attr=\"y\"/>"+ , "<baz3>a</baz3>"+ , "</bar2>"+ , "<bar3>"+ , "<bin1/>"+ , "b"+ , "<bin2/>"+ , "<bin3/>"+ , "</bar3>"+ , "<Bar1 xmlns=\"http://example.com\" Attr=\"q\"/>"+ , "</foo>"+ ]++bar2, baz2, bar3, bin2 :: Cu.Cursor+bar2 = Cu.child cursor !! 1+baz2 = Cu.child bar2 !! 1++bar3 = Cu.child cursor !! 2+bin2 = Cu.child bar3 !! 1++cursorParent, cursorAncestor, cursorOrSelf, cursorPreceding, cursorFollowing,+ cursorPrecedingSib, cursorFollowingSib, cursorDescendant, cursorCheck,+ cursorPredicate, cursorCheckNode, cursorCheckElement, cursorCheckName,+ cursorAnyElement, cursorElement, cursorLaxElement, cursorContent,+ cursorAttribute, cursorLaxAttribute, cursorHasAttribute,+ cursorAttributeIs, cursorDeep, cursorForce, cursorForceM,+ resolvedIdentifies, resolvedAllGood, resolvedMergeContent+ :: Assertion+cursorParent = name (Cu.parent bar2) @?= ["foo"]+cursorAncestor = name (Cu.ancestor baz2) @?= ["bar2", "foo"]+cursorOrSelf = name (Cu.orSelf Cu.ancestor baz2) @?= ["baz2", "bar2", "foo"]+cursorPreceding = do+ name (Cu.preceding baz2) @?= ["baz1", "bar1"]+ name (Cu.preceding bin2) @?= ["bin1", "baz3", "baz2", "baz1", "bar2", "bar1"]+cursorFollowing = do+ name (Cu.following baz2) @?= ["baz3", "bar3", "bin1", "bin2", "bin3", "Bar1"]+ name (Cu.following bar2) @?= ["bar3", "bin1", "bin2", "bin3", "Bar1"]+cursorPrecedingSib = name (Cu.precedingSibling baz2) @?= ["baz1"]+cursorFollowingSib = name (Cu.followingSibling baz2) @?= ["baz3"]+cursorDescendant = (name $ Cu.descendant cursor) @?= T.words "bar1 bar2 baz1 baz2 baz3 bar3 bin1 bin2 bin3 Bar1"+cursorCheck = null (cursor $.// Cu.check (const False)) @?= True+cursorPredicate = (name $ cursor $.// Cu.check Cu.descendant) @?= T.words "foo bar2 baz3 bar3"+cursorCheckNode = (name $ cursor $// Cu.checkNode f) @?= T.words "bar1 bar2 bar3"+ where f (Res.NodeElement e) = "bar" `T.isPrefixOf` Res.nameLocalName (Res.elementName e)+ f _ = False+cursorCheckElement = (name $ cursor $// Cu.checkElement f) @?= T.words "bar1 bar2 bar3"+ where f e = "bar" `T.isPrefixOf` Res.nameLocalName (Res.elementName e)+cursorCheckName = (name $ cursor $// Cu.checkName f) @?= T.words "bar1 bar2 bar3"+ where f n = "bar" `T.isPrefixOf` nameLocalName n+cursorAnyElement = (name $ cursor $// Cu.anyElement) @?= T.words "bar1 bar2 baz1 baz2 baz3 bar3 bin1 bin2 bin3 Bar1"+cursorElement = (name $ cursor $// Cu.element "bar1") @?= ["bar1"]+cursorLaxElement = (name $ cursor $// Cu.laxElement "bar1") @?= ["bar1", "Bar1"]+cursorContent = do+ Cu.content cursor @?= []+ (cursor $.// Cu.content) @?= ["a", "b"]+cursorAttribute = Cu.attribute "attr" cursor @?= ["x"]+cursorLaxAttribute = (cursor $.// Cu.laxAttribute "Attr") @?= ["x", "y", "q"]++cursorHasAttribute = (length $ cursor $.// Cu.hasAttribute "attr") @?= 2+cursorAttributeIs = (length $ cursor $.// Cu.attributeIs "attr" "y") @?= 1++cursorDeep = do+ (Cu.element "foo" &/ Cu.element "bar2" &// Cu.attribute "attr") cursor @?= ["y"]+ (return &.// Cu.attribute "attr") cursor @?= ["x", "y"]+ (cursor $.// Cu.attribute "attr") @?= ["x", "y"]+ (cursor $/ Cu.element "bar2" &// Cu.attribute "attr") @?= ["y"]+ (cursor $/ Cu.element "bar2" &/ Cu.element "baz2" >=> Cu.attribute "attr") @?= ["y"]+ null (cursor $| Cu.element "foo") @?= False+cursorForce = do+ Cu.force () [] @?= (Nothing :: Maybe Integer)+ Cu.force () [1] @?= Just (1 :: Int)+ Cu.force () [1,2] @?= Just (1 :: Int)+cursorForceM = do+ Cu.forceM () [] @?= (Nothing :: Maybe Integer)+ Cu.forceM () [Just 1, Nothing] @?= Just (1 :: Int)+ Cu.forceM () [Nothing, Just (1 :: Int)] @?= Nothing++showEq :: (Show a, Show b) => Either a b -> Either a b -> Assertion+showEq x y = show x @=? show y++resolvedIdentifies =+ Left (toException $ Res.UnresolvedEntityException $ Set.fromList ["foo", "bar", "baz"]) `showEq`+ Res.parseLBS def+ "<root attr='&bar;'>&foo; --- &baz; &foo;</root>"++resolvedAllGood =+ D.parseLBS_ def xml @=?+ Res.toXMLDocument (Res.parseLBS_ def xml)+ where+ xml = "<foo><bar/><baz/></foo>"++resolvedMergeContent =+ Res.documentRoot (Res.parseLBS_ def xml) @=?+ Res.Element "foo" [] [Res.NodeContent "bar&baz"]+ where+ xml = "<foo>bar&baz</foo>"
xml-enumerator.cabal view
@@ -1,17 +1,30 @@ name: xml-enumerator-version: 0.3.4+version: 0.4.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michaels@suite-sol.com>, Aristid Breitkreuz <aristidb@googlemail.com> maintainer: Michael Snoyman <michaels@suite-sol.com> synopsis: Pure-Haskell utilities for dealing with XML with the enumerator package. description:- Provides the ability to parse and render XML in a streaming manner using the enumerator package.+ This package provides parsing and rendering functions for XML. It is based on the datatypes found in the xml-types package. This package is broken up into the following modules:+ .+ * Text.XML: DOM-based parsing and rendering. This is the most commonly used module.+ .+ * Text.XML.Cursor: A wrapper around "Text.XML" which allows bidirectional traversing of the DOM, similar to XPath. (Note: Text.XML.Cursor.Generic is the same concept, but will work with any node representation.)+ .+ * Text.XML.Unresolved: A slight modification to "Text.XML" which does not require all entities to be resolved at parsing. The datatypes are slightly more complicated here, and therefore this module is only recommended when you need to deal directly with raw entities.+ .+ * Text.XML.Stream.Parse: Streaming parser, including some streaming parser combinators.+ .+ * Text.XML.Stream.Render: Streaming renderer.+ .+ Additionally, the xml-hamlet package <http://hackage.haskell.org/package/xml-hamlet> provides a more convenient syntax for creating XML documents. category: XML, Enumerator stability: Stable-cabal-version: >= 1.6+cabal-version: >= 1.8 build-type: Simple-homepage: http://github.com/snoyberg/xml-enumerator+homepage: http://github.com/snoyberg/xml+extra-source-files: test/main.hs flag test default: False@@ -29,22 +42,31 @@ , blaze-builder-enumerator >= 0.2 && < 0.3 , transformers >= 0.2 && < 0.3 , failure >= 0.1 && < 0.2- exposed-modules: Text.XML.Enumerator.Parse- Text.XML.Enumerator.Render- Text.XML.Enumerator.Document- Text.XML.Enumerator.Cursor- Text.XML.Enumerator.Resolved- other-modules: Text.XML.Enumerator.Token+ , data-default >= 0.2 && < 0.4+ exposed-modules: Text.XML.Stream.Parse+ Text.XML.Stream.Render+ Text.XML.Unresolved+ Text.XML.Cursor+ Text.XML.Cursor.Generic+ Text.XML+ other-modules: Text.XML.Stream.Token ghc-options: -Wall -executable runtests- main-is: runtests.hs- if flag(test)- Buildable: True- Build-depends: base, HUnit, hspec >= 0.3 && < 0.4- else- Buildable: False+test-suite runtests+ type: exitcode-stdio-1.0+ main-is: main.hs+ hs-source-dirs: test+ build-depends: base >= 4 && < 5+ , containers >= 0.2 && < 0.5+ , text < 1+ , transformers >= 0.2 && < 0.3+ , enumerator >= 0.4.14 && < 0.5+ , bytestring >= 0.9 && < 0.10+ , xml-enumerator >= 0.4 && < 0.5+ , hspec >= 0.6.1 && < 0.7+ , HUnit >= 1.2 && < 1.3+ , xml-types >= 0.3 && < 0.4 source-repository head type: git- location: git://github.com/snoyberg/xml-enumerator.git+ location: git://github.com/snoyberg/xml.git