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

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

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