-
Notifications
You must be signed in to change notification settings - Fork 272
/
Setter.hs
63 lines (54 loc) · 1.94 KB
/
Setter.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
{-# LANGUAGE CPP #-}
#ifdef TRUSTWORTHY
{-# LANGUAGE Trustworthy #-}
#endif
-----------------------------------------------------------------------------
-- |
-- Module : Control.Lens.Internal.Setter
-- Copyright : (C) 2012-2014 Edward Kmett
-- License : BSD-style (see the file LICENSE)
-- Maintainer : Edward Kmett <ekmett@gmail.com>
-- Stability : provisional
-- Portability : non-portable
--
----------------------------------------------------------------------------
module Control.Lens.Internal.Setter
(
-- ** Setters
Settable(..)
) where
import Control.Applicative
import Control.Applicative.Backwards
import Data.Distributive
import Data.Functor.Compose
import Data.Functor.Identity
import Data.Profunctor
import Data.Profunctor.Unsafe
import Data.Traversable
-----------------------------------------------------------------------------
-- Settable
-----------------------------------------------------------------------------
-- | Anything 'Settable' must be isomorphic to the 'Identity' 'Functor'.
class (Applicative f, Distributive f, Traversable f) => Settable f where
untainted :: f a -> a
untaintedDot :: Profunctor p => p a (f b) -> p a b
untaintedDot g = g `seq` rmap untainted g
{-# INLINE untaintedDot #-}
taintedDot :: Profunctor p => p a b -> p a (f b)
taintedDot g = g `seq` rmap pure g
{-# INLINE taintedDot #-}
-- | So you can pass our 'Control.Lens.Setter.Setter' into combinators from other lens libraries.
instance Settable Identity where
untainted = runIdentity
{-# INLINE untainted #-}
untaintedDot = (runIdentity #.)
{-# INLINE untaintedDot #-}
taintedDot = (Identity #.)
{-# INLINE taintedDot #-}
-- | 'Control.Lens.Fold.backwards'
instance Settable f => Settable (Backwards f) where
untainted = untaintedDot forwards
{-# INLINE untainted #-}
instance (Settable f, Settable g) => Settable (Compose f g) where
untainted = untaintedDot (untaintedDot getCompose)
{-# INLINE untainted #-}