Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Switched .Combinators to {-# RULES #-} instead of explicit unsafeCoerce

Unfortunately this interacts badly and causes eta-expansion in cases
like `over mapped` in its current form.
  • Loading branch information...
commit e30aee4cf5d5a4cab5686d9da03e25fbf90aa09b 1 parent 5111ab8
@shachaf shachaf authored
View
7 src/Control/Lens/Action.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE MagicHash #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-----------------------------------------------------------------------------
@@ -61,12 +60,12 @@ type Acting m r s t a b = (a -> Effect m r b) -> s -> Effect m r t
--
-- @'perform' ≡ 'flip' ('^!')@
perform :: Monad m => Acting m a s t a b -> s -> m a
-perform l = getEffect# (l (effect# return))
+perform l = getEffect # (l (_Effect # return))
{-# INLINE perform #-}
-- | Perform an 'Action' and modify the result.
performs :: Monad m => Acting m e s t a b -> (a -> e) -> s -> m e
-performs l f = getEffect# (l (effect# (return . f)))
+performs l f = getEffect # (l (_Effect # (return . f)))
-- | Perform an 'Action'
--
@@ -74,7 +73,7 @@ performs l f = getEffect# (l (effect# (return . f)))
-- hello
-- world
(^!) :: Monad m => s -> Acting m a s t a b -> m a
-a ^! l = getEffect (l (effect# return) a)
+a ^! l = getEffect (l (_Effect # return) a)
{-# INLINE (^!) #-}
-- | Construct an 'Action' from a monadic side-effect
View
20 src/Control/Lens/Classes.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE MagicHash #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
@@ -47,15 +46,6 @@ import Data.Functor.Compose
import Data.Functor.Identity
import Data.Monoid
import Prelude hiding ((.),id)
-#ifndef SAFE
-import Unsafe.Coerce
-#endif
-
-#ifndef SAFE
-#define UNSAFELY(x) unsafeCoerce
-#else
-#define UNSAFELY(f) (\g -> g `seq` \x -> (f) (g x))
-#endif
-------------------------------------------------------------------------------
@@ -116,19 +106,9 @@ instance Effective m r f => Effective m (Dual r) (Backwards f) where
class Applicative f => Settable f where
untainted :: f a -> a
- untainted# :: (a -> f b) -> a -> b
- untainted# g = g `seq` \x -> untainted (g x)
-
- tainted# :: (a -> b) -> a -> f b
- tainted# g = g `seq` \x -> pure (g x)
-
-- | so you can pass our a 'Control.Lens.Setter.Setter' into combinators from other lens libraries
instance Settable Identity where
untainted = runIdentity
- untainted# = UNSAFELY(runIdentity)
- {-# INLINE untainted #-}
- tainted# = UNSAFELY(Identity)
- {-# INLINE tainted# #-}
-- | 'Control.Lens.Fold.backwards'
instance Settable f => Settable (Backwards f) where
View
49 src/Control/Lens/Fold.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE MagicHash #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LiberalTypeSynonyms #-}
@@ -136,7 +135,7 @@ folding sfa agb = coerce . traverse_ agb . sfa
-- >>> [(1,2),(3,4)]^..folded.both
-- [1,2,3,4]
folded :: Foldable f => Fold (f a) a
-folded f = coerce . getFolding . foldMap (folding# f)
+folded f = coerce # getFolding # foldMap (Folding # f)
{-# INLINE folded #-}
-- | Fold by repeating the input forever.
@@ -216,7 +215,7 @@ filtered p f a
--
-- To change the direction of an 'Control.Lens.Iso.Iso', use 'Control.Lens.Isomorphic.from'.
backwards :: LensLike (Backwards f) s t a b -> LensLike f s t a b
-backwards l f = forwards# $ l (backwards# f)
+backwards l f = forwards # l (Backwards # f)
{-# INLINE backwards #-}
-- | Obtain a 'Fold' by taking elements from another 'Fold', 'Lens', 'Control.Lens.Iso.Iso', 'Getter' or 'Control.Lens.Traversal.Traversal' while a predicate holds.
@@ -266,7 +265,7 @@ droppingWhile p l f = fst . foldrOf l (\a r -> let s = f a *> snd r in if p a th
-- 'foldMapOf' :: 'Monoid' r => 'Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> r) -> s -> r
-- @
foldMapOf :: Getting r s t a b -> (a -> r) -> s -> r
-foldMapOf l f = runAccessor# (l (accessor# f))
+foldMapOf l f = runAccessor # (l (_Accessor # f))
{-# INLINE foldMapOf #-}
-- |
@@ -282,7 +281,7 @@ foldMapOf l f = runAccessor# (l (accessor# f))
-- 'foldOf' :: 'Monoid' m => 'Simple' 'Control.Lens.Traversal.Traversal' s m -> s -> m
-- @
foldOf :: Getting a s t a b -> s -> a
-foldOf l = runAccessor# (l Accessor)
+foldOf l = runAccessor # (l _Accessor)
{-# INLINE foldOf #-}
-- |
@@ -298,7 +297,7 @@ foldOf l = runAccessor# (l Accessor)
-- 'foldrOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> r -> r) -> r -> s -> r
-- @
foldrOf :: Getting (Endo r) s t a b -> (a -> r -> r) -> r -> s -> r
-foldrOf l f z t = appEndo (foldMapOf l (endo# f) t) z
+foldrOf l f z t = appEndo (foldMapOf l (_Endo # f) t) z
{-# INLINE foldrOf #-}
-- |
@@ -314,7 +313,7 @@ foldrOf l f z t = appEndo (foldMapOf l (endo# f) t) z
-- 'foldlOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> (r -> a -> r) -> r -> s -> r
-- @
foldlOf :: Getting (Dual (Endo r)) s t a b -> (r -> a -> r) -> r -> s -> r
-foldlOf l f z t = appEndo (getDual (foldMapOf l (dual# (endo# (flip f))) t)) z
+foldlOf l f z t = appEndo (getDual (foldMapOf l (_Dual # (Endo # (flip f))) t)) z
{-# INLINE foldlOf #-}
-- | Extract a list of the targets of a 'Fold'. See also ('^..').
@@ -382,7 +381,7 @@ s ^.. l = toListOf l s
-- 'andOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s 'Bool' -> s -> 'Bool'
-- @
andOf :: Getting All s t Bool b -> s -> Bool
-andOf l = getAll# (foldMapOf l All)
+andOf l = getAll # (foldMapOf l All)
{-# INLINE andOf #-}
-- | Returns 'True' if any target of a 'Fold' is 'True'.
@@ -402,7 +401,7 @@ andOf l = getAll# (foldMapOf l All)
-- 'orOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s 'Bool' -> s -> 'Bool'
-- @
orOf :: Getting Any s t Bool b -> s -> Bool
-orOf l = getAny# (foldMapOf l Any)
+orOf l = getAny # (foldMapOf l Any)
{-# INLINE orOf #-}
-- | Returns 'True' if any target of a 'Fold' satisfies a predicate.
@@ -423,7 +422,7 @@ orOf l = getAny# (foldMapOf l Any)
-- 'anyOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> 'Bool') -> s -> 'Bool'
-- @
anyOf :: Getting Any s t a b -> (a -> Bool) -> s -> Bool
-anyOf l f = getAny# $ foldMapOf l (any# f)
+anyOf l f = getAny # foldMapOf l (_Any # f)
{-# INLINE anyOf #-}
-- | Returns 'True' if every target of a 'Fold' satisfies a predicate.
@@ -443,7 +442,7 @@ anyOf l f = getAny# $ foldMapOf l (any# f)
-- 'allOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> 'Bool') -> s -> 'Bool'
-- @
allOf :: Getting All s t a b -> (a -> Bool) -> s -> Bool
-allOf l f = getAll# $ foldMapOf l (all# f)
+allOf l f = getAll # foldMapOf l (All # f)
{-# INLINE allOf #-}
-- | Calculate the product of every number targeted by a 'Fold'
@@ -463,7 +462,7 @@ allOf l f = getAll# $ foldMapOf l (all# f)
-- 'productOf' :: 'Num' a => 'Simple' 'Control.Lens.Traversal.Traversal' s a -> s -> a
-- @
productOf :: Getting (Product a) s t a b -> s -> a
-productOf l = getProduct# $ foldMapOf l Product
+productOf l = getProduct # foldMapOf l Product
{-# INLINE productOf #-}
-- | Calculate the sum of every number targeted by a 'Fold'.
@@ -493,7 +492,7 @@ productOf l = getProduct# $ foldMapOf l Product
-- 'sumOf' :: 'Num' a => 'Simple' 'Control.Lens.Traversal.Traversal' s a -> s -> a
-- @
sumOf :: Getting (Sum a) s t a b -> s -> a
-sumOf l = getSum# $ foldMapOf l Sum
+sumOf l = getSum # foldMapOf l Sum
{-# INLINE sumOf #-}
-- | Traverse over all of the targets of a 'Fold' (or 'Getter'), computing an 'Applicative' (or 'Functor') -based answer,
@@ -524,7 +523,7 @@ sumOf l = getSum# $ foldMapOf l Sum
-- 'traverseOf_' :: 'Applicative' f => 'Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> f r) -> s -> f ()
-- @
traverseOf_ :: Functor f => Getting (Traversed f) s t a b -> (a -> f r) -> s -> f ()
-traverseOf_ l f = getTraversed# (foldMapOf l (traversed# (void . f)))
+traverseOf_ l f = getTraversed # foldMapOf l (_Traversed # (void . f))
{-# INLINE traverseOf_ #-}
-- | Traverse over all of the targets of a 'Fold' (or 'Getter'), computing an 'Applicative' (or 'Functor') -based answer,
@@ -561,7 +560,7 @@ forOf_ = flip . traverseOf_
-- 'sequenceAOf_' :: 'Applicative' f => 'Simple' 'Control.Lens.Traversal.Traversal' s (f ()) -> s -> f ()
-- @
sequenceAOf_ :: Functor f => Getting (Traversed f) s t (f ()) b -> s -> f ()
-sequenceAOf_ l = getTraversed# (foldMapOf l (traversed# void))
+sequenceAOf_ l = getTraversed # foldMapOf l (_Traversed # void)
{-# INLINE sequenceAOf_ #-}
-- | Map each target of a 'Fold' on a structure to a monadic action, evaluate these actions from left to right, and ignore the results.
@@ -576,7 +575,7 @@ sequenceAOf_ l = getTraversed# (foldMapOf l (traversed# void))
-- 'mapMOf_' :: 'Monad' m => 'Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> m r) -> s -> m ()
-- @
mapMOf_ :: Monad m => Getting (Sequenced m) s t a b -> (a -> m r) -> s -> m ()
-mapMOf_ l f = getSequenced# (foldMapOf l (sequenced# (liftM skip . f)))
+mapMOf_ l f = getSequenced # (foldMapOf l (_Sequenced # (liftM skip . f)))
{-# INLINE mapMOf_ #-}
skip :: a -> ()
@@ -610,7 +609,7 @@ forMOf_ = flip . mapMOf_
-- 'sequenceOf_' :: 'Monad' m => 'Simple' 'Control.Lens.Traversal.Traversal' s (m a) -> s -> m ()
-- @
sequenceOf_ :: Monad m => Getting (Sequenced m) s t (m a) b -> s -> m ()
-sequenceOf_ l = getSequenced# (foldMapOf l (sequenced# (liftM skip)))
+sequenceOf_ l = getSequenced # (foldMapOf l (_Sequenced # liftM skip))
{-# INLINE sequenceOf_ #-}
-- | The sum of a collection of actions, generalizing 'concatOf'.
@@ -688,7 +687,7 @@ notElemOf l = allOf l . (/=)
-- 'concatMapOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> [r]) -> s -> [r]
-- @
concatMapOf :: Getting [r] s t a b -> (a -> [r]) -> s -> [r]
-concatMapOf l ces = runAccessor# (l (accessor# ces))
+concatMapOf l ces = runAccessor # l (_Accessor # ces)
{-# INLINE concatMapOf #-}
-- | Concatenate all of the lists targeted by a 'Fold' into a longer list.
@@ -730,7 +729,7 @@ concatOf = view
-- 'lengthOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> s -> 'Int'
-- @
lengthOf :: Getting (Sum Int) s t a b -> s -> Int
-lengthOf l = getSum# (foldMapOf l (\_ -> Sum 1))
+lengthOf l = getSum # foldMapOf l (\_ -> Sum 1)
{-# INLINE lengthOf #-}
-- | Perform a safe 'head' of a 'Fold' or 'Control.Lens.Traversal.Traversal' or retrieve 'Just' the result
@@ -746,7 +745,7 @@ lengthOf l = getSum# (foldMapOf l (\_ -> Sum 1))
-- 'headOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> s -> 'Maybe' a
-- @
headOf :: Getting (First a) s t a b -> s -> Maybe a
-headOf l = getFirst# (foldMapOf l (first# Just))
+headOf l = getFirst # foldMapOf l (_First # Just)
{-# INLINE headOf #-}
-- | Perform a safe 'head' of a 'Fold' or 'Control.Lens.Traversal.Traversal' or retrieve 'Just' the result
@@ -765,7 +764,7 @@ headOf l = getFirst# (foldMapOf l (first# Just))
-- ('^?') :: s -> 'Simple' 'Control.Lens.Traversal.Traversal' s a -> 'Maybe' a
-- @
(^?) :: s -> Getting (First a) s t a b -> Maybe a
-a ^? l = getFirst (foldMapOf l (first# Just) a)
+a ^? l = getFirst (foldMapOf l (_First # Just) a)
{-# INLINE (^?) #-}
-- | Perform an *UNSAFE* 'head' of a 'Fold' or 'Control.Lens.Traversal.Traversal' assuming that it is there.
@@ -778,7 +777,7 @@ a ^? l = getFirst (foldMapOf l (first# Just) a)
-- ('^?!') :: s -> 'Simple' 'Control.Lens.Traversal.Traversal' s a -> a
-- @
(^?!) :: s -> Getting (First a) s t a b -> a
-a ^?! l = fromMaybe (error "(^?!): empty Fold") $ getFirst (foldMapOf l (first# Just) a)
+a ^?! l = fromMaybe (error "(^?!): empty Fold") $ getFirst (foldMapOf l (_First # Just) a)
{-# INLINE (^?!) #-}
-- | Perform a safe 'last' of a 'Fold' or 'Control.Lens.Traversal.Traversal' or retrieve 'Just' the result
@@ -792,7 +791,7 @@ a ^?! l = fromMaybe (error "(^?!): empty Fold") $ getFirst (foldMapOf l (first#
-- 'lastOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> s -> 'Maybe' a
-- @
lastOf :: Getting (Last a) s t a b -> s -> Maybe a
-lastOf l = getLast# (foldMapOf l (last# Just))
+lastOf l = getLast # foldMapOf l (_Last # Just)
{-# INLINE lastOf #-}
-- |
@@ -817,7 +816,7 @@ lastOf l = getLast# (foldMapOf l (last# Just))
-- 'nullOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> s -> 'Bool'
-- @
nullOf :: Getting All s t a b -> s -> Bool
-nullOf l = getAll# (foldMapOf l (\_ -> All False))
+nullOf l = getAll # foldMapOf l (\_ -> All False)
{-# INLINE nullOf #-}
-- |
@@ -906,7 +905,7 @@ minimumByOf l cmp = foldrOf l step Nothing where
-- 'findOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> 'Bool') -> s -> 'Maybe' a
-- @
findOf :: Getting (First a) s t a b -> (a -> Bool) -> s -> Maybe a
-findOf l p = getFirst# (foldMapOf l step) where
+findOf l p = getFirst # (foldMapOf l step) where
step a
| p a = First (Just a)
| otherwise = First Nothing
View
9 src/Control/Lens/Getter.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE MagicHash #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE MultiParamTypeClasses #-}
@@ -231,7 +230,7 @@ type Getting r s t a b = (a -> Accessor r b) -> s -> Accessor r t
-- 'view' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> m a
-- @
view :: MonadReader s m => Getting a s t a b -> m a
-view l = Reader.asks (runAccessor# (l Accessor))
+view l = Reader.asks (runAccessor # (l _Accessor))
{-# INLINE view #-}
-- | View the value of a 'Getter', 'Control.Lens.Iso.Iso',
@@ -271,7 +270,7 @@ view l = Reader.asks (runAccessor# (l Accessor))
-- 'view' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> m a
-- @
views :: MonadReader s m => Getting r s t a b -> (a -> r) -> m r
-views l f = Reader.asks (runAccessor# (l (accessor# f)))
+views l f = Reader.asks (runAccessor # (l (_Accessor # f)))
{-# INLINE views #-}
-- | View the value pointed to by a 'Getter', 'Control.Lens.Iso.Iso' or
@@ -479,7 +478,7 @@ uses' l f = State.gets (views' l f)
-- 'view'' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> m a
-- @
view' :: MonadReader s m => Getting a s s a a -> m a
-view' l = Reader.asks (runAccessor# (l Accessor))
+view' l = Reader.asks (runAccessor # (l _Accessor))
{-# INLINE view' #-}
-- | This is a type restricted version of 'views' that expects a 'Simple' 'Getter'.
@@ -518,7 +517,7 @@ view' l = Reader.asks (runAccessor# (l Accessor))
-- 'views'' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> r) -> m r
-- @
views' :: MonadReader s m => Getting r s s a a -> (a -> r) -> m r
-views' l f = Reader.asks (runAccessor# (l (accessor# f)))
+views' l f = Reader.asks (runAccessor # (l (_Accessor # f)))
{-# INLINE views' #-}
------------------------------------------------------------------------------
View
19 src/Control/Lens/IndexedFold.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE MagicHash #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
@@ -85,7 +84,7 @@ type IndexedFold i s a = forall k f.
-- 'ifoldMapOf' :: 'Monoid' m => 'Control.Lens.IndexedTraversal.SimpleIndexedTraversal' i a s -> (i -> s -> m) -> a -> m
-- @
ifoldMapOf :: IndexedGetting i m s t a b -> (i -> a -> m) -> s -> m
-ifoldMapOf l f = runAccessor# (withIndex l (\i -> accessor# (f i)))
+ifoldMapOf l f = runAccessor # (withIndex l (\i -> _Accessor # f i))
{-# INLINE ifoldMapOf #-}
-- |
@@ -103,7 +102,7 @@ ifoldMapOf l f = runAccessor# (withIndex l (\i -> accessor# (f i)))
-- 'ifoldrOf' :: 'Control.Lens.IndexedTraversal.SimpleIndexedTraversal' i s a -> (i -> a -> r -> r) -> r -> s -> r
-- @
ifoldrOf :: IndexedGetting i (Endo r) s t a b -> (i -> a -> r -> r) -> r -> s -> r
-ifoldrOf l f z t = appEndo (ifoldMapOf l (\i -> endo# (f i)) t) z
+ifoldrOf l f z t = appEndo (ifoldMapOf l (\i -> _Endo # f i) t) z
{-# INLINE ifoldrOf #-}
-- |
@@ -121,7 +120,7 @@ ifoldrOf l f z t = appEndo (ifoldMapOf l (\i -> endo# (f i)) t) z
-- 'ifoldlOf' :: 'Control.Lens.IndexedTraversal.SimpleIndexedTraversal' i s a -> (i -> r -> a -> r) -> r -> s -> r
-- @
ifoldlOf :: IndexedGetting i (Dual (Endo r)) s t a b -> (i -> r -> a -> r) -> r -> s -> r
-ifoldlOf l f z t = appEndo (getDual (ifoldMapOf l (\i -> dual# (endo# (flip (f i)))) t)) z
+ifoldlOf l f z t = appEndo (getDual (ifoldMapOf l (\i -> _Dual # _Endo # flip (f i)) t)) z
{-# INLINE ifoldlOf #-}
-- |
@@ -139,7 +138,7 @@ ifoldlOf l f z t = appEndo (getDual (ifoldMapOf l (\i -> dual# (endo# (flip (f i
-- 'ianyOf' :: 'Control.Lens.IndexedTraversal.SimpleIndexedTraversal' i s a -> (i -> a -> 'Bool') -> s -> 'Bool'
-- @
ianyOf :: IndexedGetting i Any s t a b -> (i -> a -> Bool) -> s -> Bool
-ianyOf l f = getAny# (ifoldMapOf l (\i -> any# (f i)))
+ianyOf l f = getAny # (ifoldMapOf l (\i -> _Any # f i))
{-# INLINE ianyOf #-}
-- |
@@ -157,7 +156,7 @@ ianyOf l f = getAny# (ifoldMapOf l (\i -> any# (f i)))
-- 'iallOf' :: 'Control.Lens.IndexedTraversal.SimpleIndexedTraversal' i s a -> (i -> a -> 'Bool') -> s -> 'Bool'
-- @
iallOf :: IndexedGetting i All s t a b -> (i -> a -> Bool) -> s -> Bool
-iallOf l f = getAll# (ifoldMapOf l (\i -> all# (f i)))
+iallOf l f = getAll # (ifoldMapOf l (\i -> _All # f i))
{-# INLINE iallOf #-}
-- |
@@ -174,7 +173,7 @@ iallOf l f = getAll# (ifoldMapOf l (\i -> all# (f i)))
-- 'itraverseOf_' :: 'Applicative' f => 'Control.Lens.IndexedTraversal.SimpleIndexedTraversal' i s a -> (i -> a -> f r) -> s -> f ()
-- @
itraverseOf_ :: Functor f => IndexedGetting i (Traversed f) s t a b -> (i -> a -> f r) -> s -> f ()
-itraverseOf_ l f = getTraversed# (ifoldMapOf l (\i -> traversed# (void . f i)))
+itraverseOf_ l f = getTraversed # (ifoldMapOf l (\i -> _Traversed # (void . f i)))
{-# INLINE itraverseOf_ #-}
-- |
@@ -212,7 +211,7 @@ iforOf_ = flip . itraverseOf_
-- 'imapMOf_' :: 'Monad' m => 'Control.Lens.IndexedTraversal.SimpleIndexedTraversal' i s a -> (i -> a -> m r) -> s -> m ()
-- @
imapMOf_ :: Monad m => IndexedGetting i (Sequenced m) s t a b -> (i -> a -> m r) -> s -> m ()
-imapMOf_ l f = getSequenced# (ifoldMapOf l (\i -> sequenced# (liftM skip . f i)))
+imapMOf_ l f = getSequenced # (ifoldMapOf l (\i -> _Sequenced # (liftM skip . f i)))
{-# INLINE imapMOf_ #-}
skip :: a -> ()
@@ -275,7 +274,7 @@ iconcatMapOf = ifoldMapOf
-- 'ifindOf' :: 'Control.Lens.IndexedTraversal.SimpleIndexedTraversal' s a -> (i -> a -> 'Bool') -> s -> 'Maybe' (i, a)
-- @
ifindOf :: IndexedGetting i (First (i, a)) s t a b -> (i -> a -> Bool) -> s -> Maybe (i, a)
-ifindOf l p = getFirst# (ifoldMapOf l step) where
+ifindOf l p = getFirst # (ifoldMapOf l step) where
step i a
| p i a = First $ Just (i, a)
| otherwise = First Nothing
@@ -428,7 +427,7 @@ ibackwards :: Indexable i k
=> Indexed i (a -> (Backwards f) b) (s -> (Backwards f) t)
-> k (a -> f b) (s -> f t)
ibackwards l = indexed $ \ f ->
- fmap forwards . withIndex l $ \ i -> backwards# (f i)
+ fmap forwards . withIndex l $ \ i -> _Backwards # f i
{-# INLINE ibackwards #-}
-- | Obtain an 'IndexedFold' by taking elements from another
View
10 src/Control/Lens/IndexedSetter.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE MagicHash #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
@@ -29,6 +28,7 @@ module Control.Lens.IndexedSetter
, SimpleReifiedIndexedSetter
) where
+import Control.Applicative
import Control.Lens.Classes
import Control.Lens.Indexed
import Control.Lens.Internal
@@ -61,7 +61,7 @@ type SimpleIndexedSetter i s a = IndexedSetter i s s a a
-- 'imapOf' :: 'Control.Lens.IndexedTraversal.IndexedTraversal' i s t a b -> (i -> a -> b) -> s -> t
-- @
imapOf :: Overloaded (Indexed i) Mutator s t a b -> (i -> a -> b) -> s -> t
-imapOf l f = runMutator# (withIndex l (\i -> mutator# (f i)))
+imapOf l f = runMutator # withIndex l (\i -> _Mutator # f i)
{-# INLINE imapOf #-}
-- | Map with index. This is an alias for 'imapOf'.
@@ -76,7 +76,7 @@ imapOf l f = runMutator# (withIndex l (\i -> mutator# (f i)))
-- 'iover' :: 'Control.Lens.IndexedTraversal.IndexedTraversal' i s t a b -> (i -> a -> b) -> s -> t
-- @
iover :: Overloaded (Indexed i) Mutator s t a b -> (i -> a -> b) -> s -> t
-iover l f = runMutator# (withIndex l (\i -> mutator# (f i)))
+iover l f = runMutator # withIndex l (\i -> _Mutator # f i)
{-# INLINE iover #-}
-- | Build an 'IndexedSetter' from an 'imap'-like function.
@@ -98,7 +98,7 @@ iover l f = runMutator# (withIndex l (\i -> mutator# (f i)))
-- Another way to view 'sets' is that it takes a \"semantic editor combinator\"
-- and transforms it into a 'Setter'.
isets :: ((i -> a -> b) -> s -> t) -> IndexedSetter i s t a b
-isets f = indexed $ \ g -> tainted# (f (\i -> untainted# (g i)))
+isets f = indexed $ \ g -> pure # f (\i -> untainted # g i)
{-# INLINE isets #-}
-- | Adjust every target of an 'IndexedSetter', 'Control.Lens.IndexedLens.IndexedLens' or 'Control.Lens.IndexedTraversal.IndexedTraversal'
@@ -116,7 +116,7 @@ isets f = indexed $ \ g -> tainted# (f (\i -> untainted# (g i)))
-- ('%@~') :: 'Control.Lens.IndexedTraversal.IndexedTraversal' i s t a b -> (i -> a -> b) -> s -> t
-- @
(%@~) :: Overloaded (Indexed i) Mutator s t a b -> (i -> a -> b) -> s -> t
-l %@~ f = runMutator# (withIndex l (\i -> mutator# (f i)))
+l %@~ f = runMutator # withIndex l (\i -> _Mutator # f i)
{-# INLINE (%@~) #-}
-- | Adjust every target in the current state of an 'IndexedSetter', 'Control.Lens.IndexedLens.IndexedLens' or 'Control.Lens.IndexedTraversal.IndexedTraversal'
View
24 src/Control/Lens/Internal.hs
@@ -7,7 +7,6 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE MagicHash #-}
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE Trustworthy #-}
#endif
@@ -54,6 +53,7 @@ module Control.Lens.Internal
, Projected(..)
, Isomorphism(..)
, Indexed(..)
+ , _Mutator
) where
import Control.Applicative
@@ -70,12 +70,6 @@ import Data.Monoid
import Unsafe.Coerce
#endif
-#ifndef SAFE
-#define UNSAFELY(x) unsafeCoerce
-#else
-#define UNSAFELY(f) (\g -> g `seq` \x -> (f) (g x))
-#endif
-
-----------------------------------------------------------------------------
-- Functors
-----------------------------------------------------------------------------
@@ -409,22 +403,26 @@ instance (Gettable f, Applicative f) => Monoid (Folding f a) where
-- Most user code will never need to see this type.
newtype Mutator a = Mutator { runMutator :: a }
+-- This alias can't be defined in .Combinators because we need it for the
+-- 'Settable' instance. Ideally it wouldn't be exported from a public module.
+-- (.Combinators still defines a RULE for it, which isn't orphan because it
+-- involves (#).
+_Mutator :: a -> Mutator a
+_Mutator = Mutator
+
instance Functor Mutator where
fmap f (Mutator a) = Mutator (f a)
{-# INLINE fmap #-}
instance Applicative Mutator where
- pure = Mutator
- {-# INLINE pure #-}
+ pure = _Mutator
+ -- Figure out the proper {-# INLINE #-} pragma here and in Settable (and
+ -- maybe in _Mutator?) to interact with the the RULE for (#) _Mutator.
Mutator f <*> Mutator a = Mutator (f a)
{-# INLINE (<*>) #-}
instance Settable Mutator where
untainted = runMutator
- untainted# = UNSAFELY(runMutator)
- {-# INLINE untainted #-}
- tainted# = UNSAFELY(Mutator)
- {-# INLINE tainted# #-}
-- | 'BazaarT' is like 'Bazaar', except that it provides a questionable 'Gettable' instance
-- To protect this instance it relies on the soundness of another 'Gettable' type, and usage conventions.
View
316 src/Control/Lens/Internal/Combinators.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE MagicHash #-}
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 && !defined(SAFE)
{-# LANGUAGE Trustworthy #-}
#endif
@@ -14,9 +13,10 @@
--
-- This module is not exported from this package.
--
--- These combinators are used to reduce eta-expansion in the resulting code
--- which could otherwise cause both a constant and asymptotic slowdown to
--- code execution.
+-- This module exports a strict composition operator and rewrite rules (and
+-- constructor aliases) to reduce eta-expansion in the generated code for
+-- chains of newtype constructor/accessor compositions which could otherwise
+-- cause both a constant and asymptotic slowdown to code execution.
--
-- Many micro-benchmarks are improved up to 50%, and larger benchmarks can
-- win asymptotically.
@@ -24,34 +24,36 @@
----------------------------------------------------------------------------
module Control.Lens.Internal.Combinators
(
- -- * Safe "Unsafe" Coercions
- const#, getConst#
- , zipList#, getZipList#
- , wrapMonad#, unwrapMonad#
- , last#, getLast#
- , first#, getFirst#
- , product#, getProduct#
- , sum#, getSum#
- , any#, getAny#
- , all#, getAll#
- , dual#, getDual#
- , endo#, appEndo#
- , may#, getMay#
- , folding#, getFolding#
- , effect#, getEffect#
- , effectRWS#, getEffectRWS#
- , accessor#, runAccessor#
- , err#, getErr#
- , traversed#, getTraversed#
- , sequenced#, getSequenced#
- , focusing#, unfocusing#
- , focusingWith#, unfocusingWith#
- , focusingPlus#, unfocusingPlus#
- , focusingOn#, unfocusingOn#
- , focusingMay#, unfocusingMay#
- , focusingErr#, unfocusingErr#
- , mutator#, runMutator#
- , backwards#, forwards#
+ -- * Strict coercion
+ (#)
+ -- * Constructor aliases
+ , _Const
+ , _ZipList
+ , _WrapMonad
+ , _Last
+ , _First
+ , _Product
+ , _Sum
+ , _Any
+ , _All
+ , _Dual
+ , _Endo
+ , _May
+ , _Folding
+ , _Effect
+ , _EffectRWS
+ , _Accessor
+ , _Err
+ , _Traversed
+ , _Sequenced
+ , _Focusing
+ , _FocusingWith
+ , _FocusingPlus
+ , _FocusingOn
+ , _FocusingMay
+ , _FocusingErr
+ , _Mutator
+ , _Backwards
) where
import Control.Applicative
@@ -62,170 +64,194 @@ import Data.Monoid
import Unsafe.Coerce
#endif
-#ifndef SAFE
-#define UNSAFELY(x) unsafeCoerce
-#else
-#define UNSAFELY(f) (\g -> g `seq` \x -> (f) (g x))
-#endif
+-- | Strict composition.
+--
+-- @'id' '.' f@ becomes @\x -> f x@ rather than @f@, which stops GHC from doing
+-- some optimizations when we use a newtype constructor/accessor instead of
+-- 'id'. ('#') is a strict version of ('.') such that @'id' '#' f@ behaves
+-- identically to @f@.
+infixr 9 #
+(#) :: (b -> c) -> (a -> b) -> a -> c
+(#) = \f -> f `seq` \g -> g `seq` \x -> f (g x)
-const# :: (a -> b) -> a -> Const b r
-const# = UNSAFELY(Const)
+-----------------------------------------------------------------------------
+-- Constructor aliases
+-----------------------------------------------------------------------------
-getConst# :: (a -> Const b r) -> a -> b
-getConst# = UNSAFELY(getConst)
+-- GHC has trouble with rewrite rules involving newtype constructors, so we
+-- define an alias for each one that
+--
+-- '_Mutator' is defined in a separate module because Mutator's Applicative
+-- instance needs to refer to it.
-zipList# :: (a -> [b]) -> a -> ZipList b
-zipList# = UNSAFELY(ZipList)
+_Const :: a -> Const a b
+_Const = Const
-getZipList# :: (a -> ZipList b) -> a -> [b]
-getZipList# = UNSAFELY(getZipList)
+_ZipList :: [a] -> ZipList a
+_ZipList = ZipList
-wrapMonad# :: (a -> m b) -> a -> WrappedMonad m b
-wrapMonad# = UNSAFELY(WrapMonad)
+_WrapMonad :: m a -> WrappedMonad m a
+_WrapMonad = WrapMonad
-unwrapMonad# :: (a -> WrappedMonad m b) -> a -> m b
-unwrapMonad# = UNSAFELY(unwrapMonad)
+_Last :: Maybe a -> Last a
+_Last = Last
-last# :: (a -> Maybe b) -> a -> Last b
-last# = UNSAFELY(Last)
+_First :: Maybe a -> First a
+_First = First
-getLast# :: (a -> Last b) -> a -> Maybe b
-getLast# = UNSAFELY(getLast)
+_Product :: a -> Product a
+_Product = Product
-first# :: (a -> Maybe b) -> a -> First b
-first# = UNSAFELY(First)
+_Sum :: a -> Sum a
+_Sum = Sum
-getFirst# :: (a -> First b) -> a -> Maybe b
-getFirst# = UNSAFELY(getFirst)
+_Any :: Bool -> Any
+_Any = Any
-product# :: (a -> b) -> a -> Product b
-product# = UNSAFELY(Product)
+_All :: Bool -> All
+_All = All
-getProduct# :: (a -> Product b) -> a -> b
-getProduct# = UNSAFELY(getProduct)
+_Dual :: a -> Dual a
+_Dual = Dual
-sum# :: (a -> b) -> a -> Sum b
-sum# = UNSAFELY(Sum)
+_Endo :: (a -> a) -> Endo a
+_Endo = Endo
-getSum# :: (a -> Sum b) -> a -> b
-getSum# = UNSAFELY(getSum)
+_May :: Maybe a -> May a
+_May = May
-any# :: (a -> Bool) -> a -> Any
-any# = UNSAFELY(Any)
+_Folding :: f a -> Folding f a
+_Folding = Folding
-getAny# :: (a -> Any) -> a -> Bool
-getAny# = UNSAFELY(getAny)
+_Effect :: m r -> Effect m r a
+_Effect = Effect
-all# :: (a -> Bool) -> a -> All
-all# = UNSAFELY(All)
+_EffectRWS :: (st -> m (s, st, w)) -> EffectRWS w st m s a
+_EffectRWS = EffectRWS
-getAll# :: (a -> All) -> a -> Bool
-getAll# = UNSAFELY(getAll)
+_Accessor :: r -> Accessor r a
+_Accessor = Accessor
-dual# :: (a -> b) -> a -> Dual b
-dual# = UNSAFELY(Dual)
+_Err :: Either e a -> Err e a
+_Err = Err
-getDual# :: (a -> Dual b) -> a -> b
-getDual# = UNSAFELY(getDual)
+_Traversed :: f () -> Traversed f
+_Traversed = Traversed
-endo# :: (a -> b -> b) -> a -> Endo b
-endo# = UNSAFELY(Endo)
+_Sequenced :: m () -> Sequenced m
+_Sequenced = Sequenced
-appEndo# :: (a -> Endo b) -> a -> b -> b
-appEndo# = UNSAFELY(appEndo)
+_Focusing :: m (s, a) -> Focusing m s a
+_Focusing = Focusing
-may# :: (a -> Maybe b) -> a -> May b
-may# = UNSAFELY(May)
+_FocusingWith :: m (s, a, w) -> FocusingWith w m s a
+_FocusingWith = FocusingWith
-getMay# :: (a -> May b) -> a -> Maybe b
-getMay# = UNSAFELY(getMay)
+_FocusingPlus :: k (s, w) a -> FocusingPlus w k s a
+_FocusingPlus = FocusingPlus
-folding# :: (a -> f b) -> a -> Folding f b
-folding# = UNSAFELY(Folding)
+_FocusingOn :: k (f s) a -> FocusingOn f k s a
+_FocusingOn = FocusingOn
-getFolding# :: (a -> Folding f b) -> a -> f b
-getFolding# = UNSAFELY(getFolding)
+_FocusingMay :: k (May s) a -> FocusingMay k s a
+_FocusingMay = FocusingMay
-effect# :: (a -> m r) -> a -> Effect m r b
-effect# = UNSAFELY(Effect)
+_FocusingErr :: k (Err e s) a -> FocusingErr e k s a
+_FocusingErr = FocusingErr
-getEffect# :: (a -> Effect m r b) -> a -> m r
-getEffect# = UNSAFELY(getEffect)
+_Backwards :: f a -> Backwards f a
+_Backwards = Backwards
-effectRWS# :: (a -> st -> m (s, st, w)) -> a -> EffectRWS w st m s b
-effectRWS# = UNSAFELY(EffectRWS)
+-----------------------------------------------------------------------------
+-- RULES
+-----------------------------------------------------------------------------
-getEffectRWS# :: (a -> EffectRWS w st m s b) -> a -> st -> m (s, st, w)
-getEffectRWS# = UNSAFELY(getEffectRWS)
+-- When not compiling with -fsafe, we can unsafely coerce @Foo # f@ to @f@,
+-- where @Foo@ is a newtype constructor or accessor. This has identical
+-- semantics with strict composition, but GHC doesn't manage the optimization
+-- itself.
-accessor# :: (a -> r) -> a -> Accessor r b
-accessor# = UNSAFELY(Accessor)
+#ifndef SAFE
+
+{-# RULES "_Const#" (#) _Const = unsafeCoerce #-}
+{-# RULES "getConst#" (#) getConst = unsafeCoerce #-}
+
+{-# RULES "_ZipList#" (#) _ZipList = unsafeCoerce #-}
+{-# RULES "getZipList#" (#) getZipList = unsafeCoerce #-}
+
+{-# RULES "_WrapMonad#" (#) _WrapMonad = unsafeCoerce #-}
+{-# RULES "unwrapMonad#" (#) unwrapMonad = unsafeCoerce #-}
-runAccessor# :: (a -> Accessor r b) -> a -> r
-runAccessor# = UNSAFELY(runAccessor)
+{-# RULES "_Last#" (#) _Last = unsafeCoerce #-}
+{-# RULES "getLast#" (#) getLast = unsafeCoerce #-}
-err# :: (a -> Either e b) -> a -> Err e b
-err# = UNSAFELY(Err)
+{-# RULES "_First#" (#) _First = unsafeCoerce #-}
+{-# RULES "getFirst#" (#) getFirst = unsafeCoerce #-}
-getErr# :: (a -> Err e b) -> a -> Either e b
-getErr# = UNSAFELY(getErr)
+{-# RULES "_Product#" (#) _Product = unsafeCoerce #-}
+{-# RULES "getProduct#" (#) getProduct = unsafeCoerce #-}
-traversed# :: (a -> f ()) -> a -> Traversed f
-traversed# = UNSAFELY(Traversed)
+{-# RULES "_Sum#" (#) _Sum = unsafeCoerce #-}
+{-# RULES "getSum#" (#) getSum = unsafeCoerce #-}
-getTraversed# :: (a -> Traversed f) -> a -> f ()
-getTraversed# = UNSAFELY(getTraversed)
+{-# RULES "_Any#" (#) _Any = unsafeCoerce #-}
+{-# RULES "getAny#" (#) getAny = unsafeCoerce #-}
-sequenced# :: (a -> f ()) -> a -> Sequenced f
-sequenced# = UNSAFELY(Sequenced)
+{-# RULES "_All#" (#) _All = unsafeCoerce #-}
+{-# RULES "getAll#" (#) getAll = unsafeCoerce #-}
-getSequenced# :: (a -> Sequenced f) -> a -> f ()
-getSequenced# = UNSAFELY(getSequenced)
+{-# RULES "_Dual#" (#) _Dual = unsafeCoerce #-}
+{-# RULES "getDual#" (#) getDual = unsafeCoerce #-}
-focusing# :: (a -> m (s, b)) -> a -> Focusing m s b
-focusing# = UNSAFELY(Focusing)
+{-# RULES "_Endo#" (#) _Endo = unsafeCoerce #-}
+{-# RULES "appEndo#" (#) appEndo = unsafeCoerce #-}
-unfocusing# :: (a -> Focusing m s b) -> a -> m (s, b)
-unfocusing# = UNSAFELY(unfocusing)
+{-# RULES "_May#" (#) _May = unsafeCoerce #-}
+{-# RULES "getMay#" (#) getMay = unsafeCoerce #-}
-focusingWith# :: (a -> m (s, b, w)) -> a -> FocusingWith w m s b
-focusingWith# = UNSAFELY(FocusingWith)
+{-# RULES "_Folding#" (#) _Folding = unsafeCoerce #-}
+{-# RULES "getFolding#" (#) getFolding = unsafeCoerce #-}
-unfocusingWith# :: (a -> FocusingWith w m s b) -> a -> m (s, b, w)
-unfocusingWith# = UNSAFELY(unfocusingWith)
+{-# RULES "_Effect#" (#) _Effect = unsafeCoerce #-}
+{-# RULES "getEffect#" (#) getEffect = unsafeCoerce #-}
-focusingPlus# :: (a -> k (s, w) b) -> a -> FocusingPlus w k s b
-focusingPlus# = UNSAFELY(FocusingPlus)
+{-# RULES "_EffectRWS#" (#) _EffectRWS = unsafeCoerce #-}
+{-# RULES "getEffectRWS#" (#) getEffectRWS = unsafeCoerce #-}
-unfocusingPlus# :: (a -> FocusingPlus w k s b) -> a -> k (s, w) b
-unfocusingPlus# = UNSAFELY(unfocusingPlus)
+{-# RULES "_Accessor#" (#) _Accessor = unsafeCoerce #-}
+{-# RULES "runAccessor#" (#) runAccessor = unsafeCoerce #-}
-focusingOn# :: (a -> k (f s) b) -> a -> FocusingOn f k s b
-focusingOn# = UNSAFELY(FocusingOn)
+{-# RULES "_Err#" (#) _Err = unsafeCoerce #-}
+{-# RULES "getErr#" (#) getErr = unsafeCoerce #-}
-unfocusingOn# :: (a -> FocusingOn f k s b) -> a -> k (f s) b
-unfocusingOn# = UNSAFELY(unfocusingOn)
+{-# RULES "_Traversed#" (#) _Traversed = unsafeCoerce #-}
+{-# RULES "getTraversed#" (#) getTraversed = unsafeCoerce #-}
-focusingMay# :: (a -> k (May s) b) -> a -> FocusingMay k s b
-focusingMay# = UNSAFELY(FocusingMay)
+{-# RULES "_Sequenced#" (#) _Sequenced = unsafeCoerce #-}
+{-# RULES "getSequenced#" (#) getSequenced = unsafeCoerce #-}
-unfocusingMay# :: (a -> FocusingMay k s b) -> a -> k (May s) b
-unfocusingMay# = UNSAFELY(unfocusingMay)
+{-# RULES "_Focusing#" (#) _Focusing = unsafeCoerce #-}
+{-# RULES "unfocusing#" (#) unfocusing = unsafeCoerce #-}
-focusingErr# :: (a -> k (Err e s) b) -> a -> FocusingErr e k s b
-focusingErr# = UNSAFELY(FocusingErr)
+{-# RULES "_FocusingWith#" (#) _FocusingWith = unsafeCoerce #-}
+{-# RULES "unfocusingWith#" (#) unfocusingWith = unsafeCoerce #-}
-unfocusingErr# :: (a -> FocusingErr e k s b) -> a -> k (Err e s) b
-unfocusingErr# = UNSAFELY(unfocusingErr)
+{-# RULES "_FocusingPlus#" (#) _FocusingPlus = unsafeCoerce #-}
+{-# RULES "unfocusingPlus#" (#) unfocusingPlus = unsafeCoerce #-}
-mutator# :: (a -> b) -> a -> Mutator b
-mutator# = UNSAFELY(Mutator)
+{-# RULES "_FocusingOn#" (#) _FocusingOn = unsafeCoerce #-}
+{-# RULES "unfocusingOn#" (#) unfocusingOn = unsafeCoerce #-}
-runMutator# :: (a -> Mutator b) -> a -> b
-runMutator# = UNSAFELY(runMutator)
+{-# RULES "_FocusingMay#" (#) _FocusingMay = unsafeCoerce #-}
+{-# RULES "unfocusingMay#" (#) unfocusingMay = unsafeCoerce #-}
-backwards# :: (a -> f b) -> a -> Backwards f b
-backwards# = UNSAFELY(Backwards)
+{-# RULES "_FocusingErr#" (#) _FocusingErr = unsafeCoerce #-}
+{-# RULES "unfocusingErr#" (#) unfocusingErr = unsafeCoerce #-}
-forwards# :: (a -> Backwards f b) -> a -> f b
-forwards# = UNSAFELY(forwards)
+{-# RULES "_Mutator#" (#) _Mutator = unsafeCoerce #-}
+{-# RULES "runMutator#" (#) runMutator = unsafeCoerce #-}
+
+{-# RULES "_Backwards#" (#) _Backwards = unsafeCoerce #-}
+{-# RULES "forwards#" (#) forwards = unsafeCoerce #-}
+
+#endif
View
5 src/Control/Lens/Representable.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
-----------------------------------------------------------------------------
@@ -302,12 +301,12 @@ rfoldr f b m = Foldable.foldr id b (rmap f m)
-- | An 'IndexedSetter' that walks an 'Representable' 'Functor' using a 'Path' for an index.
rmapped :: Representable f => IndexedSetter (Path f) (f a) (f b) a b
-rmapped = indexed $ \f -> tainted# (rmap (\i -> untainted# (f (Path i))))
+rmapped = indexed $ \f -> pure # rmap (\i -> untainted # f (Path i))
{-# INLINE rmapped #-}
-- | An 'IndexedFold' that walks an 'Foldable' 'Representable' 'Functor' using a 'Path' for an index.
rfolded :: (Representable f, Foldable f) => IndexedFold (Path f) (f a) a
-rfolded = indexed $ \f -> coerce . getFolding . rfoldMap (\i -> folding# (f (Path i)))
+rfolded = indexed $ \f -> coerce . getFolding # rfoldMap (\i -> _Folding # f (Path i))
{-# INLINE rfolded #-}
-- | An 'IndexedTraversal' for a 'Traversable' 'Representable' 'Functor'.
View
10 src/Control/Lens/Setter.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE MagicHash #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE LiberalTypeSynonyms #-}
-----------------------------------------------------------------------------
@@ -57,6 +56,7 @@ module Control.Lens.Setter
, Mutator
) where
+import Control.Applicative
import Control.Lens.Classes
import Control.Lens.Internal
import Control.Lens.Internal.Combinators
@@ -225,7 +225,7 @@ lifted = sets liftM
-- Another way to view 'sets' is that it takes a \"semantic editor combinator\"
-- and transforms it into a 'Setter'.
sets :: ((a -> b) -> s -> t) -> Setter s t a b
-sets f g = tainted# (f (untainted# g))
+sets f g = pure # f (untainted # g)
{-# INLINE sets #-}
-----------------------------------------------------------------------------
@@ -268,7 +268,7 @@ sets f g = tainted# (f (untainted# g))
--
-- @'over' :: 'Setter' s t a b -> (a -> b) -> s -> t@
over :: Setting s t a b -> (a -> b) -> s -> t
-over l f = runMutator# (l (mutator# f))
+over l f = runMutator # l (_Mutator # f)
{-# INLINE over #-}
-- | 'mapOf' is a deprecated alias for 'over'.
@@ -298,7 +298,7 @@ mapOf = over
-- 'set' :: 'Control.Lens.Traversal.Traversal' s t a b -> b -> s -> t
-- @
set :: Setting s t a b -> b -> s -> t
-set l b = runMutator# (l (\_ -> Mutator b))
+set l b = runMutator # l (\_ -> _Mutator b)
{-# INLINE set #-}
-- |
@@ -326,7 +326,7 @@ set l b = runMutator# (l (\_ -> Mutator b))
-- 'set'' :: 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> a -> s -> s
-- @
set' :: Setting s s a a -> a -> s -> s
-set' l b = runMutator# (l (\_ -> Mutator b))
+set' l b = runMutator # l (\_ -> _Mutator b)
{-# INLINE set' #-}
-- | Modifies the target of a 'Control.Lens.Type.Lens' or all of the targets of a 'Setter' or
View
10 src/Control/Lens/Traversal.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE MagicHash #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
@@ -65,6 +64,7 @@ module Control.Lens.Traversal
-- * Exposed Implementation Details
, Bazaar(..)
+ , (#)
) where
import Control.Applicative as Applicative
@@ -192,7 +192,7 @@ sequenceAOf l = l id
-- 'mapMOf' :: 'Monad' m => 'Traversal' s t a b -> (a -> m b) -> s -> m t
-- @
mapMOf :: LensLike (WrappedMonad m) s t a b -> (a -> m b) -> s -> m t
-mapMOf l cmd = unwrapMonad# (l (wrapMonad# cmd))
+mapMOf l cmd = unwrapMonad # l (_WrapMonad # cmd)
{-# INLINE mapMOf #-}
-- | 'forMOf' is a flipped version of 'mapMOf', consistent with the definition of 'forM'.
@@ -207,7 +207,7 @@ mapMOf l cmd = unwrapMonad# (l (wrapMonad# cmd))
-- 'forMOf' :: 'Monad' m => 'Traversal' s t a b -> s -> (a -> m b) -> m t
-- @
forMOf :: LensLike (WrappedMonad m) s t a b -> s -> (a -> m b) -> m t
-forMOf l a cmd = unwrapMonad (l (wrapMonad# cmd) a)
+forMOf l a cmd = unwrapMonad (l (_WrapMonad # cmd) a)
{-# INLINE forMOf #-}
-- | Sequence the (monadic) effects targeted by a lens in a container from left to right.
@@ -224,7 +224,7 @@ forMOf l a cmd = unwrapMonad (l (wrapMonad# cmd) a)
-- 'sequenceOf' :: 'Monad' m => 'Traversal' s t (m b) b -> s -> m t
-- @
sequenceOf :: LensLike (WrappedMonad m) s t (m b) b -> s -> m t
-sequenceOf l = unwrapMonad# (l WrapMonad)
+sequenceOf l = unwrapMonad # (l WrapMonad)
{-# INLINE sequenceOf #-}
-- | This generalizes 'Data.List.transpose' to an arbitrary 'Traversal'.
@@ -241,7 +241,7 @@ sequenceOf l = unwrapMonad# (l WrapMonad)
--
-- @'transposeOf' '_2' :: (b, [a]) -> [(b, a)]@
transposeOf :: LensLike ZipList s t [a] a -> s -> [t]
-transposeOf l = getZipList# (l ZipList)
+transposeOf l = getZipList # (l ZipList)
{-# INLINE transposeOf #-}
-- | This generalizes 'Data.Traversable.mapAccumR' to an arbitrary 'Traversal'.
View
19 src/Control/Lens/WithIndex.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE MagicHash #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE FlexibleInstances #-}
@@ -142,7 +141,7 @@ class Foldable f => FoldableWithIndex i f | f -> i where
--
-- @'Data.Foldable.foldr' ≡ 'ifoldr' '.' 'const'@
ifoldr :: (i -> a -> b -> b) -> b -> f a -> b
- ifoldr f z t = appEndo (ifoldMap (\i -> endo# (f i)) t) z
+ ifoldr f z t = appEndo (ifoldMap (\i -> _Endo # f i) t) z
-- |
-- Left-associative fold of an indexed container with access to the index @i@.
@@ -151,7 +150,7 @@ class Foldable f => FoldableWithIndex i f | f -> i where
--
-- @'Data.Foldable.foldl' ≡ 'ifoldl' '.' 'const'@
ifoldl :: (i -> b -> a -> b) -> b -> f a -> b
- ifoldl f z t = appEndo (getDual (ifoldMap (\i -> dual# (endo# (flip (f i)))) t)) z
+ ifoldl f z t = appEndo (getDual (ifoldMap (\i -> _Dual # _Endo # flip (f i)) t)) z
-- | /Strictly/ fold right over the elements of a structure with access to the index @i@.
--
@@ -173,7 +172,7 @@ class Foldable f => FoldableWithIndex i f | f -> i where
-- | The 'IndexedFold' of a 'FoldableWithIndex' container.
ifolded :: FoldableWithIndex i f => IndexedFold i (f a) a
-ifolded = indexed $ \ f -> coerce . getFolding . ifoldMap (\i -> folding# (f i))
+ifolded = indexed $ \ f -> coerce . getFolding # ifoldMap (\i -> _Folding # f i)
{-# INLINE ifolded #-}
-- | Obtain a 'Fold' by lifting an operation that returns a foldable result.
@@ -190,7 +189,7 @@ ifolding sfa = indexed $ \ iagb -> coerce . itraverse_ iagb . sfa
--
-- @'any' ≡ 'iany' '.' 'const'@
iany :: FoldableWithIndex i f => (i -> a -> Bool) -> f a -> Bool
-iany f = getAny# (ifoldMap (\i -> any# (f i)))
+iany f = getAny # ifoldMap (\i -> _Any # f i)
{-# INLINE iany #-}
-- |
@@ -200,7 +199,7 @@ iany f = getAny# (ifoldMap (\i -> any# (f i)))
--
-- @'all' ≡ 'iall' '.' 'const'@
iall :: FoldableWithIndex i f => (i -> a -> Bool) -> f a -> Bool
-iall f = getAll# (ifoldMap (\i -> all# (f i)))
+iall f = getAll # ifoldMap (\i -> _All # f i)
{-# INLINE iall #-}
-- |
@@ -210,7 +209,7 @@ iall f = getAll# (ifoldMap (\i -> all# (f i)))
--
-- @'traverse_' l = 'itraverse' '.' 'const'@
itraverse_ :: (FoldableWithIndex i t, Applicative f) => (i -> a -> f b) -> t a -> f ()
-itraverse_ f = getTraversed# (ifoldMap (\i -> traversed# (void . f i)))
+itraverse_ f = getTraversed # ifoldMap (\i -> _Traversed # (void . f i))
{-# INLINE itraverse_ #-}
-- |
@@ -233,7 +232,7 @@ ifor_ = flip itraverse_
--
-- @'mapM_' ≡ 'imapM' '.' 'const'@
imapM_ :: (FoldableWithIndex i t, Monad m) => (i -> a -> m b) -> t a -> m ()
-imapM_ f = getSequenced# (ifoldMap (\i -> sequenced# (liftM skip . f i)))
+imapM_ f = getSequenced # ifoldMap (\i -> _Sequenced # (liftM skip . f i))
{-# INLINE imapM_ #-}
-- |
@@ -315,7 +314,7 @@ withIndices f = coerce . getFolding . ifoldMap (\i a -> Folding (f (i,a)))
-- | Fold a container with indices returning only the indices.
indices :: FoldableWithIndex i f => Fold (f a) i
-indices f = coerce . getFolding# (ifoldMap (const . folding# f))
+indices f = coerce . getFolding # ifoldMap (const . (_Folding # f))
{-# INLINE indices #-}
-------------------------------------------------------------------------------
@@ -363,7 +362,7 @@ ifor = flip itraverse
--
-- @'mapM' ≡ 'imapM' '.' 'const'@
imapM :: (TraversableWithIndex i t, Monad m) => (i -> a -> m b) -> t a -> m (t b)
-imapM f = unwrapMonad# (itraverse (\i -> wrapMonad# (f i)))
+imapM f = unwrapMonad # itraverse (\i -> _WrapMonad # f i)
{-# INLINE imapM #-}
-- | Map each element of a structure to a monadic action,
View
23 src/Control/Lens/Zoom.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE MagicHash #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE LiberalTypeSynonyms #-}
@@ -73,11 +72,11 @@ class (MonadState s m, MonadState t n) => Zoom m n k s t | m -> s k, n -> t k, m
zoom :: Monad m => SimpleLensLike (k c) t s -> m c -> n c
instance Monad z => Zoom (Strict.StateT s z) (Strict.StateT t z) (Focusing z) s t where
- zoom l (Strict.StateT m) = Strict.StateT $ unfocusing# (l (focusing# m))
+ zoom l (Strict.StateT m) = Strict.StateT $ unfocusing # l (_Focusing # m)
{-# INLINE zoom #-}
instance Monad z => Zoom (Lazy.StateT s z) (Lazy.StateT t z) (Focusing z) s t where
- zoom l (Lazy.StateT m) = Lazy.StateT $ unfocusing# (l (focusing# m))
+ zoom l (Lazy.StateT m) = Lazy.StateT $ unfocusing # l (_Focusing # m)
{-# INLINE zoom #-}
instance Zoom m n k s t => Zoom (ReaderT e m) (ReaderT e n) k s t where
@@ -89,19 +88,19 @@ instance Zoom m n k s t => Zoom (IdentityT m) (IdentityT n) k s t where
{-# INLINE zoom #-}
instance (Monoid w, Monad z) => Zoom (Strict.RWST r w s z) (Strict.RWST r w t z) (FocusingWith w z) s t where
- zoom l (Strict.RWST m) = Strict.RWST $ \r -> unfocusingWith# (l (focusingWith# (m r)))
+ zoom l (Strict.RWST m) = Strict.RWST $ \r -> unfocusingWith # l (_FocusingWith # m r)
{-# INLINE zoom #-}
instance (Monoid w, Monad z) => Zoom (Lazy.RWST r w s z) (Lazy.RWST r w t z) (FocusingWith w z) s t where
- zoom l (Lazy.RWST m) = Lazy.RWST $ \r -> unfocusingWith# (l (focusingWith# (m r)))
+ zoom l (Lazy.RWST m) = Lazy.RWST $ \r -> unfocusingWith # l (_FocusingWith # m r)
{-# INLINE zoom #-}
instance (Monoid w, Zoom m n k s t) => Zoom (Strict.WriterT w m) (Strict.WriterT w n) (FocusingPlus w k) s t where
- zoom l = Strict.WriterT . zoom (\afb -> unfocusingPlus# (l (focusingPlus# afb))) . Strict.runWriterT
+ zoom l = Strict.WriterT . zoom (\afb -> unfocusingPlus # l (_FocusingPlus # afb)) . Strict.runWriterT
{-# INLINE zoom #-}
instance (Monoid w, Zoom m n k s t) => Zoom (Lazy.WriterT w m) (Lazy.WriterT w n) (FocusingPlus w k) s t where
- zoom l = Lazy.WriterT . zoom (\afb -> unfocusingPlus# (l (focusingPlus# afb))) . Lazy.runWriterT
+ zoom l = Lazy.WriterT . zoom (\afb -> unfocusingPlus # l (_FocusingPlus # afb)) . Lazy.runWriterT
{-# INLINE zoom #-}
instance Zoom m n k s t => Zoom (ListT m) (ListT n) (FocusingOn [] k) s t where
@@ -109,11 +108,11 @@ instance Zoom m n k s t => Zoom (ListT m) (ListT n) (FocusingOn [] k) s t where
{-# INLINE zoom #-}
instance Zoom m n k s t => Zoom (MaybeT m) (MaybeT n) (FocusingMay k) s t where
- zoom l = MaybeT . liftM getMay . zoom (\afb -> unfocusingMay# (l (focusingMay# afb))) . liftM May . runMaybeT
+ zoom l = MaybeT . liftM getMay . zoom (\afb -> unfocusingMay # l (_FocusingMay # afb)) . liftM May . runMaybeT
{-# INLINE zoom #-}
instance (Error e, Zoom m n k s t) => Zoom (ErrorT e m) (ErrorT e n) (FocusingErr e k) s t where
- zoom l = ErrorT . liftM getErr . zoom (\afb -> unfocusingErr# (l (focusingErr# afb))) . liftM Err . runErrorT
+ zoom l = ErrorT . liftM getErr . zoom (\afb -> unfocusingErr # l (_FocusingErr # afb)) . liftM Err . runErrorT
{-# INLINE zoom #-}
-- TODO: instance Zoom m m k a a => Zoom (ContT r m) (ContT r m) k a a where
@@ -142,7 +141,7 @@ class (MonadReader b m, MonadReader a n) => Magnify m n k b a | m -> b, n -> a,
magnify :: ((b -> k c b) -> a -> k c a) -> m c -> n c
instance Monad m => Magnify (ReaderT b m) (ReaderT a m) (Effect m) b a where
- magnify l (ReaderT m) = ReaderT $ getEffect# (l (effect# m))
+ magnify l (ReaderT m) = ReaderT $ getEffect # l (_Effect # m)
{-# INLINE magnify #-}
-- | @'magnify' = 'views'@
@@ -151,11 +150,11 @@ instance Magnify ((->) b) ((->) a) Accessor b a where
{-# INLINE magnify #-}
instance (Monad m, Monoid w) => Magnify (Strict.RWST b w s m) (Strict.RWST a w s m) (EffectRWS w s m) b a where
- magnify l (Strict.RWST m) = Strict.RWST $ getEffectRWS# (l (effectRWS# m))
+ magnify l (Strict.RWST m) = Strict.RWST $ getEffectRWS # l (_EffectRWS # m)
{-# INLINE magnify #-}
instance (Monad m, Monoid w) => Magnify (Lazy.RWST b w s m) (Lazy.RWST a w s m) (EffectRWS w s m) b a where
- magnify l (Lazy.RWST m) = Lazy.RWST $ getEffectRWS# (l (effectRWS# m))
+ magnify l (Lazy.RWST m) = Lazy.RWST $ getEffectRWS # l (_EffectRWS # m)
{-# INLINE magnify #-}
instance Magnify m n k b a => Magnify (IdentityT m) (IdentityT n) k b a where
Please sign in to comment.
Something went wrong with that request. Please try again.