diff --git a/Text/XML/Expat/Annotated.hs b/Text/XML/Expat/Annotated.hs --- a/Text/XML/Expat/Annotated.hs +++ b/Text/XML/Expat/Annotated.hs @@ -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 diff --git a/Text/XML/Expat/Cursor.hs b/Text/XML/Expat/Cursor.hs --- a/Text/XML/Expat/Cursor.hs +++ b/Text/XML/Expat/Cursor.hs @@ -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 diff --git a/Text/XML/Expat/Format.hs b/Text/XML/Expat/Format.hs --- a/Text/XML/Expat/Format.hs +++ b/Text/XML/Expat/Format.hs @@ -1,18 +1,18 @@ +{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-} -- hexpat, a Haskell wrapper for expat -- Copyright (C) 2008 Evan Martin -- Copyright (C) 2009 Stephen Blackheath -- | 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 - 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 + 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 - 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 "\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 "\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 "')]: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 "')) $ + 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 diff --git a/Text/XML/Expat/Namespaced.hs b/Text/XML/Expat/Namespaced.hs --- a/Text/XML/Expat/Namespaced.hs +++ b/Text/XML/Expat/Namespaced.hs @@ -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 diff --git a/Text/XML/Expat/NodeClass.hs b/Text/XML/Expat/NodeClass.hs --- a/Text/XML/Expat/NodeClass.hs +++ b/Text/XML/Expat/NodeClass.hs @@ -1,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 diff --git a/Text/XML/Expat/Proc.hs b/Text/XML/Expat/Proc.hs --- a/Text/XML/Expat/Proc.hs +++ b/Text/XML/Expat/Proc.hs @@ -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 diff --git a/Text/XML/Expat/Qualified.hs b/Text/XML/Expat/Qualified.hs --- a/Text/XML/Expat/Qualified.hs +++ b/Text/XML/Expat/Qualified.hs @@ -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. -- diff --git a/Text/XML/Expat/SAX.hs b/Text/XML/Expat/SAX.hs --- a/Text/XML/Expat/SAX.hs +++ b/Text/XML/Expat/SAX.hs @@ -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 diff --git a/Text/XML/Expat/Tree.hs b/Text/XML/Expat/Tree.hs --- a/Text/XML/Expat/Tree.hs +++ b/Text/XML/Expat/Tree.hs @@ -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 diff --git a/hexpat.cabal b/hexpat.cabal --- a/hexpat.cabal +++ b/hexpat.cabal @@ -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, + For introduction and examples, see the /Text.XML.Expat.Tree/ module. For benchmarks, + . + This package provides pure lazy parsing. However, Haskell's lazy I\/O is + 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 , @@ -48,6 +56,14 @@ (c) 2009 Matthew Pocock , (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 diff --git a/test/hexpat-tests.cabal b/test/hexpat-tests.cabal new file mode 100644 --- /dev/null +++ b/test/hexpat-tests.cabal @@ -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 diff --git a/test/suite/TestSuite.hs b/test/suite/TestSuite.hs new file mode 100644 --- /dev/null +++ b/test/suite/TestSuite.hs @@ -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 + ] diff --git a/test/suite/Text/XML/Expat/Cursor/Tests.hs b/test/suite/Text/XML/Expat/Cursor/Tests.hs new file mode 100644 --- /dev/null +++ b/test/suite/Text/XML/Expat/Cursor/Tests.hs @@ -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 diff --git a/test/suite/Text/XML/Expat/Proc/Tests.hs b/test/suite/Text/XML/Expat/Proc/Tests.hs new file mode 100644 --- /dev/null +++ b/test/suite/Text/XML/Expat/Proc/Tests.hs @@ -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" diff --git a/test/suite/Text/XML/Expat/Tests.hs b/test/suite/Text/XML/Expat/Tests.hs new file mode 100644 --- /dev/null +++ b/test/suite/Text/XML/Expat/Tests.hs @@ -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 + diff --git a/test/suite/Text/XML/Expat/UnitTests.hs b/test/suite/Text/XML/Expat/UnitTests.hs new file mode 100644 --- /dev/null +++ b/test/suite/Text/XML/Expat/UnitTests.hs @@ -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 "") :: 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 "") :: (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 "Hello") + +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 "Hello"] + 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 = "&entity;" + + 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 "\n", + toByteString "\n"), + ("#2", + toByteString "\nWith some text in it", + toByteString "\nWith some text in it"), + ("#3", + toByteString $ "\n"++ + "", + toByteString $ "\n"++ + "\n \n \n \n"), + ("#4", + toByteString $ "\n"++ + "strengthSlaveryPeace", + toByteString $ "\n"++ + "\n strength\n Slavery\n Peace\n"), + ("#5", + toByteString $ "\n"++ + "Ministry of TruthIn between"++ + "Ministry of Love\n And some more"++ + "Ministry of Plenty"++ + "Ministry of PeaceEurasia"++ + "strength", + toByteString $ "\n"++ + "\n \n Ministry of TruthIn between"++ + "\n Ministry of LoveAnd some more"++ + "\n Ministry of Plenty"++ + "\n Ministry of Peace\n Eurasia\n \n "++ + "\n \n strength\n \n") + ] + 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 = [ + "\n"++ + "Cat & mouseDog & bone", + + "\n"++ + "Cat & mouseDog & boneRose & Crown", + + "\nCat & mouse" + ] + + +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 diff --git a/test/test.xml b/test/test.xml new file mode 100644 --- /dev/null +++ b/test/test.xml @@ -0,0 +1,101 @@ + + + + Gana Prajatantri Bangladesh + Bangladesci + Bangladesh + An Bhanglaidéis + Bangladesh - বাংলাদেশ + Bangladesia + ບັງກະລາເທດ + Bangladeş + Bangladesj + Bangladeša + Bangladešas + บังคลาเทศ + Бангладеш + బంగ్లాదేశ్ + பங்களாதேஷ் + Bangladesch + Bangladesh + བངྒ་ལ་དེཤ + Bangladesh + ಬಾಂಗ್ಲಾದೇಶ + বাংলাদেশ + Μπανγκλαντές + Bangladeŝo + Bangladesh + 孟加拉国 + Bangladesh + Bangladesh + Bangladesh + Бангладеш + Bangladesh + Бангладэш + Бангладеш + Bangladesh + Bangladesh + Gonaoprojatontri Bangladesh + Bangladeš + バングラデシュ + Bangladèsh + Bangladesch + Бангладеш + Bangla Desh + Bangladesh + Bangladéš + بنګله‌دیش + Bangladesh + Bangladesh + Bangladesz + Բանգլադեշ + Bangladeš + Bangladèch + Banglades + बंगलादेश + בנגלאדש + Bangladesh + ബംഗ്ലാദേശ് + Бангладеш + بنگلہ دیش + Bangladexx + Бангладеш + बांगलादेश + بېنگلا + Bangladesj + Bangladesh + Bangladess + ባንግላዲሽ + Bangladesh + Bangladesh + بنغلاديش + Bangladesh + Bangladesh + Bangladesh + बंगलादेश + Bangladesh + Bangladesh + Bangladesh + Bangladesh + Bangladesh + Bangaala-Deesh + Bangladesh + Bangladesh + Banglades + بنگلادش + Bangladesh + Bangladesj + ბანგლადეში + Бангладеш + Bangladeshi + 방글라데시 + Bangladesh + បង់ក្លាដេស្ហ + Bangladéš + Bangladeš + Bangladesh + Bangladeş + Bangladeš + Bangladesh + +