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