9378414 · generic-lens

git.iko.soy/generic-lens

on master help sign in

Convert prism creation to VL prisms

9378414Matthew Pickering9 years ago

src/Data/Generics/Internal/Lens.hs+12−4

compare with master

unifiedsplit

@@ -233,11 +233,19 @@ injPrism (Dirty pab) = pab

233injPrism (DMap f g pab) = dimap f g pab

234injPrism (DRight pab) = right' pab

235-}

236−

236+-- We don't need the full power of boggle, we just want to fuse together

237+-- two `fmaps`

237−prismRavel :: (Profunctor p, Choice p) =>

238+prismRavel ::

238 (forall p . (MProfunctor p, MRight p) => p a b -> p s t)

239 (forall p . (MProfunctor p, MRight p) => p a b -> p s t)

239− -> p a b -> p s t

240+ -> Prism s t a b

240−prismRavel l pab = wrappedProfunctor (ravelFusionStack l (WrappedProfunctor pab))

241+prismRavel l pab = wrappedProfunctor (lowerFusionStack (ddimap id lowerBoggle (wrappedVLMProfunctor (ravelFusionStack l (WrappedVLMProfunctor (ddimap id (liftBoggle) (liftFusionStack (WrappedProfunctor pab))))))))

241{-# INLINE prismRavel #-}

242{-# INLINE prismRavel #-}

242

243

244+prismPRavel ::

245+ (forall p . (MProfunctor p, MRight p) => p a b -> p s t)

246+ -> PrismP s t a b

247+prismPRavel l pab = wrappedProfunctor (ravelFusionStack l ((WrappedProfunctor pab)))

248+{-# INLINE prismPRavel #-}

249+

250+

243

251

src/Data/Generics/Sum/Any.hs+3−3

@@ -86,11 +86,11 @@ class AsAny (sel :: k) a s | s sel k -> a where

86 --

87 -- >>> duck ^? _As @Age

88 -- Just 2

89− _As :: PrismP s s a a

89+ _As :: Prism s s a a

91instance AsConstructor ctor s s a a => AsAny ctor a s where

92 _As = _Ctor @ctor

94−--instance AsType a s => AsAny a a s where

94+instance AsType a s => AsAny a a s where

95−-- _As = _Typed @a

95+ _As = _Typed @a

src/Data/Generics/Sum/Constructors.hs+2−1

@@ -29,6 +29,7 @@ module Data.Generics.Sum.Constructors

30 -- $setup

31 AsConstructor (..)

32+ , _CtorRaw

32 ) where

33 ) where

34import Data.Generics.Internal.Families

35import Data.Generics.Internal.Families

@@ -98,7 +99,7 @@ class AsConstructor (ctor :: Symbol) s t a b | ctor s -> a, ctor t -> b where

98 -- ...

99 -- ...

99 -- ... The type Animal Int does not contain a constructor named "Turtle"

100 -- ... The type Animal Int does not contain a constructor named "Turtle"

100 -- ...

101 -- ...

101− _Ctor :: PrismP s t a b

102+ _Ctor :: Prism s t a b

102

103

103instance

104instance

104 ( Generic s

105 ( Generic s

src/Data/Profunctor/Extra.hs+67−11

@@ -3,11 +3,14 @@

3{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE RankNTypes #-}

5{-# LANGUAGE DeriveGeneric #-}

6+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

7+{-# OPTIONS_GHC -funfolding-creation-threshold=100000 #-}

6module Data.Profunctor.Extra where

8module Data.Profunctor.Extra where

8import Data.Profunctor

10import Data.Profunctor

9import GHC.Generics

11import GHC.Generics

10import Debug.Trace

12import Debug.Trace

13+import Boggle hiding ((<.>))

13-- Pull dimaps to left and rights to right

16-- Pull dimaps to left and rights to right

@@ -365,7 +368,7 @@ specRightFreeTheorem = ravelRightFreeTheorem testRightFreeTheorem

365------------------------------------------------------------------------------

368------------------------------------------------------------------------------

366-- A partial dimap fusion pass which only fuses functions such that

369-- A partial dimap fusion pass which only fuses functions such that

367-- we still have an EitherFun in the 2nd argument of dimap.

370-- we still have an EitherFun in the 2nd argument of dimap.

368−

371+{-

369data PartialFusion p a b where

372data PartialFusion p a b where

370 PFDMap :: Fun c a -> Fun b d -> p a b -> PartialFusion p c d

373 PFDMap :: Fun c a -> Fun b d -> p a b -> PartialFusion p c d

371 PFDirty :: p a b -> PartialFusion p a b

374 PFDirty :: p a b -> PartialFusion p a b

@@ -408,7 +411,7 @@ ravelPartialFusion l pab = lowerPartialFusion (l (liftPartialFusion pab))

408-- Works

411-- Works

409specPartialFusion :: (MProfunctor p, MRight p) => p Int Int -> p Int Int

412specPartialFusion :: (MProfunctor p, MRight p) => p Int Int -> p Int Int

410specPartialFusion = ravelPartialFusion testPartialFusion

413specPartialFusion = ravelPartialFusion testPartialFusion

411−

414+-}

412------------------------------------------------------------------------------

415------------------------------------------------------------------------------

413-- We also lift the function space so that we can rewrite

416-- 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)

417-- dimap f (either g h) (right r) = dimap (either g f) (either id h) (right r)

@@ -482,32 +485,41 @@ class MRight p where

482

485

483-- Run each stage individually

486-- Run each stage individually

484

487

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

486stage1 = lowerDimapSyntax

489stage1 = lowerDimapSyntax

487−stage2 = lowerPartialFusion

490+--stage2 = lowerPartialFusion

488stage3 = lowerRightFreeTheorem

491stage3 = lowerRightFreeTheorem

489stage4 = lowerRightFuse

492stage4 = lowerRightFuse

490stage5 = lowerDimapK1

493stage5 = lowerDimapK1

491

494

492−ravelStage1, ravelStage2, ravelStage3, ravelStage4, ravelStage5, ravelStage3a

495+ravelStage1, ravelStage3, ravelStage4, ravelStage5, ravelStage3a

493 :: (MProfunctor p, MRight p)

496 :: (MProfunctor p, MRight p)

494 => (forall p . (MProfunctor p, MRight p) => p a b -> p s t) ->

497 => (forall p . (MProfunctor p, MRight p) => p a b -> p s t) ->

495 p a b -> p s t

498 p a b -> p s t

496

499

497ravelStage1 = ravelDimapSyntax

500ravelStage1 = ravelDimapSyntax

498−ravelStage2 = ravelPartialFusion

501+--ravelStage2 = ravelPartialFusion

499ravelStage3 = ravelRightFreeTheorem

502ravelStage3 = ravelRightFreeTheorem

500ravelStage3a = ravelDimapSyntaxFF

503ravelStage3a = ravelDimapSyntaxFF

501ravelStage4 = ravelRightFuse

504ravelStage4 = ravelRightFuse

502ravelStage5 = ravelDimapK1

505ravelStage5 = ravelDimapK1

503

506

507+newtype FusionStack p a b =

504−type FusionStack p a b = DimapSyntax (RightFuse (RightFreeTheorem 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 #-}

505

517

506liftFusionStack :: MProfunctor p => p a b -> FusionStack p a b

518liftFusionStack :: MProfunctor p => p a b -> FusionStack p a b

507−liftFusionStack = liftDimapSyntax . liftRightFuse . liftRightFreeTheorem

519+liftFusionStack = FusionStack . liftDimapSyntax . liftRightFuse . liftRightFreeTheorem

508

520

509lowerFusionStack :: (MProfunctor p, MRight p) => FusionStack p a b -> p a b

521lowerFusionStack :: (MProfunctor p, MRight p) => FusionStack p a b -> p a b

510−lowerFusionStack = lowerRightFreeTheorem . lowerRightFuse . lowerDimapSyntax

522+lowerFusionStack = lowerRightFreeTheorem . lowerRightFuse . lowerDimapSyntax . getFusionStack

511{-# INLINE lowerFusionStack #-}

523{-# INLINE lowerFusionStack #-}

512

524

513ravelFusionStack :: (MProfunctor p, MRight p) =>

525ravelFusionStack :: (MProfunctor p, MRight p) =>

@@ -516,9 +528,22 @@ ravelFusionStack :: (MProfunctor p, MRight p) =>

516ravelFusionStack l pab = lowerFusionStack (l (liftFusionStack pab))

528ravelFusionStack l pab = lowerFusionStack (l (liftFusionStack pab))

517{-# INLINE ravelFusionStack #-}

529{-# INLINE ravelFusionStack #-}

518

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+

519-- Works

544-- Works

520−specFusionStack1 :: (MProfunctor p, MRight p) => p Int Int -> p Int Int

545+--specFusionStack1 :: (MProfunctor p, MRight p) => p Int Int -> p Int Int

521−specFusionStack1 pab = ravelFusionStack testPartialFusion pab

546+--specFusionStack1 pab = ravelFusionStack testPartialFusion pab

522

547

523specFusionStack2 :: (MProfunctor p, MRight p) => p Int Int -> p Int Int

548specFusionStack2 :: (MProfunctor p, MRight p) => p Int Int -> p Int Int

524specFusionStack2 pab = ravelFusionStack testRightFreeTheorem pab

549specFusionStack2 pab = ravelFusionStack testRightFreeTheorem pab

@@ -527,6 +552,7 @@ specFusionStack2 pab = ravelFusionStack testRightFreeTheorem pab

527-- A wrapped profunctor which we can make an instance of our classes.

552-- A wrapped profunctor which we can make an instance of our classes.

528--

553--

529

554

555+-- Use this adapter to get a profunctor lens

530newtype WrappedProfunctor p a b = WrappedProfunctor { wrappedProfunctor :: (p a b) }

556newtype WrappedProfunctor p a b = WrappedProfunctor { wrappedProfunctor :: (p a b) }

531

557

532instance Profunctor p => MProfunctor (WrappedProfunctor p) where

558instance Profunctor p => MProfunctor (WrappedProfunctor p) where

@@ -537,6 +563,36 @@ instance Choice p => MRight (WrappedProfunctor p) where

537 mright (WrappedProfunctor p) = WrappedProfunctor (right' p)

563 mright (WrappedProfunctor p) = WrappedProfunctor (right' p)

538 {-# INLINE mright #-}

564 {-# INLINE mright #-}

539

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+

540

596

541

597

542{-

598{-

test/Spec.hs+11−4

@@ -15,6 +15,7 @@ module Main where

15import GHC.Generics

16import Data.Profunctor

17import Data.Generics.Product

18+import Data.Generics.Internal.Lens (prismPRavel)

18import Data.Generics.Sum

19import Data.Generics.Sum

19import Data.Generics.Product.Boggle

20import Data.Generics.Product.Boggle

20import Test.Inspection

21import Test.Inspection

@@ -46,10 +47,13 @@ type PrismP s t a b =

46 forall p . (Choice p) => p a b -> p s t

47 forall p . (Choice p) => p a b -> p s t

47type Traversal' s a = forall f. Applicative f => (a -> f a) -> s -> f s

48type Traversal' s a = forall f. Applicative f => (a -> f a) -> s -> f s

49−prism :: (b -> t) -> (s -> Either t a) -> PrismP s t a b

50+prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b

50−prism bt seta eta = dimap seta (either id bt) (right' eta)

51+prism bt seta eta = dimap (\x -> plus pure id (seta x)) (either id (\x -> fmap bt x)) (right' eta)

51{-# INLINE prism #-}

52{-# INLINE prism #-}

54+plus f g (Left x) = Left (f x)

55+plus f g (Right y) = Right (g y)

56+

53data Record4 a = MkRecord4

57data Record4 a = MkRecord4

54 { fieldA :: a

58 { fieldA :: a

55 , fieldB :: a

59 , fieldB :: a

@@ -96,7 +100,7 @@ subtypeLensManual f record

100

97data Sum1 = A Char | B Int | C () | D () deriving (Generic, Show)

101data Sum1 = A Char | B Int | C () | D () deriving (Generic, Show)

102

99−sum1PrismManual :: PrismP Sum1 Sum1 Int Int

103+sum1PrismManual :: Prism Sum1 Sum1 Int Int

100sum1PrismManual eta = prism g f eta

104sum1PrismManual eta = prism g f eta

101 where

105 where

102 f s1 = case s1 of

106 f s1 = case s1 of

@@ -133,9 +137,12 @@ typeChangingGenericPos = position @1

133typeChangingGenericCompose :: Lens (Record3 (Record3 a)) (Record3 (Record3 b)) a b

137typeChangingGenericCompose :: Lens (Record3 (Record3 a)) (Record3 (Record3 b)) a b

134typeChangingGenericCompose = field @"fieldA" . field @"fieldA"

138typeChangingGenericCompose = field @"fieldA" . field @"fieldA"

135

139

136−sum1PrismB :: PrismP Sum1 Sum1 Int Int

140+sum1PrismB :: Prism Sum1 Sum1 Int Int

137sum1PrismB = _Ctor @"B"

141sum1PrismB = _Ctor @"B"

138

142

143+sum1PrismBP :: PrismP Sum1 Sum1 Int Int

144+sum1PrismBP = prismPRavel (_CtorRaw @"B")

145+

139inspect $ 'fieldALensManual === 'fieldALensName

146inspect $ 'fieldALensManual === 'fieldALensName

140inspect $ 'fieldALensManual === 'fieldALensType

147inspect $ 'fieldALensManual === 'fieldALensType

141inspect $ 'fieldALensManual === 'fieldALensPos

148inspect $ 'fieldALensManual === 'fieldALensPos