@@ -1,515 +0,0 @@
1−{-# LANGUAGE GADTs #-}
2−{-# LANGUAGE LambdaCase #-}
3−{-# LANGUAGE Rank2Types #-}
4−{-# LANGUAGE TypeFamilies #-}
5−{-# LANGUAGE TypeFamilyDependencies #-}
6−{-# LANGUAGE TypeOperators #-}
7−{-# LANGUAGE TupleSections #-}
8−{-# LANGUAGE NoMonomorphismRestriction #-}
9−{-# LANGUAGE ScopedTypeVariables #-}
10−
11−-----------------------------------------------------------------------------
12−-- |
13−-- Module : Data.Generics.Internal.Lens
14−-- Copyright : (C) 2017 Csongor Kiss
15−-- License : BSD3
16−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
17−-- Stability : experimental
18−-- Portability : non-portable
19−--
20−-- Internal lens helpers. Only exported for Haddock
21−--
22−-----------------------------------------------------------------------------
23−module Data.Generics.Internal.Lens where
24−
25−import Control.Applicative (Const(..))
26−import Data.Functor.Identity (Identity(..))
27−import Data.Monoid (First (..))
28−import Data.Profunctor (Choice(..), Profunctor(..), Strong(..))
29−import Data.Bifunctor
30−import Data.Profunctor.Unsafe ((#.), (.#))
31−import Data.Tagged
32−import GHC.Generics ((:*:)(..), (:+:)(..), Generic(..), M1(..), K1(..), Rep)
33−import Data.Coerce
34−
35−-- | Type alias for lens
36−type LensVL' s a
37− = Lens s s a a
38−
39−type LensVL s t a b
40− = forall f. Functor f => (a -> f b) -> s -> f t
41−
42−type Lens s t a b
43− = forall p . (Strong p) => p a b -> p s t
44−
45−-- | Type alias for traversal
46−type Traversal' s a
47− = forall f. Applicative f => (a -> f a) -> s -> f s
48−
49−type Traversal s t a b
50− = forall f. Applicative f => (a -> f b) -> s -> f t
51−
52−type LensLike p s t a b
53− = p a b -> p s t
54−
55−-- | Type alias for prism
56−type PrismVL s t a b
57− = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)
58−
59−type Prism s t a b
60− = forall p . (Choice p) => p a b -> p s t
61−
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
66−
67−type IsoVL' s a
68− = forall p f. (Profunctor p, Functor f) => p a (f a) -> p s (f s)
69−
70−type IsoVL s t a b
71− = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)
72−
73−type Iso s t a b
74− = forall p. (Profunctor p) => p a b -> p s t
75−
76−type Iso' s a = Iso s s a a
77−
78−-- | Getting
79−(^.) :: s -> ((a -> Const a a) -> s -> Const a s) -> a
80−s ^. l = getConst (l Const s)
81−infixl 8 ^.
82−
83−-- | Setting
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
108−
109−infixr 4 .~
110−(.~) :: ((a -> b) -> s -> t) -> b -> s -> t
111−(.~) f b s = set f (s, b)
112−
113−infixl 8 ^?
114−(^?) :: s -> ((a -> Const (First a) a) -> s -> Const (First a) s) -> Maybe a
115−s ^? l = getFirst (fmof l (First #. Just) s)
116− where fmof l' f = getConst #. l' (Const #. f)
117−
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−
129−
130−-- | Lens focusing on the first element of a product
131−first :: Lens ((a :*: b) x) ((a' :*: b) x) (a x) (a' x)
132−first
133− = lens (\(a :*: b) -> a) (\((a :*: b), a') -> a' :*: b)
134−
135−-- | Lens focusing on the second element of a product
136−second :: Lens ((a :*: b) x) ((a :*: b') x) (b x) (b' x)
137−second
138− = lens (\(a :*: b) -> b) (\((a :*: b), b') -> a :*: b')
139−
140−left :: Prism ((a :+: c) x) ((b :+: c) x) (a x) (b x)
141−left = prism L1 $ gsum Right (Left . R1)
142−
143−right :: Prism ((a :+: b) x) ((a :+: c) x) (b x) (c x)
144−right = prism R1 $ gsum (Left . L1) Right
145−
146−gsum :: (a x -> c) -> (b x -> c) -> ((a :+: b) x) -> c
147−gsum f _ (L1 x) = f x
148−gsum _ g (R1 y) = g y
149−
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 #-}
153−
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)
156−
157−plus :: (a -> b) -> (c -> d) -> Either a c -> Either b d
158−plus f _ (Left x) = Left (f x)
159−plus _ g (Right y) = Right (g y)
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−
170−-- | A type and its generic representation are isomorphic
171−repIsoVL :: (Generic a, Generic b) => IsoVL a b (Rep a x) (Rep b x)
172−repIsoVL = isoVL from to
173−
174−repLens :: (Generic a, Generic b) => Lens a b (Rep a x) (Rep b x)
175−repLens f = repIso f
176−
177−-- | A type and its generic representation are isomorphic
178−repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)
179−repIso = iso from to
180−
181−
182−
183−-- | 'M1' is just a wrapper around `f p`
184−mIsoVL :: IsoVL (M1 i c f p) (M1 i c g p) (f p) (g p)
185−mIsoVL = isoVL unM1 M1
186−
187−-- | 'M1' is just a wrapper around `f p`
188−--mIso :: Iso' (M1 i c f p) (f p)
189−mIso :: Iso (M1 i c f p) (M1 i c g p) (f p) (g p)
190−mIso = iso unM1 M1
191−
192−-- These are specialised versions of the Isos above. On GHC 8.0.2, having
193−-- these functions eta-expanded allows the optimiser to inline these functions.
194−mLens :: Lens (M1 i c f p) (M1 i c g p) (f p) (g p)
195−mLens f = mIso f
196−
197−kIso :: Iso (K1 r a p) (K1 r b p) a b
198−kIso = iso unK1 K1
199−
200−sumIso :: Iso ((a :+: b) x) ((a' :+: b') x) (Either (a x) (b x)) (Either (a' x) (b' x))
201−sumIso = iso back forth
202− where forth (Left l) = (L1 l)
203− forth (Right r) = (R1 r)
204− back (L1 l) = (Left l)
205− back (R1 r) = (Right r)
206−
207−_Left :: Prism (Either a c) (Either b c) a b
208−_Left = prism Left $ either Right (Left . Right)
209−
210−_Right :: Prism (Either c a) (Either c b) a b
211−_Right = prism Right $ either (Left . Left) Right
212−
213−--------------------------------------------------------------------------------
214−
215−data Coyoneda f b = forall a. Coyoneda (a -> b) (f a)
216−
217−instance Functor (Coyoneda f) where
218− fmap f (Coyoneda g fa)
219− = Coyoneda (f . g) fa
220−
221−inj :: Functor f => Coyoneda f a -> f a
222−inj (Coyoneda f a) = fmap f a
223−
224−proj :: Functor f => f a -> Coyoneda f a
225−proj fa = Coyoneda id fa
226−
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
233−
234−prismPRavel ::
235− (Market a b a b -> Market a b s t)
236− -> Prism s t a b
237−prismPRavel l pab = (prism2prismp $ l idPrism) pab
238−
239−prismVLRavel ::
240− (Market a b a b -> Market a b s t)
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) }
245−
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))
253−
254−(??) :: Functor f => f (a -> b) -> a -> f b
255−fab ?? a = fmap ($ a) fab
256−
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
264−
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))
267−
268−prodIso :: Iso ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)
269−prodIso = iso (\(a :*: b) -> (a, b)) (\(a, b) -> (a :*: b))
270−
271−prodL :: Lens ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)
272−prodL f = prodIso f
273−
274−prodR :: Lens (a' x, b' x) (a x, b x) ((a' :*: b') x) ((a :*: b) x)
275−prodR f = fromIso prodIso f
276−
277−assoc3 :: Iso ((a, b), c) ((a', b'), c') (a, (b, c)) (a', (b', c'))
278−assoc3 = iso (\((a, b), c) -> (a, (b, c))) (\(a, (b, c)) -> ((a, b), c))
279−
280−assoc3L :: Lens ((a, b), c) ((a', b'), c') (a, (b, c)) (a', (b', c'))
281−assoc3L f = assoc3 f
282−
283−assoc3R :: Lens (a', (b', c')) (a, (b, c)) ((a', b'), c') ((a, b), c)
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))
296−
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)
302−
303−--------------------------------------------------------------------------------
304−-- Iso stuff
305−
306−data Exchange a b s t = Exchange (s -> a) (b -> t)
307−
308−instance Functor (Exchange a b s) where
309− fmap f (Exchange sa bt) = Exchange sa (f . bt)
310− {-# INLINE fmap #-}
311−
312−instance Profunctor (Exchange a b) where
313− dimap f g (Exchange sa bt) = Exchange (sa . f) (g . bt)
314− {-# INLINE dimap #-}
315− lmap f (Exchange sa bt) = Exchange (sa . f) bt
316− {-# INLINE lmap #-}
317− rmap f (Exchange sa bt) = Exchange sa (f . bt)
318− {-# INLINE rmap #-}
319− ( #. ) _ = coerce
320− {-# INLINE ( #. ) #-}
321− ( .# ) p _ = coerce p
322− {-# INLINE ( .# ) #-}
323−
324−fromIso :: Iso s t a b -> Iso b a t s
325−fromIso l = withIso l $ \ sa bt -> iso bt sa
326−{-# INLINE fromIso #-}
327−
328−isoVL :: (s -> a) -> (b -> t) -> IsoVL s t a b
329−isoVL sa bt = dimap sa (fmap bt)
330−{-# INLINE iso #-}
331−
332−iso :: (s -> a) -> (b -> t) -> Iso s t a b
333−iso = dimap
334−
335−withIso :: Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
336−withIso ai k = case ai (Exchange id id) of
337− Exchange sa bt -> k sa bt
338−
339−pairing :: Iso s t a b -> Iso s' t' a' b' -> Iso (s, s') (t, t') (a, a') (b, b')
340−pairing f g = withIso f $ \ sa bt -> withIso g $ \s'a' b't' ->
341− iso (bmap sa s'a') (bmap bt b't')
342− where bmap f' g' (a, b) = (f' a, g' b)
343−
344−--------------------------------------------------------------------------------
345−-- Prism stuff
346−
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)
349−
350−-- without :: APrism s t a b
351−-- -> APrism u v c d
352−-- -> Prism (Either s u) (Either t v) (Either a c) (Either b d)
353−-- without k =
354−-- withPrism k $ \bt seta k' ->
355−-- withPrism k' $ \dv uevc ->
356−-- prism (bimapE bt dv) $ \su ->
357−-- case su of
358−-- Left s -> bimapE Left Left (seta s)
359−-- Right u -> bimapE Right Right (uevc u)
360−-- where bimapE :: (a -> b) -> (c -> d) -> Either a c -> Either b d
361−-- bimapE f _ (Left a) = Left (f a)
362−-- bimapE _ g (Right a) = Right (g a)
363−-- {-# INLINE bimapE #-}
364−
365−without' :: Prism s t a b -> Prism s t c d -> Prism s t (Either a c) (Either b d)
366−without' k =
367− withPrism k $ \bt _ k' ->
368− withPrism k' $ \dt setc ->
369− prism (foldEither bt dt) $ \s -> fmap Right (setc s)
370− where foldEither _ g (Right r) = g r
371− foldEither f _ (Left l) = f l
372−
373−withPrism :: APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
374−withPrism k f = case k idPrism of
375− Market bt seta -> f bt seta
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−
381−--------------------------------------------------------------------------------
382−-- Market
383−
384−data Market a b s t = Market (b -> t) (s -> Either t a)
385−
386−instance Functor (Market a b s) where
387− fmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta)
388− {-# INLINE fmap #-}
389−
390−instance Profunctor (Market a b) where
391− dimap f g (Market bt seta) = Market (g . bt) (either (Left . g) Right . seta . f)
392− {-# INLINE dimap #-}
393− lmap f (Market bt seta) = Market bt (seta . f)
394− {-# INLINE lmap #-}
395− rmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta)
396− {-# INLINE rmap #-}
397− ( #. ) _ = coerce
398− {-# INLINE ( #. ) #-}
399− ( .# ) p _ = coerce p
400− {-# INLINE ( .# ) #-}
401−
402−instance Choice (Market a b) where
403− left' (Market bt seta) = Market (Left . bt) $ \sc -> case sc of
404− Left s -> case seta s of
405− Left t -> Left (Left t)
406− Right a -> Right a
407− Right c -> Left (Right c)
408− {-# INLINE left' #-}
409−
410−prism2prismp :: Market a b s t -> Prism s t a b
411−prism2prismp (Market bt seta) = prism bt seta
412−
413−prism2prismvl :: Market a b s t -> PrismVL s t a b
414−prism2prismvl (Market bt seta) = prismVL bt seta
415−{-# INLINE prism2prismvl #-}
416−
417−idPrism :: Market a b a b
418−idPrism = Market id Right
419−
420−------------------------------------------------------------------------------
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−
435−newtype Curried f a =
436− Curried { runCurried :: forall r. f (a -> r) -> f r }
437−
438−instance Functor f => Functor (Curried f) where
439− fmap f (Curried g) = Curried (g . fmap (.f))
440− {-# INLINE fmap #-}
441−
442−instance (Functor f) => Applicative (Curried f) where
443− pure a = Curried (fmap ($ a))
444− {-# INLINE pure #-}
445− Curried mf <*> Curried ma = Curried (ma . mf . fmap (.))
446− {-# INLINE (<*>) #-}
447−
448−-- | The natural isomorphism between @f@ and @Curried f f@.
449−-- @
450−-- 'lowerCurried' '.' 'liftCurried' ≡ 'id'
451−-- 'liftCurried' '.' 'lowerCurried' ≡ 'id'
452−-- @
453−--
454−-- @
455−-- 'lowerCurried' ('liftCurried' x) -- definition
456−-- 'lowerCurried' ('Curried' ('<*>' x)) -- definition
457−-- ('<*>' x) ('pure' 'id') -- beta reduction
458−-- 'pure' 'id' '<*>' x -- Applicative identity law
459−-- x
460−-- @
461−liftCurried :: Applicative f => f a -> Curried f a
462−liftCurried fa = Curried (<*> fa)
463−
464−-- | Lower 'Curried' by applying 'pure' 'id' to the continuation.
465−--
466−-- See 'liftCurried'.
467−lowerCurried :: Applicative f => Curried f a -> f a
468−lowerCurried (Curried f) = f (pure id)
469−
470−confusing :: Applicative f => Traversal s t a b -> (a -> f b) -> s -> f t
471−confusing t = \f -> lowerYoneda . lowerCurried . t (liftCurriedYoneda . f)
472− where
473− liftCurriedYoneda :: Applicative f => f a -> Curried (Yoneda f) a
474− liftCurriedYoneda fa = Curried (`yap` fa)
475− {-# INLINE liftCurriedYoneda #-}
476−
477− yap :: Applicative f => Yoneda f (a -> b) -> f a -> Yoneda f b
478− yap (Yoneda k) fa = Yoneda (\ab_r -> k (ab_r .) <*> fa)
479− {-# INLINE yap #-}
480−{-# INLINE confusing #-}
481−
482−-- | @Yoneda f a@ can be viewed as the partial application of 'fmap' to its second argument.
483−newtype Yoneda f a = Yoneda { runYoneda :: forall b. (a -> b) -> f b }
484−
485−-- | The natural isomorphism between @f@ and @'Yoneda' f@ given by the Yoneda lemma
486−-- is witnessed by 'liftYoneda' and 'lowerYoneda'
487−--
488−-- @
489−-- 'liftYoneda' . 'lowerYoneda' ≡ 'id'
490−-- 'lowerYoneda' . 'liftYoneda' ≡ 'id'
491−-- @
492−--
493−-- @
494−-- lowerYoneda (liftYoneda fa) = -- definition
495−-- lowerYoneda (Yoneda (\f -> fmap f a)) -- definition
496−-- (\f -> fmap f fa) id -- beta reduction
497−-- fmap id fa -- functor law
498−-- fa
499−-- @
500−--
501−-- @
502−-- 'lift' = 'liftYoneda'
503−-- @
504−liftYoneda :: Functor f => f a -> Yoneda f a
505−liftYoneda a = Yoneda (\f -> fmap f a)
506−
507−lowerYoneda :: Yoneda f a -> f a
508−lowerYoneda (Yoneda f) = f id
509−
510−instance Functor (Yoneda f) where
511− fmap f m = Yoneda (\k -> runYoneda m (k . f))
512−
513−instance Applicative f => Applicative (Yoneda f) where
514− pure a = Yoneda (\f -> pure (f a))
515− Yoneda m <*> Yoneda n = Yoneda (\f -> m (f .) <*> n id)