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