git.iko.soy/generic-lens
on master help sign in
Reimplement internals using profunctor representation
2b4da69Matthew Pickering
src/Data/Generics/Internal/Lens.hs+169−107
compare with master
unifiedsplit
@@ -4,6 +4,9 @@
4{-# LANGUAGE TypeFamilies #-}
4{-# LANGUAGE TypeFamilies #-}
5{-# LANGUAGE TypeFamilyDependencies #-}
5{-# LANGUAGE TypeFamilyDependencies #-}
6{-# LANGUAGE TypeOperators #-}
6{-# LANGUAGE TypeOperators #-}
7+{-# LANGUAGE TupleSections #-}
8+{-# LANGUAGE NoMonomorphismRestriction #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
7
10
8-----------------------------------------------------------------------------
11-----------------------------------------------------------------------------
9-- |
12-- |
@@ -22,19 +25,23 @@ module Data.Generics.Internal.Lens where
22import Control.Applicative (Const(..))
25import Control.Applicative (Const(..))
23import Data.Functor.Identity (Identity(..))
26import Data.Functor.Identity (Identity(..))
24import Data.Monoid (First (..))
27import Data.Monoid (First (..))
25−import Data.Profunctor (Choice(..), Profunctor(..))
28+import Data.Profunctor (Choice(..), Profunctor(..), Strong(..))
29+import Data.Bifunctor
26import Data.Profunctor.Unsafe ((#.), (.#))
30import Data.Profunctor.Unsafe ((#.), (.#))
27import Data.Tagged
31import Data.Tagged
28import GHC.Generics ((:*:)(..), (:+:)(..), Generic(..), M1(..), K1(..), Rep)
32import GHC.Generics ((:*:)(..), (:+:)(..), Generic(..), M1(..), K1(..), Rep)
29import Data.Coerce
33import Data.Coerce
30
34
31-- | Type alias for lens
35-- | Type alias for lens
32−type Lens' s a
36+type LensVL' s a
33 = Lens s s a a
37 = Lens s s a a
34
38
35−type Lens s t a b
39+type LensVL s t a b
36 = forall f. Functor f => (a -> f b) -> s -> f t
40 = forall f. Functor f => (a -> f b) -> s -> f t
37
41
42+type Lens s t a b
43+ = forall p . (Strong p) => p a b -> p s t
44+
38-- | Type alias for traversal
45-- | Type alias for traversal
39type Traversal' s a
46type Traversal' s a
40 = forall f. Applicative f => (a -> f a) -> s -> f s
47 = forall f. Applicative f => (a -> f a) -> s -> f s
@@ -42,127 +49,153 @@ type Traversal' s a
42type Traversal s t a b
49type Traversal s t a b
43 = forall f. Applicative f => (a -> f b) -> s -> f t
50 = forall f. Applicative f => (a -> f b) -> s -> f t
44
51
45−type LensLike f s t a b
52+type LensLike p s t a b
46− = (a -> f b) -> s -> f t
53+ = p a b -> p s t
47
54
48-- | Type alias for prism
55-- | Type alias for prism
49−type Prism s t a b
56+type PrismVL s t a b
50 = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)
57 = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)
51
58
52−type PrismP s t a b
59+type Prism s t a b
53 = forall p . (Choice p) => p a b -> p s t
60 = forall p . (Choice p) => p a b -> p s t
54
61
55−type Prism' s a
62+type Prism' s a = forall p . (Choice p) => p a a -> p s s
63+
64+type PrismVL' s a
56− = Prism s s a a
65+ = PrismVL s s a a
57
66
58−type Iso' s a
67+type IsoVL' s a
59 = forall p f. (Profunctor p, Functor f) => p a (f a) -> p s (f s)
68 = forall p f. (Profunctor p, Functor f) => p a (f a) -> p s (f s)
60
69
61−type Iso s t a b
70+type IsoVL s t a b
62 = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)
71 = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)
63
72
64−type IsoP s t a b
73+type Iso s t a b
65 = forall p. (Profunctor p) => p a b -> p s t
74 = forall p. (Profunctor p) => p a b -> p s t
66
75
76+type Iso' s a = Iso s s a a
77+
67-- | Getting
78-- | Getting
68(^.) :: s -> ((a -> Const a a) -> s -> Const a s) -> a
79(^.) :: s -> ((a -> Const a a) -> s -> Const a s) -> a
69s ^. l = getConst (l Const s)
80s ^. l = getConst (l Const s)
70infixl 8 ^.
81infixl 8 ^.
71
82
72-- | Setting
83-- | Setting
73−set :: ((a -> Identity b) -> s -> Identity t) -> b -> s -> t
84+set :: ((a -> b) -> s -> t) -> (s, b) -> t
74−set l b
85+set f (s, b)
86+ = f (const b) s
87+
88+viewVL :: ((a -> Const a a) -> s -> Const a s) -> s -> a
89+viewVL l s = (^.) s l
90+
91+viewVL' :: ((a -> Const a a) -> s -> Const a s) -> s -> a
92+viewVL' l s = (^.) s l
93+
94+setVL :: LensVL s t a b -> b -> s -> t
75− = runIdentity . l (\_ -> Identity b)
95+setVL l x = runIdentity . (l (Identity . const x))
96+
97+
98+view :: Lens s s a a -> s -> a
99+view l = withLens l (\get _ -> get)
100+
101+withLens :: Lens s t a b -> ((s -> a) -> ((s, b) -> t) -> r) -> r
102+withLens l k =
103+ case l idLens of
104+ ALens get set -> k get set
105+
106+idLens :: ALens a b a b
107+idLens = ALens id snd
76
108
77infixr 4 .~
109infixr 4 .~
78−(.~) :: ((a -> Identity b) -> s -> Identity t) -> b -> s -> t
110+(.~) :: ((a -> b) -> s -> t) -> b -> s -> t
79−(.~) = set
111+(.~) f b s = set f (s, b)
80
112
81infixl 8 ^?
113infixl 8 ^?
82(^?) :: s -> ((a -> Const (First a) a) -> s -> Const (First a) s) -> Maybe a
114(^?) :: s -> ((a -> Const (First a) a) -> s -> Const (First a) s) -> Maybe a
83s ^? l = getFirst (fmof l (First #. Just) s)
115s ^? l = getFirst (fmof l (First #. Just) s)
84 where fmof l' f = getConst #. l' (Const #. f)
116 where fmof l' f = getConst #. l' (Const #. f)
85
117
86−infixr 8 #
87−(#) :: (Tagged b (Identity b) -> Tagged t (Identity t)) -> b -> t
118+buildVL :: (Tagged b (Identity b) -> Tagged t (Identity t)) -> b -> t
88−(#) p = runIdentity #. unTagged #. p .# Tagged .# Identity
119+buildVL p = runIdentity #. unTagged #. p .# Tagged .# Identity
120+
121+matchVL :: PrismVL s t a b -> s -> Either t a
122+matchVL k = withPrismVL k $ \_ match -> match
123+
124+
125+
126+build :: (Tagged b b -> Tagged t t) -> b -> t
127+build p = unTagged . p . Tagged
128+
89
129
90-- | Lens focusing on the first element of a product
130-- | Lens focusing on the first element of a product
91first :: Lens ((a :*: b) x) ((a' :*: b) x) (a x) (a' x)
131first :: Lens ((a :*: b) x) ((a' :*: b) x) (a x) (a' x)
92−first f (a :*: b)
132+first
93− = fmap (:*: b) (f a)
133+ = lens (\(a :*: b) -> a) (\((a :*: b), a') -> a' :*: b)
94−{-# INLINE first #-}
95
134
96-- | Lens focusing on the second element of a product
135-- | Lens focusing on the second element of a product
97second :: Lens ((a :*: b) x) ((a :*: b') x) (b x) (b' x)
136second :: Lens ((a :*: b) x) ((a :*: b') x) (b x) (b' x)
98−second f (a :*: b)
137+second
99− = fmap (a :*:) (f b)
138+ = lens (\(a :*: b) -> b) (\((a :*: b), b') -> a :*: b')
100−{-# INLINE second #-}
101
139
102left :: Prism ((a :+: c) x) ((b :+: c) x) (a x) (b x)
140left :: Prism ((a :+: c) x) ((b :+: c) x) (a x) (b x)
103left = prism L1 $ gsum Right (Left . R1)
141left = prism L1 $ gsum Right (Left . R1)
104−{-# INLINE left #-}
105−
106−leftP :: PrismP ((a :+: c) x) ((b :+: c) x) (a x) (b x)
107−leftP = prismP L1 $ gsum Right (Left . R1)
108
142
109right :: Prism ((a :+: b) x) ((a :+: c) x) (b x) (c x)
143right :: Prism ((a :+: b) x) ((a :+: c) x) (b x) (c x)
110right = prism R1 $ gsum (Left . L1) Right
144right = prism R1 $ gsum (Left . L1) Right
111−{-# INLINE right #-}
112−
113−rightP :: PrismP ((a :+: b) x) ((a :+: c) x) (b x) (c x)
114−rightP = prismP R1 $ gsum (Left . L1) Right
115
145
116gsum :: (a x -> c) -> (b x -> c) -> ((a :+: b) x) -> c
146gsum :: (a x -> c) -> (b x -> c) -> ((a :+: b) x) -> c
117gsum f _ (L1 x) = f x
147gsum f _ (L1 x) = f x
118gsum _ g (R1 y) = g y
148gsum _ g (R1 y) = g y
119−{-# INLINE gsum #-}
120
149
121−prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
150+prismVL :: (b -> t) -> (s -> Either t a) -> PrismVL s t a b
122−prism bt seta eta = dimap (\x -> plus pure id (seta x)) (either id (\x -> fmap bt x)) (right' eta)
151+prismVL bt seta eta = dimap (\x -> plus pure id (seta x)) (either id (\x -> fmap bt x)) (right' eta)
123−{-# INLINE prism #-}
152+{-# INLINE prismVL #-}
124
153
125−prismP :: (b -> t) -> (s -> Either t a) -> PrismP s t a b
154+prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
126−prismP bt seta eta = dimap seta (either id bt) (right' eta)
155+prism bt seta eta = dimap seta (either id bt) (right' eta)
127−{-# INLINE prismP #-}
128
156
129plus :: (a -> b) -> (c -> d) -> Either a c -> Either b d
157plus :: (a -> b) -> (c -> d) -> Either a c -> Either b d
130plus f _ (Left x) = Left (f x)
158plus f _ (Left x) = Left (f x)
131plus _ g (Right y) = Right (g y)
159plus _ g (Right y) = Right (g y)
132
160
161+fork :: (a -> b) -> (a -> c) -> a -> (b, c)
162+fork f g a = (f a, g a)
163+
164+swap :: (a, b) -> (b, a)
165+swap (a, b) = (b, a)
166+
167+cross :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)
168+cross = bimap
169+
133-- | A type and its generic representation are isomorphic
170-- | A type and its generic representation are isomorphic
134−repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)
171+repIsoVL :: (Generic a, Generic b) => IsoVL a b (Rep a x) (Rep b x)
135−repIso = iso from to
172+repIsoVL = isoVL from to
136−{-# INLINE repIso #-}
137
173
138repLens :: (Generic a, Generic b) => Lens a b (Rep a x) (Rep b x)
174repLens :: (Generic a, Generic b) => Lens a b (Rep a x) (Rep b x)
139−repLens f s = repIso f s
175+repLens f = repIso f
140−{-# INLINE repLens #-}
141
176
142-- | A type and its generic representation are isomorphic
177-- | A type and its generic representation are isomorphic
143−repIsoP :: (Generic a, Generic b) => IsoP a b (Rep a x) (Rep b x)
178+repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)
144−repIsoP = dimap from to
179+repIso = iso from to
180+
145
181
146
182
147-- | 'M1' is just a wrapper around `f p`
183-- | 'M1' is just a wrapper around `f p`
148−mIso :: Iso (M1 i c f p) (M1 i c g p) (f p) (g p)
184+mIsoVL :: IsoVL (M1 i c f p) (M1 i c g p) (f p) (g p)
149−mIso = iso unM1 M1
185+mIsoVL = isoVL unM1 M1
150−{-# INLINE mIso #-}
151
186
152-- | 'M1' is just a wrapper around `f p`
187-- | 'M1' is just a wrapper around `f p`
153--mIso :: Iso' (M1 i c f p) (f p)
188--mIso :: Iso' (M1 i c f p) (f p)
154−mIsoP :: IsoP (M1 i c f p) (M1 i c g p) (f p) (g p)
189+mIso :: Iso (M1 i c f p) (M1 i c g p) (f p) (g p)
155−mIsoP = dimap unM1 M1
190+mIso = iso unM1 M1
156
191
157-- These are specialised versions of the Isos above. On GHC 8.0.2, having
192-- These are specialised versions of the Isos above. On GHC 8.0.2, having
158-- these functions eta-expanded allows the optimiser to inline these functions.
193-- these functions eta-expanded allows the optimiser to inline these functions.
159mLens :: Lens (M1 i c f p) (M1 i c g p) (f p) (g p)
194mLens :: Lens (M1 i c f p) (M1 i c g p) (f p) (g p)
160−mLens f s = mIso f s
195+mLens f = mIso f
161−{-# INLINE mLens #-}
162
196
163kIso :: Iso (K1 r a p) (K1 r b p) a b
197kIso :: Iso (K1 r a p) (K1 r b p) a b
164kIso = iso unK1 K1
198kIso = iso unK1 K1
165−{-# INLINE kIso #-}
166
199
167sumIso :: Iso ((a :+: b) x) ((a' :+: b') x) (Either (a x) (b x)) (Either (a' x) (b' x))
200sumIso :: Iso ((a :+: b) x) ((a' :+: b') x) (Either (a x) (b x)) (Either (a' x) (b' x))
168sumIso = iso back forth
201sumIso = iso back forth
@@ -170,7 +203,6 @@ sumIso = iso back forth
170 forth (Right r) = (R1 r)
203 forth (Right r) = (R1 r)
171 back (L1 l) = (Left l)
204 back (L1 l) = (Left l)
172 back (R1 r) = (Right r)
205 back (R1 r) = (Right r)
173−{-# INLINE sumIso #-}
174
206
175_Left :: Prism (Either a c) (Either b c) a b
207_Left :: Prism (Either a c) (Either b c) a b
176_Left = prism Left $ either Right (Left . Right)
208_Left = prism Left $ either Right (Left . Right)
@@ -192,70 +224,81 @@ inj (Coyoneda f a) = fmap f a
192proj :: Functor f => f a -> Coyoneda f a
224proj :: Functor f => f a -> Coyoneda f a
193proj fa = Coyoneda id fa
225proj fa = Coyoneda id fa
194
226
195−ravel :: Functor f => ((a -> Coyoneda f b) -> s -> Coyoneda f t) -> (a -> f b) -> (s -> f t)
227+lens2lensvl :: ALens a b s t -> LensVL s t a b
196−ravel coy f s = inj $ coy (\a -> proj (f a)) s
228+lens2lensvl (ALens get set) = lensVL get set
229+
230+ravel :: (ALens a b a b -> ALens a b s t)
231+ -> LensVL s t a b
232+ravel l pab = (lens2lensvl $ l idLens) pab
197
233
198prismPRavel ::
234prismPRavel ::
199 (Market a b a b -> Market a b s t)
235 (Market a b a b -> Market a b s t)
200− -> PrismP s t a b
236+ -> Prism s t a b
201prismPRavel l pab = (prism2prismp $ l idPrism) pab
237prismPRavel l pab = (prism2prismp $ l idPrism) pab
202−{-# INLINE prismPRavel #-}
203
238
204−prismRavel ::
239+prismVLRavel ::
205 (Market a b a b -> Market a b s t)
240 (Market a b a b -> Market a b s t)
206− -> Prism s t a b
241+ -> PrismVL s t a b
207−prismRavel l pab = (prism2prismvl $ l idPrism) pab
242+prismVLRavel l pab = (prism2prismvl $ l idPrism) pab
208−{-# INLINE prismRavel #-}
243+
244+newtype Alongside p s t a b = Alongside { getAlongside :: p (s, a) (t, b) }
209
245
210−newtype AlongsideLeft f b a = AlongsideLeft { getAlongsideLeft :: f (a, b) }
246+instance Profunctor p => Profunctor (Alongside p c d) where
211−newtype AlongsideRight f b a = AlongsideRight { getAlongsideRight :: f (b, a) }
247+ dimap f g (Alongside pab) = Alongside $ dimap (fmap f) (fmap g) pab
248+
249+instance Strong p => Strong (Alongside p c d) where
250+ second' (Alongside pab) = Alongside . dimap shuffle shuffle . second' $ pab
251+ where
252+ shuffle (x,(y,z)) = (y,(x,z))
212
253
213(??) :: Functor f => f (a -> b) -> a -> f b
254(??) :: Functor f => f (a -> b) -> a -> f b
214fab ?? a = fmap ($ a) fab
255fab ?? a = fmap ($ a) fab
215
256
216−instance Functor f => Functor (AlongsideLeft f b) where
257+-- Could implement this using primitives?
217− fmap f = AlongsideLeft . fmap (\(a, b) -> (f a, b)) . getAlongsideLeft
258+alongside :: Profunctor p =>
218−
259+ LensLike (Alongside p s' t') s t a b
219−instance Functor f => Functor (AlongsideRight f b) where
260+ -> LensLike (Alongside p a b) s' t' a' b'
220− fmap f = AlongsideRight . fmap (\(a, b) -> (a, f b)) . getAlongsideRight
261+ -> LensLike p (s, s') (t, t') (a, a') (b, b')
262+alongside l1 l2
263+ = dimap swap swap . getAlongside . l1 . Alongside . dimap swap swap . getAlongside . l2 . Alongside
221
264
222−alongside :: LensLike (AlongsideLeft f b') s t a b
265+prodIsoVL :: IsoVL ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)
223− -> LensLike (AlongsideRight f t) s' t' a' b'
266+prodIsoVL = isoVL (\(a :*: b) -> (a, b)) (\(a, b) -> (a :*: b))
224− -> LensLike f (s, s') (t, t') (a, a') (b, b')
225−alongside l1 l2 f (a1, a2)
226− = getAlongsideRight $ l2 ?? a2 $ \b2 -> AlongsideRight
227− $ getAlongsideLeft $ l1 ?? a1 $ \b1 -> AlongsideLeft
228− $ f (b1,b2)
229−{-# INLINE alongside #-}
230
267
231prodIso :: Iso ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)
268prodIso :: Iso ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)
232prodIso = iso (\(a :*: b) -> (a, b)) (\(a, b) -> (a :*: b))
269prodIso = iso (\(a :*: b) -> (a, b)) (\(a, b) -> (a :*: b))
233−{-# INLINE prodIso #-}
234
270
235prodL :: Lens ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)
271prodL :: Lens ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)
236−prodL f s = prodIso f s
272+prodL f = prodIso f
237−{-# INLINE prodL #-}
238
273
239prodR :: Lens (a' x, b' x) (a x, b x) ((a' :*: b') x) ((a :*: b) x)
274prodR :: Lens (a' x, b' x) (a x, b x) ((a' :*: b') x) ((a :*: b) x)
240−prodR f s = fromIso prodIso f s
275+prodR f = fromIso prodIso f
241−{-# INLINE prodR #-}
242
276
243assoc3 :: Iso ((a, b), c) ((a', b'), c') (a, (b, c)) (a', (b', c'))
277assoc3 :: Iso ((a, b), c) ((a', b'), c') (a, (b, c)) (a', (b', c'))
244assoc3 = iso (\((a, b), c) -> (a, (b, c))) (\(a, (b, c)) -> ((a, b), c))
278assoc3 = iso (\((a, b), c) -> (a, (b, c))) (\(a, (b, c)) -> ((a, b), c))
245−{-# INLINE assoc3 #-}
246
279
247assoc3L :: Lens ((a, b), c) ((a', b'), c') (a, (b, c)) (a', (b', c'))
280assoc3L :: Lens ((a, b), c) ((a', b'), c') (a, (b, c)) (a', (b', c'))
248−assoc3L f s = assoc3 f s
281+assoc3L f = assoc3 f
249−{-# INLINE assoc3L #-}
250
282
251assoc3R :: Lens (a', (b', c')) (a, (b, c)) ((a', b'), c') ((a, b), c)
283assoc3R :: Lens (a', (b', c')) (a, (b, c)) ((a', b'), c') ((a, b), c)
252−assoc3R f s = fromIso assoc3 f s
284+assoc3R f = fromIso assoc3 f
253−{-# INLINE assoc3R #-}
285+
286+stron :: (Either s s', b) -> Either (s, b) (s', b)
287+stron (e, b) = bimap (,b) (, b) e
288+
289+choosing :: forall s t a b s' t' . Lens s t a b -> Lens s' t' a b -> Lens (Either s s') (Either t t') a b
290+choosing l r = withLens l (\getl setl ->
291+ withLens r (\getr setr ->
292+ let g :: Either s s' -> a
293+ g = either getl getr
294+ s = bimap setl setr . stron
295+ in lens g s))
254
296
255−choosing :: Lens s t a b -> Lens s' t' a b -> Lens (Either s s') (Either t t') a b
297+lens :: (s -> a) -> ((s,b) -> t) -> Lens s t a b
256−choosing l _ f (Left a) = Left <$> l f a
298+lens get set = dimap (fork id get) set . second'
257−choosing _ r f (Right a') = Right <$> r f a'
299+
258−{-# INLINE choosing #-}
300+lensVL :: (s -> a) -> ((s, b) -> t) -> LensVL s t a b
301+lensVL get set f x = curry set x <$> f (get x)
259
302
260--------------------------------------------------------------------------------
303--------------------------------------------------------------------------------
261-- Iso stuff
304-- Iso stuff
@@ -282,13 +325,16 @@ fromIso :: Iso s t a b -> Iso b a t s
282fromIso l = withIso l $ \ sa bt -> iso bt sa
325fromIso l = withIso l $ \ sa bt -> iso bt sa
283{-# INLINE fromIso #-}
326{-# INLINE fromIso #-}
284
327
285−iso :: (s -> a) -> (b -> t) -> Iso s t a b
328+isoVL :: (s -> a) -> (b -> t) -> IsoVL s t a b
286−iso sa bt = dimap sa (fmap bt)
329+isoVL sa bt = dimap sa (fmap bt)
287{-# INLINE iso #-}
330{-# INLINE iso #-}
288
331
332+iso :: (s -> a) -> (b -> t) -> Iso s t a b
333+iso = dimap
334+
289withIso :: Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
335withIso :: Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
290−withIso ai k = case ai (Exchange id Identity) of
336+withIso ai k = case ai (Exchange id id) of
291− Exchange sa bt -> k sa (runIdentity #. bt)
337+ Exchange sa bt -> k sa bt
292
338
293pairing :: Iso s t a b -> Iso s' t' a' b' -> Iso (s, s') (t, t') (a, a') (b, b')
339pairing :: Iso s t a b -> Iso s' t' a' b' -> Iso (s, s') (t, t') (a, a') (b, b')
294pairing f g = withIso f $ \ sa bt -> withIso g $ \s'a' b't' ->
340pairing f g = withIso f $ \ sa bt -> withIso g $ \s'a' b't' ->
@@ -298,7 +344,8 @@ pairing f g = withIso f $ \ sa bt -> withIso g $ \s'a' b't' ->
298--------------------------------------------------------------------------------
344--------------------------------------------------------------------------------
299-- Prism stuff
345-- Prism stuff
300
346
301−type APrism s t a b = Market a b a (Identity b) -> Market a b s (Identity t)
347+type APrism s t a b = Market a b a b -> Market a b s t
348+type APrismVL s t a b = Market a b a (Identity b) -> Market a b s (Identity t)
302
349
303-- without :: APrism s t a b
350-- without :: APrism s t a b
304-- -> APrism u v c d
351-- -> APrism u v c d
@@ -315,7 +362,7 @@ type APrism s t a b = Market a b a (Identity b) -> Market a b s (Identity t)
315-- bimapE _ g (Right a) = Right (g a)
362-- bimapE _ g (Right a) = Right (g a)
316-- {-# INLINE bimapE #-}
363-- {-# INLINE bimapE #-}
317
364
318−without' :: APrism s t a b -> APrism s t c d -> Prism s t (Either a c) (Either b d)
365+without' :: Prism s t a b -> Prism s t c d -> Prism s t (Either a c) (Either b d)
319without' k =
366without' k =
320 withPrism k $ \bt _ k' ->
367 withPrism k $ \bt _ k' ->
321 withPrism k' $ \dt setc ->
368 withPrism k' $ \dt setc ->
@@ -324,9 +371,13 @@ without' k =
324 foldEither f _ (Left l) = f l
371 foldEither f _ (Left l) = f l
325
372
326withPrism :: APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
373withPrism :: APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
327−withPrism k f = case coerce (k (Market Identity Right)) of
374+withPrism k f = case k idPrism of
328 Market bt seta -> f bt seta
375 Market bt seta -> f bt seta
329
376
377+withPrismVL :: APrismVL s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
378+withPrismVL k f = case coerce (k (Market Identity Right)) of
379+ Market bt seta -> f bt seta
380+
330--------------------------------------------------------------------------------
381--------------------------------------------------------------------------------
331-- Market
382-- Market
332
383
@@ -356,11 +407,11 @@ instance Choice (Market a b) where
356 Right c -> Left (Right c)
407 Right c -> Left (Right c)
357 {-# INLINE left' #-}
408 {-# INLINE left' #-}
358
409
359−prism2prismp :: Market a b s t -> PrismP s t a b
410+prism2prismp :: Market a b s t -> Prism s t a b
360−prism2prismp (Market bt seta) = prismP bt seta
411+prism2prismp (Market bt seta) = prism bt seta
361
412
362−prism2prismvl :: Market a b s t -> Prism s t a b
413+prism2prismvl :: Market a b s t -> PrismVL s t a b
363−prism2prismvl (Market bt seta) = prism bt seta
414+prism2prismvl (Market bt seta) = prismVL bt seta
364{-# INLINE prism2prismvl #-}
415{-# INLINE prism2prismvl #-}
365
416
366idPrism :: Market a b a b
417idPrism :: Market a b a b
@@ -368,6 +419,19 @@ idPrism = Market id Right
368
419
369------------------------------------------------------------------------------
420------------------------------------------------------------------------------
370
421
422+data ALens a b s t = ALens (s -> a) ((s, b) -> t)
423+
424+instance Functor (ALens a b s) where
425+ fmap f (ALens get set) = ALens get (f . set)
426+
427+instance Profunctor (ALens a b) where
428+ dimap f g (ALens get set) = ALens (get . f) (g . set . cross f id)
429+
430+instance Strong (ALens a b) where
431+ second' (ALens get set) = ALens (get . snd) (bimap id set . assoc)
432+ where
433+ assoc ((a, b), c) = (a, (b, c))
434+
371newtype Curried f a =
435newtype Curried f a =
372 Curried { runCurried :: forall r. f (a -> r) -> f r }
436 Curried { runCurried :: forall r. f (a -> r) -> f r }
373
437
@@ -396,14 +460,12 @@ instance (Functor f) => Applicative (Curried f) where
396-- @
460-- @
397liftCurried :: Applicative f => f a -> Curried f a
461liftCurried :: Applicative f => f a -> Curried f a
398liftCurried fa = Curried (<*> fa)
462liftCurried fa = Curried (<*> fa)
399−{-# INLINE liftCurried #-}
400
463
401-- | Lower 'Curried' by applying 'pure' 'id' to the continuation.
464-- | Lower 'Curried' by applying 'pure' 'id' to the continuation.
402--
465--
403-- See 'liftCurried'.
466-- See 'liftCurried'.
404lowerCurried :: Applicative f => Curried f a -> f a
467lowerCurried :: Applicative f => Curried f a -> f a
405lowerCurried (Curried f) = f (pure id)
468lowerCurried (Curried f) = f (pure id)
406−{-# INLINE lowerCurried #-}
407
469
408confusing :: Applicative f => Traversal s t a b -> (a -> f b) -> s -> f t
470confusing :: Applicative f => Traversal s t a b -> (a -> f b) -> s -> f t
409confusing t = \f -> lowerYoneda . lowerCurried . t (liftCurriedYoneda . f)
471confusing t = \f -> lowerYoneda . lowerCurried . t (liftCurriedYoneda . f)
src/Data/Generics/Product/Any.hs+1−1
@@ -67,7 +67,7 @@ class HasAny (sel :: k) s t a b | s sel k -> a where
67 --
67 --
68 -- >>> human ^. the @3
68 -- >>> human ^. the @3
69 -- "London"
69 -- "London"
70− the :: Lens s t a b
70+ the :: LensVL s t a b
71
71
72instance HasPosition i s t a b => HasAny i s t a b where
72instance HasPosition i s t a b => HasAny i s t a b where
73 the = position @i
73 the = position @i
src/Data/Generics/Product/Fields.hs+4−4
@@ -108,21 +108,21 @@ class HasField (field :: Symbol) s t a b | s field -> a, t field -> b, s field b
108 -- ... The offending constructors are:
108 -- ... The offending constructors are:
109 -- ... HumanNoAddress
109 -- ... HumanNoAddress
110 -- ...
110 -- ...
111− field :: Lens s t a b
111+ field :: LensVL s t a b
112
112
113type HasField' field s a = HasField field s s a a
113type HasField' field s a = HasField field s s a a
114
114
115-- |
115-- |
116-- >>> getField @"age" human
116-- >>> getField @"age" human
117-- 50
117-- 50
118−getField :: forall f s a. HasField' f s a => s -> a
118+getField :: forall f s t a b . HasField' f s a => s -> a
119−getField s = s ^. field @f
119+getField = viewVL' (field @f)
120
120
121-- |
121-- |
122-- >>> setField @"age" 60 human
122-- >>> setField @"age" 60 human
123-- Human {name = "Tunyasz", age = 60, address = "London", other = False}
123-- Human {name = "Tunyasz", age = 60, address = "London", other = False}
124setField :: forall f s a. HasField' f s a => a -> s -> s
124setField :: forall f s a. HasField' f s a => a -> s -> s
125−setField = set (field @f)
125+setField = setVL (field @f)
126
126
127instance -- see Note [Changing type parameters]
127instance -- see Note [Changing type parameters]
128 ( Generic s
128 ( Generic s
src/Data/Generics/Product/Internal/List.hs+7−6
@@ -47,6 +47,7 @@ import Data.Generics.Internal.Lens
47
47
48import Data.Kind (Type)
48import Data.Kind (Type)
49import GHC.Generics
49import GHC.Generics
50+import Data.Profunctor
50
51
51data List (as :: [(m, Type)]) where
52data List (as :: [(m, Type)]) where
52 Nil :: List '[]
53 Nil :: List '[]
@@ -80,10 +81,10 @@ class GIsList
80 glist :: Iso (f x) (g x) (List as) (List bs)
81 glist :: Iso (f x) (g x) (List as) (List bs)
81
82
82 glistL :: Lens (f x) (g x) (List as) (List bs)
83 glistL :: Lens (f x) (g x) (List as) (List bs)
83− glistL f s = glist @m f s
84+ glistL f = glist @m f
84
85
85 glistR :: Lens (List bs) (List as) (g x) (f x)
86 glistR :: Lens (List bs) (List as) (g x) (f x)
86− glistR f s = fromIso (glist @m) f s
87+ glistR f = fromIso (glist @m) f
87
88
88instance
89instance
89 ( GIsList m l l' as as'
90 ( GIsList m l l' as as'
@@ -168,15 +169,15 @@ instance {-# OVERLAPPING #-}
168 ( as ~ ('(f, a) ': as')
169 ( as ~ ('(f, a) ': as')
169 , bs ~ ('(f, b) ': as')
170 , bs ~ ('(f, b) ': as')
170 ) => IndexList 0 as bs a b where
171 ) => IndexList 0 as bs a b where
171− point f (x :> xs) = (:> xs) <$> f x
172+ point = lens (\(x :> xs) -> x) (\((x :> xs), x') -> x' :> xs)
172 {-# INLINE point #-}
173 {-# INLINE point #-}
173
174
174instance
175instance
175 ( IndexList (n - 1) as' bs' a b
176 ( IndexList (n - 1) as' bs' a b
176− , as ~ (x ': as')
177+ , as ~ ('(f, x) ': as')
177− , bs ~ (x ': bs')
178+ , bs ~ ('(f, x) ': bs')
178 ) => IndexList n as bs a b where
179 ) => IndexList n as bs a b where
179− point f (x :> xs) = (x :>) <$> point @(n - 1) f xs
180+ point = fromIso consing . alongside id (point @(n-1)) . second'
180 {-# INLINE point #-}
181 {-# INLINE point #-}
181
182
182--------------------------------------------------------------------------------
183--------------------------------------------------------------------------------
src/Data/Generics/Product/Internal/Subtype.hs+2−2
@@ -50,7 +50,7 @@ instance
50 GHasKey field sub sub t t
50 GHasKey field sub sub t t
51 => GUpcast sub (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where
51 => GUpcast sub (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where
52
52
53− gupcast r = M1 (K1 (r ^. gkey @field))
53+ gupcast r = M1 (K1 (view (gkey @field) r))
54
54
55instance GUpcast sub sup => GUpcast sub (C1 c sup) where
55instance GUpcast sub sup => GUpcast sub (C1 c sup) where
56 gupcast = M1 . gupcast
56 gupcast = M1 . gupcast
@@ -86,7 +86,7 @@ class GSmashLeaf sub sup (w :: Bool) where
86instance
86instance
87 GHasKey field sup sup t t
87 GHasKey field sup sup t t
88 => GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'True where
88 => GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'True where
89− gsmashLeaf sup _ = M1 (K1 (sup ^. gkey @field))
89+ gsmashLeaf sup _ = M1 (K1 (view (gkey @field) sup))
90
90
91instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'False where
91instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'False where
92 gsmashLeaf _ = id
92 gsmashLeaf _ = id
src/Data/Generics/Product/Positions.hs+2−2
@@ -86,7 +86,7 @@ class HasPosition (i :: Nat) s t a b | s i -> a, t i -> b, s i b -> t, t i a ->
86 -- ...
86 -- ...
87 -- ... The type Human does not contain a field at position 4
87 -- ... The type Human does not contain a field at position 4
88 -- ...
88 -- ...
89− position :: Lens s t a b
89+ position :: LensVL s t a b
90
90
91type HasPosition' i s a = HasPosition i s s a a
91type HasPosition' i s a = HasPosition i s s a a
92
92
@@ -94,7 +94,7 @@ getPosition :: forall i s a. HasPosition' i s a => s -> a
94getPosition s = s ^. position @i
94getPosition s = s ^. position @i
95
95
96setPosition :: forall i s a. HasPosition' i s a => a -> s -> s
96setPosition :: forall i s a. HasPosition' i s a => a -> s -> s
97−setPosition = set (position @i)
97+setPosition = setVL (position @i)
98
98
99instance -- see Note [Changing type parameters]
99instance -- see Note [Changing type parameters]
100 ( Generic s
100 ( Generic s
src/Data/Generics/Product/Subtype.hs+4−4
@@ -80,9 +80,9 @@ class Subtype sup sub where
80 --
80 --
81 -- >>> set (super @Animal) (Animal "dog" 10) human
81 -- >>> set (super @Animal) (Animal "dog" 10) human
82 -- Human {name = "dog", age = 10, address = "London"}
82 -- Human {name = "dog", age = 10, address = "London"}
83− super :: Lens' sub sup
83+ super :: LensVL sub sub sup sup
84− super f sub
84+ super
85− = fmap (`smash` sub) (f (upcast sub))
85+ = lensVL upcast (uncurry smash . swap)
86
86
87 -- |Cast the more specific subtype to the more general supertype
87 -- |Cast the more specific subtype to the more general supertype
88 --
88 --
@@ -103,7 +103,7 @@ class Subtype sup sub where
103 -- >>> smash (Animal "dog" 10) human
103 -- >>> smash (Animal "dog" 10) human
104 -- Human {name = "dog", age = 10, address = "London"}
104 -- Human {name = "dog", age = 10, address = "London"}
105 smash :: sup -> sub -> sub
105 smash :: sup -> sub -> sub
106− smash = set (super @sup)
106+ smash = setVL (super @sup)
107
107
108 {-# MINIMAL super | smash, upcast #-}
108 {-# MINIMAL super | smash, upcast #-}
109
109
src/Data/Generics/Product/Typed.hs+4−4
@@ -91,9 +91,9 @@ class HasType a s where
91 -- ... The offending constructors are:
91 -- ... The offending constructors are:
92 -- ... HumanNoTall
92 -- ... HumanNoTall
93 -- ...
93 -- ...
94− typed :: Lens' s a
94+ typed :: LensVL s s a a
95− typed f t
95+ typed
96− = fmap (flip (setTyped @a) t) (f (getTyped @a t))
96+ = lensVL (getTyped @a) (uncurry (setTyped @a) . swap)
97
97
98 -- |Get field at type.
98 -- |Get field at type.
99 getTyped :: s -> a
99 getTyped :: s -> a
@@ -101,7 +101,7 @@ class HasType a s where
101
101
102 -- |Set field at type.
102 -- |Set field at type.
103 setTyped :: a -> s -> s
103 setTyped :: a -> s -> s
104− setTyped = set (typed @a)
104+ setTyped = setVL (typed @a)
105
105
106 {-# MINIMAL typed | setTyped, getTyped #-}
106 {-# MINIMAL typed | setTyped, getTyped #-}
107
107
src/Data/Generics/Sum/Any.hs+1−1
@@ -86,7 +86,7 @@ class AsAny (sel :: k) a s | s sel k -> a where
86 --
86 --
87 -- >>> duck ^? _As @Age
87 -- >>> duck ^? _As @Age
88 -- Just 2
88 -- Just 2
89− _As :: Prism s s a a
89+ _As :: PrismVL s s a a
90
90
91instance AsConstructor ctor s s a a => AsAny ctor a s where
91instance AsConstructor ctor s s a a => AsAny ctor a s where
92 _As = _Ctor @ctor
92 _As = _Ctor @ctor
src/Data/Generics/Sum/Constructors.hs+2−2
@@ -98,7 +98,7 @@ class AsConstructor (ctor :: Symbol) s t a b | ctor s -> a, ctor t -> b where
98 -- ...
98 -- ...
99 -- ... The type Animal Int does not contain a constructor named "Turtle"
99 -- ... The type Animal Int does not contain a constructor named "Turtle"
100 -- ...
100 -- ...
101− _Ctor :: Prism s t a b
101+ _Ctor :: PrismVL s t a b
102
102
103instance
103instance
104 ( Generic s
104 ( Generic s
@@ -121,7 +121,7 @@ instance
121 , s ~ Infer t b' a
121 , s ~ Infer t b' a
122 ) => AsConstructor ctor s t a b where
122 ) => AsConstructor ctor s t a b where
123
123
124− _Ctor eta = prismRavel (repIsoP . _GCtor @ctor) eta
124+ _Ctor eta = prismVLRavel (repIso . _GCtor @ctor) eta
125 {-# INLINE _Ctor #-}
125 {-# INLINE _Ctor #-}
126
126
127-- See Note [Uncluttering type signatures]
127-- See Note [Uncluttering type signatures]
src/Data/Generics/Sum/Internal/Constructors.hs+6−6
@@ -40,7 +40,7 @@ import Data.Kind
40-- |As 'AsConstructor' but over generic representations as defined by
40-- |As 'AsConstructor' but over generic representations as defined by
41-- "GHC.Generics".
41-- "GHC.Generics".
42class GAsConstructor (ctor :: Symbol) s t a b | ctor s -> a, ctor t -> b where
42class GAsConstructor (ctor :: Symbol) s t a b | ctor s -> a, ctor t -> b where
43− _GCtor :: PrismP (s x) (t x) a b
43+ _GCtor :: Prism (s x) (t x) a b
44
44
45type GAsConstructor' ctor s a = GAsConstructor ctor s s a a
45type GAsConstructor' ctor s a = GAsConstructor ctor s s a a
46
46
@@ -53,7 +53,7 @@ instance
53
53
54-- _GCtor = prismP (M1 . gfromCollection . tupleToList) (Right . listToTuple . gtoCollection . unM1)
54-- _GCtor = prismP (M1 . gfromCollection . tupleToList) (Right . listToTuple . gtoCollection . unM1)
55-- {-# INLINE _GCtor #-}
55-- {-# INLINE _GCtor #-}
56− _GCtor = prismP (M1 . (^. fromIso (glist @Type)) . tupleToList) (Right . listToTuple . (^. glist @Type) . unM1)
56+ _GCtor = prism (M1 . (view (fromIso (glist @Type))) . tupleToList) (Right . listToTuple . (view (glist @Type)) . unM1)
57
57
58
58
59instance GSumAsConstructor ctor (HasCtorP ctor l) l r l' r' a b => GAsConstructor ctor (l :+: r) (l' :+: r') a b where
59instance GSumAsConstructor ctor (HasCtorP ctor l) l r l' r' a b => GAsConstructor ctor (l :+: r) (l' :+: r') a b where
@@ -61,16 +61,16 @@ instance GSumAsConstructor ctor (HasCtorP ctor l) l r l' r' a b => GAsConstructo
61 {-# INLINE _GCtor #-}
61 {-# INLINE _GCtor #-}
62
62
63instance GAsConstructor ctor f f' a b => GAsConstructor ctor (M1 D meta f) (M1 D meta f') a b where
63instance GAsConstructor ctor f f' a b => GAsConstructor ctor (M1 D meta f) (M1 D meta f') a b where
64− _GCtor = mIsoP . _GCtor @ctor
64+ _GCtor = mIso . _GCtor @ctor
65 {-# INLINE _GCtor #-}
65 {-# INLINE _GCtor #-}
66
66
67class GSumAsConstructor (ctor :: Symbol) (contains :: Bool) l r l' r' a b | ctor l r -> a, ctor l' r' -> b where
67class GSumAsConstructor (ctor :: Symbol) (contains :: Bool) l r l' r' a b | ctor l r -> a, ctor l' r' -> b where
68− _GSumCtor :: PrismP ((l :+: r) x) ((l' :+: r') x) a b
68+ _GSumCtor :: Prism ((l :+: r) x) ((l' :+: r') x) a b
69
69
70instance GAsConstructor ctor l l' a b => GSumAsConstructor ctor 'True l r l' r a b where
70instance GAsConstructor ctor l l' a b => GSumAsConstructor ctor 'True l r l' r a b where
71− _GSumCtor = leftP . _GCtor @ctor
71+ _GSumCtor = left . _GCtor @ctor
72 {-# INLINE _GSumCtor #-}
72 {-# INLINE _GSumCtor #-}
73
73
74instance GAsConstructor ctor r r' a b => GSumAsConstructor ctor 'False l r l r' a b where
74instance GAsConstructor ctor r r' a b => GSumAsConstructor ctor 'False l r l r' a b where
75− _GSumCtor = rightP . _GCtor @ctor
75+ _GSumCtor = right . _GCtor @ctor
76 {-# INLINE _GSumCtor #-}
76 {-# INLINE _GSumCtor #-}
src/Data/Generics/Sum/Internal/Typed.hs+2−2
@@ -36,7 +36,7 @@ import Data.Generics.Internal.Lens
36
36
37-- |As 'AsType' but over generic representations as defined by "GHC.Generics".
37-- |As 'AsType' but over generic representations as defined by "GHC.Generics".
38class GAsType (f :: Type -> Type) (as :: [((), Type)]) where
38class GAsType (f :: Type -> Type) (as :: [((), Type)]) where
39− _GTyped :: Prism' (f x) (List as)
39+ _GTyped :: Prism (f x) (f x) (List as) (List as)
40
40
41instance
41instance
42 ( GIsList () f f as as
42 ( GIsList () f f as as
@@ -50,7 +50,7 @@ instance GAsType f a => GAsType (M1 D meta f) a where
50 _GTyped = mIso . _GTyped
50 _GTyped = mIso . _GTyped
51
51
52class GSumAsType (contains :: Bool) l r (a :: [((), Type)]) where
52class GSumAsType (contains :: Bool) l r (a :: [((), Type)]) where
53− _GSumTyped :: Prism' ((l :+: r) x) (List a)
53+ _GSumTyped :: Prism ((l :+: r) x) ((l :+: r) x) (List a) (List a)
54
54
55instance GAsType l a => GSumAsType 'True l r a where
55instance GAsType l a => GSumAsType 'True l r a where
56 _GSumTyped = left . _GTyped
56 _GSumTyped = left . _GTyped
src/Data/Generics/Sum/Subtype.hs+1−1
@@ -92,7 +92,7 @@ class AsSubtype sub sup where
92
92
93 -- |Injects a subtype into a supertype (upcast).
93 -- |Injects a subtype into a supertype (upcast).
94 injectSub :: sub -> sup
94 injectSub :: sub -> sup
95− injectSub = (_Sub @sub @sup #)
95+ injectSub = build (_Sub @sub @sup)
96
96
97 -- |Projects a subtype from a supertype (downcast).
97 -- |Projects a subtype from a supertype (downcast).
98 projectSub :: sup -> Either sup sub
98 projectSub :: sup -> Either sup sub
src/Data/Generics/Sum/Typed.hs+5−4
@@ -85,17 +85,17 @@ class AsType a s where
85 -- ... Duck
85 -- ... Duck
86 -- ... Turtle
86 -- ... Turtle
87 -- ...
87 -- ...
88− _Typed :: Prism' s a
88+ _Typed :: PrismVL' s a
89
89
90 -- |Inject by type.
90 -- |Inject by type.
91 injectTyped :: a -> s
91 injectTyped :: a -> s
92 injectTyped
92 injectTyped
93− = (_Typed #)
93+ = buildVL _Typed
94
94
95 -- |Project by type.
95 -- |Project by type.
96 projectTyped :: s -> Maybe a
96 projectTyped :: s -> Maybe a
97 projectTyped
97 projectTyped
98− = either (const Nothing) Just . (withPrism _Typed (\_ b -> b))
98+ = either (const Nothing) Just . (matchVL _Typed)
99
99
100instance
100instance
101 ( Generic s
101 ( Generic s
@@ -112,7 +112,8 @@ instance
112-- = to . ginjectTyped
112-- = to . ginjectTyped
113-- projectTyped
113-- projectTyped
114-- = either (const Nothing) Just . gprojectTyped . from
114-- = either (const Nothing) Just . gprojectTyped . from
115− _Typed = repIso . _GTyped @_ @as . tupled
115+ _Typed = prismVLRavel (repIso . _GTyped @_ @as . tupled)
116+ {-# INLINE _Typed #-}
116
117
117-- See Note [Uncluttering type signatures]
118-- See Note [Uncluttering type signatures]
118instance {-# OVERLAPPING #-} AsType a Void where
119instance {-# OVERLAPPING #-} AsType a Void where