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

    {- |
       Module     : Control.Arrow.ArrowTree
       Copyright  : Copyright (C) 2010 Uwe Schmidt
       License    : MIT

       Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)
       Stability  : stable
       Portability: portable

       List arrows for tree processing.

       Trees that implement the "Data.Tree.Class" interface, can be processed
       with these arrows.
    -}

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

    module Control.Arrow.ArrowTree
        ( ArrowTree(..)
        , Tree
        )
    where

    import Data.Tree.Class (Tree)
    import qualified Data.Tree.Class as T hiding (Tree)

    import Control.Arrow
    import Control.Arrow.ArrowList
    import Control.Arrow.ArrowIf

    infixl 5 />, //>, </

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

    -- | The interface for tree arrows
    --
    -- all functions have default implementations

    class (ArrowPlus a, ArrowIf a) => ArrowTree a where

        -- | construct a leaf

        mkLeaf              :: Tree t => b -> a c (t b)
        mkLeaf              = constA . T.mkLeaf
        {-# INLINE mkLeaf #-}

        -- | construct an inner node

        mkTree              :: Tree t => b -> [t b] -> a c (t b)
        mkTree n            = constA . T.mkTree n
        {-# INLINE mkTree #-}

        -- | select the children of the root of a tree

        getChildren         :: Tree t => a (t b) (t b)
        getChildren         = arrL T.getChildren
        {-# INLINE getChildren #-}

        -- | select the node info of the root of a tree

        getNode             :: Tree t => a (t b) b
        getNode             = arr T.getNode
        {-# INLINE getNode #-}

        -- | select the attribute of the root of a tree

        hasNode             :: Tree t => (b -> Bool) -> a (t b) (t b)
        hasNode p           = (getNode >>> isA p) `guards` this
        {-# INLINE hasNode #-}

        -- | substitute the children of the root of a tree

        setChildren         :: Tree t =>            [t b] -> a (t b) (t b)
        setChildren cs      = arr (T.setChildren cs)
        {-# INLINE setChildren #-}

        -- | substitute the attribute of the root of a tree

        setNode             :: Tree t =>                b -> a (t b) (t b)
        setNode n           = arr (T.setNode n)
        {-# INLINE setNode #-}

        -- | edit the children of the root of a tree

        changeChildren      :: Tree t => ([t b] -> [t b]) -> a (t b) (t b)
        changeChildren csf  = arr (T.changeChildren csf)
        {-# INLINE changeChildren #-}

        -- | edit the attribute of the root of a tree

        changeNode          :: Tree t =>        (b  -> b) -> a (t b) (t b)
        changeNode nf       = arr (T.changeNode nf)
        {-# INLINE changeNode #-}

                                                                    -- compound arrows

        -- | apply an arrow element wise to all children of the root of a tree
        -- collect these results and substitute the children with this result
        --
        -- example: @ processChildren isText @ deletes all subtrees, for which isText does not hold
        --
        -- example: @ processChildren (none \`when\` isCmt) @ removes all children, for which isCmt holds

        processChildren     :: Tree t => a (t b) (t b) -> a (t b) (t b)
        processChildren f   = arr T.getNode
                              &&&
                              listA (arrL T.getChildren >>> f)      -- new children, deterministic filter: single element result
                              >>>
                              arr2 T.mkTree

        -- | similar to processChildren, but the new children are computed by processing
        -- the whole input tree
        --
        -- example: @ replaceChildren (deep isText) @ selects all subtrees for which isText holds
        -- and substitutes the children component of the root node with this list

        replaceChildren     :: Tree t => a (t b) (t b) -> a (t b) (t b)
        replaceChildren f   = arr T.getNode
                              &&&
                              listA f                               -- compute new children
                              >>>
                              arr2 T.mkTree

        -- |
        -- pronounced \"slash\", meaning g inside f
        --
        -- defined as @ f \/> g = f >>> getChildren >>> g @
        --
        -- example: @ hasName \"html\" \/> hasName \"body\" \/> hasName \"h1\" @
        --
        -- This expression selects
        -- all \"h1\" elements in the \"body\" element of an \"html\" element, an expression, that
        -- corresponds 1-1 to the XPath selection path \"html\/body\/h1\"

        (/>)                :: Tree t => a b (t c) -> a (t c) d -> a b d
        f /> g              = f >>> getChildren >>> g
        {-# INLINE (/>) #-}

        -- |
        -- pronounced \"double slash\", meaning g arbitrarily deep inside f
        --
        -- defined as @ f \/\/> g = f >>> getChildren >>> deep g @
        --
        -- example: @ hasName \"html\" \/\/> hasName \"table\" @
        --
        -- This expression selects
        -- all top level \"table\" elements within an \"html\" element, an expression.
        -- Attention: This does not correspond
        -- to the XPath selection path \"html\/\/table\". The latter on matches all table elements
        -- even nested ones, but @\/\/>@ gives in many cases the appropriate functionality.

        (//>)               :: Tree t => a b (t c) -> a (t c) d -> a b d
        f //> g             = f >>> getChildren >>> deep g
        {-# INLINE (//>) #-}

        -- |
        -- pronounced \"outside\" meaning f containing g
        --
        -- defined as @ f \<\/ g = f \`containing\` (getChildren >>> g) @

        (</)                :: Tree t => a (t b) (t b) -> a (t b) (t b) -> a (t b) (t b)
        f </ g              = f `containing` (getChildren >>> g)
        {-# INLINE (</) #-}

        -- | recursively searches a whole tree for subtrees, for which a predicate holds.
        -- The search is performed top down. When a tree is found, this becomes an element of the result
        -- list. The tree found is not further examined for any subtress, for which the predicate also could hold.
        -- See 'multi' for this kind of search.
        --
        -- example: @ deep isHtmlTable @ selects all top level table elements in a document
        -- (with an appropriate definition for isHtmlTable) but no tables occuring within a table cell.

        deep                :: Tree t => a (t b) c -> a (t b) c
        deep f              = f                                     -- success when applying f
                              `orElse`
                              (getChildren >>> deep f)              -- seach children

        -- | recursively searches a whole tree for subrees, for which a predicate holds.
        -- The search is performed bottom up.
        --
        -- example: @ deepest isHtmlTable @ selects all innermost table elements in a document
        -- but no table elements containing tables. See 'deep' and 'multi' for other search strategies.

        deepest             :: Tree t => a (t b) c -> a (t b) c
        deepest f           = (getChildren >>> deepest f)           -- seach children
                              `orElse`
                              f                                     -- no success: apply f to root

        -- | recursively searches a whole tree for subtrees, for which a predicate holds.
        -- The search is performed top down. All nodes of the tree are searched, even within the
        -- subtrees of trees for which the predicate holds.
        --
        -- example: @ multi isHtmlTable @ selects all table elements, even nested ones.

        multi               :: Tree t => a (t b) c -> a (t b) c
        multi f             = f                                     -- combine result for root
                              <+>
                              (getChildren >>> multi f)             -- with result for all descendants

        -- | recursively transforms a whole tree by applying an arrow to all subtrees,
        -- this is done bottom up depth first, leaves first, root as last tree
        --
        -- example: @ processBottomUp (getChildren \`when\` isHtmlFont) @ removes all font tags in a HTML document, even nested ones
        -- (with an appropriate definition of isHtmlFont)

        processBottomUp     :: Tree t => a (t b) (t b) -> a (t b) (t b)
        processBottomUp f   = processChildren (processBottomUp f)   -- process all descendants first
                              >>>
                              f                                     -- then process root

        -- | similar to 'processBottomUp', but recursively transforms a whole tree by applying an arrow to all subtrees
        -- with a top down depth first traversal strategie. In many cases 'processBottomUp' and 'processTopDown'
        -- give same results.

        processTopDown      :: Tree t => a (t b) (t b) -> a (t b) (t b)
        processTopDown f    = f                                     -- first process root
                              >>>
                              processChildren (processTopDown f)    -- then process all descendants of new root

        -- | recursively transforms a whole tree by applying an arrow to all subtrees,
        -- but transformation stops when a predicte does not hold for a subtree,
        -- leaves are transformed first

        processBottomUpWhenNot
                            :: Tree t => a (t b) (t b) -> a (t b) (t b) -> a (t b) (t b)
        processBottomUpWhenNot f p
                            = ( processChildren (processBottomUpWhenNot f p)
                                >>>
                                f
                              ) `whenNot` p

        -- | recursively transforms a whole tree by applying an arrow to all subtrees,
        -- but transformation stops when a tree is successfully transformed.
        -- the transformation is done top down
        --
        -- example: @ processTopDownUntil (isHtmlTable \`guards\` tranformTable) @
        -- transforms all top level table elements into something else, but inner tables remain unchanged

        processTopDownUntil :: Tree t => a (t b) (t b) -> a (t b) (t b)
        processTopDownUntil f
                            = f
                              `orElse`
                              processChildren (processTopDownUntil f)

        -- | computes a list of trees by applying an arrow to the input
        -- and inserts this list in front of index i in the list of children
        --
        -- example: @ insertChildrenAt 0 (deep isCmt) @ selects all subtrees for which isCmt holds
        -- and copies theses in front of the existing children

        insertChildrenAt    :: Tree t =>           Int -> a (t b) (t b) -> a (t b) (t b)
        insertChildrenAt i f
                            = listA f &&& this >>> arr2 insertAt
                              where
                              insertAt newcs
                                  = T.changeChildren (\ cs -> let
                                                              (cs1, cs2) = splitAt i cs
                                                              in
                                                              cs1 ++ newcs ++ cs2
                                                     )

        -- | similar to 'insertChildrenAt', but the insertion position is searched with a predicate

        insertChildrenAfter :: Tree t => a (t b) (t b) -> a (t b) (t b) -> a (t b) (t b)
        insertChildrenAfter p f
                            = replaceChildren
                              ( ( ( listA getChildren
                                    >>>
                                    spanA p
                                  )
                                  &&&
                                  listA f
                                )
                                >>> arr2L (\ (xs1, xs2) xs -> xs1 ++ xs ++ xs2)
                              )

        -- | an arrow for inserting a whole subtree with some holes in it (a template)
        -- into a document. The holes can be filled with contents from the input.
        --
        -- Example
        --
        -- > insertTreeTemplateTest :: ArrowXml a => a b XmlTree
        -- > insertTreeTemplateTest
        -- >     = doc
        -- >       >>>
        -- >       insertTreeTemplate template pattern
        -- >     where
        -- >     doc                                                                -- the input data
        -- >        = constA "<x><y>The Title</y><z>The content</z></x>"
        -- >          >>> xread
        -- >     template                                                           -- the output template with 2 holes: xxx and yyy
        -- >        = constA "<html><head><title>xxx</title></head><body><h1>yyy</h1></body></html>"
        -- >          >>> xread
        -- >     pattern
        -- >        = [ hasText (== "xxx")                                          -- fill the xxx hole with the input contents from element "x/y"
        -- >            :-> ( getChildren >>> hasName "y" >>> deep isText )
        -- >
        -- >          , hasText (== "yyy")                                          -- fill the yyy hole with the input contents from element "x/z"
        -- >            :-> ( getChildren >>> hasName "z" >>> getChildren )
        -- >          ]
        --
        -- computes the XML tree for the following document
        --
        -- > "<html><head><title>The Title</title></head><body><h1>The content</h1></body></html>"

        insertTreeTemplate  :: Tree t =>
                               a (t b) (t b) ->                                     -- the the template
                               [IfThen (a (t b) c) (a (t b) (t b))] ->              -- the list of nodes in the template to be substituted
                               a (t b) (t b)
        insertTreeTemplate template choices
            = insertTree $< this
              where
              insertTree t
                  = template                                        -- swap input and template
                    >>>
                    processTemplate
                  where
                  processTemplate
                      = choiceA choices'                            -- check whether node is a "hole" within the template
                        `orElse`
                        processChildren processTemplate             -- else descent into template tree
                  choices'
                      = map feedTree choices                        -- modify choices, such that the input is feed into the action arrows
                  feedTree (cond :-> action)
                      = cond :-> (constA t >>> action)              -- the real input becomes the input at the holes