hexpat 0.13 → 0.14

raw patch · 17 files changed

+1986/−316 lines, 17 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Text/XML/Expat/Annotated.hs +31/−6
• Text/XML/Expat/Cursor.hs +389/−160
• Text/XML/Expat/Format.hs +144/−74
• Text/XML/Expat/Namespaced.hs +4/−8
• Text/XML/Expat/NodeClass.hs +19/−3
• Text/XML/Expat/Proc.hs +48/−28
• Text/XML/Expat/Qualified.hs +1/−1
• Text/XML/Expat/SAX.hs +14/−14
• Text/XML/Expat/Tree.hs +21/−14
• hexpat.cabal +24/−8
• test/hexpat-tests.cabal +32/−0
• test/suite/TestSuite.hs +17/−0
• test/suite/Text/XML/Expat/Cursor/Tests.hs +611/−0
• test/suite/Text/XML/Expat/Proc/Tests.hs +168/−0
• test/suite/Text/XML/Expat/Tests.hs +79/−0
• test/suite/Text/XML/Expat/UnitTests.hs +283/−0
• test/test.xml +101/−0

@@ -7,11 +7,11 @@ -- if you want to use both modules. module Text.XML.Expat.Annotated (   -- * Tree structure-  NodeG(..),   Node,-  Attributes,  -- re-export from Tree+  NodeG(..),+  Attributes,  -- re-export from NodeClass   UNode,-  UAttributes,+  UAttributes, -- re-export from NodeClass   LNode,   ULNode,   textContent,@@ -87,7 +87,6 @@ ) where  import Control.Arrow-import Text.XML.Expat.Tree ( Attributes, UAttributes ) import qualified Text.XML.Expat.Tree as Tree import Text.XML.Expat.SAX ( Encoding(..)                           , GenericXMLString(..)@@ -113,7 +112,27 @@ import Data.Monoid  --- | Annotated variant of the tree representation of the XML document.+-- | Annotated variant of the tree representation of the XML document, meaning+-- that it has an extra piece of information of your choice attached to each+-- Element.+--+-- @c@ is the container type for the element's children, which is usually [],+-- except when you are using chunked I\/O with the @hexpat-iteratee@ package.+--+-- @tag@ is the tag type, which can either be one of several string types,+-- or a special type from the @Text.XML.Expat.Namespaced@ or+-- @Text.XML.Expat.Qualified@ modules.+--+-- @text@ is the string type for text content.+--+-- @a@ is the type of the annotation.  One of the things this can be used for+-- is to store the XML parse location, which is useful for error handling.+--+-- Note that some functions in the @Text.XML.Expat.Cursor@ module need to create+-- new nodes through the 'MkElementClass' type class. Normally this can only be done+-- if @a@ is a Maybe type (so it can provide the Nothing value for the annotation+-- on newly created nodes).  Or, you can write your own 'MkElementClass' instance.+-- Apart from that, there is no requirement for @a@ to be a Maybe type. data NodeG a c tag text =     Element {         eName       :: !tag,@@ -123,7 +142,8 @@     } |     Text !text --- | A pure Node that uses a list as its container type.+-- | A pure tree representation that uses a list as its container type,+-- annotated variant. type Node a = NodeG a []  instance (Show tag, Show text, Show a) => Show (NodeG a [] tag text) where@@ -193,6 +213,11 @@         ch' <- f ch         return $ Element n a ch' an     mapNodeContainer _ (Text t) = return $ Text t++    mkText = Text++instance (Functor c, List c) => MkElementClass (NodeG (Maybe a)) c where+    mkElement name attrs children = Element name attrs children Nothing  -- | Convert an annotated tree (/Annotated/ module) into a non-annotated -- tree (/Tree/ module).  Needed, for example, when you @format@ your tree to

@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts, UndecidableInstances #-} -------------------------------------------------------------------- -- | -- Module    : Text.XML.Expat.Cursor@@ -8,10 +9,16 @@ -- an XML document.  This implementation is based on the general -- tree zipper written by Krasimir Angelov and Iavor S. Diatchki. --+-- With the exception of 'modifyContentM', then M-suffixed functions are+-- for use with monadic node types, as used when dealing with chunked I\/O+-- with the /hexpat-iteratee/ package.  In the more common pure case, you+-- wouldn't need these *M functions.  module Text.XML.Expat.Cursor-  ( Tag(..), getTag, fromTag-  , Cursor(..), Path+  ( +  -- * Types+    Cursor, CursorG(..), Path, PathG+  , Tag(..), getTag, fromTag    -- * Conversions   , fromTree@@ -23,22 +30,31 @@   , parent   , root   , getChild+  , getChildM   , firstChild+  , firstChildM   , lastChild+  , lastChildM   , left+  , leftM   , right+  , rightM   , nextDF+  , nextDFM    -- ** Searching   , findChild   , findLeft   , findRight   , findRec+  , findRecM    -- * Node classification   , isRoot   , isFirst+  , isFirstM   , isLast+  , isLastM   , isLeaf   , isChild   , hasChildren@@ -48,6 +64,7 @@   , setContent   , modifyContent   , modifyContentList+  , modifyContentListM   , modifyContentM    -- ** Inserting content@@ -64,16 +81,23 @@    -- ** Removing content   , removeLeft+  , removeLeftM   , removeRight+  , removeRightM   , removeGoLeft+  , removeGoLeftM   , removeGoRight+  , removeGoRightM   , removeGoUp    ) where  import Text.XML.Expat.Tree+import Text.XML.Expat.NodeClass import Data.Maybe(isNothing)-import Control.Monad(mplus)+import Data.Monoid+import Control.Monad.Identity+import Data.List.Class  data Tag tag text = Tag { tagName    :: tag                         , tagAttribs :: Attributes tag text@@ -84,26 +108,39 @@ setTag t e = fromTag t (elContent e) -} -fromTag :: Tag tag text -> [Node tag text] -> Node tag text-fromTag t cs = Element { eName       = tagName t-                       , eAttributes = tagAttribs t-                       , eChildren   = cs-                       }+fromTag :: MkElementClass n c => Tag tag text -> c (n c tag text) -> n c tag text+fromTag t cs = mkElement (tagName t) (tagAttribs t) cs -type Path tag text = [([Node tag text],Tag tag text,[Node tag text])]+-- | Generalized path within an XML document.+type PathG n c tag text = [(c (n c tag text),Tag tag text,c (n c tag text))] --- | The position of a piece of content in an XML document.-data Cursor tag text = Cur-  { current :: Node tag text      -- ^ The currently selected content.-  , lefts   :: [Node tag text]    -- ^ Siblings on the left, closest first.-  , rights  :: [Node tag text]    -- ^ Siblings on the right, closest first.-  , parents :: Path tag text -- ^ The contexts of the parent elements of this location.-  } deriving (Show)+-- | A path specific to @Text.XML.Expat.Tree.Node@ trees.+type Path tag text = PathG NodeG [] tag text +-- | Generalized cursor: The position of a piece of content in an XML document.+-- @n@ is the Node type and @c@ is the list type, which would usually be [],+-- except when you're using chunked I\/O.+data CursorG n c tag text = Cur+  { current :: n c tag text       -- ^ The currently selected content.+  , lefts   :: c (n c tag text)   -- ^ Siblings on the left, closest first.+  , rights  :: c (n c tag text)   -- ^ Siblings on the right, closest first.+  , parents :: PathG n c tag text -- ^ The contexts of the parent elements of this location.+  }++instance (Show (n c tag text), Show (c (n c tag text)), Show tag, Show text)+                                           => Show (CursorG n c tag text) where+    show (Cur c l r p) = "Cur { current="++show c+++                         ", lefts="++show l+++                         ", rights="++show r+++                         ", parents="++show p++" }"++-- | A cursor specific to @Text.XML.Expat.Tree.Node@ trees.+type Cursor tag text = CursorG NodeG [] tag text+ -- Moving around ---------------------------------------------------------------  -- | The parent of the given location.-parent :: Cursor tag text -> Maybe (Cursor tag text)+parent :: MkElementClass n c => CursorG n c tag text -> Maybe (CursorG n c tag text) parent loc =   case parents loc of     (pls,v,prs) : ps -> Just@@ -115,83 +152,200 @@   -- | The top-most parent of the given location.-root :: Cursor tag text -> Cursor tag text+root :: MkElementClass n c => CursorG n c tag text -> CursorG n c tag text root loc = maybe loc root (parent loc) --- | The left sibling of the given location.-left :: Cursor tag text -> Maybe (Cursor tag text)-left loc =-  case lefts loc of-    t : ts -> Just loc { current = t, lefts = ts-                                    , rights = current loc : rights loc }-    []     -> Nothing+-- | The left sibling of the given location - pure version.+left :: CursorG n [] tag text -> Maybe (CursorG n [] tag text)+left loc = runIdentity $ leftM loc --- | The right sibling of the given location.-right :: Cursor tag text -> Maybe (Cursor tag text)-right loc =-  case rights loc of-    t : ts -> Just loc { current = t, lefts = current loc : lefts loc-                                    , rights = ts }-    []     -> Nothing+-- | The left sibling of the given location - used for monadic node types.+leftM :: List c => CursorG n c tag text -> ItemM c (Maybe (CursorG n c tag text))+leftM loc = do+  let l = lefts loc+  li <- runList l+  case li of+    Nil -> return Nothing+    Cons t ts -> return $ Just loc { current = t, lefts = ts+                                   , rights = cons (current loc) (rights loc) } --- | The first child of the given location.-firstChild :: Cursor tag text -> Maybe (Cursor tag text)-firstChild loc =-  do (t : ts, ps) <- downParents loc-     return Cur { current = t, lefts = [], rights = ts , parents = ps }+-- | The right sibling of the given location - pure version.+right :: CursorG n [] tag text -> Maybe (CursorG n [] tag text)+right loc = runIdentity $ rightM loc --- | The last child of the given location.-lastChild :: Cursor tag text -> Maybe (Cursor tag text)-lastChild loc =-  do (ts, ps) <- downParents loc-     case reverse ts of-       l : ls -> return Cur { current = l, lefts = ls, rights = []-                                                     , parents = ps }-       [] -> Nothing+-- | The right sibling of the given location - used for monadic node types.+rightM :: List c => CursorG n c tag text -> ItemM c (Maybe (CursorG n c tag text))+rightM loc = do+  let r = rights loc+  li <- runList r+  case li of+    Nil -> return Nothing+    Cons t ts -> return $ Just loc { current = t, lefts = cons (current loc) (lefts loc)+                                   , rights = ts } +-- | The first child of the given location - pure version.+firstChild :: (NodeClass n [], Monoid tag) => CursorG n [] tag text -> Maybe (CursorG n [] tag text)+firstChild loc = runIdentity $ firstChildM loc++-- | The first child of the given location - used for monadic node types.+firstChildM :: (NodeClass n c, Monoid tag) => CursorG n c tag text -> ItemM c (Maybe (CursorG n c tag text))+firstChildM loc = do+    case downParents loc of+        Just (l, ps) -> do+            li <- runList l+            return $ case li of+                Cons t ts -> Just $ Cur { current = t, lefts = mzero, rights = ts , parents = ps }+                Nil       -> Nothing+        Nothing -> return $ Nothing++-- | The last child of the given location - pure version.+lastChild :: (NodeClass n [], Monoid tag) => CursorG n [] tag text -> Maybe (CursorG n [] tag text)+lastChild loc = runIdentity $ lastChildM loc++-- | The last child of the given location - used for monadic node types.+lastChildM :: (NodeClass n c, Monoid tag) => CursorG n c tag text -> ItemM c (Maybe (CursorG n c tag text))+lastChildM loc = do+    case downParents loc of+        Just (l, ps) -> do+            li <- runList (reverseL l)+            return $ case li of+                Cons t ts -> Just $ Cur { current = t, lefts = ts, rights = mzero , parents = ps }+                Nil       -> Nothing+        Nothing -> return $ Nothing+ -- | Find the next left sibling that satisfies a predicate.-findLeft :: (Cursor tag text -> Bool) -> Cursor tag text -> Maybe (Cursor tag text)-findLeft p loc = do loc1 <- left loc-                    if p loc1 then return loc1 else findLeft p loc1+findLeft :: NodeClass n [] =>+            (CursorG n [] tag text -> Bool)+         -> CursorG n [] tag text+         -> Maybe (CursorG n [] tag text)+findLeft p loc = runIdentity (findLeftM p loc) --- | Find the next right sibling that satisfies a predicate.-findRight :: (Cursor tag text -> Bool) -> Cursor tag text -> Maybe (Cursor tag text)-findRight p loc = do loc1 <- right loc-                     if p loc1 then return loc1 else findRight p loc1+-- | Find the next left sibling that satisfies a predicate.+findLeftM :: NodeClass n c =>+             (CursorG n c tag text -> Bool)+          -> CursorG n c tag text+          -> ItemM c (Maybe (CursorG n c tag text))+findLeftM p loc = do+    mLoc1 <- leftM loc+    case mLoc1 of+        Just loc1 -> if p loc1 then return (Just loc1) else findLeftM p loc1+        Nothing   -> return Nothing --- | The first child that satisfies a predicate.-findChild :: (Cursor tag text -> Bool) -> Cursor tag text -> Maybe (Cursor tag text)-findChild p loc =-  do loc1 <- firstChild loc-     if p loc1 then return loc1 else findRight p loc1+-- | Find the next right sibling that satisfies a predicate - pure version.+findRight :: (CursorG n [] tag text -> Bool)+          -> CursorG n [] tag text+          -> Maybe (CursorG n [] tag text)+findRight p loc = runIdentity $ findRightM p loc +-- | Find the next right sibling that satisfies a predicate - used for monadic node types.+findRightM :: List c =>+              (CursorG n c tag text -> Bool)+           -> CursorG n c tag text+           -> ItemM c (Maybe (CursorG n c tag text))+findRightM p loc = do+    mLoc1 <- rightM loc+    case mLoc1 of+        Just loc1 -> if p loc1 then return $ Just loc1 else findRightM p loc1+        Nothing   -> return Nothing++-- | The first child that satisfies a predicate - pure version.+findChild :: (NodeClass n [], Monoid tag) =>+             (CursorG n [] tag text -> Bool)+          -> CursorG n [] tag text+          -> Maybe (CursorG n [] tag text)+findChild p loc = runIdentity $ findChildM p loc++-- | The first child that satisfies a predicate - used for monadic node types.+findChildM :: (NodeClass n c, Monoid tag) =>+              (CursorG n c tag text -> Bool)+           -> CursorG n c tag text+           -> ItemM c (Maybe (CursorG n c tag text))+findChildM p loc = do+    mLoc1 <- firstChildM loc+    case mLoc1 of+        Just loc1 -> if p loc1 then return $ Just loc1 else findRightM p loc1+        Nothing   -> return Nothing+ -- | The next position in a left-to-right depth-first traversal of a document: -- either the first child, right sibling, or the right sibling of a parent that--- has one.-nextDF :: Cursor tag text -> Maybe (Cursor tag text)-nextDF c = firstChild c `mplus` up c-  where up x = right x `mplus` (up =<< parent x)+-- has one. Pure version.+nextDF :: (MkElementClass n [], Monoid tag) => CursorG n [] tag text -> Maybe (CursorG n [] tag text)+nextDF c = runIdentity $ nextDFM c +-- | The next position in a left-to-right depth-first traversal of a document:+-- either the first child, right sibling, or the right sibling of a parent that+-- has one. Used for monadic node types.+nextDFM :: (MkElementClass n c, Monoid tag) => CursorG n c tag text -> ItemM c (Maybe (CursorG n c tag text))+nextDFM c = do+    mFirst <- firstChildM c+    case mFirst of+        Just c' -> return $ Just c'+        Nothing -> up c+  where+    up x = do+        mRight <- rightM x+        case mRight of+            Just c' -> return $ Just c'+            Nothing ->+                case parent x of+                    Just p -> up p+                    Nothing -> return Nothing+ -- | Perform a depth first search for a descendant that satisfies the--- given predicate.-findRec :: (Cursor tag text -> Bool) -> Cursor tag text -> Maybe (Cursor tag text)-findRec p c = if p c then Just c else findRec p =<< nextDF c+-- given predicate. Pure version.+findRec :: (MkElementClass n [], Monoid tag) =>+           (CursorG n [] tag text -> Bool)+        -> CursorG n [] tag text+        -> Maybe (CursorG n [] tag text)+findRec p c = runIdentity $ findRecM (return . p) c +-- | Perform a depth first search for a descendant that satisfies the+-- given predicate. Used for monadic node types.+findRecM :: (MkElementClass n c, Monoid tag) =>+            (CursorG n c tag text -> ItemM c Bool)+         -> CursorG n c tag text+         -> ItemM c (Maybe (CursorG n c tag text))+findRecM p c = do+    found <- p c+    if found+        then return $ Just c+        else do+            mC' <- nextDFM c+            case mC' of+                Just c' -> findRecM p c'+                Nothing -> return Nothing --- | The child with the given index (starting from 0).-getChild :: Int -> Cursor tag text -> Maybe (Cursor tag text)-getChild n loc =-  do (ts,ps) <- downParents loc-     (ls,t,rs) <- splitChildren ts n-     return Cur { current = t, lefts = ls, rights = rs, parents = ps }+-- | The child with the given index (starting from 0). - pure version.+getChild :: (NodeClass n [], Monoid tag) => Int -> CursorG n [] tag text -> Maybe (CursorG n [] tag text)+getChild n loc = runIdentity $ getChildM n loc +-- | The child with the given index (starting from 0) - used for monadic node types.+getChildM :: (NodeClass n c, Monoid tag) =>+             Int+          -> CursorG n c tag text+          -> ItemM c (Maybe (CursorG n c tag text))+getChildM n loc = do+    let mParents = downParents loc+    case mParents of+        Just (ts, ps) -> do+            mSplit <- splitChildrenM ts n+            case mSplit of+                Just (ls,t,rs) -> return $ Just $+                    Cur { current = t, lefts = ls, rights = rs, parents = ps }+                Nothing -> return Nothing+        Nothing -> return Nothing + -- | private: computes the parent for "down" operations.-downParents :: Cursor tag text -> Maybe ([Node tag text], Path tag text)+downParents :: (NodeClass n c, Monoid tag) => CursorG n c tag text -> Maybe (c (n c tag text), PathG n c tag text) downParents loc =   case current loc of-    Element n a c -> Just ( c-                      , (lefts loc, Tag n a, rights loc) : parents loc+    e | isElement e ->+        let n = getName e+            a = getAttributes e+            c = getChildren e+        in  Just ( c+                      , cons (lefts loc, Tag n a, rights loc) (parents loc)                       )     _      -> Nothing @@ -204,52 +358,79 @@ -- Conversions -----------------------------------------------------------------  -- | A cursor for the given content.-fromTree :: Node tag text -> Cursor tag text-fromTree t = Cur { current = t, lefts = [], rights = [], parents = [] }+fromTree :: List c => n c tag text -> CursorG n c tag text+fromTree t = Cur { current = t, lefts = mzero, rights = mzero, parents = [] } --- | The location of the first tree in a forest.-fromForest :: [Node tag text] -> Maybe (Cursor tag text)-fromForest (t:ts) = Just Cur { current = t, lefts = [], rights = ts-                                                      , parents = [] }-fromForest []     = Nothing+-- | The location of the first tree in a forest - pure version.+fromForest :: NodeClass n [] => [n [] tag text] -> Maybe (CursorG n [] tag text)+fromForest l = runIdentity $ fromForestM l +-- | The location of the first tree in a forest - used with monadic node types.+fromForestM :: List c => c (n c tag text) -> ItemM c (Maybe (CursorG n c tag text))+fromForestM l = do+    li <- runList l+    return $ case li of+        Cons t ts -> Just Cur { current = t, lefts = mzero, rights = ts+                                                          , parents = [] }+        Nil       -> Nothing+ -- | Computes the tree containing this location.-toTree :: Cursor tag text -> Node tag text+toTree :: MkElementClass n c => CursorG n c tag text -> n c tag text toTree loc = current (root loc)  -- | Computes the forest containing this location.-toForest :: Cursor tag text -> [Node tag text]+toForest :: MkElementClass n c => CursorG n c tag text -> c (n c tag text) toForest loc = let r = root loc in combChildren (lefts r) (current r) (rights r)   -- Queries ---------------------------------------------------------------------  -- | Are we at the top of the document?-isRoot :: Cursor tag text -> Bool+isRoot :: CursorG n c tag text -> Bool isRoot loc = null (parents loc) --- | Are we at the left end of the the document?-isFirst :: Cursor tag text -> Bool-isFirst loc = null (lefts loc)+-- | Are we at the left end of the the document? (Pure version.)+isFirst :: CursorG n [] tag text -> Bool+isFirst loc = runIdentity $ isFirstM loc --- | Are we at the right end of the document?-isLast :: Cursor tag text -> Bool-isLast loc = null (rights loc)+-- | Are we at the left end of the the document? (Used for monadic node types.)+isFirstM :: List c => CursorG n c tag text -> ItemM c Bool+isFirstM loc = do+    li <- runList (lefts loc)+    return $ case li of+        Nil -> True+        _   -> False +-- | Are we at the right end of the document? (Pure version.)+isLast :: CursorG n [] tag text -> Bool+isLast loc = runIdentity $ isLastM loc++-- | Are we at the right end of the document? (Used for monadic node types.)+isLastM :: List c => CursorG n c tag text -> ItemM c Bool+isLastM loc = do+    li <- runList (rights loc)+    return $ case li of+        Nil -> True+        _   -> False+ -- | Are we at the bottom of the document?-isLeaf :: Cursor tag text -> Bool+isLeaf :: (NodeClass n c, Monoid tag) => CursorG n c tag text -> Bool isLeaf loc = isNothing (downParents loc)  -- | Do we have a parent?-isChild :: Cursor tag text -> Bool+isChild :: CursorG n c tag text -> Bool isChild loc = not (isRoot loc) --- | Get the node index inside the sequence of children-getNodeIndex :: Cursor tag text -> Int-getNodeIndex loc = length (lefts loc)+-- | Get the node index inside the sequence of children - pure version.+getNodeIndex :: CursorG n [] tag text -> Int+getNodeIndex loc = runIdentity $ getNodeIndexM loc +-- | Get the node index inside the sequence of children - used for monadic node types.+getNodeIndexM :: List c => CursorG n c tag text -> ItemM c Int+getNodeIndexM loc = lengthL (lefts loc)+ -- | Do we have children?-hasChildren :: Cursor tag text -> Bool+hasChildren :: (NodeClass n c, Monoid tag) => CursorG n c tag text -> Bool hasChildren loc = not (isLeaf loc)  @@ -257,122 +438,170 @@ -- Updates ---------------------------------------------------------------------  -- | Change the current content.-setContent :: Node tag text -> Cursor tag text -> Cursor tag text+setContent :: n c tag text -> CursorG n c tag text -> CursorG n c tag text setContent t loc = loc { current = t }  -- | Modify the current content.-modifyContent :: (Node tag text -> Node tag text) -> Cursor tag text -> Cursor tag text+modifyContent :: (n c tag text -> n c tag text) -> CursorG n c tag text -> CursorG n c tag text modifyContent f loc = setContent (f (current loc)) loc --- | Modify the current content.-modifyContentList :: (Node tag text -> [Node tag text]) -> Cursor tag text -> Maybe (Cursor tag text)-modifyContentList f loc = removeGoRight $ insertManyRight (f $ current loc) loc+-- | Modify the current content - pure version.+modifyContentList :: NodeClass n [] =>+                     (n [] tag text -> [n [] tag text]) -> CursorG n [] tag text -> Maybe (CursorG n [] tag text)+modifyContentList f loc = runIdentity $ modifyContentListM f loc +-- | Modify the current content - used for monadic node types.+modifyContentListM :: NodeClass n c =>+                      (n c tag text -> c (n c tag text))+                   -> CursorG n c tag text+                   -> ItemM c (Maybe (CursorG n c tag text))+modifyContentListM f loc = removeGoRightM $ insertManyRight (f $ current loc) loc+ -- | Modify the current content, allowing for an effect.-modifyContentM :: Monad m => (Node tag text -> m (Node tag text)) -> Cursor tag text -> m (Cursor tag text)+modifyContentM :: Monad m => (n [] tag text -> m (n [] tag text)) -> CursorG n [] tag text -> m (CursorG n [] tag text) modifyContentM f loc = do x <- f (current loc)                           return (setContent x loc)  -- | Insert content to the left of the current position.-insertLeft :: Node tag text -> Cursor tag text -> Cursor tag text-insertLeft t loc = loc { lefts = t : lefts loc }+insertLeft :: List c => n c tag text -> CursorG n c tag text -> CursorG n c tag text+insertLeft t loc = loc { lefts = t `cons` lefts loc }  -- | Insert content to the right of the current position.-insertRight :: Node tag text -> Cursor tag text -> Cursor tag text-insertRight t loc = loc { rights = t : rights loc }+insertRight :: List c => n c tag text -> CursorG n c tag text -> CursorG n c tag text+insertRight t loc = loc { rights = t `cons` rights loc }  -- | Insert content to the left of the current position.-insertManyLeft :: [Node tag text] -> Cursor tag text -> Cursor tag text-insertManyLeft t loc = loc { lefts = reverse t ++ lefts loc }+insertManyLeft :: List c => c (n c tag text) -> CursorG n c tag text -> CursorG n c tag text+insertManyLeft t loc = loc { lefts = reverseL t `mplus` lefts loc }  -- | Insert content to the right of the current position.-insertManyRight :: [Node tag text] -> Cursor tag text -> Cursor tag text-insertManyRight t loc = loc { rights = t ++ rights loc }+insertManyRight :: List c => c (n c tag text) -> CursorG n c tag text -> CursorG n c tag text+insertManyRight t loc = loc { rights = t `mplus` rights loc }  -- | Insert content as the first child of the current position.-mapChildren :: ([Node tag text] -> [Node tag text])-            -> Cursor tag text-            -> Maybe (Cursor tag text)+mapChildren :: NodeClass n c => (c (n c tag text) -> c (n c tag text))+            -> CursorG n c tag text+            -> Maybe (CursorG n c tag text) mapChildren f loc = let e = current loc in-  case e of-    Text _ -> Nothing-    Element _ _ c -> Just $ loc { current = e { eChildren = f c } }+  if isElement e then+      Just $ loc { current = modifyChildren f e }+  else+      Nothing  -- | Insert content as the first child of the current position.-insertFirstChild :: Node tag text -> Cursor tag text -> Maybe (Cursor tag text)-insertFirstChild t = mapChildren (t:)+insertFirstChild :: NodeClass n c => n c tag text -> CursorG n c tag text -> Maybe (CursorG n c tag text)+insertFirstChild t = mapChildren (t `cons`)  -- | Insert content as the first child of the current position.-insertLastChild :: Node tag text -> Cursor tag text -> Maybe (Cursor tag text)-insertLastChild t = mapChildren (++[t])+insertLastChild :: NodeClass n c => n c tag text -> CursorG n c tag text -> Maybe (CursorG n c tag text)+insertLastChild t = mapChildren (`mplus` return t)  -- | Insert content as the first child of the current position.-insertManyFirstChild :: [Node tag text] -> Cursor tag text -> Maybe (Cursor tag text)-insertManyFirstChild t = mapChildren (t++)+insertManyFirstChild :: NodeClass n c => c (n c tag text) -> CursorG n c tag text -> Maybe (CursorG n c tag text)+insertManyFirstChild t = mapChildren (t `mplus`)  -- | Insert content as the first child of the current position.-insertManyLastChild :: [Node tag text] -> Cursor tag text -> Maybe (Cursor tag text)-insertManyLastChild t = mapChildren (++t)+insertManyLastChild :: NodeClass n c => c (n c tag text) -> CursorG n c tag text -> Maybe (CursorG n c tag text)+insertManyLastChild t = mapChildren (`mplus` t) --- | Remove the content on the left of the current position, if any.-removeLeft :: Cursor tag text -> Maybe (Node tag text,Cursor tag text)-removeLeft loc = case lefts loc of-                   l : ls -> return (l,loc { lefts = ls })-                   [] -> Nothing+-- | Remove the content on the left of the current position, if any - pure version.+removeLeft :: CursorG n [] tag text -> Maybe (n [] tag text, CursorG n [] tag text)+removeLeft loc = runIdentity $ removeLeftM loc --- | Remove the content on the right of the current position, if any.-removeRight :: Cursor tag text -> Maybe (Node tag text,Cursor tag text)-removeRight loc = case rights loc of-                    l : ls -> return (l,loc { rights = ls })-                    [] -> Nothing+-- | Remove the content on the left of the current position, if any - used for monadic node types.+removeLeftM :: List c => CursorG n c tag text -> ItemM c (Maybe (n c tag text, CursorG n c tag text))+removeLeftM loc = do+    li <- runList (lefts loc)+    return $ case li of+       Cons l ls -> Just $ (l,loc { lefts = ls })+       Nil       -> Nothing +-- | Remove the content on the right of the current position, if any - pure version.+removeRight :: CursorG n [] tag text -> Maybe (n [] tag text, CursorG n [] tag text)+removeRight loc = runIdentity $ removeRightM loc +-- | Remove the content on the left of the current position, if any - used for monadic node types.+removeRightM :: List c => CursorG n c tag text -> ItemM c (Maybe (n c tag text, CursorG n c tag text))+removeRightM loc = do+    li <- runList (rights loc)+    return $ case li of+       Cons l ls -> Just $ (l,loc { rights = ls })+       Nil       -> Nothing+ -- | Insert content to the left of the current position. -- The new content becomes the current position.-insertGoLeft :: Node tag text -> Cursor tag text -> Cursor tag text-insertGoLeft t loc = loc { current = t, rights = current loc : rights loc }+insertGoLeft :: List c => n c tag text -> CursorG n c tag text -> CursorG n c tag text+insertGoLeft t loc = loc { current = t, rights = current loc `cons` rights loc }  -- | Insert content to the right of the current position. -- The new content becomes the current position.-insertGoRight :: Node tag text -> Cursor tag text -> Cursor tag text-insertGoRight t loc = loc { current = t, lefts = current loc : lefts loc }+insertGoRight :: List c => n c tag text -> CursorG n c tag text -> CursorG n c tag text+insertGoRight t loc = loc { current = t, lefts = current loc `cons` lefts loc }  -- | Remove the current element.--- The new position is the one on the left.-removeGoLeft :: Cursor tag text -> Maybe (Cursor tag text)+-- The new position is the one on the left. Pure version.+removeGoLeft :: CursorG n [] tag text -> Maybe (CursorG n [] tag text) removeGoLeft loc = case lefts loc of                      l : ls -> Just loc { current = l, lefts = ls }                      []     -> Nothing  -- | Remove the current element.--- The new position is the one on the right.-removeGoRight :: Cursor tag text -> Maybe (Cursor tag text)-removeGoRight loc = case rights loc of-                     l : ls -> Just loc { current = l, rights = ls }-                     []     -> Nothing+-- The new position is the one on the left. Pure version.+removeGoLeftM :: List c => CursorG n c tag text -> ItemM c (Maybe (CursorG n c tag text))+removeGoLeftM loc = do+    li <- runList (lefts loc)+    return $ case li of+        Cons l ls -> Just loc { current = l, lefts = ls }+        Nil       -> Nothing  -- | Remove the current element.+-- The new position is the one on the right. Pure version.+removeGoRight :: CursorG n [] tag text -> Maybe (CursorG n [] tag text)+removeGoRight loc = runIdentity $ removeGoRightM loc++-- | Remove the current element.+-- The new position is the one on the right. Used for monadic node types.+removeGoRightM :: List c => CursorG n c tag text -> ItemM c (Maybe (CursorG n c tag text))+removeGoRightM loc = do+     li <- runList (rights loc)+     return $ case li of+         Cons l ls -> Just loc { current = l, rights = ls }+         Nil       -> Nothing++-- | Remove the current element. -- The new position is the parent of the old position.-removeGoUp :: Cursor tag text -> Maybe (Cursor tag text)+removeGoUp :: MkElementClass n c => CursorG n c tag text -> Maybe (CursorG n c tag text) removeGoUp loc =-  case parents loc of-    (pls,v,prs) : ps -> Just-      Cur { current = fromTag v (reverse (lefts loc) ++ rights loc)-          , lefts = pls, rights = prs, parents = ps-          }-    [] -> Nothing+    case (parents loc) of+        [] -> Nothing+        (pls, v, prs):ps -> Just $+            Cur { current = fromTag v (reverseL (lefts loc) `mplus` rights loc)+                , lefts = pls, rights = prs, parents = ps+                }   -- | private: Gets the given element of a list. -- Also returns the preceding elements (reversed) and the following elements.-splitChildren :: [a] -> Int -> Maybe ([a],a,[a])-splitChildren _ n | n < 0 = Nothing-splitChildren cs pos = loop [] cs pos-  where loop acc (x:xs) 0 = Just (acc,x,xs)-        loop acc (x:xs) n = loop (x:acc) xs $! n-1-        loop _ _ _        = Nothing+splitChildrenM :: List c => c a -> Int -> ItemM c (Maybe (c a,a,c a))+splitChildrenM _ n | n < 0 = return Nothing+splitChildrenM cs pos = loop mzero cs pos+  where+    loop acc l n = do+        li <- runList l+        case li of+            Nil -> return Nothing+            Cons x l' -> if n == 0+                then return $ Just (acc, x, l')+                else loop (cons x acc) l' $! n-1 --- | private: combChildren ls x ys = reverse ls ++ [x] ++ ys-combChildren :: [a] -> a -> [a] -> [a]-combChildren ls t rs = foldl (flip (:)) (t:rs) ls+-- | private: combChildren ls x ys = reverse ls ++ [x] ++ rs+combChildren :: List c =>+                c a    -- ^ ls+             -> a      -- ^ x+             -> c a    -- ^ rs+             -> c a+combChildren ls t rs = joinL $ foldlL (flip cons) (cons t rs) ls++reverseL :: List c => c a -> c a+reverseL = joinL . foldlL (flip cons) mzero 

@@ -1,18 +1,18 @@+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-} -- hexpat, a Haskell wrapper for expat -- Copyright (C) 2008 Evan Martin <martine@danga.com> -- Copyright (C) 2009 Stephen Blackheath <http://blacksapphire.com/antispam>  -- | This module provides functions to format a tree -- structure or SAX stream as UTF-8 encoded XML.--{-# LANGUAGE FlexibleContexts #-}- module Text.XML.Expat.Format (         -- * High level         format,         format',+        formatG,         formatNode,         formatNode',+        formatNodeG,         -- * Deprecated names         formatTree,         formatTree',@@ -21,93 +21,125 @@         treeToSAX,         formatSAX,         formatSAX',+        formatSAXG,         -- * Indentation         indent,         indent_     ) where  import Text.XML.Expat.NodeClass-import Text.XML.Expat.Tree+import Text.XML.Expat.SAX  import Control.Monad import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.ByteString.Internal (c2w, w2c) import Data.Char (isSpace)-import Data.List import Data.List.Class import Data.Monoid import Data.Word  -- | DEPRECATED: Renamed to 'format'.-formatTree :: (GenericXMLString tag, GenericXMLString text) =>-              Node tag text+formatTree :: (NodeClass n [], GenericXMLString tag, GenericXMLString text) =>+              n [] tag text            -> L.ByteString formatTree = format  -- | Format document with <?xml.. header - lazy variant that returns lazy ByteString.-format :: (GenericXMLString tag, GenericXMLString text) =>-              Node tag text-           -> L.ByteString-format node = xmlHeader `L.append` formatNode node+format :: (NodeClass n [], GenericXMLString tag, GenericXMLString text) =>+          n [] tag text+       -> L.ByteString+format node = L.fromChunks (xmlHeader : formatNodeG node) +-- | Format document with <?xml.. header - generalized variant that returns a generic+-- list of strict ByteStrings.+formatG :: (NodeClass n c, GenericXMLString tag, GenericXMLString text) =>+          n c tag text+       -> c B.ByteString+formatG node = cons xmlHeader $ formatNodeG node+ -- | DEPRECATED: Renamed to 'format''.-formatTree' :: (GenericXMLString tag, GenericXMLString text) =>-               Node tag text+formatTree' :: (NodeClass n [], GenericXMLString tag, GenericXMLString text) =>+               n [] tag text             -> B.ByteString formatTree' = B.concat . L.toChunks . formatTree  -- | Format document with <?xml.. header - strict variant that returns strict ByteString.-format' :: (GenericXMLString tag, GenericXMLString text) =>-           Node tag text+format' :: (NodeClass n [], GenericXMLString tag, GenericXMLString text) =>+           n [] tag text         -> B.ByteString-format' = B.concat . L.toChunks . formatTree+format' = B.concat . L.toChunks . format  -- | Format XML node with no header - lazy variant that returns lazy ByteString.-formatNode :: (GenericXMLString tag, GenericXMLString text) =>-              Node tag text+formatNode :: (NodeClass n [], GenericXMLString tag, GenericXMLString text) =>+              n [] tag text            -> L.ByteString formatNode = formatSAX . treeToSAX  -- | Format XML node with no header - strict variant that returns strict ByteString.-formatNode' :: (GenericXMLString tag, GenericXMLString text) =>-               Node tag text+formatNode' :: (NodeClass n [], GenericXMLString tag, GenericXMLString text) =>+               n [] tag text             -> B.ByteString formatNode' = B.concat . L.toChunks . formatNode -xmlHeader :: L.ByteString-xmlHeader = L.pack $ map c2w "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"+-- | Format XML node with no header - generalized variant that returns a generic+-- list of strict ByteStrings.+formatNodeG :: (NodeClass n c, GenericXMLString tag, GenericXMLString text) =>+              n c tag text+           -> c B.ByteString+formatNodeG = formatSAXG . treeToSAX +-- | The standard XML header with UTF-8 encoding.+xmlHeader :: B.ByteString+xmlHeader = B.pack $ map c2w "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"+ -- | Flatten a tree structure into SAX events, monadic version.-treeToSAX :: (GenericXMLString tag, GenericXMLString text, Monoid text, NodeClass n c,-              Functor c) =>+treeToSAX :: forall tag text n c . (GenericXMLString tag, GenericXMLString text,+                 Monoid text, NodeClass n c) =>              n c tag text -> c (SAXEvent tag text) treeToSAX node     | isElement node =         let name = getName node             atts = getAttributes node             children = getChildren node+            postpend :: c (SAXEvent tag text) -> c (SAXEvent tag text)+            postpend l = joinL $ do+                li <- runList l+                return $ case li of+                    Nil -> singleton (EndElement name)+                    Cons n l' -> cons n (postpend l')         in  cons (StartElement name atts) $-            concatL (fmap treeToSAX children)-            `mplus`-            cons (EndElement name) mzero-    | otherwise =-        cons (CharacterData $ getText node) mzero+            postpend (concatL $ fmap treeToSAX children)+    | isText node =+        singleton (CharacterData $ getText node)+    | otherwise = mzero   where-    concatL :: List l => l (l a) -> l a-    concatL xs = joinL $ foldlL mplus mzero xs+    singleton = return +concatL :: List l => l (l a) -> l a+concatL l1 = joinL $ do+    li1 <- runList l1+    return $ case li1 of+        Nil -> mzero+        Cons l2 l1' ->+            let concat2L l2 = joinL $ do+                    li2 <- runList l2+                    return $ case li2 of+                        Nil -> concatL l1'+                        Cons elt l2' -> cons elt $ concat2L l2'+            in  concat2L l2+ -- | Format SAX events with no header - lazy variant that returns lazy ByteString. formatSAX :: (GenericXMLString tag, GenericXMLString text) =>              [SAXEvent tag text]           -> L.ByteString-formatSAX = L.fromChunks . putSAX+formatSAX = L.fromChunks . formatSAXG  -- | Format SAX events with no header - strict variant that returns strict ByteString. formatSAX' :: (GenericXMLString tag, GenericXMLString text) =>               [SAXEvent tag text]            -> B.ByteString-formatSAX' = B.concat . L.toChunks . formatSAX+formatSAX' = B.concat . formatSAXG  -- Do start tag and attributes but omit closing > startTagHelper :: (GenericXMLString tag, GenericXMLString text) =>@@ -126,19 +158,40 @@                 [B.singleton (c2w '"')]         ) atts -putSAX :: (GenericXMLString tag, GenericXMLString text) =>-           [SAXEvent tag text]-        -> [B.ByteString]-putSAX (StartElement name attrs:EndElement _:elts) =-    B.concat (startTagHelper name attrs ++ [pack "/>"]):putSAX elts-putSAX (StartElement name attrs:elts) =-    B.concat (startTagHelper name attrs ++ [B.singleton (c2w '>')]):putSAX elts-putSAX (EndElement name:elts) =-    B.concat [pack "</", gxToByteString name, B.singleton (c2w '>')]:putSAX elts-putSAX (CharacterData txt:elts) =-    B.concat (escapeText (gxToByteString txt)):putSAX elts-putSAX (FailDocument _:elts) = putSAX elts-putSAX [] = []+-- | Format SAX events with no header - generalized variant that uses generic+-- list.+formatSAXG :: forall c tag text . (List c, GenericXMLString tag,+              GenericXMLString text) =>+          c (SAXEvent tag text)    -- ^ SAX events+       -> c B.ByteString+formatSAXG l1 = joinL $ do+    it1 <- runList l1+    return $ case it1 of+        Nil -> mzero+        Cons (StartElement name attrs) l2 ->+            fromList (startTagHelper name attrs)+            `mplus` (+                joinL $ do+                    it2 <- runList l2+                    return $ case it2 of+                        Cons (EndElement _) l3 ->+                            cons (pack "/>") $+                            formatSAXG l3+                        _ ->+                            cons (B.singleton (c2w '>')) $+                            formatSAXG l2+            )+        Cons (EndElement name) l2 ->+            cons (pack "</") $+            cons (gxToByteString name) $+            cons (B.singleton (c2w '>')) $+            formatSAXG l2+        Cons (CharacterData txt) l2 ->+            fromList (escapeText (gxToByteString txt))+            `mplus`+            formatSAXG l2+        Cons (FailDocument _) l2 ->+            formatSAXG l2  pack :: String -> B.ByteString pack = B.pack . map c2w@@ -162,42 +215,59 @@     rema = B.tail str  -- | Make the output prettier by adding indentation.-indent :: (GenericXMLString tag, GenericXMLString text) =>+indent :: (NodeClass n c, GenericXMLString tag, GenericXMLString text) =>           Int   -- ^ Number of indentation spaces per nesting level-       -> Node tag text-       -> Node tag text+       -> n c tag text+       -> n c tag text indent = indent_ 0  -- | Make the output prettier by adding indentation, specifying initial indent.-indent_ :: (GenericXMLString tag, GenericXMLString text) =>+indent_ :: forall n c tag text . (NodeClass n c, GenericXMLString tag, GenericXMLString text) =>            Int   -- ^ Initial indent (spaces)         -> Int   -- ^ Number of indentation spaces per nesting level-        -> Node tag text-        -> Node tag text-indent_ _ _ t@(Text _) = t-indent_ cur perLevel elt@(Element name attrs chs) =-    if any isElement chs-        then Element name attrs $-                let (_, chs') = mapAccumL (\startOfText ch -> case ch of-                            Element _ _ _ ->-                                let cur' = cur + perLevel-                                in  (-                                        True,-                                        [-                                            Text (gxFromString ('\n':replicate cur' ' ')),-                                            indent_ cur' perLevel ch-                                        ]-                                    )-                            Text t | startOfText ->-                                case strip t of-                                    Nothing -> (True, [])-                                    Just t' -> (False, [Text t'])-                            Text _ -> (False, [ch])-                        ) True chs-                in  concat chs' ++ [Text $ gxFromString ('\n':replicate cur ' ')]-        else elt+        -> n c tag text+        -> n c tag text+indent_ cur perLevel elt | isElement elt =+    flip modifyChildren elt $ \chs -> joinL $ do+        anyElts <- anyElements chs+        if anyElts+            then addSpace True chs+            else return chs   where+    addSpace :: Bool -> c (n c tag text) -> ItemM c (c (n c tag text))+    addSpace startOfText l = do+        ch <- runList l+        case ch of+            Nil -> return $ singleton (mkText $ gxFromString ('\n':replicate cur ' '))+            Cons elt l' | isElement elt -> do+                let cur' = cur + perLevel+                return $+                    cons (mkText $ gxFromString ('\n':replicate cur' ' ')) $+                    cons (indent_ cur' perLevel elt) $+                    joinL (addSpace True l')++            Cons tx l' | isText tx && startOfText ->+                case strip (getText tx) of+                    Nothing -> addSpace True l'+                    Just t' -> return $+                        cons (mkText t') $+                        joinL $ addSpace False l'+            Cons n l' ->+                return $+                    cons n $+                    joinL $ addSpace False l'+    anyElements :: c (n c tag text) -> ItemM c Bool+    anyElements l = do+        n <- runList l+        case n of+            Nil                    -> return False+            Cons n _ | isElement n -> return True+            Cons _ l'              -> anyElements l'+     strip t | gxNullString t = Nothing     strip t | isSpace (gxHead t) = strip (gxTail t)     strip t = Just t++    singleton = return+indent_ _ _ n = n 

@@ -86,13 +86,11 @@    , (Just xmlnsUri, Just xmlns)    ] -toNamespaced :: (NodeClass n c, GenericXMLString text, Ord text, Show text,-                    Functor c)+toNamespaced :: (NodeClass n c, GenericXMLString text, Ord text, Show text)                => n c (QName text) text -> n c (NName text) text toNamespaced = nodeWithNamespaces baseNsBindings -nodeWithNamespaces :: (NodeClass n c, GenericXMLString text, Ord text, Show text,-                          Functor c)+nodeWithNamespaces :: (NodeClass n c, GenericXMLString text, Ord text, Show text)                    => NsPrefixMap text -> n c (QName text) text -> n c (NName text) text nodeWithNamespaces bindings = mapElement namespaceify   where@@ -127,13 +125,11 @@          nchildren   = ffor qchildren $ nodeWithNamespaces chldBs -fromNamespaced :: (NodeClass n c, GenericXMLString text, Ord text,-                      Functor c) =>+fromNamespaced :: (NodeClass n c, GenericXMLString text, Ord text, Functor c) =>                   n c (NName text) text -> n c (QName text) text fromNamespaced = nodeWithQualifiers 1 basePfBindings -nodeWithQualifiers :: (NodeClass n c, GenericXMLString text, Ord text,-                          Functor c) =>+nodeWithQualifiers :: (NodeClass n c, GenericXMLString text, Ord text, Functor c) =>                       Int                    -> PrefixNsMap text                    -> n c (NName text) text

@@ -1,6 +1,7 @@ {-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, TypeFamilies #-}--- | A typeclass to allow for functions that work with different node types--- such as the ones defined in /Tree/ and /Annotated/.+-- | Type classes to allow for XML handling functions to be generalized to+-- work with different node types, including the ones defined in /Tree/ and+-- /Annotated/. module Text.XML.Expat.NodeClass where  import Control.Monad.Identity@@ -9,12 +10,19 @@ import Text.XML.Expat.SAX (GenericXMLString)  +-- | Type shortcut for attributes+type Attributes tag text = [(tag, text)]++-- | Type shortcut for attributes with unqualified names where tag and+-- text are the same string type.+type UAttributes text = Attributes text text+ -- | Extract all text content from inside a tag into a single string, including -- any text contained in children. textContent :: (NodeClass n [], Monoid text) => n [] tag text -> text textContent node = runIdentity $ textContentM node -class List c => NodeClass n c where+class (Functor c, List c) => NodeClass n c where     -- | Is the given node an element?     isElement :: n c tag text -> Bool @@ -70,6 +78,14 @@     mapNodeContainer :: (c (n c tag text) -> ItemM c (c' (n c' tag text)))                      -> n c tag text                      -> ItemM c (n c' tag text)++    -- | Create a text node+    mkText :: text -> n c tag text++-- | A class of node types where an Element can be constructed given a tag,+-- attributes and children.+class NodeClass n c => MkElementClass n c where+    mkElement :: tag -> Attributes tag text -> c (n c tag text) -> n c tag text  -- | Get the value of the attribute having the specified name. getAttribute :: (NodeClass n c, GenericXMLString tag) => n c tag text -> tag -> Maybe text

@@ -1,76 +1,96 @@+{-# LANGUAGE FlexibleContexts #-} -- | This module ported from Text.XML.Light.Proc module Text.XML.Expat.Proc where -import Text.XML.Expat.Tree+import Text.XML.Expat.NodeClass+import Text.XML.Expat.SAX +import Control.Monad+import Data.List.Class import Data.Maybe(listToMaybe)+import Data.Monoid+import Prelude hiding (filter) + -- | Select only the elements from a list of XML content.-onlyElems          :: [Node tag text] -> [Node tag text]-onlyElems xs        = [ x | x@(Element _ _ _) <- xs ]+onlyElems          :: NodeClass n c => c (n c tag text) -> c (n c tag text)+onlyElems           = filter isElement  -- | Select only the text from a list of XML content.-onlyText           :: [Node tag text] -> [text]-onlyText xs         = [ x | Text x <- xs ]+onlyText           :: (NodeClass n c, Monoid text) => c (n c tag text) -> c text+onlyText            = fmap getText . filter isText  -- | Find all immediate children with the given name.-findChildren       :: (GenericXMLString tag) => tag -> Node tag text -> [Node tag text]-findChildren q e    = filterChildren ((q ==) . eName) e+findChildren       :: (NodeClass n c, Eq tag, Monoid tag) => tag -> n c tag text -> c (n c tag text)+findChildren q e    = filterChildren ((q ==) . getName) e  -- | Filter all immediate children wrt a given predicate.-filterChildren       :: (Node tag text -> Bool) -> Node tag text -> [Node tag text]-filterChildren _ (Text _) = []-filterChildren p e    = filter p (onlyElems (eChildren e))+filterChildren       :: NodeClass n c => (n c tag text -> Bool) -> n c tag text -> c (n c tag text)+filterChildren p e | isElement e = filter p (onlyElems (getChildren e))+filterChildren _ _               = mzero  -- | Filter all immediate children wrt a given predicate over their names.-filterChildrenName      :: (tag -> Bool) -> Node tag text -> [Node tag text]-filterChildrenName _ (Text _) = []-filterChildrenName p e   = filter (p . eName) (onlyElems (eChildren e))+filterChildrenName      :: (NodeClass n c, Monoid tag) => (tag -> Bool) -> n c tag text -> c (n c tag text)+filterChildrenName p e | isElement e = filter (p . getName) (onlyElems (getChildren e))+filterChildrenName _ _               = mzero  -- | Find an immediate child with the given name.-findChild          :: (GenericXMLString tag) => tag -> Node tag text -> Maybe (Node tag text)+findChild          :: (NodeClass n [], GenericXMLString tag) => tag -> n [] tag text -> Maybe (n [] tag text) findChild q e       = listToMaybe (findChildren q e)  -- | Find an immediate child with the given name.-filterChild          :: (Node tag text -> Bool) -> Node tag text -> Maybe (Node tag text)+filterChild          :: NodeClass n [] => (n [] tag text -> Bool) -> n [] tag text -> Maybe (n [] tag text) filterChild p e       = listToMaybe (filterChildren p e)  -- | Find an immediate child with name matching a predicate.-filterChildName      :: (tag -> Bool) -> Node tag text -> Maybe (Node tag text)+filterChildName      :: (NodeClass n [], Monoid tag) => (tag -> Bool) -> n [] tag text -> Maybe (n [] tag text) filterChildName p e   = listToMaybe (filterChildrenName p e)  -- | Find the left-most occurrence of an element matching given name.-findElement        :: (GenericXMLString tag) => tag -> Node tag text -> Maybe (Node tag text)+findElement        :: (NodeClass n [], Eq tag, Monoid tag) => tag -> n [] tag text -> Maybe (n [] tag text) findElement q e     = listToMaybe (findElements q e)  -- | Filter the left-most occurrence of an element wrt. given predicate.-filterElement        :: (Node tag text -> Bool) -> Node tag text -> Maybe (Node tag text)+filterElement        :: NodeClass n [] => (n [] tag text -> Bool) -> n [] tag text -> Maybe (n [] tag text) filterElement p e     = listToMaybe (filterElements p e)  -- | Filter the left-most occurrence of an element wrt. given predicate.-filterElementName     :: (tag -> Bool) -> Node tag text -> Maybe (Node tag text)+filterElementName     :: (NodeClass n [], Monoid tag) => (tag -> Bool) -> n [] tag text -> Maybe (n [] tag text) filterElementName p e  = listToMaybe (filterElementsName p e)  -- | Find all non-nested occurances of an element. -- (i.e., once we have found an element, we do not search -- for more occurances among the element's children).-findElements       :: (GenericXMLString tag) => tag -> Node tag text -> [Node tag text]+findElements       :: (NodeClass n c, Eq tag, Monoid tag) => tag -> n c tag text -> c (n c tag text) findElements qn e = filterElementsName (qn==) e  -- | Find all non-nested occurrences of an element wrt. given predicate. -- (i.e., once we have found an element, we do not search -- for more occurances among the element's children).-filterElements       :: (Node tag text -> Bool) -> Node tag text -> [Node tag text]+filterElements       :: NodeClass n c => (n c tag text -> Bool) -> n c tag text -> c (n c tag text) filterElements p e- | p e        = [e]- | otherwise  = case e of-                  Element _ _ c -> concatMap (filterElements p) $ onlyElems c-                  _             -> []+    | p e         = return e+    | isElement e = concatL $ fmap (filterElements p) $ onlyElems $ getChildren e+    | otherwise   = mzero+  where+    -- Remove here if this gets added to List package.+    concatL :: List l => l (l a) -> l a+    concatL l1 = joinL $ do+        li1 <- runList l1+        return $ case li1 of+            Nil -> mzero+            Cons l2 l1' ->+                let concat2L l2 = joinL $ do+                        li2 <- runList l2+                        return $ case li2 of+                            Nil -> concatL l1'+                            Cons elt l2' -> cons elt $ concat2L l2'+                in  concat2L l2  -- | Find all non-nested occurences of an element wrt a predicate over element names. -- (i.e., once we have found an element, we do not search -- for more occurances among the element's children).-filterElementsName       :: (tag -> Bool) -> Node tag text -> [Node tag text]-filterElementsName _ (Text _) = []-filterElementsName p e = filterElements (p.eName) e+filterElementsName       :: (NodeClass n c, Monoid tag) => (tag -> Bool) -> n c tag text -> c (n c tag text)+filterElementsName p e | isElement e = filterElements (p . getName) e+filterElementsName _ _               = mzero 

@@ -22,8 +22,8 @@  import Text.XML.Expat.NodeClass import Text.XML.Expat.Tree-import Control.Monad.Writer import Control.Parallel.Strategies+import Data.Monoid  -- | A qualified name. --

@@ -16,7 +16,7 @@   ParserOptions(..),   SAXEvent(..), -  mkText,+  textFromCString,   parse,   parseLocations,   parseLocationsThrowing,@@ -139,9 +139,9 @@   -- | Converts a 'CString' to a 'GenericXMLString' type.-mkText :: GenericXMLString text => CString -> IO text-{-# INLINE mkText #-}-mkText cstr = do+textFromCString :: GenericXMLString text => CString -> IO text+{-# INLINE textFromCString #-}+textFromCString cstr = do     len <- c_strlen cstr     gxFromCStringLen (cstr, fromIntegral len) @@ -159,7 +159,7 @@   where     skip _ 1 = return False     skip entityName 0 = do-        en <- mkText entityName+        en <- textFromCString entityName         let mbt = decoder en         maybe (return False)               (\t -> do@@ -188,7 +188,7 @@   where     skip _ 1 = return False     skip entityName 0 = do-        en <- mkText entityName+        en <- textFromCString entityName         let mbt = decoder en         maybe (return False)               (\t -> do@@ -223,16 +223,16 @@           mEntityDecoder      setStartElementHandler parser $ \cName cAttrs -> do-        name <- mkText cName+        name <- textFromCString cName         attrs <- forM cAttrs $ \(cAttrName,cAttrValue) -> do-            attrName <- mkText cAttrName-            attrValue <- mkText cAttrValue+            attrName <- textFromCString cAttrName+            attrValue <- textFromCString cAttrValue             return (attrName, attrValue)         modifyIORef queueRef (StartElement name attrs:)         return True      setEndElementHandler parser $ \cName -> do-        name <- mkText cName+        name <- textFromCString cName         modifyIORef queueRef (EndElement name:)         return True @@ -298,17 +298,17 @@           mEntityDecoder      setStartElementHandler parser $ \cName cAttrs -> do-        name <- mkText cName+        name <- textFromCString cName         attrs <- forM cAttrs $ \(cAttrName,cAttrValue) -> do-            attrName <- mkText cAttrName-            attrValue <- mkText cAttrValue+            attrName <- textFromCString cAttrName+            attrValue <- textFromCString cAttrValue             return (attrName, attrValue)         loc <- getParseLocation parser         modifyIORef queueRef ((StartElement name attrs,loc):)         return True      setEndElementHandler parser $ \cName -> do-        name <- mkText cName+        name <- textFromCString cName         loc <- getParseLocation parser         modifyIORef queueRef ((EndElement name, loc):)         return True

@@ -94,8 +94,8 @@  module Text.XML.Expat.Tree (   -- * Tree structure-  NodeG(..),   Node,+  NodeG(..),   Attributes,   UNode,   UAttributes,@@ -155,7 +155,7 @@                           , XMLParseException(..)                           , SAXEvent(..)                           , defaultParserOptions-                          , mkText+                          , textFromCString                           , parseSAX                           , parseSAXLocations                           , parseSAXLocationsThrowing@@ -179,6 +179,15 @@   -- | The tree representation of the XML document.+--+-- @c@ is the container type for the element's children, which is usually [],+-- except when you are using chunked I\/O with the @hexpat-iteratee@ package.+--+-- @tag@ is the tag type, which can either be one of several string types,+-- or a special type from the @Text.XML.Expat.Namespaced@ or+-- @Text.XML.Expat.Qualified@ modules.+--+-- @text@ is the string type for text content. data NodeG c tag text =     Element {         eName       :: !tag,@@ -199,7 +208,7 @@     Text t1 == Text t2 = t1 == t2     _ == _ = False --- | A pure Node that uses a list as its container type.+-- | A pure tree representation that uses a list as its container type. type Node = NodeG []  eAttrs :: Node tag text -> [(tag, text)]@@ -210,9 +219,6 @@     rnf (Element nam att chi) = rnf (nam, att, chi)     rnf (Text txt) = rnf txt --- | Type shortcut for attributes-type Attributes tag text = [(tag, text)]- -- | DEPRECATED: Use [Node tag text] instead. -- -- Type shortcut for nodes.@@ -230,10 +236,6 @@ -- text are the same string type. type UNode text = Node text text --- | Type shortcut for attributes with unqualified names where tag and--- text are the same string type.-type UAttributes text = Attributes text text- instance (Functor c, List c) => NodeClass NodeG c where     textContentM (Element _ _ children) = foldlL mappend mempty $ joinM $ fmap textContentM children     textContentM (Text txt) = return txt@@ -281,6 +283,11 @@         return $ Element n a ch'     mapNodeContainer _ (Text t) = return $ Text t +    mkText = Text+    +instance (Functor c, List c) => MkElementClass NodeG c where+    mkElement name attrs children = Element name attrs children+ setEntityDecoder :: (GenericXMLString tag, GenericXMLString text)                  => Parser                  -> IORef [Node tag text]@@ -297,7 +304,7 @@      skip _ 1 = return False     skip entityName 0 = do-        en <- mkText entityName+        en <- textFromCString entityName         let mbt = decoder en         maybe (return False)               (\t -> do@@ -335,10 +342,10 @@           mEntityDecoder      setStartElementHandler parser $ \cName cAttrs -> do-        name <- mkText cName+        name <- textFromCString cName         attrs <- forM cAttrs $ \(cAttrName,cAttrValue) -> do-            attrName <- mkText cAttrName-            attrValue <- mkText cAttrValue+            attrName <- textFromCString cAttrName+            attrValue <- textFromCString cAttrValue             return (attrName, attrValue)         modifyIORef stack (start name attrs)         return True

@@ -1,6 +1,6 @@ Cabal-Version: >= 1.6 Name: hexpat-Version: 0.13+Version: 0.14 Synopsis: wrapper for expat, the fast XML parser Description:   This package provides a general purpose Haskell XML library using Expat to@@ -14,12 +14,20 @@   XML source location (/Annotated/), XML cursors (/Cursor/), more intelligent   handling of qualified tag names (/Qualified/), tags qualified with namespaces   (/Namespaced/), SAX-style parse (/SAX/), and access to the low-level interface-  in case speed is paramount (/IO/).+  in case speed is paramount (/IO/).  And, /NodeClass/ contains type classes for+  generalized tree processing.   .-  The design goals are speed, speed, speed, interface simplicity and modular design.+  The design goals are speed, speed, speed, interface simplicity and modularity+  (in that order).   .-  For examples, see /Text.XML.Expat.Tree/ module. For benchmarks, <http://haskell.org/haskellwiki/Hexpat/>+  For introduction and examples, see the /Text.XML.Expat.Tree/ module. For benchmarks,+  <http://haskell.org/haskellwiki/Hexpat/>   .+  This package provides pure lazy parsing.  However, Haskell's lazy I\/O is+  problematic in some applications because it doesn't handle I\/O errors properly+  and can give no guarantee of timely resource cleanup.  In these cases, chunked+  I\/O is a better approach: Take a look at the /hexpat-iteratee/ package.+  .   Credits to Iavor Diatchki and the @xml@ (XML.Light) package for /Proc/ and /Cursor/.   .   INSTALLATION: Unix install requires an OS package called something like @libexpat-dev@.@@ -34,11 +42,11 @@ License: BSD3 License-File: LICENSE Author:+  Stephen Blackheath [blackh] (the primary author),   Doug Beardsley,-  Stephen Blackheath (blackh),   Gregory Collins,-  Evan Martin,-  Matthew Pocock (drdozer)+  Evan Martin (who started the project),+  Matthew Pocock [drdozer] Maintainer: http://blacksapphire.com/antispam/ Copyright:   (c) 2009 Doug Beardsley <mightybyte@gmail.com>,@@ -48,6 +56,14 @@   (c) 2009 Matthew Pocock <matthew.pocock@ncl.ac.uk>,   (c) 2007-2009 Galois Inc. Homepage: http://haskell.org/haskellwiki/Hexpat/+Extra-Source-Files:+  test/hexpat-tests.cabal,+  test/test.xml,+  test/suite/TestSuite.hs,+  test/suite/Text/XML/Expat/Proc/Tests.hs,+  test/suite/Text/XML/Expat/UnitTests.hs,+  test/suite/Text/XML/Expat/Tests.hs,+  test/suite/Text/XML/Expat/Cursor/Tests.hs Build-Type: Simple Stability: beta source-repository head@@ -77,4 +93,4 @@     Text.XML.Expat.SAX,     Text.XML.Expat.Tree   Extra-Libraries: expat-  ghc-options: -Wall+  ghc-options: -Wall -fno-warn-name-shadowing

@@ -0,0 +1,32 @@+Cabal-Version: >= 1.4+Name: hexpat-tests+Version: 0.11+Build-Type: Simple++Executable testsuite+  hs-source-dirs:  .. suite+  main-is:         TestSuite.hs++  extra-libraries: expat++  build-depends:+    HUnit < 1.3,+    QuickCheck == 1.2.0.0,+    base >= 3 && < 5,+    bytestring,+    containers,+    extensible-exceptions >= 0.1 && < 0.2,+    haskell98,+    mtl >= 1.1.0.0,+    parallel,+    QuickCheck == 1.2.0.0,+    test-framework < 0.3,+    test-framework-hunit < 0.3,+    test-framework-quickcheck < 0.3,+    text >= 0.5,+    utf8-string >= 0.3.3,+    List >= 0.2++  ghc-options: -Wall -fhpc+  if impl(ghc >= 6.8)+    ghc-options: -fwarn-tabs

@@ -0,0 +1,17 @@+module Main where++import qualified Text.XML.Expat.UnitTests+import qualified Text.XML.Expat.Cursor.Tests+import qualified Text.XML.Expat.Proc.Tests++import Test.Framework (defaultMain, testGroup)++main :: IO ()+main = defaultMain tests+  where tests = [ testGroup "unit tests"+                            Text.XML.Expat.UnitTests.tests+                , testGroup "Text.XML.Expat.Proc"+                            Text.XML.Expat.Proc.Tests.tests+                , testGroup "Text.XML.Expat.Cursor"+                            Text.XML.Expat.Cursor.Tests.tests+                ]

@@ -0,0 +1,611 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++module Text.XML.Expat.Cursor.Tests (tests) where++import           Control.Monad (replicateM)+import           Data.Maybe+import           Test.Framework (Test)+import           Test.Framework.Providers.QuickCheck+import           Test.QuickCheck+import           Text.XML.Expat.Tests+import           Text.XML.Expat.Cursor+import           Text.XML.Expat.Tree+++tests :: [Test]+tests = [ testProperty "invertible"        prop_invertible+        , testProperty "invertible2"       prop_invertible2+        , testProperty "fromTag"           prop_fromTag+        , testProperty "fromForest"        prop_fromForest+        , testProperty "firstChild"        prop_firstChild+        , testProperty "firstChild2"       prop_firstChild2+        , testProperty "downUp"            prop_downUp+        , testProperty "leftRight"         prop_leftRight+        , testProperty "root"              prop_root+        , testProperty "lastChild"         prop_lastChild+        , testProperty "findLeft"          prop_findLeft +        , testProperty "findRight"         prop_findRight+        , testProperty "findChild"         prop_findChild+        , testProperty "findChild2"        prop_findChild2+        , testProperty "nextDF1"           prop_nextDF1+        , testProperty "nextDF2"           prop_nextDF2+        , testProperty "nextDF3"           prop_nextDF3+        , testProperty "findRec"           prop_findRec+        , testProperty "getNodeIndex"      prop_getNodeIndex+        , testProperty "emptyChild"        prop_emptyChild+        , testProperty "negativeChild"     prop_negativeChild+        , testProperty "isChild"           prop_isChild+        , testProperty "modifyContent"     prop_modifyContent+        , testProperty "modifyContentList" prop_modifyContentList+        , testProperty "insertChildren"    prop_insertChildren+        , testProperty "insertLeftRight"   prop_insertLeftRight+        , testProperty "removeLeftRight"   prop_removeLeftRight+        , testProperty "insertGo"          prop_insertGo+        , testProperty "removeGo"          prop_removeGo+       ]+++------------------------------------------------------------------------------+satisfy :: (Arbitrary a) =>+           (a -> Bool)          -- ^ predicate that generated values must+                                -- satisfy+        -> Gen a                -- ^ generator+        -> Gen a+satisfy f g = do+    x <- arbitrary+    if f x then return x else satisfy f g+++currentsEq :: TCursor -> TCursor -> Bool+currentsEq a b = current a == current b+++someNodes :: Gen [TNode]+someNodes = do+    n     <- choose (3::Int, 8::Int)+    replicateM n arbitrary++const' :: a -> b -> a+const' x y = y `seq` x+++allSame :: (Eq a) => [a] -> Bool+allSame [] = True+allSame xs = and $ map (uncurry (==)) (xs `zip` tail xs)+++------------------------------------------------------------------------------++prop_invertible :: TNode -> Bool+prop_invertible n = p+  where+    p = toTree (fromTree n) == n++prop_invertible2 :: [TNode] -> Property+prop_invertible2 n = not (null n) ==> p+  where+    p = toForest (fromJust $ fromForest n :: TCursor) == n+++-- this is stupid because the function is so trivial, but I lust after the+-- green bar+prop_fromTag :: TNode -> Property+prop_fromTag n = isElement n ==> fromTag (getTag n) (eChildren n) == n+++prop_fromForest :: Bool+prop_fromForest = isNothing (fromForest [] :: Maybe TCursor)++prop_firstChild :: TNode -> Property+prop_firstChild node = isElement node ==> p1 && p2+  where+    child1 :: TNode+    child1 = Element "gryphon" [] []++    node' = node { eChildren= child1:(eChildren node) }++    mbfc = do+        c <- firstChild $ fromTree node'+        return $ current c++    p1 = isJust mbfc+    p2 = maybe False (== child1) mbfc+++prop_firstChild2 :: Bool+prop_firstChild2 = (isNothing $ firstChild c) && (isNothing $ firstChild c2)+  where+    node :: TNode+    node = Element "root" [] []++    txt :: TNode+    txt = Text ""++    c = fromTree node+    c2 = fromTree txt+++prop_downUp :: TNode -> Property+prop_downUp node = isElement node && (not $ null $ eChildren node) ==> p+  where+    p = p1 && p2++    cursor = fromTree node++    p1 = isNothing $ parent cursor++    m = do+        cur' <- firstChild cursor+        pa   <- parent cur'++        return $ current pa++    p2 = maybe False (== node) m+++prop_leftRight :: Property+prop_leftRight = forAll gen p+  where+    gen :: Gen (TNode,TNode,TNode)+    gen = do+        ch1  <- arbitrary+        ch2  <- arbitrary+        chN1 <- arbitrary+        chN  <- arbitrary+        n    <- satisfy isElement (arbitrary :: Gen TNode)++        let n' = n {eChildren = ([ch1,ch2] ++ (eChildren n) ++ [chN1,chN])}++        return (n', ch1, chN)++    p (node, ch1, chN) = p1 && p2+      where+        cursor = fromTree node++        m1 = do+            curFirst <- firstChild cursor+            curLast  <- lastChild cursor++            let f = current curFirst+            let l = current curLast++            return $ (f == ch1) && (l == chN)++        p1 = fromMaybe False m1+++        m2 = do+            curFirst <- firstChild cursor+            curLast  <- lastChild cursor+            l        <- left curLast >>= left+            r        <- right l >>= right++            a        <- right curFirst >>= right+            b        <- left a >>= left++            let bad1 =  left curFirst+            let bad2 =  right curLast++            let lch = current curLast+            let x   = current r++            let fch = current curFirst+            let y   = current b++            return (x == lch && y == fch && isNothing bad1 && isNothing bad2)++        p2 = fromMaybe False m2+++prop_root :: Property+prop_root = forAll gen f+  where+    gen :: Gen (TNode,TNode,TNode)+    gen = do+        ch1' <- satisfy isElement arbitrary+        ch2  <- arbitrary+        let ch1 = ch1' { eChildren = ch2:(eChildren ch1') }+        n    <- satisfy isElement (arbitrary :: Gen TNode)++        let n' = n {eChildren = ch1:(eChildren n)}++        return (n',ch1,ch2)+++    f (n,ch1,ch2) = do+        fromMaybe False m+      where+        m = do c1 <- firstChild $ fromTree n+               c2 <- firstChild c1+               let r = root c2++               return $ and [ current r == n+                            , current c1 == ch1+                            , current c2 == ch2 ]++prop_lastChild :: TNode -> Property+prop_lastChild n' = isElement n' ==> p+  where+    n  = n' { eChildren=[] }+    c  = fromTree n+    n2 = n { eChildren=[n'] }+    c2 = fromTree n2+    p  = p1 && p2+    p1 = isNothing $ lastChild c+    mc = lastChild c2 >>= parent+    p2 = maybe False (\x -> toTree x == n2) mc+++++prop_findLeft :: Property+prop_findLeft = forAll gen f+  where+    gen :: Gen (TCursor,TCursor)+    gen = do+        nodes <- someNodes++        let ch = Element "halibut" [] []++        let node = Element "root" [] (ch:nodes)++        i <- choose (1,length nodes)++        let cn = fromTree node++        let c1 = fromMaybe (error "impossible") (getChild i cn)+        let c2 = fromMaybe (error "impossible") (firstChild cn)++        return (c1, c2)+++    f :: (TCursor,TCursor) -> Bool+    f (c,c') = maybe False (currentsEq c') mbC+      where+        mbC = findLeft (\x -> isNamed "halibut" $ current x) c+++prop_findRight :: Property+prop_findRight = forAll gen f+  where+    gen :: Gen (TCursor,TCursor)+    gen = do+        n     <- choose (3::Int, 8::Int)+        i     <- choose (0,n-1)+        nodes <- replicateM n arbitrary++        let ch = Element "halibut" [] []++        let node = Element "root" [] (nodes ++ [ch])++        let cn = fromTree node++        let c1 = fromMaybe (error "impossible") (getChild i cn)+        let c2 = fromMaybe (error "impossible") (lastChild cn)++        return (c1, c2)+++    f :: (TCursor,TCursor) -> Bool+    f (c,c') = maybe False (currentsEq c') mbC+      where+        mbC = findRight (\x -> isNamed "halibut" $ current x) c+++prop_findChild :: Property+prop_findChild = forAll gen f+  where+    gen :: Gen (TCursor,TCursor)+    gen = do+        nodes <- someNodes++        let ch = Element "halibut" [] []+        let n = length nodes++        let node = Element "root" [] (nodes ++ [ch] ++ nodes ++ [ch])++        let cn = fromTree node+        let c1 = fromMaybe (error "impossible") (getChild n cn)++        return (cn, c1)+++    f :: (TCursor,TCursor) -> Bool+    f (c,c') = maybe False (currentsEq c') mbC+      where+        mbC = findChild (\x -> isNamed "halibut" $ current x) c+++prop_findChild2 :: Property+prop_findChild2 = forAll gen f+  where+    gen :: Gen (TCursor,TCursor)+    gen = do+        nodes <- someNodes++        let ch = Element "halibut" [] []++        let node = Element "root" [] (ch:nodes)++        let cn = fromTree node+        let c1 = fromMaybe (error "impossible") (firstChild cn)++        return (cn, c1)+++    f :: (TCursor,TCursor) -> Bool+    f (c,c') = maybe False (currentsEq c') mbC+      where+        mbC = findChild (\x -> isNamed "halibut" $ current x) c+++prop_nextDF1 :: Property+prop_nextDF1 = forAll gen $ uncurry currentsEq+  where+    gen :: Gen (TCursor, TCursor)+    gen = do+        nodes <- someNodes+        let ch = Element "halibut" [] []+        let node = Element "root" [] (ch:nodes)++        let cn = fromJust $ fromForest [node]+        let c1 = fromJust (firstChild cn)+        let c2 = fromJust (nextDF cn)++        return (c1, c2)++prop_nextDF2 :: Property+prop_nextDF2 = forAll gen $ uncurry currentsEq+  where+    gen :: Gen (TCursor, TCursor)+    gen = do+        nodes <- someNodes+        let ch = Element "halibut" [] []+        let node = Element "root" [] (ch:nodes)++        let cn = fromJust $ fromForest [node]+        let cc = fromJust (firstChild cn)+        let c1 = fromJust (nextDF cc)+        let c2 = fromJust (right cc)++        return (c1, c2)++prop_nextDF3 :: Property+prop_nextDF3 = forAll gen $ uncurry currentsEq+  where+    gen :: Gen (TCursor, TCursor)+    gen = do+        nodes <- someNodes+        let ch = Element "halibut" [] []+        let ch2 = Element "pike" [] []+        let node1 = Element "subtree1" [] [ch]+        let node2 = Element "subtree2" [] (ch2:nodes)+        let node = Element "root" [] [node1, node2]++        let cn = fromJust $ fromForest [node] :: TCursor+        let cc = fromJust (firstChild cn >>= firstChild)+        let c1 = fromJust $ nextDF cc+        let c2 = fromJust (firstChild cn >>= right)++        return (c1, c2)+++prop_findRec :: Property+prop_findRec = forAll gen $ uncurry currentsEq+  where+    gen :: Gen (TCursor, TCursor)+    gen = do+        nodes <- someNodes+        let ch = Element "halibut" [] []+        let ch2 = Element "pike" [] []+        let node1 = Element "subtree1" [] [ch]+        let node2 = Element "subtree2" [] (ch2:nodes)+        let node = Element "root" [] [node1, node2]++        let cn = fromTree node+        let c1 = fromJust (firstChild cn >>= right >>= firstChild)+        let c2 = fromJust $ findRec (isNamed "pike" . current) cn++        return (c1, c2)+++prop_emptyChild :: Bool+prop_emptyChild = isNothing m+  where+    tree :: TNode+    tree = Element "root" [] []+    m    = getChild 0 $ fromTree tree+++prop_negativeChild :: Property+prop_negativeChild = forAll gen f+  where+    gen = satisfy isElement (arbitrary :: Gen TNode)++    f node = isNothing $ getChild (-1) (fromTree node)+++prop_getNodeIndex :: Property+prop_getNodeIndex = forAll gen $ uncurry (==)+  where+    gen :: Gen (Int, Int)+    gen = do+        nodes <- replicateM 10 arbitrary+        i     <- choose (0,9)++        let node = (Element "root" [] nodes)::TNode++        let cn = fromTree node+        let c1 = fromJust $ getChild i cn+        let j  = getNodeIndex c1++        return (i,j)+++prop_isChild :: TNode -> Bool+prop_isChild n = isChild c && hasChildren r && isFirst r && isLast c+  where+    node = Element "root" [] [n]+    r    = fromTree node+    c    = fromJust $ firstChild r+++prop_modifyContent :: Property+prop_modifyContent = forAll gen allSame+  where+    gen :: Gen [TNode]+    gen = do+        nodes <- replicateM 10 arbitrary++        let n1 = Element "apple" [] []+        let n2 = Element "banana" [] []++        let tree1 = Element "root" [] (n1:nodes)+        let tree2 = Element "root" [] (n2:nodes)++        let c = fromJust . firstChild . fromTree $ tree1+        let c1 = modifyContent (const' n2) c+        c2 <- modifyContentM (const' $ return n2) c++        let tree3 = toTree c1+        let tree4 = toTree c2+        return [tree2, tree3, tree4]+++prop_modifyContentList :: Property+prop_modifyContentList = forAll gen $ uncurry (==)+  where+    gen :: Gen (TNode,TNode)+    gen = do+        nodes <- replicateM 10 arbitrary++        let n = Element "apple" [] []++        let tree1 = Element "root" [] [n]+        let tree2 = Element "root" [] nodes++        let c = fromJust . firstChild . fromTree $ tree1+        let c1 = fromJust $ modifyContentList (const' nodes) c++        let treeResult = toTree c1+        return (tree2, treeResult)+++prop_insertChildren :: [TNode] -> Bool+prop_insertChildren ns = isNothing m1 && tree2 == tree3+  where+    tree = Element "root" [] ns+    n1 = Element "alpha" [] []+    n2 = Element "omega" [] []+    n3 = Element "beta" [] []+    n4 = Element "gamma" [] []++    tree2 = Element "root" [] $ concat [[n1,n2], ns, [n3,n4]]++    txt :: TNode+    txt = Text "foo"++    m1 = insertFirstChild n1 $ fromTree txt++    top = fromTree tree++    tree3 = fromJust $ do+                c1 <- insertFirstChild n2 top+                c2 <- insertLastChild n3 c1+                c3 <- insertManyFirstChild [n1] c2+                c4 <- insertManyLastChild [n4] c3++                return $ toTree c4+++prop_insertLeftRight :: (TNode,TNode) -> Bool+prop_insertLeftRight (n,n') = f == [n1, n', n, n2]+  where+    n1 = Element "alpha" [] []+    n2 = Element "omega" [] []+    c = insertRight n2 $ insertManyLeft [n'] $ insertLeft n1 $ fromTree n++    f = toForest c+++prop_removeLeftRight :: [TNode] -> Property+prop_removeLeftRight ns = not (null ns) ==> p1 && p2 && p3+  where+    n1      = Element "alpha" [] []+    n2      = Element "omega" [] []++    tree1   = Element "root" [] (n1:(ns ++ [n2]))+    tree2   = Element "root" [] ns++    c1      = fromJust $ firstChild (fromTree tree1)+    m1      = removeLeft c1++    c2      = fromJust $ right c1+    (x1,c3) = fromJust $ removeLeft c2++    c4      = fromJust (parent c3 >>= lastChild)+    m4      = removeRight c4++    c5      = fromJust $ left c4+    (x2,c6) = fromJust $ removeRight c5++    tree3   = toTree c6++    p1      = tree2 == tree3+    p2      = isNothing m1 && isNothing m4+    p3      = n1 == x1 && n2 == x2+++prop_insertGo :: [TNode] -> Property+prop_insertGo ns = not (null ns) ==> p1+  where+    n1      = Element "alpha" [] []+    n2      = Element "omega" [] []++    tree1   = Element "root" [] ns+    tree2   = Element "root" [] $ [n1,n2] ++ ns++    c1      = fromJust $ firstChild (fromTree tree1)+    c2      = insertGoLeft n1 c1+    c3      = insertGoRight n2 c2++    tree3   = toTree c3++    p1      = tree2 == tree3+++prop_removeGo :: [TNode] -> Property+prop_removeGo ns = not (null ns) ==> p1 && p2 && p3+  where+    n1      = Element "alpha" [] []+    n2      = Element "omega" [] []++    tree1   = Element "root" [] $ [n1,n2] ++ ns+    tree2   = Element "root" [] ns++    top     = fromTree tree1++    c1      = fromJust $ firstChild top+    c2      = fromJust $ lastChild top+    m1      = removeGoLeft c1+    m2      = removeGoRight c2+    m3      = removeGoUp top++    c3      = fromJust $ right c1+    c4      = fromJust $ removeGoLeft c3++    n3      = current c4++    c5      = fromJust $ removeGoRight c4+    c6      = fromJust $ removeGoUp c4++    m4      = left c6+    m5      = right c6++    tree3   = toTree c5+    tree4   = toTree c6++    p1      = and $ map isNothing [m1,m2,m3,m4,m5]+    p2      = tree2 == tree3 && tree2 == tree4+    p3      = n1 == n3

@@ -0,0 +1,168 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+++module Text.XML.Expat.Proc.Tests (tests) where++import           Data.Maybe+import           Test.Framework (Test)+import           Test.Framework.Providers.QuickCheck+import           Test.QuickCheck+import           Text.XML.Expat.Tests+import           Text.XML.Expat.Proc+import           Text.XML.Expat.Tree+++tests :: [Test]+tests = [ testProperty "onlyElems"       prop_onlyElems+        , testProperty "onlyText"        prop_onlyText+        , testProperty "findChildren"    prop_findChildren+        , testProperty "findChildren2"   prop_findChildren2+        , testProperty "findChildren3"   prop_findChildren3+        , testProperty "filterChildren"  prop_filterChildren+        , testProperty "findChild"       prop_findChild+        , testProperty "filterElements1" prop_filterElements1+        , testProperty "filterElements2" prop_filterElements2+        , testProperty "filterElements3" prop_filterElements3+        , testProperty "filterElements4" prop_filterElements4+        , testProperty "others"          prop_others+        ]++++prop_onlyElems :: [TNode] -> Bool+prop_onlyElems nodes = all isElement els+  where+    els = onlyElems nodes+++prop_onlyText :: [TNode] -> Bool+prop_onlyText nodes = all isAText txts+  where+    txts     = onlyText nodes+    isAText b = elem b testTextSet++++prop_findChildren :: TNode -> Bool+prop_findChildren node = all p ch+  where+    ch = findChildren "banana" node++    p (Text _)         = False+    p (Element nm _ _) = nm == "banana"+++prop_findChildren2 :: Bool+prop_findChildren2 = ch == [child1]+  where+    child1 :: TNode+    child1 = Element "banana" [] []++    child2 :: TNode+    child2 = Element "rhubarb" [] []++    node :: TNode+    node   = Element "root" [] [child1, child2]+    ch     = findChildren "banana" node+++prop_findChildren3 :: Bool+prop_findChildren3 = null ch+  where+    child :: TNode+    child = Text "foo"++    !ch = findChildren "banana" child+++prop_filterChildren :: TNode -> Bool+prop_filterChildren node = all p ch+  where+    ch = filterChildrenName (=="banana") node++    p (Text _)         = False+    p (Element nm _ _) = nm == "banana"+++prop_findChild :: TNode -> Property+prop_findChild node' = isElement node' ==> r == (Just child)+  where+    child :: TNode+    child = Element "tag" [] []++    node = node' { eChildren = child:(eChildren node') }++    r = findChild "tag" node+++-- test positive case+prop_filterElements1 :: TNode -> Bool+prop_filterElements1 n@(Text _)         = filterElements isText n == [n]+prop_filterElements1 n@(Element nm _ _) = filterElements f n == [n]+  where+    f = isNamed nm++-- test that all results obey the predicate+prop_filterElements2 :: TNode -> Bool+prop_filterElements2 n = p1 && p2+  where+    l1 = filterElements isText n+    l2 = filterElements isElement n+    p1 = all isText l1+    p2 = all isElement l2++-- test that we grab all elements+prop_filterElements3 :: TNode -> Bool+prop_filterElements3 n = p1 && p2+  where+    l1 = filterElements isText n+    l2 = filterElements isElement n+    p1 = all isText l1+    p2 = all isElement l2+++-- test that all children match & that we don't recurse into matching children+prop_filterElements4 :: Property+prop_filterElements4 = forAll gen $ \node ->+                         let ch = getChildren node+                         in ch == f node && ch == g node+  where+    gen = do+        let node = Element "banana" [] [] :: TNode+        let node'= Element "banana" [] [node] :: TNode+        n       <- choose(0,5)+        let l    = node':(replicate n node)+        return $ Element "root" [] l++    f = filterElements (isNamed "banana")+    g = filterElementsName (=="banana")+++-- other functions are all trivial, this property just gives us code coverage+prop_others :: Bool+prop_others = and [p1, p2, p3, p4]+  where+    child1 :: TNode+    child1 = Element "banana" [] []++    child2 :: TNode+    child2 = Element "rhubarb" [] []++    node :: TNode+    node   = Element "root" [] [child1, child2]++    fc1 = filterChild (isNamed "rhubarb") node+    fc2 = filterChildName (=="rhubarb") node+    fc3 = findElement "banana" node+    fc4 = filterElement (isNamed "root") node+    fc5 = filterChild (isNamed "root") node+    fc6 = filterElementName (=="root") node++    p1 = all isJust [fc1, fc2, fc3, fc4, fc6]+    p2 = all (not . isJust) [fc5]+    p3 = findElements "banana" node == [child1]+    p4 = filterElementsName (=="root") foo == []++    foo :: TNode+    foo = Text "foo"

@@ -0,0 +1,79 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Text.XML.Expat.Tests+  ( TCursor+  , TNode+  , testTagSet+  , testTextSet+  , testAttrSet )+where++import           Control.Monad (liftM)+import           Data.ByteString.Char8 (ByteString)+import           Test.QuickCheck+import           Text.XML.Expat.Cursor (Cursor)+import           Text.XML.Expat.Tree++------------------------------------------------------------------------------++type TCursor = Cursor ByteString ByteString+type TNode = Node ByteString ByteString+++testTagSet :: [ByteString]+testTagSet = [ "apple"+             , "banana"+             , "cauliflower"+             , "duck"+             , "eel"+             , "ferret"+             , "grape" ]++testTextSet :: [ByteString]+testTextSet = [ "zoo"+              , "yellow"+              , "xylophone"+              , "wet"+              , "vulture"+              , "ululate"+              , "tympani" ]++testAttrSet :: [ByteString]+testAttrSet = [ "sheep"+              , "ram"+              , "quail"+              , "penguin"+              , "ox"+              , "narwhal" ]+++instance Arbitrary TNode where+    coarbitrary = undefined++    arbitrary = depth 0+      where+        depth :: Int -> Gen TNode+        depth n = do+            which <- (arbitrary :: Gen Bool)+            if which then mkElem n else mkText+++        mkAttr = do+            key <- elements testAttrSet+            val <- elements testAttrSet+            return (key,val)++        mkText = liftM Text $ elements testTextSet++        mkElem n = do+            nchildren <- if n > 3+                           then return 0+                           else choose ((0,6) :: (Int,Int))+            nattrs    <- choose ((0,3) :: (Int,Int))+            attrs     <- sequence $ replicate nattrs mkAttr+            children  <- sequence $ replicate nchildren (depth (n+1))+            tagname   <- elements testTagSet++            return $ Element tagname attrs children+

@@ -0,0 +1,283 @@+module Text.XML.Expat.UnitTests where++import Text.XML.Expat.Tree hiding (parse)+import qualified Text.XML.Expat.Tree as Tree+import Text.XML.Expat.IO hiding (parse)+import qualified Text.XML.Expat.IO as IO+import Text.XML.Expat.Cursor+import Text.XML.Expat.Format+import Text.XML.Expat.Qualified+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.Text as T+import CForeign+import Data.ByteString.Internal (c2w, w2c)+import Data.Char+import Data.Maybe+import Data.IORef+import Control.Applicative+import Control.Exception as E+import Control.Monad+import Control.Parallel.Strategies+import Test.HUnit hiding (Node)+import System.IO++import Test.Framework.Providers.HUnit (hUnitTestToTests)+++toByteStringL :: String -> L.ByteString+toByteStringL = L.pack . map c2w++fromByteStringL :: L.ByteString -> String+fromByteStringL = map w2c . L.unpack++toByteString :: String -> B.ByteString+toByteString = B.pack . map c2w++fromByteString :: B.ByteString -> String+fromByteString = map w2c . B.unpack++testDoc :: (Show tag, Show text) =>+           (ParserOptions tag text+                -> bs+                -> Either XMLParseError (Node tag text))+        -> (Node tag text -> L.ByteString)+        -> (String -> bs)+        -> String+        -> Int+        -> String+        -> IO ()+testDoc parseFn fmt toBS descr0 idx xml = do+    let eTree = parseFn popts (toBS xml)+        descr = descr0++" #"++show idx+    case eTree of+        Right tree -> do+            let out = fromByteStringL $ fmt tree+            assertEqual descr xml out+        Left error -> do+            hPutStrLn stderr $ "parse failed: "++show error+            assertFailure descr+  where+    popts = defaultParserOptions { parserEncoding = Just UTF8 }+++eitherify f mEnc bs = do+    case f mEnc bs of+        (_, Just err)  -> Left err+        (doc, Nothing) -> Right doc++test_error1 :: IO ()+test_error1 = do+    let eDoc = Tree.parse' defaultParserOptions (toByteString "<hello></goodbye>") :: Either XMLParseError (UNode String)+    assertEqual "error1" (Left $ XMLParseError "mismatched tag" (XMLParseLocation 1 9 9 0)) eDoc++test_error2 :: IO ()+test_error2 = do+    assertEqual "error2" (+            Element {eName = "hello", eAttributes = [], eChildren = []},+            Just (XMLParseError "mismatched tag" (XMLParseLocation 1 9 9 0))+        ) (Tree.parse defaultParserOptions+              (toByteStringL "<hello></goodbye>") :: (UNode String, Maybe XMLParseError))++test_error3 :: IO ()+test_error3 =+    assertEqual "error3" (+            Element {eName = "open", eAttributes = [], eChildren = [+                Element {eName = "test1", eAttributes = [], eChildren = [Text "Hello"]},+                Element {eName = "hello", eAttributes = [], eChildren = []}+            ]},+            Just (XMLParseError "mismatched tag" (XMLParseLocation 1 35 35 0))+        ) $ Tree.parse defaultParserOptions+              (toByteStringL "<open><test1>Hello</test1><hello></goodbye>")++test_error4 :: IO ()+test_error4 = do+    let eDoc = Tree.parse' defaultParserOptions (toByteString "!") :: Either XMLParseError (UNode String)+    assertEqual "error1" (Left $ XMLParseError "not well-formed (invalid token)"+        (XMLParseLocation 1 0 0 0)) eDoc++test_parse :: IO ()+test_parse = do+    ref <- newIORef []+    let lazy = L.fromChunks [+            toByteString "<open><tes",+            toByteString "t1>Hello</test",+            toByteString "1><hello></he",+            toByteString "llo></open>"]+    parser <- newParser Nothing+    setStartElementHandler parser $ \cname cattrs -> do+        name <- peekCString cname+        ref <- modifyIORef ref $ \l -> ("start "++name):l+        return True+    setEndElementHandler parser $ \cname -> do+        name <- peekCString cname+        ref <- modifyIORef ref $ \l -> ("end "++name):l+        return True+    IO.parse parser lazy+    l <- reverse <$> readIORef ref+    assertEqual "parse"+        ["start open","start test1","end test1","start hello","end hello","end open"]+        l+++test_entities = do+    assertEqual "parse error" merr Nothing+    assertEqual "entity substitution" (Text "foo") c+  where+    xml = "<root>&entity;</root>"++    popts = defaultParserOptions { entityDecoder = Just entityLookup }++    (tree,merr) = Tree.parse popts $ toByteStringL xml++    c = current $ fromJust $ firstChild $ fromTree tree++    entityLookup b = if b == "entity"+                       then Just "foo"+                       else Nothing+++test_textContent = do+    let tree = Element "cheese" [("type", "edam")]+            [Text "You don't actually ",+             Element "sub" [] [Text "have any "],+             Text "cheese at all",+             Text ", do you?"]+    assertEqual "textContent" "You don't actually have any cheese at all, do you?" (textContent tree)++testXMLFile :: IO String+testXMLFile = do+    s <- map w2c . B.unpack <$> B.readFile "test.xml"+    -- Remove trailing newline+    return (reverse . dropWhile (== '\n') . reverse $ s)++test_indent = do+    let tests = [+                ("#1",+                 toByteString "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<test/>",+                 toByteString "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<test/>"),+                ("#2",+                 toByteString "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<test>With some text in it</test>",+                 toByteString "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<test>With some text in it</test>"),+                ("#3",+                 toByteString $ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"+++                     "<test><ignorance/><freedom/><war/></test>",+                 toByteString $ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"+++                     "<test>\n  <ignorance/>\n  <freedom/>\n  <war/>\n</test>"),+                ("#4",+                 toByteString $ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"+++                     "<test><ignorance>strength</ignorance><freedom>Slavery</freedom><war>Peace</war></test>",+                 toByteString $ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"+++                     "<test>\n  <ignorance>strength</ignorance>\n  <freedom>Slavery</freedom>\n  <war>Peace</war>\n</test>"),+                ("#5",+                 toByteString $ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"+++                     "<test><ministries><mini name=\"minitrue\">Ministry of Truth</mini>In between"+++                     "<mini name=\"minilove\">Ministry of Love</mini>\n  And some more"+++                     "<mini name=\"miniplenty\">Ministry of Plenty</mini>"+++                     "<mini name=\"minipax\">Ministry of Peace<at-war-with>Eurasia</at-war-with></mini></ministries>"+++                     "<wisdom><ignorance>strength</ignorance></wisdom></test>",+                 toByteString $ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"+++                     "<test>\n  <ministries>\n    <mini name=\"minitrue\">Ministry of Truth</mini>In between"+++                     "\n    <mini name=\"minilove\">Ministry of Love</mini>And some more"+++                     "\n    <mini name=\"miniplenty\">Ministry of Plenty</mini>"+++                     "\n    <mini name=\"minipax\">Ministry of Peace\n      <at-war-with>Eurasia</at-war-with>\n    </mini>\n  </ministries>"+++                     "\n  <wisdom>\n    <ignorance>strength</ignorance>\n  </wisdom>\n</test>")+            ]+    forM_ tests $ \(name, inp, outSB) -> do+        let eree = Tree.parse' defaultParserOptions inp :: Either XMLParseError (UNode String)+        case eree of+            Left err -> assertFailure $ show err+            Right tree -> do+                let outIS = format' (indent 2 tree)+                assertEqual name outSB outIS++test_setAttribute :: IO ()+test_setAttribute = do+    assertEqual "#1" [("abc", "def")] $ getAttributes $+            setAttribute "abc" "def"+                (Element "test" [] [])+    assertEqual "#2" [("abc", "def")] $ getAttributes $+            setAttribute "abc" "def"+                (Element "test" [("abc", "xyzzy")] [])+    assertEqual "#2" [("abc", "def"), ("abc", "xyzzy")] $ getAttributes $+            setAttribute "abc" "def"+                (Element "test" [("abc", "zapf"), ("abc", "xyzzy")] [])+    assertEqual "#3" [("zanzi", "zapf"), ("bar", "xyzzy"), ("abc", "def")] $ getAttributes $+            setAttribute "abc" "def"+                (Element "test" [("zanzi", "zapf"), ("bar", "xyzzy")] [])+    assertEqual "#4" [("zanzi", "zapf"), ("bar", "xyzzy")] $ getAttributes $+            deleteAttribute "abc"+                (Element "test" [("zanzi", "zapf"), ("bar", "xyzzy"), ("abc", "def")] [])+    assertEqual "#5" [("zanzi", "zapf"), ("abc", "def")] $ getAttributes $+            deleteAttribute "bar"+                (Element "test" [("zanzi", "zapf"), ("bar", "xyzzy"), ("abc", "def")] [])+    assertEqual "#6" [("zanzi", "zapf"), ("bar", "xyzzy"), ("abc", "def")] $ getAttributes $+            deleteAttribute "bumpf"+                (Element "test" [("zanzi", "zapf"), ("bar", "xyzzy"), ("abc", "def")] [])++simpleDocs = [+    "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"+++    "<test xmlns:abc=\"http://blacksapphire.com/abc\"><abc:test1 type=\"expression\">Cat &amp; mouse</abc:test1><test2 type=\"communication\" language=\"Rhyming slang\">Dog &amp; bone</test2></test>",++    "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"+++    "<second><test><test1 type=\"expression\">Cat &amp; mouse</test1><test2 type=\"communication\" language=\"Rhyming slang\">Dog &amp; bone</test2></test><test>Rose &amp; Crown</test></second>",++    "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<test>Cat &amp; mouse</test>"+  ]+++tests = hUnitTestToTests $+    TestList [+        t' ("String",+            Tree.parse' :: ParserOptions String String+                        -> B.ByteString+                        -> Either XMLParseError (Node String String),+            formatTree),+        t' ("ByteString",+            Tree.parse' :: ParserOptions B.ByteString B.ByteString+                        -> B.ByteString+                        -> Either XMLParseError (Node B.ByteString B.ByteString),+            formatTree),+        t' ("Text",+            Tree.parse' :: ParserOptions T.Text T.Text+                        -> B.ByteString+                        -> Either XMLParseError (Node T.Text T.Text),+            formatTree),+        t ("String/Lazy",+            eitherify $ Tree.parse :: ParserOptions String String+                                   -> L.ByteString+                                   -> Either XMLParseError (Node String String),+            formatTree),+        t ("ByteString/Lazy",+            eitherify $ Tree.parse :: ParserOptions B.ByteString B.ByteString+                                   -> L.ByteString+                                   -> Either XMLParseError (Node B.ByteString B.ByteString),+            formatTree),+        t ("Text/Lazy",+            eitherify $ Tree.parse :: ParserOptions T.Text T.Text+                                   -> L.ByteString+                                   -> Either XMLParseError (Node T.Text T.Text),+            formatTree),+        TestLabel "error1" $ TestCase $ test_error1,+        TestLabel "error2" $ TestCase $ test_error2,+        TestLabel "error3" $ TestCase $ test_error3,+        TestLabel "error4" $ TestCase $ test_error4,+        TestLabel "parse" $ TestCase $ test_parse,+        TestLabel "entities" $ TestCase $ test_entities,+        TestLabel "textContent" $ TestCase $ test_textContent,+        TestLabel "indent" $ TestCase $ test_indent,+        TestLabel "setAttribute" $ TestCase $ test_setAttribute+      ]++  where+    t (descr, parse, fmt) = TestLabel descr $ TestCase $ do+        f <- testXMLFile+        let docs = f:simpleDocs+        forM_ (zip [1..] docs) $ \(idx, doc) ->+            testDoc parse fmt toByteStringL descr idx doc++    t' (descr, parse, fmt) = TestLabel descr $ TestCase $ do+        f <- testXMLFile+        let docs = f:simpleDocs+        forM_ (zip [1..] docs) $ \(idx, doc) ->+            testDoc parse fmt toByteString descr idx doc

@@ -0,0 +1,101 @@+<?xml version="1.0" encoding="UTF-8"?>+<countries>+  <country category="geo" continent="AS" currency="BDT" languages="bn_BD,en" lat="24.0" long="90.0" name="geo.BD" owner="system" type="geo" tz="Asia/Dhaka">+    <text lang="">Gana Prajatantri Bangladesh</text>+    <text lang="scn">Bangladesci</text>+    <text lang="gd">Bangladesh</text>+    <text lang="ga">An Bhanglaidéis</text>+    <text lang="gl">Bangladesh - বাংলাদেশ</text>+    <text lang="la">Bangladesia</text>+    <text lang="lo">ບັງກະລາເທດ</text>+    <text lang="tr">Bangladeş</text>+    <text lang="li">Bangladesj</text>+    <text lang="lv">Bangladeša</text>+    <text lang="lt">Bangladešas</text>+    <text lang="th">บังคลาเทศ</text>+    <text lang="tg">Бангладеш</text>+    <text lang="te">బంగ్లాదేశ్</text>+    <text lang="ta">பங்களாதேஷ்</text>+    <text lang="de">Bangladesch</text>+    <text lang="da">Bangladesh</text>+    <text lang="dz">བངྒ་ལ་དེཤ</text>+    <text lang="qu">Bangladesh</text>+    <text lang="kn">ಬಾಂಗ್ಲಾದೇಶ</text>+    <text lang="bpy">বাংলাদেশ</text>+    <text lang="el">Μπανγκλαντές</text>+    <text lang="eo">Bangladeŝo</text>+    <text lang="en">Bangladesh</text>+    <text lang="zh">孟加拉国</text>+    <text lang="eu">Bangladesh</text>+    <text lang="et">Bangladesh</text>+    <text lang="es">Bangladesh</text>+    <text lang="ru">Бангладеш</text>+    <text lang="ro">Bangladesh</text>+    <text lang="be">Бангладэш</text>+    <text lang="bg">Бангладеш</text>+    <text lang="ms">Bangladesh</text>+    <text lang="ast">Bangladesh</text>+    <text lang="bn">Gonaoprojatontri Bangladesh</text>+    <text lang="bs">Bangladeš</text>+    <text lang="ja">バングラデシュ</text>+    <text lang="oc">Bangladèsh</text>+    <text lang="nds">Bangladesch</text>+    <text lang="os">Бангладеш</text>+    <text lang="ca">Bangla Desh</text>+    <text lang="cy">Bangladesh</text>+    <text lang="cs">Bangladéš</text>+    <text lang="ps">بنګله‌دیش</text>+    <text lang="pt">Bangladesh</text>+    <text lang="tl">Bangladesh</text>+    <text lang="pl">Bangladesz</text>+    <text lang="hy">Բանգլադեշ</text>+    <text lang="hr">Bangladeš</text>+    <text lang="ht">Bangladèch</text>+    <text lang="hu">Banglades</text>+    <text lang="hi">बंगलादेश</text>+    <text lang="he">בנגלאדש</text>+    <text lang="fur">Bangladesh</text>+    <text lang="ml">ബംഗ്ലാദേശ്</text>+    <text lang="mk">Бангладеш</text>+    <text lang="ur">بنگلہ دیش</text>+    <text lang="mt">Bangladexx</text>+    <text lang="uk">Бангладеш</text>+    <text lang="mr">बांगलादेश</text>+    <text lang="ug">بېنگلا</text>+    <text lang="af">Bangladesj</text>+    <text lang="vi">Bangladesh</text>+    <text lang="is">Bangladess</text>+    <text lang="am">ባንግላዲሽ</text>+    <text lang="it">Bangladesh</text>+    <text lang="an">Bangladesh</text>+    <text lang="ar">بنغلاديش</text>+    <text lang="io">Bangladesh</text>+    <text lang="ia">Bangladesh</text>+    <text lang="id">Bangladesh</text>+    <text lang="ks">बंगलादेश</text>+    <text lang="nl">Bangladesh</text>+    <text lang="nn">Bangladesh</text>+    <text lang="no">Bangladesh</text>+    <text lang="na">Bangladesh</text>+    <text lang="nb">Bangladesh</text>+    <text lang="so">Bangaala-Deesh</text>+    <text lang="pam">Bangladesh</text>+    <text lang="fr">Bangladesh</text>+    <text lang="fy">Banglades</text>+    <text lang="fa">بنگلادش</text>+    <text lang="fi">Bangladesh</text>+    <text lang="fo">Bangladesj</text>+    <text lang="ka">ბანგლადეში</text>+    <text lang="sr">Бангладеш</text>+    <text lang="sq">Bangladeshi</text>+    <text lang="ko">방글라데시</text>+    <text lang="sv">Bangladesh</text>+    <text lang="km">បង់ក្លាដេស្ហ</text>+    <text lang="sk">Bangladéš</text>+    <text lang="sh">Bangladeš</text>+    <text lang="kw">Bangladesh</text>+    <text lang="ku">Bangladeş</text>+    <text lang="sl">Bangladeš</text>+    <text lang="se">Bangladesh</text>+  </country>+</countries>