Merge remote-tracking branch 'origin/master' into ghc-head

1 files changed, 49 insertions, 6 deletions

diff --git a/haddock-api/src/Haddock/Syb.hs b/haddock-api/src/Haddock/Syb.hs
index 4847e486..7e34ae8c 100644
--- a/haddock-api/src/Haddock/Syb.hs
+++ b/haddock-api/src/Haddock/Syb.hs
@@ -1,8 +1,11 @@
 {-# LANGUAGE Rank2Types #-}
-
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Haddock.Syb
-    ( everything, everythingWithState, everywhere
+    ( everything, everythingButType, everythingWithState
+    , everywhere, everywhereButType
     , mkT
     , combine
     ) where
@@ -10,16 +13,41 @@ module Haddock.Syb
 
 import Data.Data
 import Control.Applicative
+import Data.Maybe
+import Data.Foldable
 
+-- | Returns true if a == t.
+-- requires AllowAmbiguousTypes
+isType :: forall a b. (Typeable a, Typeable b) => b -> Bool
+isType _ = isJust $ eqT @a @b
 
 -- | Perform a query on each level of a tree.
 --
 -- This is stolen directly from SYB package and copied here to not introduce
 -- additional dependencies.
-everything :: (r -> r -> r) -> (forall a. Data a => a -> r)
+everything :: (r -> r -> r)
+           -> (forall a. Data a => a -> r)
            -> (forall a. Data a => a -> r)
-everything k f x = foldl k (f x) (gmapQ (everything k f) x)
+everything k f x = foldl' k (f x) (gmapQ (everything k f) x)
+
+-- | Variation of "everything" with an added stop condition
+-- Just like 'everything', this is stolen from SYB package.
+everythingBut :: (r -> r -> r)
+              -> (forall a. Data a => a -> (r, Bool))
+              -> (forall a. Data a => a -> r)
+everythingBut k f x = let (v, stop) = f x
+                      in if stop
+                           then v
+                           else foldl' k v (gmapQ (everythingBut k f) x)
 
+-- | Variation of "everything" that does not recurse into children of type t
+-- requires AllowAmbiguousTypes
+everythingButType ::
+  forall t r. (Typeable t)
+  => (r -> r -> r)
+  -> (forall a. Data a => a -> r)
+  -> (forall a. Data a => a -> r)
+everythingButType k f = everythingBut k $ (,) <$> f <*> isType @t
 
 -- | Perform a query with state on each level of a tree.
 --
@@ -31,8 +59,7 @@ everythingWithState :: s -> (r -> r -> r)
                     -> (forall a. Data a => a -> r)
 everythingWithState s k f x =
     let (r, s') = f x s
-    in foldl k r (gmapQ (everythingWithState s' k f) x)
-
+    in foldl' k r (gmapQ (everythingWithState s' k f) x)
 
 -- | Apply transformation on each level of a tree.
 --
@@ -40,6 +67,22 @@ everythingWithState s k f x =
 everywhere :: (forall a. Data a => a -> a) -> (forall a. Data a => a -> a)
 everywhere f = f . gmapT (everywhere f)
 
+-- | Variation on everywhere with an extra stop condition
+-- Just like 'everything', this is stolen from SYB package.
+everywhereBut :: (forall a. Data a => a -> Bool)
+  -> (forall a. Data a => a -> a)
+  -> (forall a. Data a => a -> a)
+everywhereBut q f x
+    | q x       = x
+    | otherwise = f (gmapT (everywhereBut q f) x)
+
+-- | Variation of "everywhere" that does not recurse into children of type t
+-- requires AllowAmbiguousTypes
+everywhereButType :: forall t . (Typeable t)
+  => (forall a. Data a => a -> a)
+  -> (forall a. Data a => a -> a)
+everywhereButType = everywhereBut (isType @t)
+
 -- | Create generic transformation.
 --
 -- Another function stolen from SYB package.