module Text.XML.HXT.XPath.NavTree
( module Text.XML.HXT.XPath.NavTree
, module Data.Tree.NTree.TypeDefs
)
where
import Data.Maybe
import Data.Tree.NTree.TypeDefs
import Text.XML.HXT.DOM.Interface ( XNode
, xmlnsNamespace
, namespaceUri
)
import Text.XML.HXT.DOM.XmlNode ( isRoot
, isElem
, getName
, getAttrl
)
data NavTree a = NT { self :: (NTree a)
, selfIndex :: Int
, ancestors :: [NavTree a]
, previousSiblings :: [NTree a]
, followingSiblings :: [NTree a]
}
deriving (Show)
ntree :: NTree a -> NavTree a
ntree nd = NT nd (1) [] [] []
subtreeNT :: NavTree a -> NTree a
subtreeNT (NT nd _ _ _ _) = nd
dataNT :: NavTree a -> a
dataNT (NT (NTree a _) _ _ _ _) = a
childrenNT :: NavTree a -> [NTree a]
childrenNT (NT (NTree _ cs) _ _ _ _)
= cs
indexNT :: NavTree a -> Int
indexNT (NT _ ix _ _ _) = ix
pathNT :: NavTree a -> [Int]
pathNT = tail . reverse . map selfIndex . ancestorOrSelfAxis
upNT
, downNT
, leftNT
, rightNT :: NavTree a -> Maybe (NavTree a)
upNT (NT _ _ (p:_) _ _) = Just p
upNT (NT _ _ [] _ _) = Nothing
downNT t@(NT (NTree _ (c:cs)) _ u _ _) = Just (NT c 0 (t:u) [] cs)
downNT (NT (NTree _ [] ) _ _ _ _) = Nothing
leftNT (NT s ix u (l:ls) r) = Just (NT l (ix 1) u ls (s:r))
leftNT (NT _ _ _ [] _) = Nothing
rightNT (NT s ix u l (r:rs)) = Just (NT r (ix + 1) u (s:l) rs)
rightNT (NT _ _ _ _ [] ) = Nothing
preorderNT :: NavTree a -> [NavTree a]
preorderNT = visit []
where
visit k t = t : maybe k (visit' k) (downNT t)
visit' k t = visit (maybe k (visit' k) (rightNT t)) t
revPreorderNT :: NavTree a -> [NavTree a]
revPreorderNT t = t : concatMap revPreorderNT (reverse (children t))
where
children = maybe [] (maybeStar rightNT) . downNT
getChildrenNT :: NavTree a -> [NavTree a]
getChildrenNT node = maybe [] follow (downNT node)
where
follow n = n : maybe [] follow (rightNT n)
o' :: (b -> [c]) -> (a -> [b]) -> (a -> [c])
f `o'` g = \x -> g x >>= f
maybeStar, maybePlus :: (a -> Maybe a) -> a -> [a]
maybeStar f a = a : maybe [] (maybeStar f) (f a)
maybePlus f a = maybe [] (maybeStar f) (f a)
parentAxis :: NavTree a -> [NavTree a]
parentAxis = maybeToList . upNT
ancestorAxis :: NavTree a -> [NavTree a]
ancestorAxis = ancestors
ancestorOrSelfAxis :: NavTree a -> [NavTree a]
ancestorOrSelfAxis t = t : ancestors t
childAxis :: NavTree a -> [NavTree a]
childAxis = maybe [] (maybeStar rightNT) . downNT
descendantAxis :: NavTree a -> [NavTree a]
descendantAxis = tail . preorderNT
descendantOrSelfAxis :: NavTree a -> [NavTree a]
descendantOrSelfAxis = preorderNT
followingSiblingAxis :: NavTree a -> [NavTree a]
followingSiblingAxis = maybePlus rightNT
precedingSiblingAxis :: NavTree a -> [NavTree a]
precedingSiblingAxis = maybePlus leftNT
selfAxis :: NavTree a -> [NavTree a]
selfAxis = (:[])
followingAxis :: NavTree a -> [NavTree a]
followingAxis = preorderNT `o'` followingSiblingAxis `o'` ancestorOrSelfAxis
precedingAxis :: NavTree a -> [NavTree a]
precedingAxis = revPreorderNT `o'` precedingSiblingAxis `o'` ancestorOrSelfAxis
attributeAxis :: NavTree XNode -> [NavTree XNode]
attributeAxis t@(NT xt _ a _ _)
| isElem xt
&&
not (isRoot xt) = foldr (\ (ix, attr) -> ((NT attr ix (t:a) [] []):)) [] al
| otherwise = []
where
aix xs = zip [(0 length xs) .. (1)] xs
al = filter ((/= xmlnsNamespace) . maybe "" namespaceUri . getName . snd)
. aix
. fromMaybe []
. getAttrl $ xt