@@ -121,6 +121,10 @@ prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
121121prism bt seta eta = dimap (\x -> plus pure id (seta x)) (either id (\x -> fmap bt x)) (right' eta)
122122{-# INLINE prism #-}
123123
124+prismP :: (b -> t) -> (s -> Either t a) -> PrismP s t a b
125+prismP bt seta eta = dimap seta (either id bt) (right' eta)
126+{-# INLINE prismP #-}
127+
124128-- | A type and its generic representation are isomorphic
125129repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)
126130repIso = dimap from (fmap to)
@@ -236,17 +240,155 @@ injPrism (DRight pab) = right' pab
236240-}
237241-- We don't need the full power of boggle, we just want to fuse together
238242-- two `fmaps`
243+{-
239244prismRavel ::
240245 (forall p . (MProfunctor p, MRight p) => p a b -> p s t)
241246 -> Prism s t a b
242247prismRavel l pab = wrappedProfunctor (lowerFusionStack (ddimap id lowerBoggle (wrappedVLMProfunctor (ravelFusionStack l (WrappedVLMProfunctor (ddimap id (liftBoggle) (liftFusionStack (WrappedProfunctor pab))))))))
243−{-# INLINE prismRavel #-}
248+-}
244249
245250prismPRavel ::
246− (forall p . (MProfunctor p, MRight p) => p a b -> p s t)
251+ (Market a b a b -> Market a b s t)
247252 -> PrismP s t a b
248−prismPRavel l pab = wrappedProfunctor (ravelFusionStack l ((WrappedProfunctor pab)))
253+prismPRavel l pab = (prism2prismp $ l idPrism) pab
249254{-# INLINE prismPRavel #-}
250255
256+prismRavel ::
257+ (Market a b a b -> Market a b s t)
258+ -> Prism s t a b
259+prismRavel l pab = (prism2prismvl $ l idPrism) pab
260+{-# INLINE prismRavel #-}
261+
262+------------------------------------------------------------------------------
263+-- Prism: Market
264+------------------------------------------------------------------------------
265+
266+-- | This type is used internally by the 'Control.Lens.Prism.Prism' code to
267+-- provide efficient access to the two parts of a 'Prism'.
268+data Market a b s t = Market (b -> t) (s -> Either t a)
269+
270+-- | @type 'Market'' a s t = 'Market' a a s t@
271+type Market' a = Market a a
272+
273+instance Functor (Market a b s) where
274+ fmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta)
275+ {-# INLINE fmap #-}
276+
277+instance Profunctor (Market a b) where
278+ dimap f g (Market bt seta) = Market (g . bt) (either (Left . g) Right . seta . f)
279+ {-# INLINE dimap #-}
280+
281+instance Choice (Market a b) where
282+ right' (Market bt seta) = Market (Right . bt) $ \cs -> case cs of
283+ Left c -> Left (Left c)
284+ Right s -> case seta s of
285+ Left t -> Left (Right t)
286+ Right a -> Right a
287+ {-# INLINE right' #-}
288+
289+instance MProfunctor (Market a b) where
290+ mdimap f g m = dimap (lowerFun f) (lowerFun g) m
291+ {-# INLINE mdimap #-}
292+
293+instance MRight (Market a b) where
294+ mright m = right' m
295+ {-# INLINE mright #-}
296+
297+prism2prismp :: Market a b s t -> PrismP s t a b
298+prism2prismp (Market bt seta) = prismP bt seta
299+
300+prism2prismvl :: Market a b s t -> Prism s t a b
301+prism2prismvl (Market bt seta) = prism bt seta
302+{-# INLINE prism2prismvl #-}
303+
304+idPrism :: Market a b a b
305+idPrism = Market id Right
306+
307+------------------------------------------------------------------------------
308+
309+newtype Curried f a =
310+ Curried { runCurried :: forall r. f (a -> r) -> f r }
311+
312+instance Functor f => Functor (Curried f) where
313+ fmap f (Curried g) = Curried (g . fmap (.f))
314+ {-# INLINE fmap #-}
315+
316+instance (Functor f) => Applicative (Curried f) where
317+ pure a = Curried (fmap ($ a))
318+ {-# INLINE pure #-}
319+ Curried mf <*> Curried ma = Curried (ma . mf . fmap (.))
320+ {-# INLINE (<*>) #-}
321+
322+-- | The natural isomorphism between @f@ and @Curried f f@.
323+-- @
324+-- 'lowerCurried' '.' 'liftCurried' ≡ 'id'
325+-- 'liftCurried' '.' 'lowerCurried' ≡ 'id'
326+-- @
327+--
328+-- @
329+-- 'lowerCurried' ('liftCurried' x) -- definition
330+-- 'lowerCurried' ('Curried' ('<*>' x)) -- definition
331+-- ('<*>' x) ('pure' 'id') -- beta reduction
332+-- 'pure' 'id' '<*>' x -- Applicative identity law
333+-- x
334+-- @
335+liftCurried :: Applicative f => f a -> Curried f a
336+liftCurried fa = Curried (<*> fa)
337+{-# INLINE liftCurried #-}
338+
339+-- | Lower 'Curried' by applying 'pure' 'id' to the continuation.
340+--
341+-- See 'liftCurried'.
342+lowerCurried :: Applicative f => Curried f a -> f a
343+lowerCurried (Curried f) = f (pure id)
344+{-# INLINE lowerCurried #-}
345+
346+confusing :: Applicative f => Traversal s t a b -> (a -> f b) -> s -> f t
347+confusing t = \f -> lowerYoneda . lowerCurried . t (liftCurriedYoneda . f)
348+ where
349+ liftCurriedYoneda :: Applicative f => f a -> Curried (Yoneda f) a
350+ liftCurriedYoneda fa = Curried (`yap` fa)
351+ {-# INLINE liftCurriedYoneda #-}
352+
353+ yap :: Applicative f => Yoneda f (a -> b) -> f a -> Yoneda f b
354+ yap (Yoneda k) fa = Yoneda (\ab_r -> k (ab_r .) <*> fa)
355+ {-# INLINE yap #-}
356+{-# INLINE confusing #-}
357+
358+-- | @Yoneda f a@ can be viewed as the partial application of 'fmap' to its second argument.
359+newtype Yoneda f a = Yoneda { runYoneda :: forall b. (a -> b) -> f b }
360+
361+-- | The natural isomorphism between @f@ and @'Yoneda' f@ given by the Yoneda lemma
362+-- is witnessed by 'liftYoneda' and 'lowerYoneda'
363+--
364+-- @
365+-- 'liftYoneda' . 'lowerYoneda' ≡ 'id'
366+-- 'lowerYoneda' . 'liftYoneda' ≡ 'id'
367+-- @
368+--
369+-- @
370+-- lowerYoneda (liftYoneda fa) = -- definition
371+-- lowerYoneda (Yoneda (\f -> fmap f a)) -- definition
372+-- (\f -> fmap f fa) id -- beta reduction
373+-- fmap id fa -- functor law
374+-- fa
375+-- @
376+--
377+-- @
378+-- 'lift' = 'liftYoneda'
379+-- @
380+liftYoneda :: Functor f => f a -> Yoneda f a
381+liftYoneda a = Yoneda (\f -> fmap f a)
382+
383+lowerYoneda :: Yoneda f a -> f a
384+lowerYoneda (Yoneda f) = f id
385+
386+instance Functor (Yoneda f) where
387+ fmap f m = Yoneda (\k -> runYoneda m (k . f))
388+
389+instance Applicative f => Applicative (Yoneda f) where
390+ pure a = Yoneda (\f -> pure (f a))
391+ Yoneda m <*> Yoneda n = Yoneda (\f -> m (f .) <*> n id)
392+
251393
252394