-
Notifications
You must be signed in to change notification settings - Fork 271
/
Action.hs
146 lines (124 loc) · 4.52 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
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
{-# 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
, Effect(..)
) where
import Control.Applicative
import Control.Applicative.Backwards
import Control.Lens.Getter
import Control.Lens.Iso
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)
-- | Wrap a monadic effect with a phantom type argument.
newtype Effect m r a = Effect { getEffect :: m r }
instance Monad m => Functor (Effect m r) where
fmap _ (Effect m) = Effect m
instance (Monad m, Monoid r) => Monoid (Effect m r a) where
mempty = Effect (return mempty)
Effect ma `mappend` Effect mb = Effect (liftM2 mappend ma mb)
instance (Monad m, Monoid r) => Applicative (Effect m r) where
pure _ = Effect (return mempty)
Effect ma <*> Effect mb = Effect (liftM2 mappend ma mb)
instance Monad m => Gettable (Effect m r) where
coerce (Effect m) = Effect m
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 #-}