    {-# LANGUAGE RankNTypes, ScopedTypeVariables, CPP #-}
    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Data.Generics.Schemes
    -- Copyright   :  (c) The University of Glasgow, CWI 2001--2003
    -- License     :  BSD-style (see the LICENSE file)
    --
    -- Maintainer  :  generics@haskell.org
    -- Stability   :  experimental
    -- Portability :  non-portable (local universal quantification)
    --
    -- \"Scrap your boilerplate\" --- Generic programming in Haskell
    -- See <http://www.cs.uu.nl/wiki/GenericProgramming/SYB>. The present module
    -- provides frequently used generic traversal schemes.
    --
    -----------------------------------------------------------------------------

    module Data.Generics.Schemes (

            everywhere,
            everywhere',
            everywhereBut,
            everywhereM,
            somewhere,
            everything,
            everythingBut,
            everythingWithContext,
            listify,
            something,
            synthesize,
            gsize,
            glength,
            gdepth,
            gcount,
            gnodecount,
            gtypecount,
            gfindtype

     ) where

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

    #ifdef __HADDOCK__
    import Prelude
    #endif
    import Data.Data
    import Data.Generics.Aliases
    import Control.Monad

    -- | Apply a transformation everywhere in bottom-up manner

    everywhere :: (forall a. Data a => a -> a)
               -> (forall a. Data a => a -> a)

    -- Use gmapT to recurse into immediate subterms;
    -- recall: gmapT preserves the outermost constructor;
    -- post-process recursively transformed result via f
    --
    everywhere f = go
      where
        go :: forall a. Data a => a -> a
        go = f . gmapT go

    -- | Apply a transformation everywhere in top-down manner
    everywhere' :: (forall a. Data a => a -> a)
                -> (forall a. Data a => a -> a)

    -- Arguments of (.) are flipped compared to everywhere
    everywhere' f = go
      where
        go :: forall a. Data a => a -> a
        go = gmapT go . f

    -- | Variation on everywhere with an extra stop condition
    everywhereBut :: GenericQ Bool -> GenericT -> GenericT

    -- Guarded to let traversal cease if predicate q holds for x
    everywhereBut q f = go
      where
        go :: GenericT
        go x
          | q x       = x
          | otherwise = f (gmapT go x)

    -- | Monadic variation on everywhere
    everywhereM :: forall m. Monad m => GenericM m -> GenericM m

    -- Bottom-up order is also reflected in order of do-actions
    everywhereM f = go
      where
        go :: GenericM m
        go x = do
          x' <- gmapM go x
          f x'

    -- | Apply a monadic transformation at least somewhere
    somewhere :: forall m. MonadPlus m => GenericM m -> GenericM m

    -- We try "f" in top-down manner, but descent into "x" when we fail
    -- at the root of the term. The transformation fails if "f" fails
    -- everywhere, say succeeds nowhere.
    --
    somewhere f = go
      where
        go :: GenericM m
        go x = f x `mplus` gmapMp go x

    -- | Summarise all nodes in top-down, left-to-right order
    everything :: forall r. (r -> r -> r) -> GenericQ r -> GenericQ r

    -- Apply f to x to summarise top-level node;
    -- use gmapQ to recurse into immediate subterms;
    -- use ordinary foldl to reduce list of intermediate results
    --
    everything k f = go
      where
        go :: GenericQ r
        go x = foldl k (f x) (gmapQ go x)

    -- | Variation of "everything" with an added stop condition
    everythingBut :: forall r. (r -> r -> r) -> GenericQ (r, Bool) -> GenericQ r
    everythingBut k f = go
      where
        go :: GenericQ r
        go x = let (v, stop) = f x
               in if stop
                    then v
                    else foldl k v (gmapQ go x)

    -- | Summarise all nodes in top-down, left-to-right order, carrying some state
    -- down the tree during the computation, but not left-to-right to siblings.
    everythingWithContext :: forall s r. s -> (r -> r -> r) -> GenericQ (s -> (r, s)) -> GenericQ r
    everythingWithContext s0 f q = go s0
      where
        go :: s -> GenericQ r
        go s x = foldl f r (gmapQ (go s') x)
          where (r, s') = q x s

    -- | Get a list of all entities that meet a predicate
    listify :: Typeable r => (r -> Bool) -> GenericQ [r]
    listify p = everything (++) ([] `mkQ` (\x -> if p x then [x] else []))

    -- | Look up a subterm by means of a maybe-typed filter
    something :: GenericQ (Maybe u) -> GenericQ (Maybe u)

    -- "something" can be defined in terms of "everything"
    -- when a suitable "choice" operator is used for reduction
    --
    something = everything orElse

    -- | Bottom-up synthesis of a data structure;
    --   1st argument z is the initial element for the synthesis;
    --   2nd argument o is for reduction of results from subterms;
    --   3rd argument f updates the synthesised data according to the given term
    --
    synthesize :: forall s t. s  -> (t -> s -> s) -> GenericQ (s -> t) -> GenericQ t
    synthesize z o f = go
      where
        go :: GenericQ t
        go x = f x (foldr o z (gmapQ go x))

    -- | Compute size of an arbitrary data structure
    gsize :: Data a => a -> Int
    gsize t = 1 + sum (gmapQ gsize t)

    -- | Count the number of immediate subterms of the given term
    glength :: GenericQ Int
    glength = length . gmapQ (const ())

    -- | Determine depth of the given term
    gdepth :: GenericQ Int
    gdepth = (+) 1 . foldr max 0 . gmapQ gdepth

    -- | Determine the number of all suitable nodes in a given term
    gcount :: GenericQ Bool -> GenericQ Int
    gcount p =  everything (+) (\x -> if p x then 1 else 0)

    -- | Determine the number of all nodes in a given term
    gnodecount :: GenericQ Int
    gnodecount = gcount (const True)

    -- | Determine the number of nodes of a given type in a given term
    gtypecount :: Typeable a => a -> GenericQ Int
    gtypecount (_::a) = gcount (False `mkQ` (\(_::a) -> True))

    -- | Find (unambiguously) an immediate subterm of a given type
    gfindtype :: (Data x, Typeable y) => x -> Maybe y
    gfindtype = singleton
              . foldl unJust []
              . gmapQ (Nothing `mkQ` Just)
     where
      unJust l (Just x) = x:l
      unJust l Nothing  = l
      singleton [s] = Just s
      singleton _   = Nothing