/
Action.hs
128 lines (111 loc) · 3.94 KB
/
Action.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
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
-----------------------------------------------------------------------------
-- |
-- Module : Control.Lens.Action
-- Copyright : (C) 2012 Edward Kmett
-- License : BSD-style (see the file LICENSE)
-- Maintainer : Edward Kmett <ekmett@gmail.com>
-- Stability : experimental
-- Portability : MTPCs, FDs, Rank2
--
----------------------------------------------------------------------------
module Control.Lens.Action
(
-- * Composable Actions
Action
, act
, acts
, perform
, liftAct
, (^!)
-- * Folds with Effecs
, MonadicFold
-- * Implementation Details
, Acting
, Effective(..)
, ineffective
) where
import Control.Applicative
import Control.Applicative.Backwards
import Control.Lens.Internal
import Control.Lens.Isomorphic
import Control.Monad
import Control.Monad.Trans.Class
import Data.Functor.Identity
import Data.Monoid
infixr 8 ^!
-- | An 'Action' is a 'Getter' enriched with access to a 'Monad' for side-effects.
--
-- Every 'Getter' can be used as an 'Action'
--
-- You can compose an 'Action' with another 'Action' using ('Prelude..') from the @Prelude@.
type Action m a c = forall f r. Effective m r f => (c -> f c) -> a -> f a
-- | A 'MonadicFold' is a 'Fold' enriched with access to a 'Monad' for side-effects.
--
-- Every 'Fold' can be used as a 'MonadicFold', that simply ignores the access to the 'Monad'.
--
-- You can compose a 'MonadicFold' with another 'MonadicFold' using ('Prelude..') from the @Prelude@.
type MonadicFold m a c = forall f r. (Effective m r f, Applicative f) => (c -> f c) -> a -> f a
-- | An 'Effective' 'Functor' ignores its argument and is isomorphic to a monad wrapped around a value.
--
-- That said, the monad is possibly rather unrelated to any 'Applicative' structure.
class (Monad m, Gettable f) => Effective m r f | f -> m r where
effective :: Isomorphic k => k (m r) (f a)
-- | A convenient antonym that is used internally.
ineffective :: Effective m r f => Isomorphic k => k (f a) (m r)
ineffective = from effective
{-# INLINE ineffective #-}
instance Effective Identity r (Accessor r) where
effective = isomorphic (Accessor . runIdentity) (Identity . runAccessor)
{-# INLINE effective #-}
{-# SPECIALIZE effective :: Identity r -> Accessor r a #-}
{-# SPECIALIZE effective :: Isomorphism (Identity r) (Accessor r a) #-}
instance Effective m r f => Effective m (Dual r) (Backwards f) where
effective = isomorphic (Backwards . effective . liftM getDual) (liftM Dual . ineffective . forwards)
instance Monad m => Effective m r (Effect m r) where
effective = isomorphic Effect getEffect
{-# SPECIALIZE effective :: Monad m => m r -> Effect m r a #-}
{-# SPECIALIZE effective :: Monad m => Isomorphism (m r) (Effect m r a) #-}
-- | Used to evaluate an 'Action'.
type Acting m r a c = (c -> Effect m r c) -> a -> Effect m r a
-- | Perform an 'Action'.
--
-- > perform = flip (^!)
--
perform :: Monad m => Acting m c a c -> a -> m c
perform l = getEffect . l (Effect . return)
{-# INLINE perform #-}
-- | Perform an 'Action'
--
-- >>> import Control.Lens
--
-- >>> ["hello","world"]^!folded.act putStrLn
-- hello
-- world
--
(^!) :: Monad m => a -> Acting m c a c -> m c
a ^! l = getEffect (l (Effect . return) a)
{-# INLINE (^!) #-}
-- | Construct an 'Action' from a monadic side-effect
act :: Monad m => (a -> m c) -> Action m a c
act amc cfd a = effective (amc a >>= from effective . cfd)
{-# INLINE act #-}
-- | A self-running 'Action', analogous to 'Control.Monad.join'.
--
-- @'acts' = 'act' 'id'@
--
-- >>> import Control.Lens
--
-- >>> (1,"hello")^!_2.acts.to succ
-- "ifmmp"
acts :: Action m (m a) a
acts = act id
{-# INLINE acts #-}
-- | Apply a 'Monad' transformer to an 'Action'.
liftAct :: (MonadTrans t, Monad m) => Acting m c a c -> Action (t m) a c
liftAct l = act (lift . perform l)
{-# INLINE liftAct #-}