@@ -3,11 +3,14 @@
33{-# LANGUAGE ScopedTypeVariables #-}
44{-# LANGUAGE RankNTypes #-}
55{-# LANGUAGE DeriveGeneric #-}
6+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7+{-# OPTIONS_GHC -funfolding-creation-threshold=100000 #-}
68module Data.Profunctor.Extra where
79
810import Data.Profunctor
911import GHC.Generics
1012import Debug.Trace
13+import Boggle hiding ((<.>))
1114
1215
1316-- Pull dimaps to left and rights to right
@@ -365,7 +368,7 @@ specRightFreeTheorem = ravelRightFreeTheorem testRightFreeTheorem
365368------------------------------------------------------------------------------
366369-- A partial dimap fusion pass which only fuses functions such that
367370-- we still have an EitherFun in the 2nd argument of dimap.
368−
371+{-
369372data PartialFusion p a b where
370373 PFDMap :: Fun c a -> Fun b d -> p a b -> PartialFusion p c d
371374 PFDirty :: p a b -> PartialFusion p a b
@@ -408,7 +411,7 @@ ravelPartialFusion l pab = lowerPartialFusion (l (liftPartialFusion pab))
408411-- Works
409412specPartialFusion :: (MProfunctor p, MRight p) => p Int Int -> p Int Int
410413specPartialFusion = ravelPartialFusion testPartialFusion
411−
414+-}
412415------------------------------------------------------------------------------
413416-- We also lift the function space so that we can rewrite
414417-- dimap f (either g h) (right r) = dimap (either g f) (either id h) (right r)
@@ -482,32 +485,41 @@ class MRight p where
482485
483486-- Run each stage individually
484487
485−stage1, stage2, stage3, stage4, stage5 :: (MProfunctor p, MRight p) => (forall p . (MProfunctor p, MRight p) => p a b) -> p a b
488+stage1, stage3, stage4, stage5 :: (MProfunctor p, MRight p) => (forall p . (MProfunctor p, MRight p) => p a b) -> p a b
486489stage1 = lowerDimapSyntax
487−stage2 = lowerPartialFusion
490+--stage2 = lowerPartialFusion
488491stage3 = lowerRightFreeTheorem
489492stage4 = lowerRightFuse
490493stage5 = lowerDimapK1
491494
492−ravelStage1, ravelStage2, ravelStage3, ravelStage4, ravelStage5, ravelStage3a
495+ravelStage1, ravelStage3, ravelStage4, ravelStage5, ravelStage3a
493496 :: (MProfunctor p, MRight p)
494497 => (forall p . (MProfunctor p, MRight p) => p a b -> p s t) ->
495498 p a b -> p s t
496499
497500ravelStage1 = ravelDimapSyntax
498−ravelStage2 = ravelPartialFusion
501+--ravelStage2 = ravelPartialFusion
499502ravelStage3 = ravelRightFreeTheorem
500503ravelStage3a = ravelDimapSyntaxFF
501504ravelStage4 = ravelRightFuse
502505ravelStage5 = ravelDimapK1
503506
504−type FusionStack p a b = DimapSyntax (RightFuse (RightFreeTheorem p)) a b
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 #-}
505517
506518liftFusionStack :: MProfunctor p => p a b -> FusionStack p a b
507−liftFusionStack = liftDimapSyntax . liftRightFuse . liftRightFreeTheorem
519+liftFusionStack = FusionStack . liftDimapSyntax . liftRightFuse . liftRightFreeTheorem
508520
509521lowerFusionStack :: (MProfunctor p, MRight p) => FusionStack p a b -> p a b
510−lowerFusionStack = lowerRightFreeTheorem . lowerRightFuse . lowerDimapSyntax
522+lowerFusionStack = lowerRightFreeTheorem . lowerRightFuse . lowerDimapSyntax . getFusionStack
511523{-# INLINE lowerFusionStack #-}
512524
513525ravelFusionStack :: (MProfunctor p, MRight p) =>
@@ -516,9 +528,22 @@ ravelFusionStack :: (MProfunctor p, MRight p) =>
516528ravelFusionStack l pab = lowerFusionStack (l (liftFusionStack pab))
517529{-# INLINE ravelFusionStack #-}
518530
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+
519544-- Works
520−specFusionStack1 :: (MProfunctor p, MRight p) => p Int Int -> p Int Int
521−specFusionStack1 pab = ravelFusionStack testPartialFusion pab
545+--specFusionStack1 :: (MProfunctor p, MRight p) => p Int Int -> p Int Int
546+--specFusionStack1 pab = ravelFusionStack testPartialFusion pab
522547
523548specFusionStack2 :: (MProfunctor p, MRight p) => p Int Int -> p Int Int
524549specFusionStack2 pab = ravelFusionStack testRightFreeTheorem pab
@@ -527,6 +552,7 @@ specFusionStack2 pab = ravelFusionStack testRightFreeTheorem pab
527552-- A wrapped profunctor which we can make an instance of our classes.
528553--
529554
555+-- Use this adapter to get a profunctor lens
530556newtype WrappedProfunctor p a b = WrappedProfunctor { wrappedProfunctor :: (p a b) }
531557
532558instance Profunctor p => MProfunctor (WrappedProfunctor p) where
@@ -537,6 +563,36 @@ instance Choice p => MRight (WrappedProfunctor p) where
537563 mright (WrappedProfunctor p) = WrappedProfunctor (right' p)
538564 {-# INLINE mright #-}
539565
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+
540596
541597
542598{-