-- |
-- Navigable tree structure which allow a program to traverse
-- for XPath expressions
-- copied and modified from HXML (<http://www.flightlab.com/~joe/hxml/>)
--

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
					)

-- -----------------------------------------------------------------------------

-- NavTree
--
-- | navigable tree with nodes of type node
--
-- a navigable tree consists of a n-ary tree for the current fragment tree,
-- a navigable tree for all ancestors, and two n-ary trees for
-- the previous- and following siblings

data NavTree a 	= NT { self			:: (NTree a)
		     , selfIndex		:: Int
		     , ancestors		:: [NavTree a]
		     , previousSiblings		:: [NTree a]
		     , followingSiblings	:: [NTree a]
		     }
		  deriving (Show)		-- deriving not reasonable for Eq and Ord

-- -----------------------------------------------------------------------------


-- |
-- converts a n-ary tree in a navigable tree

ntree				:: NTree a -> NavTree a
ntree nd			= NT nd (-1) [] [] []

-- |
-- converts a navigable tree in a n-ary tree

subtreeNT			:: NavTree a -> NTree a
subtreeNT (NT nd _ _ _ _)	= nd


-- |
-- function for selecting the value of the current fragment tree

dataNT				:: NavTree a -> a
dataNT (NT (NTree a _) _ _ _ _) = a

-- |
-- function for selecting all children of a tree

childrenNT			:: NavTree a -> [NTree a]
childrenNT (NT (NTree _ cs) _ _ _ _)
				= cs

-- |
-- position of tree in parent

indexNT				:: NavTree a -> Int
indexNT	(NT _ ix _ _ _)		= ix

-- |
-- path (index list) of a navigatable tree

pathNT				:: NavTree a -> [Int]
pathNT 				= tail . reverse . map selfIndex . ancestorOrSelfAxis

-- -----------------------------------------------------------------------------

-- functions for traversing up, down, left and right in a navigable tree

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 t = t : concatMap preorderNT (children t)
-- where children = maybe [] (maybeStar rightNT) . downNT

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)

-- -----------------------------------------------------------------------------
-- Miscellaneous useful combinators

-- |
-- Kleisli composition:

o' 			:: (b -> [c]) -> (a -> [b]) -> (a -> [c])
f `o'` g 		= \x -> g x >>= f

-- Some useful anamorphisms:

maybeStar, maybePlus 	:: (a -> Maybe a) -> a -> [a]
maybeStar f a 		= a : maybe [] (maybeStar f) (f a)
maybePlus f a 		=     maybe [] (maybeStar f) (f a)

-- -----------------------------------------------------------------------------
-- functions for representing XPath axes. All axes except the namespace-axis are supported


parentAxis		:: NavTree a -> [NavTree a]
parentAxis		= maybeToList . upNT

ancestorAxis		:: NavTree a -> [NavTree a]
ancestorAxis 		= ancestors			-- or: maybePlus upNT

ancestorOrSelfAxis	:: NavTree a -> [NavTree a]
ancestorOrSelfAxis t	= t : ancestors t		-- or: maybeStar upNT

childAxis		:: NavTree a -> [NavTree a]
childAxis		= maybe [] (maybeStar rightNT) . downNT

descendantAxis		:: NavTree a -> [NavTree a]
descendantAxis		= tail . preorderNT 		-- concatMap preorderNT . childAxis

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

-- attributes are indexed in the path with negative indices
-- this corresponds to document order and makes the index paths
-- for attributes and children disjoint.
-- The attribute index is never referenced when navigating in trees

-- ------------------------------------------------------------