@@ -4,6 +4,9 @@
44{-# LANGUAGE TypeFamilies #-}
55{-# LANGUAGE TypeFamilyDependencies #-}
66{-# LANGUAGE TypeOperators #-}
7+{-# LANGUAGE TupleSections #-}
8+{-# LANGUAGE NoMonomorphismRestriction #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
710
811-----------------------------------------------------------------------------
912-- |
@@ -22,19 +25,23 @@ module Data.Generics.Internal.Lens where
2225import Control.Applicative (Const(..))
2326import Data.Functor.Identity (Identity(..))
2427import Data.Monoid (First (..))
25−import Data.Profunctor (Choice(..), Profunctor(..))
28+import Data.Profunctor (Choice(..), Profunctor(..), Strong(..))
29+import Data.Bifunctor
2630import Data.Profunctor.Unsafe ((#.), (.#))
2731import Data.Tagged
2832import GHC.Generics ((:*:)(..), (:+:)(..), Generic(..), M1(..), K1(..), Rep)
2933import Data.Coerce
3034
3135-- | Type alias for lens
32−type Lens' s a
36+type LensVL' s a
3337 = Lens s s a a
3438
35−type Lens s t a b
39+type LensVL s t a b
3640 = forall f. Functor f => (a -> f b) -> s -> f t
3741
42+type Lens s t a b
43+ = forall p . (Strong p) => p a b -> p s t
44+
3845-- | Type alias for traversal
3946type Traversal' s a
4047 = forall f. Applicative f => (a -> f a) -> s -> f s
@@ -42,127 +49,153 @@ type Traversal' s a
4249type Traversal s t a b
4350 = forall f. Applicative f => (a -> f b) -> s -> f t
4451
45−type LensLike f s t a b
46− = (a -> f b) -> s -> f t
52+type LensLike p s t a b
53+ = p a b -> p s t
4754
4855-- | Type alias for prism
49−type Prism s t a b
56+type PrismVL s t a b
5057 = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)
5158
52−type PrismP s t a b
59+type Prism s t a b
5360 = forall p . (Choice p) => p a b -> p s t
5461
55−type Prism' s a
56− = Prism s s a a
62+type Prism' s a = forall p . (Choice p) => p a a -> p s s
63+
64+type PrismVL' s a
65+ = PrismVL s s a a
5766
58−type Iso' s a
67+type IsoVL' s a
5968 = forall p f. (Profunctor p, Functor f) => p a (f a) -> p s (f s)
6069
61−type Iso s t a b
70+type IsoVL s t a b
6271 = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)
6372
64−type IsoP s t a b
73+type Iso s t a b
6574 = forall p. (Profunctor p) => p a b -> p s t
6675
76+type Iso' s a = Iso s s a a
77+
6778-- | Getting
6879(^.) :: s -> ((a -> Const a a) -> s -> Const a s) -> a
6980s ^. l = getConst (l Const s)
7081infixl 8 ^.
7182
7283-- | Setting
73−set :: ((a -> Identity b) -> s -> Identity t) -> b -> s -> t
74−set l b
75− = runIdentity . l (\_ -> Identity b)
84+set :: ((a -> b) -> s -> t) -> (s, b) -> t
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
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
76108
77109infixr 4 .~
78−(.~) :: ((a -> Identity b) -> s -> Identity t) -> b -> s -> t
79−(.~) = set
110+(.~) :: ((a -> b) -> s -> t) -> b -> s -> t
111+(.~) f b s = set f (s, b)
80112
81113infixl 8 ^?
82114(^?) :: s -> ((a -> Const (First a) a) -> s -> Const (First a) s) -> Maybe a
83115s ^? l = getFirst (fmof l (First #. Just) s)
84116 where fmof l' f = getConst #. l' (Const #. f)
85117
86−infixr 8 #
87−(#) :: (Tagged b (Identity b) -> Tagged t (Identity t)) -> b -> t
88−(#) p = runIdentity #. unTagged #. p .# Tagged .# Identity
118+buildVL :: (Tagged b (Identity b) -> Tagged t (Identity t)) -> b -> t
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+
89129
90130-- | Lens focusing on the first element of a product
91131first :: Lens ((a :*: b) x) ((a' :*: b) x) (a x) (a' x)
92−first f (a :*: b)
93− = fmap (:*: b) (f a)
94−{-# INLINE first #-}
132+first
133+ = lens (\(a :*: b) -> a) (\((a :*: b), a') -> a' :*: b)
95134
96135-- | Lens focusing on the second element of a product
97136second :: Lens ((a :*: b) x) ((a :*: b') x) (b x) (b' x)
98−second f (a :*: b)
99− = fmap (a :*:) (f b)
100−{-# INLINE second #-}
137+second
138+ = lens (\(a :*: b) -> b) (\((a :*: b), b') -> a :*: b')
101139
102140left :: Prism ((a :+: c) x) ((b :+: c) x) (a x) (b x)
103141left = 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)
108142
109143right :: Prism ((a :+: b) x) ((a :+: c) x) (b x) (c x)
110144right = 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
115145
116146gsum :: (a x -> c) -> (b x -> c) -> ((a :+: b) x) -> c
117147gsum f _ (L1 x) = f x
118148gsum _ g (R1 y) = g y
119−{-# INLINE gsum #-}
120149
121−prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
122−prism bt seta eta = dimap (\x -> plus pure id (seta x)) (either id (\x -> fmap bt x)) (right' eta)
123−{-# INLINE prism #-}
150+prismVL :: (b -> t) -> (s -> Either t a) -> PrismVL s t a b
151+prismVL bt seta eta = dimap (\x -> plus pure id (seta x)) (either id (\x -> fmap bt x)) (right' eta)
152+{-# INLINE prismVL #-}
124153
125−prismP :: (b -> t) -> (s -> Either t a) -> PrismP s t a b
126−prismP bt seta eta = dimap seta (either id bt) (right' eta)
127−{-# INLINE prismP #-}
154+prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
155+prism bt seta eta = dimap seta (either id bt) (right' eta)
128156
129157plus :: (a -> b) -> (c -> d) -> Either a c -> Either b d
130158plus f _ (Left x) = Left (f x)
131159plus _ g (Right y) = Right (g y)
132160
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+
133170-- | A type and its generic representation are isomorphic
134−repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)
135−repIso = iso from to
136−{-# INLINE repIso #-}
171+repIsoVL :: (Generic a, Generic b) => IsoVL a b (Rep a x) (Rep b x)
172+repIsoVL = isoVL from to
137173
138174repLens :: (Generic a, Generic b) => Lens a b (Rep a x) (Rep b x)
139−repLens f s = repIso f s
140−{-# INLINE repLens #-}
175+repLens f = repIso f
141176
142177-- | A type and its generic representation are isomorphic
143−repIsoP :: (Generic a, Generic b) => IsoP a b (Rep a x) (Rep b x)
144−repIsoP = dimap from to
178+repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)
179+repIso = iso from to
180+
145181
146182
147183-- | '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)
149−mIso = iso unM1 M1
150−{-# INLINE mIso #-}
184+mIsoVL :: IsoVL (M1 i c f p) (M1 i c g p) (f p) (g p)
185+mIsoVL = isoVL unM1 M1
151186
152187-- | 'M1' is just a wrapper around `f p`
153188--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)
155−mIsoP = dimap unM1 M1
189+mIso :: Iso (M1 i c f p) (M1 i c g p) (f p) (g p)
190+mIso = iso unM1 M1
156191
157192-- These are specialised versions of the Isos above. On GHC 8.0.2, having
158193-- these functions eta-expanded allows the optimiser to inline these functions.
159194mLens :: Lens (M1 i c f p) (M1 i c g p) (f p) (g p)
160−mLens f s = mIso f s
161−{-# INLINE mLens #-}
195+mLens f = mIso f
162196
163197kIso :: Iso (K1 r a p) (K1 r b p) a b
164198kIso = iso unK1 K1
165−{-# INLINE kIso #-}
166199
167200sumIso :: Iso ((a :+: b) x) ((a' :+: b') x) (Either (a x) (b x)) (Either (a' x) (b' x))
168201sumIso = iso back forth
@@ -170,7 +203,6 @@ sumIso = iso back forth
170203 forth (Right r) = (R1 r)
171204 back (L1 l) = (Left l)
172205 back (R1 r) = (Right r)
173−{-# INLINE sumIso #-}
174206
175207_Left :: Prism (Either a c) (Either b c) a b
176208_Left = prism Left $ either Right (Left . Right)
@@ -192,70 +224,81 @@ inj (Coyoneda f a) = fmap f a
192224proj :: Functor f => f a -> Coyoneda f a
193225proj fa = Coyoneda id fa
194226
195−ravel :: Functor f => ((a -> Coyoneda f b) -> s -> Coyoneda f t) -> (a -> f b) -> (s -> f t)
196−ravel coy f s = inj $ coy (\a -> proj (f a)) s
227+lens2lensvl :: ALens a b s t -> LensVL s t a b
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
197233
198234prismPRavel ::
199235 (Market a b a b -> Market a b s t)
200− -> PrismP s t a b
236+ -> Prism s t a b
201237prismPRavel l pab = (prism2prismp $ l idPrism) pab
202−{-# INLINE prismPRavel #-}
203238
204−prismRavel ::
239+prismVLRavel ::
205240 (Market a b a b -> Market a b s t)
206− -> Prism s t a b
207−prismRavel l pab = (prism2prismvl $ l idPrism) pab
208−{-# INLINE prismRavel #-}
241+ -> PrismVL s t a b
242+prismVLRavel l pab = (prism2prismvl $ l idPrism) pab
243+
244+newtype Alongside p s t a b = Alongside { getAlongside :: p (s, a) (t, b) }
209245
210−newtype AlongsideLeft f b a = AlongsideLeft { getAlongsideLeft :: f (a, b) }
211−newtype AlongsideRight f b a = AlongsideRight { getAlongsideRight :: f (b, a) }
246+instance Profunctor p => Profunctor (Alongside p c d) where
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))
212253
213254(??) :: Functor f => f (a -> b) -> a -> f b
214255fab ?? a = fmap ($ a) fab
215256
216−instance Functor f => Functor (AlongsideLeft f b) where
217− fmap f = AlongsideLeft . fmap (\(a, b) -> (f a, b)) . getAlongsideLeft
218−
219−instance Functor f => Functor (AlongsideRight f b) where
220− fmap f = AlongsideRight . fmap (\(a, b) -> (a, f b)) . getAlongsideRight
257+-- Could implement this using primitives?
258+alongside :: Profunctor p =>
259+ LensLike (Alongside p s' t') s t a b
260+ -> LensLike (Alongside p a b) s' t' a' b'
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
221264
222−alongside :: LensLike (AlongsideLeft f b') s t a b
223− -> LensLike (AlongsideRight f t) s' t' 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 #-}
265+prodIsoVL :: IsoVL ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)
266+prodIsoVL = isoVL (\(a :*: b) -> (a, b)) (\(a, b) -> (a :*: b))
230267
231268prodIso :: Iso ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)
232269prodIso = iso (\(a :*: b) -> (a, b)) (\(a, b) -> (a :*: b))
233−{-# INLINE prodIso #-}
234270
235271prodL :: Lens ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)
236−prodL f s = prodIso f s
237−{-# INLINE prodL #-}
272+prodL f = prodIso f
238273
239274prodR :: Lens (a' x, b' x) (a x, b x) ((a' :*: b') x) ((a :*: b) x)
240−prodR f s = fromIso prodIso f s
241−{-# INLINE prodR #-}
275+prodR f = fromIso prodIso f
242276
243277assoc3 :: Iso ((a, b), c) ((a', b'), c') (a, (b, c)) (a', (b', c'))
244278assoc3 = iso (\((a, b), c) -> (a, (b, c))) (\(a, (b, c)) -> ((a, b), c))
245−{-# INLINE assoc3 #-}
246279
247280assoc3L :: Lens ((a, b), c) ((a', b'), c') (a, (b, c)) (a', (b', c'))
248−assoc3L f s = assoc3 f s
249−{-# INLINE assoc3L #-}
281+assoc3L f = assoc3 f
250282
251283assoc3R :: Lens (a', (b', c')) (a, (b, c)) ((a', b'), c') ((a, b), c)
252−assoc3R f s = fromIso assoc3 f s
253−{-# INLINE assoc3R #-}
284+assoc3R f = fromIso assoc3 f
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))
254296
255−choosing :: Lens s t a b -> Lens s' t' a b -> Lens (Either s s') (Either t t') a b
256−choosing l _ f (Left a) = Left <$> l f a
257−choosing _ r f (Right a') = Right <$> r f a'
258−{-# INLINE choosing #-}
297+lens :: (s -> a) -> ((s,b) -> t) -> Lens s t a b
298+lens get set = dimap (fork id get) set . second'
299+
300+lensVL :: (s -> a) -> ((s, b) -> t) -> LensVL s t a b
301+lensVL get set f x = curry set x <$> f (get x)
259302
260303--------------------------------------------------------------------------------
261304-- Iso stuff
@@ -282,13 +325,16 @@ fromIso :: Iso s t a b -> Iso b a t s
282325fromIso l = withIso l $ \ sa bt -> iso bt sa
283326{-# INLINE fromIso #-}
284327
285−iso :: (s -> a) -> (b -> t) -> Iso s t a b
286−iso sa bt = dimap sa (fmap bt)
328+isoVL :: (s -> a) -> (b -> t) -> IsoVL s t a b
329+isoVL sa bt = dimap sa (fmap bt)
287330{-# INLINE iso #-}
288331
332+iso :: (s -> a) -> (b -> t) -> Iso s t a b
333+iso = dimap
334+
289335withIso :: Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
290−withIso ai k = case ai (Exchange id Identity) of
291− Exchange sa bt -> k sa (runIdentity #. bt)
336+withIso ai k = case ai (Exchange id id) of
337+ Exchange sa bt -> k sa bt
292338
293339pairing :: Iso s t a b -> Iso s' t' a' b' -> Iso (s, s') (t, t') (a, a') (b, b')
294340pairing 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' ->
298344--------------------------------------------------------------------------------
299345-- Prism stuff
300346
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)
302349
303350-- without :: APrism s t a b
304351-- -> 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)
315362-- bimapE _ g (Right a) = Right (g a)
316363-- {-# INLINE bimapE #-}
317364
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)
319366without' k =
320367 withPrism k $ \bt _ k' ->
321368 withPrism k' $ \dt setc ->
@@ -324,9 +371,13 @@ without' k =
324371 foldEither f _ (Left l) = f l
325372
326373withPrism :: 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
328375 Market bt seta -> f bt seta
329376
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+
330381--------------------------------------------------------------------------------
331382-- Market
332383
@@ -356,11 +407,11 @@ instance Choice (Market a b) where
356407 Right c -> Left (Right c)
357408 {-# INLINE left' #-}
358409
359−prism2prismp :: Market a b s t -> PrismP s t a b
360−prism2prismp (Market bt seta) = prismP bt seta
410+prism2prismp :: Market a b s t -> Prism s t a b
411+prism2prismp (Market bt seta) = prism bt seta
361412
362−prism2prismvl :: Market a b s t -> Prism s t a b
363−prism2prismvl (Market bt seta) = prism bt seta
413+prism2prismvl :: Market a b s t -> PrismVL s t a b
414+prism2prismvl (Market bt seta) = prismVL bt seta
364415{-# INLINE prism2prismvl #-}
365416
366417idPrism :: Market a b a b
@@ -368,6 +419,19 @@ idPrism = Market id Right
368419
369420------------------------------------------------------------------------------
370421
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+
371435newtype Curried f a =
372436 Curried { runCurried :: forall r. f (a -> r) -> f r }
373437
@@ -396,14 +460,12 @@ instance (Functor f) => Applicative (Curried f) where
396460-- @
397461liftCurried :: Applicative f => f a -> Curried f a
398462liftCurried fa = Curried (<*> fa)
399−{-# INLINE liftCurried #-}
400463
401464-- | Lower 'Curried' by applying 'pure' 'id' to the continuation.
402465--
403466-- See 'liftCurried'.
404467lowerCurried :: Applicative f => Curried f a -> f a
405468lowerCurried (Curried f) = f (pure id)
406−{-# INLINE lowerCurried #-}
407469
408470confusing :: Applicative f => Traversal s t a b -> (a -> f b) -> s -> f t
409471confusing t = \f -> lowerYoneda . lowerCurried . t (liftCurriedYoneda . f)