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

{- |
   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.
    -- Attantion: 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