HXQ-0.1: hxml-0.2/NTree.hs

----------------------------------------------------------------------------
--
-- Module	: HXML.NTree
-- Copyright	: (C) 2000-2002 Joe English.  Freely redistributable.
-- License	: "MIT-style"
--
-- Author	: Joe English <jenglish@flightlab.com>
-- Stability	: experimental
-- Portability	: portable
--
-- CVS  	: $Id: NTree.hs,v 1.3 2002/10/12 01:58:58 joe Exp $
--
----------------------------------------------------------------------------
--
-- Description: "Navigable trees": allow a program to traverse 
-- up the tree as well as down.
--

module NTree where

import Tree
import Misc (maybeStar, maybePlus, maybeToList, o)

data NTree a = NT
    (Tree a)		-- self
    [NTree a]		-- ancestors
    [Tree a]		-- previous siblings (in reverse order)
    [Tree a]		-- following siblings

ntree :: Tree a -> NTree a
ntree nd = NT nd [] [] []

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

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

upNT, downNT, leftNT, rightNT :: NTree a -> Maybe (NTree a)

upNT	  (NT _ (p:_) _ _)		= Just p
upNT	  (NT _ [] _ _) 		= Nothing
downNT	t@(NT (Tree _ (c:cs)) u _ _)	= Just (NT c (t:u) [] cs)
downNT 	  (NT (Tree _ []    ) _ _ _)	= Nothing
leftNT	  (NT s u (l:ls) r)		= Just (NT l u ls (s:r))
leftNT	  (NT _ _ []     _)		= Nothing
rightNT   (NT s u l (r:rs))		= Just (NT r u (s:l) rs)
rightNT   (NT _ _ _ []    ) 		= Nothing

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

-- XPath axes:

ancestorAxis, ancestorOrSelfAxis, childAxis,
    descendantAxis, descendantOrSelfAxis,
    followingAxis, followingSiblingAxis, parentAxis,
    precedingAxis, precedingSiblingAxis, selfAxis 
    :: NTree a -> [NTree a]

-- attributeAxis, namespaceAxis : not supported

parentAxis		= maybeToList . upNT
ancestorAxis 		= \(NT _ u _ _) -> u		-- or: maybePlus upNT
ancestorOrSelfAxis	= \t@(NT _ u _ _) -> t:u	-- or: maybeStar upNT
childAxis		= maybe [] (maybeStar rightNT) . downNT
descendantAxis		= tail . preorderNT -- concatMap preorderNT . childAxis
descendantOrSelfAxis	= preorderNT
followingSiblingAxis	= maybePlus rightNT
precedingSiblingAxis	= maybePlus leftNT
selfAxis		= wrap  where wrap x = [x]

followingAxis = preorderNT     `o` followingSiblingAxis `o` ancestorOrSelfAxis 
precedingAxis = revPreorderNT  `o` precedingSiblingAxis `o` ancestorOrSelfAxis

-- EOF --