@@ -1,589 +0,0 @@
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−