-- |
-- 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

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