content: -- ------------------------------------------------------------
  
  {- |
     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 #-}
  
  -- ------------------------------------------------------------
  
  