@@ -0,0 +1,589 @@
1+{-# LANGUAGE GADTs #-}
2+{-# LANGUAGE TypeApplications #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+{-# LANGUAGE RankNTypes #-}
5+{-# LANGUAGE DeriveGeneric #-}
6+module Data.Profunctor.Extra where
7+
8+import Data.Profunctor
9+import GHC.Generics
10+import Debug.Trace
11+
12+
13+-- Pull dimaps to left and rights to right
14+{-
15+data Boggle p a b where
16+ DRight :: (p x y) -> Boggle p (Either z x) (Either z y)
17+ DMap :: (c -> a) -> (b -> d) -> (p a b) -> Boggle p c d
18+ Dirty :: p a b -> Boggle p a b
19+
20+instance Choice p => Profunctor (Boggle p) where
21+ dimap f g (Dirty pab) = DMap f g pab
22+ dimap f g (DMap f' g' pab) = DMap (f' . f) (g . g') pab
23+ dimap f g (DRight pab) = DMap f g (right' pab)
24+
25+instance Choice p => Choice (Boggle p) where
26+ right' (Dirty pab) = DRight pab
27+ right' (DMap f g pab) = DMap (fmap f) (fmap g) (right' pab)
28+ right' (DRight pab) = DRight (right' pab)
29+
30+lift :: p a b -> Boggle p a b
31+lift pab = Dirty pab
32+
33+
34+lower :: Choice p => Boggle p a b -> p a b
35+lower (Dirty pab) = pab
36+lower (DMap f g pab) = dimap f g pab
37+lower (DRight pab) = right' pab
38+
39+test1 :: Choice p => p Int Int -> p (Either z Int) (Either z Int)
40+test1 pab = right' (dimap (+1) (subtract 1) pab)
41+
42+test1spec :: Choice p => p Int Int -> p (Either z Int) (Either z Int)
43+test1spec = lower . test1 . lift
44+-}
45+
46+
47+------------------------------------------------------------------------------
48+
49+--- This type fuses together uses of `dimap` we want to do this last
50+-- as we first need to rearrange the "Eithers"
51+newtype DimapK p b c = DimapK (forall a d . (Fun a b -> Fun c d -> p a d))
52+
53+liftDimapK :: MProfunctor p => p a b -> DimapK p a b
54+liftDimapK pa = DimapK (\f g -> mdimap f g pa)
55+
56+lowerDimapK :: DimapK p a b -> p a b
57+lowerDimapK (DimapK pa) = pa (liftFun id) (liftFun id)
58+
59+-- Note that here because we use (<.>) we potentially flatten "either"
60+instance MProfunctor (DimapK p) where
61+ mdimap f g (DimapK x) = DimapK (\y z -> x (f <.> y) (z <.> g))
62+ {-# INLINE mdimap #-}
63+
64+fmdimap :: Fun a b -> Fun c d -> DimapK p b c -> p a d
65+fmdimap f g (DimapK x) = x f g
66+
67+------------------------------------------------------------------------------
68+-- Wrapper to ensure that a liftDimapK followed by lowerDimapK doesn't
69+-- introduce a dimap.
70+
71+data DimapK1 p b c = DimapK1 (p b c) (DimapK p b c)
72+ | DirtyDimapK1 (p b c)
73+
74+liftDimapK1 :: MProfunctor p => p a b -> DimapK1 p a b
75+liftDimapK1 pab = DimapK1 pab (liftDimapK pab)
76+
77+lowerDimapK1 :: DimapK1 p a b -> p a b
78+lowerDimapK1 (DimapK1 pab _) = pab
79+lowerDimapK1 (DirtyDimapK1 pab) = pab
80+
81+instance MProfunctor p => MProfunctor (DimapK1 p) where
82+ mdimap f g (DimapK1 _ d) = DimapK1 (fmdimap f g d) (mdimap f g d)
83+ mdimap f g (DirtyDimapK1 pab) = DimapK1 (mdimap f g pab) (mdimap f g (liftDimapK pab))
84+ {-# INLINE mdimap #-}
85+
86+--instance MRight p => MRight (DiMapK1 p) where
87+-- mright (DimapK1
88+instance MRight p => MRight (DimapK1 p) where
89+ mright (DimapK1 f g) = DirtyDimapK1 (mright f)
90+ mright (DirtyDimapK1 pab) = DirtyDimapK1 (mright pab)
91+ {-# INLINE mright #-}
92+
93+-- Should be the identity, works
94+testDimapK1 :: (MProfunctor p, MRight p) => p Int Int -> p Int Int
95+testDimapK1 pab = lowerDimapK1 (liftDimapK1 pab)
96+
97+a, b :: Fun Int Int
98+a = liftFun id
99+b = liftFun id
100+
101+-- Should observe one dimap in the specialised version
102+testDimapK1A :: (MProfunctor p) => p Int Int -> p Int Int
103+testDimapK1A pab = mdimap a b (mdimap a b pab)
104+
105+ravelDimapK1 :: (MProfunctor p)
106+ => (DimapK1 p a b -> DimapK1 p c d)
107+ -> p a b -> p c d
108+ravelDimapK1 l pab = lowerDimapK1 (l (liftDimapK1 pab))
109+
110+-- As expected
111+specDimapK1A :: (MProfunctor p) => p Int Int -> p Int Int
112+specDimapK1A = ravelDimapK1 testDimapK1A
113+
114+
115+
116+
117+-------------------------------------------------------------------------------
118+-- Pull Dimaps to the left
119+
120+data DimapSyntax p c d where
121+ DMSMap :: Fun c a -> Fun b d -> p a b -> DimapSyntax p c d
122+ DMSDirty :: p a b -> DimapSyntax p a b
123+
124+liftDimapSyntax :: p a b -> DimapSyntax p a b
125+liftDimapSyntax pab = DMSDirty pab
126+
127+lowerDimapSyntax :: MProfunctor p => DimapSyntax p a b -> p a b
128+lowerDimapSyntax (DMSDirty pab) = pab
129+lowerDimapSyntax (DMSMap pca pbd pab) = mdimap pca pbd pab
130+
131+instance MRight p => MRight (DimapSyntax p) where
132+ mright (DMSDirty pab) = DMSDirty (mright pab)
133+ mright (DMSMap fca fbd pab) = DMSMap (femap fca) (femap fbd) (mright pab)
134+ {-# INLINE mright #-}
135+
136+-- Don't fuse here, we do that in DimapK1 at the end
137+instance MProfunctor p => MProfunctor (DimapSyntax p) where
138+ mdimap f g (DMSDirty p) = DMSMap f g p
139+ mdimap f g (DMSMap f' g' p) = DMSMap (f' <.> f) (g <.> g') p
140+ {-# INLINE mdimap #-}
141+
142+f :: Fun Int (Either Int Int)
143+f = undefined
144+g :: Fun (Either Int Int) Int
145+g = undefined
146+
147+
148+testDimapSyntax :: (MProfunctor p, MRight p) => p Int Int -> p Int Int
149+testDimapSyntax pab = mdimap f g (mright (mdimap f g (mright pab)))
150+
151+ravelDimapSyntax :: (MProfunctor p, MRight p) =>
152+ (DimapSyntax p a b -> DimapSyntax p s t)
153+ -> p a b -> p s t
154+ravelDimapSyntax l pab = lowerDimapSyntax (l (liftDimapSyntax pab))
155+
156+ravelDimapSyntaxFF :: (MProfunctor p, MRight p) =>
157+ (DimapSyntax (RightFuse (RightFreeTheorem p)) a b -> DimapSyntax (RightFuse (RightFreeTheorem p)) s t)
158+ -> p a b -> p s t
159+ravelDimapSyntaxFF l pab = lowerRightFreeTheorem (lowerRightFuse (lowerDimapSyntax (l (liftDimapSyntax (liftRightFuse (liftRightFreeTheorem pab))))))
160+
161+-- Works
162+specDimapSyntax :: (MProfunctor p, MRight p) => p Int Int -> p Int Int
163+specDimapSyntax = ravelDimapSyntax testDimapSyntax
164+
165+
166+-------------------------------------------------------------------------------
167+-- Fuse together rights
168+{-
169+data RightSyntax p c d where
170+ RSRight :: Fun c a -> Fun b d -> p a b -> DimapSyntax p c d
171+ RSDirty :: p a b -> DimapSyntax p a b
172+
173+liftRightSyntax :: p a b -> RightSyntax p a b
174+liftRightSyntax pab = RSDirty pab
175+
176+lowerRightSyntax :: MRight p => RightSyntax p a b -> p a b
177+lowerRightSyntax (RSDirty pab) = pab
178+lowerRightSyntax (RSRight paa) = mright pa
179+
180+instance MRight p => MRight (DimapSyntax p) where
181+ mright (DMSDirty pab) = DMSDirty (mright pab)
182+ mright (DMSMap fca fbd pab) = DMSMap (ffmap fca) (ffmap fbd) (mright pab)
183+
184+-- Don't fuse here, we do that in DimapK1 at the end
185+instance MProfunctor p => MProfunctor (DimapSyntax p) where
186+ mdimap f g (DMSDirty p) = DMSMap f g p
187+ mdimap f g (DMSMap f' g' p) = DMSMap f g (mdimap f' g' p)
188+ -}
189+-- We always want to ensure that "RightFuse p b c ~ p b c" So after
190+-- applying the "RightFuse" constructor when we encounter a right, we need
191+-- to ensure the type is "p (Either z b) (Either z c) as that's the type of
192+-- applying right
193+data RightFuse p b c where
194+ RightFuse :: (forall a d z . Fun a (Either z b) -> Fun (Either z c) d -> p a d) -> RightFuse p (Either z b) (Either z c)
195+ DirtyRightFuse :: p b c -> RightFuse p b c
196+
197+initRightFuse :: (MRight p, MProfunctor p) => p a b -> RightFuse p (Either z a) (Either z b)
198+initRightFuse pa = RightFuse (\f g -> mdimap f g (mright pa))
199+
200+liftRightFuse :: p a b -> RightFuse p a b
201+liftRightFuse pa = DirtyRightFuse pa
202+
203+lowerRightFuse :: RightFuse p a b -> p a b
204+lowerRightFuse (DirtyRightFuse pa) = pa
205+lowerRightFuse (RightFuse pa) = pa (liftFun id) (liftFun id)
206+
207+instance (MProfunctor p, MRight p) => MRight (RightFuse p) where
208+ -- Both these work but this version maintains the EitherFun invariant
209+ mright (RightFuse r) = RightFuse (\f1 f2 -> r (assocNew <.> f1) (f2 <.> assoc'New))
210+-- mright (RightFuse r) = RightFuse (\f1 f2 -> r (assoc <.> f1) (f2 <.> assoc'))
211+ mright (DirtyRightFuse pab) = initRightFuse pab
212+ {-# INLINE mright #-}
213+
214+-- Once we encounter a dimap we're done. As expressions are already in
215+-- a normal form. | We are here
216+-- |
217+-- dimap . dimap . dimap . <-| right . right . right
218+instance MProfunctor p => MProfunctor (RightFuse p) where
219+ mdimap f g (RightFuse p) = DirtyRightFuse (p f g)
220+-- RightFuse (\aezb ezcd -> p (EitherFun Left (Right . lowerFun f) <.> aezb)
221+-- (ezcd <.> EitherFun Left (Right . lowerFun g)))
222+
223+ -- We apply this adapther after floating all dimaps to the left so that
224+ -- this should never happen
225+ mdimap f g (DirtyRightFuse p) = DirtyRightFuse (mdimap f g p)
226+ {-# INLINE mdimap #-}
227+
228+-- These are assoc and assoc' but with the free theorem applied
229+assocNew = WrappedFun (plus assocg id) <.> assoc
230+assoc'New = EitherFun id (\c -> Right (Right c))
231+
232+assocg = (\eab -> case eab of
233+ Left a -> Left a
234+ Right b -> Right (Left b))
235+
236+assoc :: Fun (Either a (Either b c)) (Either (Either a b) c)
237+assoc = EitherFun (\a -> Left (Left a))
238+ (\ebc ->
239+ case ebc of
240+ Left b -> Left (Right b)
241+ Right c -> Right c)
242+
243+assoc' :: Fun (Either (Either a b) c) (Either a (Either b c))
244+assoc' = EitherFun
245+ (\eab -> case eab of
246+ Left a -> Left a
247+ Right b -> Right (Left b))
248+ (\c -> Right (Right c) )
249+
250+-- Want to only have one mright
251+testRightFuse :: (MProfunctor p, MRight p) => p Int Int -> p (Either z2 (Either z (Either z1 Int))) (Either z2 ((Either z (Either z1 Int))))
252+testRightFuse pab = mright (mright (mright pab))
253+
254+ravelRightFuse :: (MProfunctor p, MRight p) =>
255+ (RightFuse p a b -> RightFuse p s t)
256+ -> p a b -> p s t
257+ravelRightFuse l pab = lowerRightFuse (l (liftRightFuse pab))
258+
259+-- Works
260+specRightFuse :: (MProfunctor p, MRight p) => p Int Int -> p (Either z2 (Either z (Either z1 Int))) (Either z2 ((Either z (Either z1 Int))))
261+specRightFuse = ravelRightFuse testRightFuse
262+
263+------------------------------------------------------------------------------
264+-- Then only start after a right
265+-- Don't think this is needed actually
266+{-
267+
268+data RightFuse1 p b c where
269+ RightFuse1 :: p (Either z b) (Either z c) -> (RightFuse p (Either z b) (Either z c)) -> RightFuse1 p (Either z b) (Either z c)
270+ DirtyRightFuse1 :: (p b c) -> RightFuse1 p b c
271+
272+initRightFuse1 :: (MRight p, MProfunctor p) => p a b -> RightFuse1 p (Either z a) (Either z b)
273+initRightFuse1 pab = RightFuse1 (mright pab) (initRightFuse pab)
274+
275+liftRightFuse1 = DirtyRightFuse1
276+
277+lowerRightFuse1 :: RightFuse1 p a b -> p a b
278+lowerRightFuse1 (RightFuse1 pab _) = pab
279+lowerRightFuse1 (DirtyRightFuse1 pbc) = pbc
280+
281+rfdimap :: Fun c a -> Fun b d -> RightFuse p a b -> p c d
282+rfdimap f g (RightFuse rf) = rf f g
283+
284+-- Once we see a dimap, it's over, remember the normal form invariant
285+instance MProfunctor p => MProfunctor (RightFuse1 p) where
286+ mdimap f g (RightFuse1 _ d) = DirtyRightFuse1 (rfdimap f g d) -- RightFuse1 (rfdimap f g d) (mdimap f g d)
287+ mdimap f g (DirtyRightFuse1 pbc) = DirtyRightFuse1 (mdimap f g pbc)
288+
289+instance (MProfunctor p, MRight p) => MRight (RightFuse1 p) where
290+ mright (DirtyRightFuse1 pbc) = initRightFuse1 pbc
291+ mright (RightFuse1 _ d) = RightFuse1 (mright (lowerRightFuse d)) (mright d)
292+
293+-- Want to only have one mright
294+testRightFuse1 :: (MProfunctor p, MRight p) => p Int Int -> p (Either z (Either z1 Int)) ((Either z (Either z1 Int)))
295+testRightFuse1 pab = mright (mright pab)
296+
297+ravelRightFuse1 :: (MProfunctor p, MRight p) =>
298+ (RightFuse1 p a b -> RightFuse1 p s t)
299+ -> p a b -> p s t
300+ravelRightFuse1 l pab = lowerRightFuse1 (l (liftRightFuse1 pab))
301+
302+-- Fails
303+specRightFuse1 :: (MProfunctor p, MRight p) => p Int Int -> p (Either z (Either z1 Int)) ((Either z (Either z1 Int)))
304+specRightFuse1 = ravelRightFuse1 testRightFuse1
305+-}
306+------------------------------------------------------------------------------
307+-- Now apply a specialised version of the free theorem, do this before
308+-- fusing anything or we risk losing information
309+-- dimap f (either g h) (right p) = dimap (either g f) (either id h) (right p)
310+
311+data RightFreeTheorem p a b where
312+ RFRight :: p a b -> RightFreeTheorem p (Either z a) (Either z b)
313+-- RFDMap :: Fun c a -> Fun b d -> p a b -> RightFreeTheorem p c d
314+ RFDirty :: p a b -> RightFreeTheorem p a b
315+
316+liftRightFreeTheorem :: p a b -> RightFreeTheorem p a b
317+liftRightFreeTheorem = RFDirty
318+
319+lowerRightFreeTheorem :: (MProfunctor p, MRight p) => RightFreeTheorem p a b -> p a b
320+lowerRightFreeTheorem (RFDirty pab) = pab
321+--lowerRightFreeTheorem (RFDMap fa fb pab) = mdimap fa fb pab
322+lowerRightFreeTheorem (RFRight pab) = mright pab
323+
324+instance (MRight p, MProfunctor p) => MProfunctor (RightFreeTheorem p) where
325+ -- We are interested in dimap ... (right so dimap after a dirty is
326+ -- pointless so just delegate
327+ mdimap f g (RFDirty pab) = RFDirty (mdimap f g pab)
328+ -- Actually I we need to do fusion in the same pass otherwise we just do
329+ -- this for dimaps immediately next to a right BUT we do a partial fusion
330+ -- pass first which spots these opporunities
331+ mdimap f (EitherFun g h) (RFRight pab) = RFDirty (mdimap (liftFun (plus g id) <.> f) (EitherFun id h) (mright pab))
332+ mdimap f g (RFRight pab) = RFDirty (mdimap f g (mright pab))
333+ {-# INLINE mdimap #-}
334+
335+instance MRight p => MRight (RightFreeTheorem p) where
336+ mright (RFDirty pab) = RFRight pab
337+ mright (RFRight pab) = RFRight (mright pab)
338+ {-# INLINE mright #-}
339+
340+
341+plus :: (a -> b) -> (c -> d) -> Either a c -> Either b d
342+plus f g (Left x) = Left (f x)
343+plus f g (Right x) = Right (g x)
344+
345+
346+-- Want to only have one mright
347+testRightFreeTheorem :: (MProfunctor p, MRight p) => p Int Int -> p Int Int
348+testRightFreeTheorem pab = mdimap f g (mright (mdimap f g (mright pab)))
349+ where
350+ f :: Fun Int (Either Int Int)
351+ f = liftFun Left
352+
353+ g :: Fun (Either Int Int) Int
354+ g = EitherFun (const 0) (const 0)
355+
356+ravelRightFreeTheorem :: (MProfunctor p, MRight p) =>
357+ (RightFreeTheorem p a b -> RightFreeTheorem p s t)
358+ -> p a b -> p s t
359+ravelRightFreeTheorem l pab = lowerRightFreeTheorem (l (liftRightFreeTheorem pab))
360+
361+-- Works
362+specRightFreeTheorem :: (MProfunctor p, MRight p) => p Int Int -> p Int Int
363+specRightFreeTheorem = ravelRightFreeTheorem testRightFreeTheorem
364+
365+------------------------------------------------------------------------------
366+-- A partial dimap fusion pass which only fuses functions such that
367+-- we still have an EitherFun in the 2nd argument of dimap.
368+
369+data PartialFusion p a b where
370+ PFDMap :: Fun c a -> Fun b d -> p a b -> PartialFusion p c d
371+ PFDirty :: p a b -> PartialFusion p a b
372+
373+liftPartialFusion :: p a b -> PartialFusion p a b
374+liftPartialFusion = PFDirty
375+
376+lowerPartialFusion :: MProfunctor p => PartialFusion p a b -> p a b
377+lowerPartialFusion (PFDirty pab) = pab
378+lowerPartialFusion (PFDMap fca fbd pcd) = mdimap fca fbd pcd
379+
380+instance (MRight p, MProfunctor p) => MProfunctor (PartialFusion p) where
381+ mdimap f g (PFDirty pab) = PFDMap f g pab
382+ mdimap f g (PFDMap f' (EitherFun l r) pab) = PFDMap (f' <.> f) (EitherFun ((lowerFun g) . l) ((lowerFun g) . r)) pab
383+ mdimap f g (PFDMap f' g' pab) = PFDMap f g (mdimap f' g' pab)
384+
385+instance (MProfunctor p, MRight p) => MRight (PartialFusion p) where
386+ mright pab = PFDirty (mright (lowerPartialFusion pab))
387+
388+
389+-- We want g and g' to fuse but not the innermost dimap so we are left with
390+-- two dimaps
391+testPartialFusion :: (MProfunctor p, MRight p) => p Int Int -> p Int Int
392+testPartialFusion pab = (mdimap id' g (mdimap (WrappedFun Left) g' (mdimap id' id' (mright pab))))
393+ where
394+ id' = WrappedFun id
395+
396+ g' :: Fun (Either Int Int) Int
397+ g' = EitherFun (const 0) (const 0)
398+
399+ g :: Fun Int Int
400+ g = WrappedFun (const 2)
401+
402+
403+ravelPartialFusion :: (MProfunctor p, MRight p) =>
404+ (PartialFusion p a b -> PartialFusion p s t)
405+ -> p a b -> p s t
406+ravelPartialFusion l pab = lowerPartialFusion (l (liftPartialFusion pab))
407+
408+-- Works
409+specPartialFusion :: (MProfunctor p, MRight p) => p Int Int -> p Int Int
410+specPartialFusion = ravelPartialFusion testPartialFusion
411+
412+------------------------------------------------------------------------------
413+-- We also lift the function space so that we can rewrite
414+-- dimap f (either g h) (right r) = dimap (either g f) (either id h) (right r)
415+--
416+data Fun a b where
417+ WrappedFun :: (a -> b) -> Fun a b
418+-- PlusFun :: (x1 -> x2) -> (y1 -> y2) -> Fun (Either x1 y1) (Either x2 y2)
419+ EitherFun :: (x1 -> z) -> (x2 -> z) -> Fun (Either x1 x2) z
420+
421+lowerFun :: Fun a b -> a -> b
422+lowerFun (WrappedFun f) = f
423+lowerFun (EitherFun l r) = either l r
424+
425+liftFun :: (a -> b) -> Fun a b
426+liftFun = WrappedFun
427+
428+ffmap :: Functor f => Fun a b -> Fun (f a) (f b)
429+ffmap fab = liftFun (fmap (lowerFun fab))
430+
431+ddimap :: MProfunctor p => (c -> a) -> (b -> d) -> p a b -> p c d
432+ddimap f g = mdimap (liftFun f) (liftFun g)
433+
434+femap :: Fun a b -> Fun (Either z a) (Either z b)
435+femap f = EitherFun (Left . id) (Right . lowerFun f)
436+
437+-- Note that (<.>) never destroys an inner EitherFun, that is good
438+-- for the free theorem as it means we are free to fuse dimaps whenever
439+-- we like without fear of destroying this chance. For if we had the chance
440+-- before, we still will afterwards.
441+(<.>) :: Fun b c -> Fun a b -> Fun a c
442+(<.>) cb (EitherFun l r) = EitherFun (lowerFun cb . l) (lowerFun cb . r)
443+(<.>) f g = liftFun (lowerFun f . lowerFun g)
444+
445+(<.) :: Fun b c -> (a -> b) -> Fun a c
446+(<.) f g = f <.> liftFun g
447+
448+(.>) :: (b -> c) -> Fun a b -> Fun a c
449+(.>) f g = liftFun f <.> g
450+
451+-------------------------------------------------------------------------------
452+
453+class MProfunctor p where
454+ mdimap :: Fun c a -> Fun b d -> p a b -> p c d
455+
456+class MRight p where
457+ mright :: p x y -> p (Either z x) (Either z y)
458+
459+
460+-------------------------------------------------------------------------------
461+-- Note [Optimisating Prisms Plan]
462+-- We want to write prisms in a normal form of
463+-- dimap f (EitherFun id g) . right
464+--
465+-- To that end, the optimisation plan is
466+--
467+-- 1. Float dimaps to the left and rights to the right, fusing together
468+-- dimaps as we go.
469+-- 2. Fuse together rights (taking care not to introduce EitherFun with
470+-- non-id first argument
471+-- 3. Apply the right free theorem to replace EitherFun f g with EitherFun
472+-- id g
473+--
474+-- There are three different adapters for this purpose
475+--
476+-- 1. DimapSyntax
477+-- 2. RightFuse
478+-- 3. RightFreeTheorem
479+--
480+-------------------------------------------------------------------------------
481+-- Debugging help
482+
483+-- Run each stage individually
484+
485+stage1, stage2, stage3, stage4, stage5 :: (MProfunctor p, MRight p) => (forall p . (MProfunctor p, MRight p) => p a b) -> p a b
486+stage1 = lowerDimapSyntax
487+stage2 = lowerPartialFusion
488+stage3 = lowerRightFreeTheorem
489+stage4 = lowerRightFuse
490+stage5 = lowerDimapK1
491+
492+ravelStage1, ravelStage2, ravelStage3, ravelStage4, ravelStage5, ravelStage3a
493+ :: (MProfunctor p, MRight p)
494+ => (forall p . (MProfunctor p, MRight p) => p a b -> p s t) ->
495+ p a b -> p s t
496+
497+ravelStage1 = ravelDimapSyntax
498+ravelStage2 = ravelPartialFusion
499+ravelStage3 = ravelRightFreeTheorem
500+ravelStage3a = ravelDimapSyntaxFF
501+ravelStage4 = ravelRightFuse
502+ravelStage5 = ravelDimapK1
503+
504+type FusionStack p a b = DimapSyntax (RightFuse (RightFreeTheorem p)) a b
505+
506+liftFusionStack :: MProfunctor p => p a b -> FusionStack p a b
507+liftFusionStack = liftDimapSyntax . liftRightFuse . liftRightFreeTheorem
508+
509+lowerFusionStack :: (MProfunctor p, MRight p) => FusionStack p a b -> p a b
510+lowerFusionStack = lowerRightFreeTheorem . lowerRightFuse . lowerDimapSyntax
511+{-# INLINE lowerFusionStack #-}
512+
513+ravelFusionStack :: (MProfunctor p, MRight p) =>
514+ (FusionStack p a b -> FusionStack p s t)
515+ -> p a b -> p s t
516+ravelFusionStack l pab = lowerFusionStack (l (liftFusionStack pab))
517+{-# INLINE ravelFusionStack #-}
518+
519+-- Works
520+specFusionStack1 :: (MProfunctor p, MRight p) => p Int Int -> p Int Int
521+specFusionStack1 pab = ravelFusionStack testPartialFusion pab
522+
523+specFusionStack2 :: (MProfunctor p, MRight p) => p Int Int -> p Int Int
524+specFusionStack2 pab = ravelFusionStack testRightFreeTheorem pab
525+
526+-------------------------------------------------------------------------------
527+-- A wrapped profunctor which we can make an instance of our classes.
528+--
529+
530+newtype WrappedProfunctor p a b = WrappedProfunctor { wrappedProfunctor :: (p a b) }
531+
532+instance Profunctor p => MProfunctor (WrappedProfunctor p) where
533+ mdimap f g (WrappedProfunctor p) = WrappedProfunctor (dimap (lowerFun f) (lowerFun g) p)
534+ {-# INLINE mdimap #-}
535+
536+instance Choice p => MRight (WrappedProfunctor p) where
537+ mright (WrappedProfunctor p) = WrappedProfunctor (right' p)
538+ {-# INLINE mright #-}
539+
540+
541+
542+{-
543+instance MoreProfunctor p => MoreProfunctor (MoreBoggle p) where
544+ mdimap f g (MDirty pab) = MDMap f g pab
545+ mdimap f g (MDMap f' g' pab) = MDMap (f' <.> f) (g <.> g') pab
546+ mdimap f (EitherFun l r) (MDRight pab)
547+ = MDMap (liftFun (plus l id) <.> f) (EitherFun id r) (mright pab)
548+ mdimap f g (MDRight pab) = MDMap f g (mright pab)
549+
550+ mright (MDirty pab) = MDRight pab
551+ mright (MDMap f g pab) = MDMap (ffmap f) (ffmap g) (mright pab)
552+ mright (MDRight pab) = MDMap assoc assoc' (mright pab)
553+
554+
555+
556+data WInt = Wrap { unWrap :: !Int }
557+
558+--test :: MoreProfunctor p => p Int Int -> p (Either WInt Int) (Either WInt Int)
559+--test pii = mdimap (PlusFun unWrap id) (liftFun id) (mplusp Wrap (mright pii))
560+
561+test :: MoreProfunctor p => p Int Int -> p WInt WInt
562+test pii = mdimap (liftFun too) (EitherFun Wrap Wrap) (mright pii)
563+ where
564+ too :: WInt -> Either Int Int
565+ too (Wrap 0) = Left 0
566+ too (Wrap n) = Right n
567+
568+spec1 :: forall p . Choice p => p Int Int -> p WInt WInt
569+spec1 eta = wrappedProfunctor (test (WrappedProfunctor eta))
570+
571+spec :: Choice p => p Int Int -> p WInt WInt
572+spec eta = prismRavel test eta
573+
574+injPrism :: MoreProfunctor p => MoreBoggle p s t -> p s t
575+injPrism (MDRight pa) = mright pa
576+injPrism (MDirty pa) = pa
577+injPrism (MDMap f g pa) = mdimap f g pa
578+projPrism = MDirty
579+
580+
581+prismRavel :: (Choice p)
582+ => (MoreBoggle (WrappedProfunctor p) a b -> MoreBoggle (WrappedProfunctor p) s t)
583+ -> (p a b -> p s t)
584+prismRavel coy pafb = wrappedProfunctor (injPrism (coy (projPrism (WrappedProfunctor pafb))))
585+{-# INLINE prismRavel #-}
586+-}
587+
588+
589+