uniplate 1.6.7 → 1.6.8
raw patch · 9 files changed
+91/−32 lines, 9 filesdep ~unordered-containers
Dependency ranges changed: unordered-containers
Files
- Data/Generics/Str.hs +9/−9
- Data/Generics/Uniplate/Direct.hs +21/−4
- Data/Generics/Uniplate/Internal/Data.hs +9/−0
- Data/Generics/Uniplate/Internal/DataInc.hs +5/−0
- Data/Generics/Uniplate/Internal/DataOnlyOperations.hs +1/−1
- Data/Generics/Uniplate/Internal/OperationsInc.hs +31/−10
- Data/Generics/Uniplate/Internal/Utils.hs +12/−5
- Data/Generics/Uniplate/Operations.hs +1/−1
- uniplate.cabal +2/−2
Data/Generics/Str.hs view
@@ -25,21 +25,21 @@ _ == _ = False instance Functor Str where- fmap f Zero = Zero- fmap f (One x) = One (f x)- fmap f (Two x y) = Two (fmap f x) (fmap f y)+ fmap f Zero = Zero+ fmap f (One x) = One (f x)+ fmap f (Two x y) = Two (fmap f x) (fmap f y) instance Foldable Str where- foldMap m Zero = mempty- foldMap m (One x) = m x- foldMap m (Two l r) = foldMap m l `mappend` foldMap m r+ foldMap m Zero = mempty+ foldMap m (One x) = m x+ foldMap m (Two l r) = foldMap m l `mappend` foldMap m r instance Traversable Str where- traverse f Zero = pure Zero- traverse f (One x) = One <$> f x- traverse f (Two x y) = Two <$> traverse f x <*> traverse f y+ traverse f Zero = pure Zero+ traverse f (One x) = One <$> f x+ traverse f (Two x y) = Two <$> traverse f x <*> traverse f y -- | Take the type of the method, will crash if called
Data/Generics/Uniplate/Direct.hs view
@@ -66,27 +66,44 @@ -- The following rule can be used for optimisation: -- -- > plate Ctor |- x == plate (Ctor x)-{-# INLINE plate #-}+{-# INLINE[1] plate #-} plate :: from -> Type from to plate f = (Zero, \_ -> f) +{-# RULES+"plate/-" forall f x. plate f |- x = plate (f x)+"plate/+" forall f x. plate f |+ x = platePlus f x+"plate/*" forall f x. plate f |* x = plateStar f x+ #-}+++{-# INLINE plateStar #-}+plateStar :: (to -> from) -> to -> Type from to+plateStar f x = (One x, \(One x) -> f x)++{-# INLINE platePlus #-}+platePlus :: Biplate item to => (item -> from) -> item -> Type from to+platePlus f x = case biplate x of+ (ys,y_) -> (ys, \ys -> f $ y_ ys)++ -- | The field to the right is the target.-{-# INLINE (|*) #-}+{-# INLINE[1] (|*) #-} (|*) :: Type (to -> from) to -> to -> Type from to (|*) (xs,x_) y = (Two xs (One y),\(Two xs (One y)) -> x_ xs y) -- | The field to the right may contain the target.-{-# INLINE (|+) #-}+{-# INLINE[1] (|+) #-} (|+) :: Biplate item to => Type (item -> from) to -> item -> Type from to (|+) (xs,x_) y = case biplate y of (ys,y_) -> (Two xs ys, \(Two xs ys) -> x_ xs (y_ ys)) -- | The field to the right /does not/ contain the target.-{-# INLINE (|-) #-}+{-# INLINE[1] (|-) #-} (|-) :: Type (item -> from) to -> item -> Type from to (|-) (xs,x_) y = (xs,\xs -> x_ xs y)
Data/Generics/Uniplate/Internal/Data.hs view
@@ -322,6 +322,15 @@ Follow -> gmapT (descendBiData oracle op) x Miss -> x +descendDataM :: (Data on, Monad m) => (forall a . Typeable a => a -> Answer on) -> (on -> m on) -> on -> m on+descendDataM oracle op = gmapM (descendBiDataM oracle op)++descendBiDataM :: (Data on, Data with, Monad m) => (forall a . Typeable a => a -> Answer with) -> (with -> m with) -> on -> m on+descendBiDataM oracle op x = case oracle x of+ Hit y -> unsafeCoerce $ op y+ Follow -> gmapM (descendBiDataM oracle op) x+ Miss -> return x+ --------------------------------------------------------------------- -- FUSION
Data/Generics/Uniplate/Internal/DataInc.hs view
@@ -8,6 +8,9 @@ descend = descendData $ fromOracle answer where answer = hitTest (undefined :: a) (undefined :: a) + descendM = descendDataM $ fromOracle answer+ where answer = hitTest (undefined :: a) (undefined :: a)+ instance (Data a, Data b, Uniplate b) => Biplate a b where biplate = biplateData $ fromOracle answer where answer = hitTest (undefined :: a) (undefined :: b)@@ -15,3 +18,5 @@ descendBi = descendBiData $ fromOracle answer where answer = hitTest (undefined :: a) (undefined :: b) + descendBiM = descendBiDataM $ fromOracle answer+ where answer = hitTest (undefined :: a) (undefined :: b)
Data/Generics/Uniplate/Internal/DataOnlyOperations.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, MultiParamTypeClasses #-}+{-# LANGUAGE CPP, MultiParamTypeClasses, BangPatterns #-} module Data.Generics.Uniplate.Internal.DataOnlyOperations where
Data/Generics/Uniplate/Internal/OperationsInc.hs view
@@ -1,4 +1,4 @@-import Control.Monad(liftM)+import Control.Monad(liftM,liftM2) import Data.Traversable import Prelude hiding (mapM) import Data.Generics.Str@@ -39,16 +39,27 @@ -- > descend f (Val i ) = Val i -- > descend f (Neg a ) = Neg (f a) -- > descend f (Add a b) = Add (f a) (f b)+ {-# INLINE descend #-} descend :: (on -> on) -> on -> on- descend f x = generate $ fmap f current- where (current, generate) = uniplate x+ descend f x = case uniplate x of+ (current, generate) -> generate $ g current+ where+ g Zero = Zero+ g (One x) = One $ f x+ g (Two x y) = Two (g x) (g y) - -- | Monadic variant of 'descend' + -- | Monadic variant of 'descend'+ {-# INLINE descendM #-} descendM :: Monad m => (on -> m on) -> on -> m on- descendM f x = liftM generate $ mapM f current- where (current, generate) = uniplate x+ descendM f x = case uniplate x of+ (current, generate) -> liftM generate $ g SPEC current+ where+ g !spec Zero = return Zero+ g !spec (One x) = liftM One $ f x+ g !spec (Two x y) = liftM2 Two (g spec x) (g spec y) + -- | Children are defined as the top-most items of type to -- /starting at the root/. All instances must define 'biplate', while -- 'descendBi' and 'descendBiM' are optional.@@ -65,14 +76,23 @@ -- highly unlikely that this function should be used in the recursive case. -- A common pattern is to first match the types using 'descendBi', then continue -- the recursion with 'descend'.+ {-# INLINE descendBi #-} descendBi :: (to -> to) -> from -> from- descendBi f x = generate $ fmap f current- where (current, generate) = biplate x+ descendBi f x = case biplate x of+ (current, generate) -> generate $ g current+ where+ g Zero = Zero+ g (One x) = One $ f x+ g (Two x y) = Two (g x) (g y) descendBiM :: Monad m => (to -> m to) -> from -> m from- descendBiM f x = liftM generate $ mapM f current- where (current, generate) = biplate x+ descendBiM f x = case biplate x of+ (current, generate) -> liftM generate $ g SPEC current+ where+ g !spec Zero = return Zero+ g !spec (One x) = liftM One $ f x+ g !spec (Two x y) = liftM2 Two (g spec x) (g spec y) -- * Single Type Operations@@ -195,6 +215,7 @@ -- | Return the children of a type. If @to == from@ then it returns the -- original element (in contrast to 'children')+-- FIXME: Was confusing to Roman childrenBi :: Biplate from to => from -> [to] childrenBi x = builder f where
Data/Generics/Uniplate/Internal/Utils.hs view
@@ -1,11 +1,9 @@ {-# LANGUAGE CPP, Rank2Types, MagicHash, UnboxedTuples, ExistentialQuantification #-}--{- |- Internal module, do not import or use.--}+{-# OPTIONS_GHC -fno-warn-unused-binds #-} -- SPEC2 +-- | Internal module, do not import or use. module Data.Generics.Uniplate.Internal.Utils(- unsafeCoerce, builder, unsafePerformIO, inlinePerformIO, concatCont+ unsafeCoerce, builder, unsafePerformIO, inlinePerformIO, concatCont, SPEC(SPEC) ) where #if __GLASGOW_HASKELL__ >= 702@@ -24,7 +22,12 @@ #endif #endif +#if __GLASGOW_HASKELL__ >= 701+import GHC.Exts(SpecConstrAnnotation(..))+{-# ANN type SPEC ForceSpecConstr #-}+#endif + {-# INLINE builder #-} -- | GHCs @foldr@\/@build@ system, but on all platforms #ifdef __GLASGOW_HASKELL__@@ -50,3 +53,7 @@ -- | Perform concatentation of continuations concatCont :: [a -> a] -> a -> a concatCont xs rest = foldr ($) rest xs+++-- | Constructor specialisation on newer GHC+data SPEC = SPEC | SPEC2
Data/Generics/Uniplate/Operations.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, MultiParamTypeClasses #-}+{-# LANGUAGE CPP, MultiParamTypeClasses, BangPatterns #-} {- | Definitions of 'Uniplate' and 'Biplate' classes, along with all the standard operations.
uniplate.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.6 build-type: Simple name: uniplate-version: 1.6.7+version: 1.6.8 author: Neil Mitchell <ndmitchell@gmail.com> maintainer: Neil Mitchell <ndmitchell@gmail.com> copyright: Neil Mitchell 2006-2012@@ -57,7 +57,7 @@ build-depends: base >=4.4 && <5, containers, syb, hashable >= 1.1.2.3 && < 1.2,- unordered-containers >= 0.1 && < 0.3+ unordered-containers >= 0.2.1 && < 0.3 else if flag(separate_syb) build-depends: base >=4 && <4.4, containers, syb