{-# 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 :: (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere forall a. Data a => a -> a
f = a -> a
forall a. Data a => a -> a
go
  where
    go :: forall a. Data a => a -> a
    go :: a -> a
go = a -> a
forall a. Data a => a -> a
f (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Data a => a -> a) -> a -> a
forall a. Data a => (forall a. Data a => a -> a) -> a -> a
gmapT forall a. Data a => a -> a
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' :: (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere' forall a. Data a => a -> a
f = a -> a
forall a. Data a => a -> a
go
  where
    go :: forall a. Data a => a -> a
    go :: a -> a
go = (forall a. Data a => a -> a) -> a -> a
forall a. Data a => (forall a. Data a => a -> a) -> a -> a
gmapT forall a. Data a => a -> a
go (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
forall a. Data a => a -> a
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 :: GenericQ Bool
-> (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhereBut GenericQ Bool
q forall a. Data a => a -> a
f = a -> a
forall a. Data a => a -> a
go
  where
    go :: GenericT
    go :: a -> a
go a
x
      | a -> Bool
GenericQ Bool
q a
x       = a
x
      | Bool
otherwise = a -> a
forall a. Data a => a -> a
f ((forall a. Data a => a -> a) -> a -> a
forall a. Data a => (forall a. Data a => a -> a) -> a -> a
gmapT forall a. Data a => a -> a
go a
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 :: GenericM m -> GenericM m
everywhereM GenericM m
f = a -> m a
GenericM m
go
  where
    go :: GenericM m
    go :: a -> m a
go a
x = do
      a
x' <- GenericM m -> a -> m a
forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> a -> m a
gmapM GenericM m
go a
x
      a -> m a
GenericM m
f a
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 :: GenericM m -> GenericM m
somewhere GenericM m
f = a -> m a
GenericM m
go
  where
    go :: GenericM m
    go :: a -> m a
go a
x = a -> m a
GenericM m
f a
x m a -> m a -> m a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` GenericM m -> a -> m a
forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d) -> a -> m a
gmapMp GenericM m
go a
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 :: (r -> r -> r) -> GenericQ r -> GenericQ r
everything r -> r -> r
k GenericQ r
f = a -> r
GenericQ r
go
  where
    go :: GenericQ r
    go :: a -> r
go a
x = (r -> r -> r) -> r -> [r] -> r
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl r -> r -> r
k (a -> r
GenericQ r
f a
x) (GenericQ r -> a -> [r]
forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
gmapQ GenericQ r
go a
x)

-- | Variation of "everything" with an added stop condition
everythingBut :: forall r. (r -> r -> r) -> GenericQ (r, Bool) -> GenericQ r
everythingBut :: (r -> r -> r) -> GenericQ (r, Bool) -> GenericQ r
everythingBut r -> r -> r
k GenericQ (r, Bool)
f = a -> r
GenericQ r
go
  where
    go :: GenericQ r
    go :: a -> r
go a
x = let (r
v, Bool
stop) = a -> (r, Bool)
GenericQ (r, Bool)
f a
x
           in if Bool
stop
                then r
v
                else (r -> r -> r) -> r -> [r] -> r
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl r -> r -> r
k r
v (GenericQ r -> a -> [r]
forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
gmapQ GenericQ r
go a
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 :: s -> (r -> r -> r) -> GenericQ (s -> (r, s)) -> GenericQ r
everythingWithContext s
s0 r -> r -> r
f GenericQ (s -> (r, s))
q = s -> GenericQ r
go s
s0
  where
    go :: s -> GenericQ r
    go :: s -> GenericQ r
go s
s a
x = (r -> r -> r) -> r -> [r] -> r
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl r -> r -> r
f r
r (GenericQ r -> a -> [r]
forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
gmapQ (s -> GenericQ r
go s
s') a
x)
      where (r
r, s
s') = a -> s -> (r, s)
GenericQ (s -> (r, s))
q a
x s
s

-- | Get a list of all entities that meet a predicate
listify :: Typeable r => (r -> Bool) -> GenericQ [r]
listify :: (r -> Bool) -> GenericQ [r]
listify r -> Bool
p = ([r] -> [r] -> [r]) -> GenericQ [r] -> GenericQ [r]
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything [r] -> [r] -> [r]
forall a. [a] -> [a] -> [a]
(++) ([] [r] -> (r -> [r]) -> a -> [r]
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
`mkQ` (\r
x -> if r -> Bool
p r
x then [r
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 :: GenericQ (Maybe u) -> GenericQ (Maybe u)
something = (Maybe u -> Maybe u -> Maybe u)
-> GenericQ (Maybe u) -> GenericQ (Maybe u)
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything Maybe u -> Maybe u -> Maybe u
forall a. Maybe a -> Maybe a -> Maybe a
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 :: s -> (t -> s -> s) -> GenericQ (s -> t) -> GenericQ t
synthesize s
z t -> s -> s
o GenericQ (s -> t)
f = a -> t
GenericQ t
go
  where
    go :: GenericQ t
    go :: a -> t
go a
x = a -> s -> t
GenericQ (s -> t)
f a
x ((t -> s -> s) -> s -> [t] -> s
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr t -> s -> s
o s
z (GenericQ t -> a -> [t]
forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
gmapQ GenericQ t
go a
x))


-- | Compute size of an arbitrary data structure
gsize :: Data a => a -> Int
gsize :: a -> Int
gsize a
t = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((forall d. Data d => d -> Int) -> a -> [Int]
forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
gmapQ forall d. Data d => d -> Int
gsize a
t)


-- | Count the number of immediate subterms of the given term
glength :: GenericQ Int
glength :: a -> Int
glength = [()] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([()] -> Int) -> (a -> [()]) -> a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall d. Data d => d -> ()) -> a -> [()]
forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
gmapQ (() -> d -> ()
forall a b. a -> b -> a
const ())


-- | Determine depth of the given term
gdepth :: GenericQ Int
gdepth :: a -> Int
gdepth = Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Int
1 (Int -> Int) -> (a -> Int) -> a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int) -> Int -> [Int] -> Int
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 ([Int] -> Int) -> (a -> [Int]) -> a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall d. Data d => d -> Int) -> a -> [Int]
forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
gmapQ forall d. Data d => d -> Int
gdepth


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


-- | Determine the number of all nodes in a given term
gnodecount :: GenericQ Int
gnodecount :: a -> Int
gnodecount = GenericQ Bool -> forall d. Data d => d -> Int
gcount (Bool -> a -> Bool
forall a b. a -> b -> a
const Bool
True)


-- | Determine the number of nodes of a given type in a given term
gtypecount :: Typeable a => a -> GenericQ Int
gtypecount :: a -> forall d. Data d => d -> Int
gtypecount (a
_::a) = GenericQ Bool -> forall d. Data d => d -> Int
gcount (Bool
False Bool -> (a -> Bool) -> a -> Bool
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
`mkQ` (\(a
_::a) -> Bool
True))


-- | Find (unambiguously) an immediate subterm of a given type
gfindtype :: (Data x, Typeable y) => x -> Maybe y
gfindtype :: x -> Maybe y
gfindtype = [y] -> Maybe y
forall a. [a] -> Maybe a
singleton
          ([y] -> Maybe y) -> (x -> [y]) -> x -> Maybe y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([y] -> Maybe y -> [y]) -> [y] -> [Maybe y] -> [y]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [y] -> Maybe y -> [y]
forall a. [a] -> Maybe a -> [a]
unJust []
          ([Maybe y] -> [y]) -> (x -> [Maybe y]) -> x -> [y]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall d. Data d => d -> Maybe y) -> x -> [Maybe y]
forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
gmapQ (Maybe y
forall a. Maybe a
Nothing Maybe y -> (y -> Maybe y) -> d -> Maybe y
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
`mkQ` y -> Maybe y
forall a. a -> Maybe a
Just)
 where
  unJust :: [a] -> Maybe a -> [a]
unJust [a]
l (Just a
x) = a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
l
  unJust [a]
l Maybe a
Nothing  = [a]
l
  singleton :: [a] -> Maybe a
singleton [a
s] = a -> Maybe a
forall a. a -> Maybe a
Just a
s
  singleton [a]
_   = Maybe a
forall a. Maybe a
Nothing