-- | 
-- Lightweight generic traversals for Haskell.
-- See <http://www-ps.informatik.uni-kiel.de/~sebf/projects/traversal.html>
--
module Traversal where

import Monad

-- |
-- A datatype is @Traversable@ if it defines the function @scrap@
-- that can decompose a value into a list of children of the same type
-- and recombine new children to a new value of the original type. 
--
class Traversable a b
 where scrap :: a -> ([b],[b] -> a)

-- |
-- Yields the children of a value.
--
children :: Traversable a b => a -> [b]
children = fst . scrap

-- |
-- Replaces the children of a value.
-- 
replaceChildren :: Traversable a b => a -> [b] -> a
replaceChildren = snd . scrap

-- |
-- Applies the given function to each child of a value.
--
mapChildren :: Traversable a b => (b -> b) -> a -> a
mapChildren f a = rep (map f cs)
 where (cs,rep) = scrap a

-- |
-- Computes a list of the given value, its children, those children, etc.
--
family :: Traversable a a => a -> [a]
family a = a : childFamilies a

-- |
-- Computes a list of family members of the children of a value.
-- The value and its children can have different types.
--
childFamilies :: (Traversable a b, Traversable b b) => a -> [b]
childFamilies = concatMap family . children

-- |
-- Applies the given function to each member of the family of a value.
-- Proceeds bottom-up.
--
mapFamily :: Traversable a a => (a -> a) -> a -> a
mapFamily f = f . mapChildFamilies f

-- |
-- Applies the given function to each member of the families of the children
-- of a value. The value and its children can have different types.
-- Proceeds bottom-up.
--
mapChildFamilies :: (Traversable a b, Traversable b b) => (b -> b) -> a -> a
mapChildFamilies = mapChildren . mapFamily

-- |
-- Applies the given function to each member of the family of a value 
-- as long as possible. On each member of the family of the result the given
-- function will yield @Nothing@.
-- Proceeds bottom-up.
--
evalFamily :: Traversable a a => (a -> Maybe a) -> a -> a
evalFamily f = mapFamily g
 where g x = maybe x (mapFamily g) (f x)

-- |
-- Applies the given function to each member of the families of the children
-- of a value as long as possible.
-- Similar to 'evalFamily'.
--
evalChildFamilies :: (Traversable a b, Traversable b b)
                  => (b -> Maybe b) -> a -> a
evalChildFamilies = mapChildren . evalFamily

-- |
-- Implements a traversal similar to a fold with possible default cases.
--
fold :: Traversable a a => (a -> [r] -> r) -> a -> r
fold f = foldChildren f f

-- |
-- Fold the children and combine the results.
--
foldChildren :: (Traversable a b, Traversable b b)
             => (a -> [rb] -> ra) -> (b -> [rb] -> rb) -> a -> ra
foldChildren f g a = f a (map (fold g) (children a))


-- |
-- Monadic variant of 'replaceChildren'.
--
replaceChildrenM :: (Monad m, Traversable a b) => a -> m [b] -> m a
replaceChildrenM = liftM . replaceChildren

-- |
-- Monadic variant of 'mapChildren'.
--
mapChildrenM :: (Monad m, Traversable a b) => (b -> m b) -> a -> m a
mapChildrenM f a = replaceChildrenM a (mapM f (children a))

-- |
-- Monadic variant of 'mapFamily'.
--
mapFamilyM :: (Monad m, Traversable a a) => (a -> m a) -> a -> m a
mapFamilyM f a = f =<< mapChildFamiliesM f a

-- |
-- Monadic variant of 'mapChildFamilies'.
--
mapChildFamiliesM :: (Monad m, Traversable a b, Traversable b b)
                  => (b -> m b) -> a -> m a
mapChildFamiliesM = mapChildrenM . mapFamilyM

-- |
-- Monadic variant of 'evalFamily'.
--
evalFamilyM :: (Monad m, Traversable a a) => (a -> m (Maybe a)) -> a -> m a
evalFamilyM f = mapFamilyM g
 where g x = maybe (return x) (mapFamilyM g) =<< f x

-- |
-- Monadic variant of 'evalChildFamilies'.
--
evalChildFamiliesM :: (Monad m, Traversable a b, Traversable b b)
                   => (b -> m (Maybe b)) -> a -> m a
evalChildFamiliesM = mapChildrenM . evalFamilyM