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
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
|
{-# LANGUAGE CPP #-}
#ifndef HASKELL98
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
# if __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE Safe #-}
# elif __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
# endif
#endif
-- |
-- Module : Control.Applicative.Lift
-- Copyright : (c) Ross Paterson 2010
-- License : BSD-style (see the file LICENSE)
--
-- Maintainer : ross@soi.city.ac.uk
-- Stability : experimental
-- Portability : portable
--
-- Adding a new kind of pure computation to an applicative functor.
--
-- NB: This module is only included in @lens@ for backwards compatibility with
-- @transformers@ versions before 3.0.
module Control.Applicative.Lift (
-- * Lifting an applicative
Lift(..),
unLift,
mapLift,
elimLift,
-- * Collecting errors
Errors,
runErrors,
failure,
eitherToErrors
) where
import Data.Functor.Classes
import Control.Applicative
import Data.Foldable (Foldable(foldMap))
import Data.Functor.Constant
import Data.Monoid (Monoid(..))
import Data.Traversable (Traversable(traverse))
#ifndef HASKELL98
# ifdef GENERIC_DERIVING
import Generics.Deriving.Base
# elif __GLASGOW_HASKELL__ >= 702
import GHC.Generics
# endif
#endif
-- | Applicative functor formed by adding pure computations to a given
-- applicative functor.
data Lift f a = Pure a | Other (f a)
#ifndef HASKELL98
# if __GLASGOW_HASKELL__ >= 702 || defined(GENERIC_DERIVING)
-- Generic(1) instances for Lift
instance Generic (Lift f a) where
type Rep (Lift f a) = D1 D1'Lift (C1 C1_0'Lift (S1 NoSelector (Rec0 a)) :+: C1 C1_1'Lift (S1 NoSelector (Rec0 (f a))))
from (Pure x) = M1 (L1 (M1 (M1 (K1 x))))
from (Other x) = M1 (R1 (M1 (M1 (K1 x))))
to (M1 (L1 (M1 (M1 (K1 x))))) = Pure x
to (M1 (R1 (M1 (M1 (K1 x))))) = Other x
instance Generic1 (Lift f) where
type Rep1 (Lift f) = D1 D1'Lift (C1 C1_0'Lift (S1 NoSelector Par1) :+: C1 C1_1'Lift (S1 NoSelector (Rec1 f)))
from1 (Pure x) = M1 (L1 (M1 (M1 (Par1 x))))
from1 (Other x) = M1 (R1 (M1 (M1 (Rec1 x))))
to1 (M1 (L1 (M1 (M1 x)))) = Pure (unPar1 x)
to1 (M1 (R1 (M1 (M1 x)))) = Other (unRec1 x)
instance Datatype D1'Lift where
datatypeName _ = "Lift"
moduleName _ = "Control.Applicative.Lift"
instance Constructor C1_0'Lift where
conName _ = "Pure"
instance Constructor C1_1'Lift where
conName _ = "Other"
data D1'Lift
data C1_0'Lift
data C1_1'Lift
# endif
#endif
instance (Eq1 f) => Eq1 (Lift f) where
liftEq eq (Pure x1) (Pure x2) = eq x1 x2
liftEq _ (Pure _) (Other _) = False
liftEq _ (Other _) (Pure _) = False
liftEq eq (Other y1) (Other y2) = liftEq eq y1 y2
{-# INLINE liftEq #-}
instance (Ord1 f) => Ord1 (Lift f) where
liftCompare comp (Pure x1) (Pure x2) = comp x1 x2
liftCompare _ (Pure _) (Other _) = LT
liftCompare _ (Other _) (Pure _) = GT
liftCompare comp (Other y1) (Other y2) = liftCompare comp y1 y2
{-# INLINE liftCompare #-}
instance (Read1 f) => Read1 (Lift f) where
liftReadsPrec rp rl = readsData $
readsUnaryWith rp "Pure" Pure `mappend`
readsUnaryWith (liftReadsPrec rp rl) "Other" Other
instance (Show1 f) => Show1 (Lift f) where
liftShowsPrec sp _ d (Pure x) = showsUnaryWith sp "Pure" d x
liftShowsPrec sp sl d (Other y) =
showsUnaryWith (liftShowsPrec sp sl) "Other" d y
instance (Eq1 f, Eq a) => Eq (Lift f a) where (==) = eq1
instance (Ord1 f, Ord a) => Ord (Lift f a) where compare = compare1
instance (Read1 f, Read a) => Read (Lift f a) where readsPrec = readsPrec1
instance (Show1 f, Show a) => Show (Lift f a) where showsPrec = showsPrec1
instance (Functor f) => Functor (Lift f) where
fmap f (Pure x) = Pure (f x)
fmap f (Other y) = Other (fmap f y)
{-# INLINE fmap #-}
instance (Foldable f) => Foldable (Lift f) where
foldMap f (Pure x) = f x
foldMap f (Other y) = foldMap f y
{-# INLINE foldMap #-}
instance (Traversable f) => Traversable (Lift f) where
traverse f (Pure x) = Pure <$> f x
traverse f (Other y) = Other <$> traverse f y
{-# INLINE traverse #-}
-- | A combination is 'Pure' only if both parts are.
instance (Applicative f) => Applicative (Lift f) where
pure = Pure
{-# INLINE pure #-}
Pure f <*> ax = f <$> ax
Other f <*> ax = Other (f <*> unLift ax)
{-# INLINE (<*>) #-}
-- | A combination is 'Pure' only either part is.
instance (Alternative f) => Alternative (Lift f) where
empty = Other empty
{-# INLINE empty #-}
Pure x <|> _ = Pure x
Other _ <|> Pure y = Pure y
Other x <|> Other y = Other (x <|> y)
{-# INLINE (<|>) #-}
-- | Projection to the other functor.
unLift :: (Applicative f) => Lift f a -> f a
unLift (Pure x) = pure x
unLift (Other e) = e
{-# INLINE unLift #-}
-- | Apply a transformation to the other computation.
mapLift :: (f a -> g a) -> Lift f a -> Lift g a
mapLift _ (Pure x) = Pure x
mapLift f (Other e) = Other (f e)
{-# INLINE mapLift #-}
-- | Eliminator for 'Lift'.
--
-- * @'elimLift' f g . 'pure' = f@
--
-- * @'elimLift' f g . 'Other' = g@
--
elimLift :: (a -> r) -> (f a -> r) -> Lift f a -> r
elimLift f _ (Pure x) = f x
elimLift _ g (Other e) = g e
{-# INLINE elimLift #-}
-- | An applicative functor that collects a monoid (e.g. lists) of errors.
-- A sequence of computations fails if any of its components do, but
-- unlike monads made with 'Control.Monad.Trans.Except.ExceptT' from
-- "Control.Monad.Trans.Except", these computations continue after an
-- error, collecting all the errors.
--
-- * @'pure' f '<*>' 'pure' x = 'pure' (f x)@
--
-- * @'pure' f '<*>' 'failure' e = 'failure' e@
--
-- * @'failure' e '<*>' 'pure' x = 'failure' e@
--
-- * @'failure' e1 '<*>' 'failure' e2 = 'failure' (e1 '<>' e2)@
--
type Errors e = Lift (Constant e)
-- | Extractor for computations with accumulating errors.
--
-- * @'runErrors' ('pure' x) = 'Right' x@
--
-- * @'runErrors' ('failure' e) = 'Left' e@
--
runErrors :: Errors e a -> Either e a
runErrors (Other (Constant e)) = Left e
runErrors (Pure x) = Right x
{-# INLINE runErrors #-}
-- | Report an error.
failure :: e -> Errors e a
failure e = Other (Constant e)
{-# INLINE failure #-}
-- | Convert from 'Either' to 'Errors' (inverse of 'runErrors').
eitherToErrors :: Either e a -> Errors e a
eitherToErrors = either failure Pure
|
