diff options
Diffstat (limited to 'haddock-api/src/Haddock/Syb.hs')
| -rw-r--r-- | haddock-api/src/Haddock/Syb.hs | 55 |
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. |