hxt-9.1.0: src/Control/Arrow/ArrowNavigatableTree.hs
-- ------------------------------------------------------------
{- |
Module : Control.Arrow.ArrowNavigatableTree
Copyright : Copyright (C) 2010 Uwe Schmidt
License : MIT
Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)
Stability : experimental
Portability: portable
List arrows for navigatable trees
Trees that implement the "Data.Tree.NavigatableTree.Class" interface, can be processed
with these arrows.
-}
-- ------------------------------------------------------------
module Control.Arrow.ArrowNavigatableTree
where
import Control.Arrow
import Control.Arrow.ArrowList
import Control.Arrow.ArrowIf
import Data.Maybe
import Data.Tree.NavigatableTree.Class ( NavigatableTree
, NavigatableTreeToTree
, NavigatableTreeModify
)
import qualified Data.Tree.NavigatableTree.Class as T
import qualified Data.Tree.NavigatableTree.XPathAxis as T
-- ------------------------------------------------------------
-- | The interface for navigatable tree arrows
--
-- all functions have default implementations
class (ArrowList a) => ArrowNavigatableTree a where
-- move one step towards the root
moveUp :: NavigatableTree t => a (t b) (t b)
moveUp = arrL $ maybeToList . T.mvUp
-- descend one step to the leftmost child
moveDown :: NavigatableTree t => a (t b) (t b)
moveDown = arrL $ maybeToList . T.mvDown
-- move to the left neighbour
moveLeft :: NavigatableTree t => a (t b) (t b)
moveLeft = arrL $ maybeToList . T.mvLeft
-- move to the right neighbour
moveRight :: NavigatableTree t => a (t b) (t b)
moveRight = arrL $ maybeToList . T.mvRight
-- derived functions
parentAxis :: (ArrowList a, NavigatableTree t) => a (t b) (t b)
parentAxis = arrL T.parentAxis
-- | XPath axis: ancestor
ancestorAxis :: (ArrowList a, NavigatableTree t) => a (t b) (t b)
ancestorAxis = arrL T.ancestorAxis
-- | XPath axis: ancestor or self
ancestorOrSelfAxis :: (ArrowList a, NavigatableTree t) => a (t b) (t b)
ancestorOrSelfAxis = arrL T.ancestorOrSelfAxis
-- | XPath axis: child
childAxis :: (ArrowList a, NavigatableTree t) => a (t b) (t b)
childAxis = arrL T.childAxis
-- | XPath axis: descendant
descendantAxis :: (ArrowList a, NavigatableTree t) => a (t b) (t b)
descendantAxis = arrL T.descendantAxis
-- | XPath axis: descendant or self
descendantOrSelfAxis :: (ArrowList a, NavigatableTree t) => a (t b) (t b)
descendantOrSelfAxis = arrL T.descendantOrSelfAxis
-- | not an XPath axis but useful: descendant or following
descendantOrFollowingAxis :: (ArrowList a, NavigatableTree t) => a (t b) (t b)
descendantOrFollowingAxis = descendantAxis <+> followingAxis
-- | not an official XPath axis but useful: reverse descendant or self, used in preceding axis
revDescendantOrSelfAxis :: (ArrowList a, NavigatableTree t) => a (t b) (t b)
revDescendantOrSelfAxis = arrL T.revDescendantOrSelfAxis
-- | XPath axis: following sibling
followingSiblingAxis :: (ArrowList a, NavigatableTree t) => a (t b) (t b)
followingSiblingAxis = arrL T.followingSiblingAxis
-- | XPath axis: preceeding sibling
precedingSiblingAxis :: (ArrowList a, NavigatableTree t) => a (t b) (t b)
precedingSiblingAxis = arrL T.precedingSiblingAxis
-- | XPath axis: self
selfAxis :: (ArrowList a, NavigatableTree t) => a (t b) (t b)
selfAxis = arrL T.selfAxis
-- | XPath axis: following
followingAxis :: (ArrowList a, NavigatableTree t) => a (t b) (t b)
followingAxis = arrL T.followingAxis
-- | XPath axis: preceding
precedingAxis :: (ArrowList a, NavigatableTree t) => a (t b) (t b)
precedingAxis = arrL T.precedingAxis
-- ------------------------------------------------------------
-- | move to the root
moveToRoot :: (Arrow a, NavigatableTree t) => a (t b) (t b)
moveToRoot = arr T.mvToRoot
isAtRoot :: (ArrowList a, NavigatableTree t) => a (t b) (t b)
isAtRoot = isA (null . T.ancestorAxis)
-- ------------------------------------------------------------
-- | Conversion from a tree into a navigatable tree
addNav :: ( ArrowList a
, NavigatableTreeToTree nt t
) =>
a (t b) (nt b)
addNav = arr T.fromTree
-- | Conversion from a navigatable tree into an ordinary tree
remNav :: ( ArrowList a
, NavigatableTreeToTree nt t
) =>
a (nt b) (t b)
remNav = arr T.toTree
-- | apply an operation using navigation to an ordinary tree
--
-- This root and all children may be visited in arbitrary order
withNav :: ( ArrowList a
, NavigatableTreeToTree nt t
) =>
a (nt b) (nt c) -> a (t b) (t c)
withNav f = addNav >>> f >>> remNav
-- | apply a simple operation without use of navigation to a navigatable tree
--
-- This enables to apply arbitrary tree operations to navigatable trees
withoutNav :: ( ArrowList a
, NavigatableTreeToTree nt t
, NavigatableTreeModify nt t
) =>
a (t b) (t b) -> a (nt b) (nt b)
withoutNav f = ( (remNav >>> f) -- apply the simple arrow to the tree
&&&
this -- remember the navigation context
)
>>> arr (uncurry T.substThisTree) -- resore the context
-- ------------------------------------------------------------
-- | Filter an axis with an ordinary tree predicate
--
-- Example: In a tree of Ints find all nodes in the subtrees (in preorder) that have label 42
--
-- > descendantAxis >>> filterAxis (hasNode (== 42))
--
-- Example: In an XML Tree find the following nodes of a node with attribute id and value 42
--
-- > descendantAxis >>> filterAxis (hasAttrValue "id" (=="42")) >>> followingAxis
filterAxis :: ( ArrowIf a
, NavigatableTreeToTree nt t
) =>
a (t b) c -> a (nt b) (nt b)
filterAxis p = (remNav >>> p) `guards` this
{-# INLINE filterAxis #-}
-- | Move to the next tree on a given axis. Deterministic arrow
--
-- Example: Move to the next node in a preorder visit: next child or else next following
--
-- > moveOn descendantOrFollowingAxis
moveOn :: ( ArrowList a
, NavigatableTree t
) =>
a (t b) (t b) -> a (t b) (t b)
moveOn axis = single $ axis
{-# INLINE moveOn #-}
-- ------------------------------------------------------------
-- | Change the current subtree of a navigatable tree.
--
-- The arrow for computing the changes should be deterministic. If it fails
-- nothing is changed.
changeThisTree :: ( ArrowList a
, ArrowIf a
, NavigatableTreeToTree nt t
, NavigatableTreeModify nt t
) =>
a (t b) (t b) -> a (nt b) (nt b)
changeThisTree cf = withoutNav $ single cf `orElse` this
-- | Substitute the current subtree of a navigatable tree by a given tree
substThisTree :: ( ArrowList a
, ArrowIf a
, NavigatableTreeToTree nt t
, NavigatableTreeModify nt t
) =>
t b -> a (nt b) (nt b)
substThisTree t = changeThisTree (constA t)
-- ------------------------------------------------------------
-- | apply an ordinary arrow to the current subtree of a navigatabe tree and add the result trees in front of the current tree.
--
-- If this arrow is applied to the root, it will fail, because we want a tree as result, not a forest.
addToTheLeft :: ( ArrowList a
, NavigatableTreeToTree nt t
, NavigatableTreeModify nt t
) =>
a (t b) (t b) -> a (nt b) (nt b)
addToTheLeft = addToOneSide $
foldl (\ acc t -> acc >>= T.addTreeLeft t)
{-# INLINE addToTheLeft #-}
-- | apply an ordinary arrow to the current subtree of a navigatabe tree and add the result trees behind the current tree.
--
-- If this arrow is applied to the root, it will fail, because we want a tree as result, not a forest.
addToTheRight :: ( ArrowList a
, NavigatableTreeToTree nt t
, NavigatableTreeModify nt t
) =>
a (t b) (t b) -> a (nt b) (nt b)
addToTheRight = addToOneSide $
foldr (\ t acc -> acc >>= T.addTreeRight t)
{-# INLINE addToTheRight #-}
-- | addToOneSide does the real work for 'addToTheLeft' and 'addToTheRight'
addToOneSide :: ( ArrowList a
, NavigatableTreeToTree nt t
, NavigatableTreeModify nt t
) =>
( Maybe (nt b) -> [t b] -> Maybe (nt b) ) ->
a (t b) (t b) ->
a (nt b) (nt b)
addToOneSide side f = ( ( remNav >>> listA f )
&&&
this
)
>>>
arrL ( uncurry (\ ts nt -> side (Just nt) ts)
>>>
maybeToList
)
-- ------------------------------------------------------------
-- | drop the direct left sibling tree of the given navigatable tree
--
-- If this arrow is applied to the root or a leftmost tree, it will fail, because there is nothing to remove
dropFromTheLeft :: ( ArrowList a
-- , NavigatableTreeToTree nt t
, NavigatableTreeModify nt t
) =>
a (nt b) (nt b)
dropFromTheLeft = arrL $ T.dropTreeLeft >>> maybeToList
{-# INLINE dropFromTheLeft #-}
-- | drop the direct left sibling tree of the given navigatable tree
--
-- If this arrow is applied to the root or a rightmost tree, it will fail, because there is nothing to remove
dropFromTheRight :: ( ArrowList a
, NavigatableTreeModify nt t
) =>
a (nt b) (nt b)
dropFromTheRight = arrL $ T.dropTreeRight >>> maybeToList
{-# INLINE dropFromTheRight #-}
-- ------------------------------------------------------------