git.iko.soy/generic-lens
on master help sign in
Optimising prisms
ff59890Matthew Pickering
generic-lens.cabal+1
compare with master
unifiedsplit
@@ -54,6 +54,7 @@ library
54 , Data.Generics.Product.Internal.Subtype
54 , Data.Generics.Product.Internal.Subtype
55 , Data.Generics.Product.Internal.Typed
55 , Data.Generics.Product.Internal.Typed
56 , Data.Generics.Product.Internal.Types
56 , Data.Generics.Product.Internal.Types
57+ , Data.Profunctor.Extra
57
58
58 build-depends: base >= 4.9 && <= 5.0
59 build-depends: base >= 4.9 && <= 5.0
59 , profunctors >= 5.0 && <= 6.0
60 , profunctors >= 5.0 && <= 6.0
src/Data/Generics/Internal/Lens.hs+48−5
@@ -21,10 +21,12 @@ import Control.Applicative (Const(..))
21import Data.Functor.Identity (Identity(..))
21import Data.Functor.Identity (Identity(..))
22import Data.Monoid (First (..))
22import Data.Monoid (First (..))
23import Data.Profunctor (Choice(right'), Profunctor(dimap, rmap))
23import Data.Profunctor (Choice(right'), Profunctor(dimap, rmap))
24+import Data.Profunctor.Extra
24import Data.Profunctor.Unsafe ((#.), (.#))
25import Data.Profunctor.Unsafe ((#.), (.#))
25import Data.Tagged
26import Data.Tagged
26import GHC.Generics ((:*:)(..), (:+:)(..), Generic(..), M1(..), Rep)
27import GHC.Generics ((:*:)(..), (:+:)(..), Generic(..), M1(..), Rep)
27import Boggle hiding (Dirty)
28import Boggle hiding (Dirty)
29+import Debug.Trace
28
30
29-- | Type alias for lens
31-- | Type alias for lens
30type Lens' s a
32type Lens' s a
@@ -41,6 +43,12 @@ type Traversal' s a
41type Prism s t a b
43type Prism s t a b
42 = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)
44 = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)
43
45
46+type PrismP s t a b
47+ = forall p . (Choice p) => p a b -> p s t
48+
49+type PrismE s t a b
50+ = forall p f. (MRight p, MProfunctor p) => p a b -> p s t
51+
44type Prism' s a
52type Prism' s a
45 = Prism s s a a
53 = Prism s s a a
46
54
@@ -50,6 +58,9 @@ type Iso' s a
50type Iso s t a b
58type Iso s t a b
51 = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)
59 = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)
52
60
61+type IsoE s t a b
62+ = forall p f. (MProfunctor p) => p a b -> p s t
63+
53-- | Getting
64-- | Getting
54(^.) :: s -> ((a -> Const a a) -> s -> Const a s) -> a
65(^.) :: s -> ((a -> Const a a) -> s -> Const a s) -> a
55s ^. l = getConst (l Const s)
66s ^. l = getConst (l Const s)
@@ -89,6 +100,12 @@ left = prism L1 $ gsum Right (Left . R1)
89right :: Prism ((a :+: b) x) ((a :+: c) x) (b x) (c x)
100right :: Prism ((a :+: b) x) ((a :+: c) x) (b x) (c x)
90right = prism R1 $ gsum (Left . L1) Right
101right = prism R1 $ gsum (Left . L1) Right
91
102
103+leftE :: PrismE ((a :+: c) x) ((b :+: c) x) (a x) (b x)
104+leftE = prismE L1 $ gsum Right (Left . R1)
105+
106+rightE :: PrismE ((a :+: b) x) ((a :+: c) x) (b x) (c x)
107+rightE = prismE R1 $ gsum (Left . L1) Right
108+
92gsum :: (a x -> c) -> (b x -> c) -> ((a :+: b) x) -> c
109gsum :: (a x -> c) -> (b x -> c) -> ((a :+: b) x) -> c
93gsum f _ (L1 x) = f x
110gsum f _ (L1 x) = f x
94gsum _ g (R1 y) = g y
111gsum _ g (R1 y) = g y
@@ -97,6 +114,9 @@ combine :: Lens' (s x) a -> Lens' (t x) a -> Lens' ((s :+: t) x) a
97combine sa _ f (L1 s) = fmap (\a -> L1 (set sa a s)) (f (s ^. sa))
114combine sa _ f (L1 s) = fmap (\a -> L1 (set sa a s)) (f (s ^. sa))
98combine _ ta f (R1 t) = fmap (\a -> R1 (set ta a t)) (f (t ^. ta))
115combine _ ta f (R1 t) = fmap (\a -> R1 (set ta a t)) (f (t ^. ta))
99
116
117+prismE :: (b -> t) -> (s -> Either t a) -> PrismE s t a b
118+prismE bt seta = mdimap (liftFun seta) (EitherFun id bt) . mright
119+
100prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
120prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
101prism bt seta = dimap seta (either pure (fmap bt)) . right'
121prism bt seta = dimap seta (either pure (fmap bt)) . right'
102
122
@@ -104,11 +124,20 @@ prism bt seta = dimap seta (either pure (fmap bt)) . right'
104repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)
124repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)
105repIso = dimap from (fmap to)
125repIso = dimap from (fmap to)
106
126
127+repIsoE :: (Generic a, Generic b) => IsoE a b (Rep a x) (Rep b x)
128+repIsoE = ddimap from to
129+
130+
107-- | 'M1' is just a wrapper around `f p`
131-- | 'M1' is just a wrapper around `f p`
108--mIso :: Iso' (M1 i c f p) (f p)
132--mIso :: Iso' (M1 i c f p) (f p)
109mIso :: Iso (M1 i c f p) (M1 i c g p) (f p) (g p)
133mIso :: Iso (M1 i c f p) (M1 i c g p) (f p) (g p)
110mIso = dimap unM1 (fmap M1)
134mIso = dimap unM1 (fmap M1)
111
135
136+-- | 'M1' is just a wrapper around `f p`
137+--mIso :: Iso' (M1 i c f p) (f p)
138+mIsoE :: IsoE (M1 i c f p) (M1 i c g p) (f p) (g p)
139+mIsoE = ddimap unM1 M1
140+
112-- These are specialised versions of the Isos above. On GHC 8.0.2, having
141-- These are specialised versions of the Isos above. On GHC 8.0.2, having
113-- these functions eta-expanded allows the optimiser to inline these functions.
142-- these functions eta-expanded allows the optimiser to inline these functions.
114mLens :: Lens (M1 i c f p) (M1 i c g p) (f p) (g p)
143mLens :: Lens (M1 i c f p) (M1 i c g p) (f p) (g p)
@@ -151,6 +180,18 @@ ravel coy f s = inj $ coy (\a -> proj (f a)) s
151
180
152-- Pull dimaps to left and rights to right
181-- Pull dimaps to left and rights to right
153
182
183+{-
184+instance Choice p => Profunctor (MergeRight p) where
185+ dimap f g (MergeRight (Dirty pab)) = MergeRight (DMap f g pab)
186+ dimap f g (MergeRight (DMap f' g' pab)) = MergeRight (DMap (f' . f) (g . g') pab)
187+ dimap f g (MergeRight (DRight pab)) = MergeRight (DMap f g (right' pab))
188+
189+instance Choice p => Choice (MergeRight p) where
190+ right' (MergeRight (Dirty pab)) = MergeRight (DRight pab)
191+ right' (MergeRight (DMap f g pab)) = MergeRight (DMap (fmap f) (fmap g) (right' pab))
192+ right' (MergeRight (DRight pab)) = MergeRight (DMap assoc' assoc (right' pab))
193+ -}
194+{-
154data PrismBoggle p a b where
195data PrismBoggle p a b where
155 DRight :: (p x y) -> PrismBoggle p (Either z x) (Either z y)
196 DRight :: (p x y) -> PrismBoggle p (Either z x) (Either z y)
156 DMap :: (c -> a) -> (b -> d) -> (p a b) -> PrismBoggle p c d
197 DMap :: (c -> a) -> (b -> d) -> (p a b) -> PrismBoggle p c d
@@ -184,17 +225,19 @@ projPrism :: p a b -> PrismBoggle p a b
184projPrism pab = Dirty pab
225projPrism pab = Dirty pab
185
226
186--rightFuse :: Choice p => p a b -> p (Either c (Either d a)) (Either c (Either d b))
227--rightFuse :: Choice p => p a b -> p (Either c (Either d a)) (Either c (Either d b))
187−rightFuse x = injPrism (projPrism (injPrism (right' (right' (right' (projPrism x))))))
228+rightFuse x = injPrism (injPrism (right' (right' (right' (projPrism (projPrism x))))))
188
229
189
230
190injPrism :: Choice p => PrismBoggle p a b -> p a b
231injPrism :: Choice p => PrismBoggle p a b -> p a b
191injPrism (Dirty pab) = pab
232injPrism (Dirty pab) = pab
192injPrism (DMap f g pab) = dimap f g pab
233injPrism (DMap f g pab) = dimap f g pab
193injPrism (DRight pab) = right' pab
234injPrism (DRight pab) = right' pab
235+-}
194
236
195−prismRavel :: (Choice p, Applicative f)
237+prismRavel :: (Profunctor p, Choice p) =>
196− => (PrismBoggle (PrismBoggle p) a (Boggle f b) -> PrismBoggle (PrismBoggle p) s (Boggle f t))
238+ (forall p . (MProfunctor p, MRight p) => p a b -> p s t)
197− -> (p a (f b) -> p s (f t))
239+ -> p a b -> p s t
198−prismRavel coy pafb = injPrism (injPrism (dimap id lowerBoggle (coy (dimap id liftBoggle (projPrism (projPrism pafb))))))
240+prismRavel l pab = wrappedProfunctor (ravelFusionStack l (WrappedProfunctor pab))
199{-# INLINE prismRavel #-}
241{-# INLINE prismRavel #-}
200
242
243+
src/Data/Generics/Sum/Any.hs+3−3
@@ -86,11 +86,11 @@ class AsAny (sel :: k) a s | s sel k -> a where
86 --
86 --
87 -- >>> duck ^? _As @Age
87 -- >>> duck ^? _As @Age
88 -- Just 2
88 -- Just 2
89− _As :: Prism' s a
89+ _As :: PrismP s s a a
90
90
91instance AsConstructor ctor s s a a => AsAny ctor a s where
91instance AsConstructor ctor s s a a => AsAny ctor a s where
92 _As = _Ctor @ctor
92 _As = _Ctor @ctor
93
93
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
96
96
src/Data/Generics/Sum/Constructors.hs+17−2
@@ -9,6 +9,7 @@
9{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE TypeFamilies #-}
10{-# LANGUAGE TypeOperators #-}
10{-# LANGUAGE TypeOperators #-}
11{-# LANGUAGE UndecidableInstances #-}
11{-# LANGUAGE UndecidableInstances #-}
12+{-# LANGUAGE FlexibleContexts #-}
12
13
13-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
14-- |
15-- |
@@ -38,6 +39,7 @@ import Data.Generics.Sum.Internal.Constructors
38import Data.Kind (Constraint, Type)
39import Data.Kind (Constraint, Type)
39import GHC.Generics (Generic (Rep))
40import GHC.Generics (Generic (Rep))
40import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
41import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))
42+import Data.Profunctor.Extra
41
43
42-- $setup
44-- $setup
43-- == /Running example:/
45-- == /Running example:/
@@ -96,7 +98,7 @@ class AsConstructor (ctor :: Symbol) s t a b | ctor s -> a, ctor t -> b where
96 -- ...
98 -- ...
97 -- ... The type Animal Int does not contain a constructor named "Turtle"
99 -- ... The type Animal Int does not contain a constructor named "Turtle"
98 -- ...
100 -- ...
99− _Ctor :: Prism s t a b
101+ _Ctor :: PrismP s t a b
100
102
101instance
103instance
102 ( Generic s
104 ( Generic s
@@ -110,9 +112,22 @@ instance
110 , '(t, b) ~ Infer s' a' a (PickTv a' b)
112 , '(t, b) ~ Infer s' a' a (PickTv a' b)
111 ) => AsConstructor ctor s t a b where
113 ) => AsConstructor ctor s t a b where
112
114
113− _Ctor eta = prismRavel (repIso . _GCtor @ctor) eta
115+ _Ctor eta = prismRavel (repIsoE . _GCtor @ctor) eta
114 {-# INLINE _Ctor #-}
116 {-# INLINE _Ctor #-}
115
117
118+-- Used for testing the optimisation passes
119+_CtorRaw :: forall ctor s t s' a' a b . ( Generic s
120+ , ErrorUnless ctor s (HasCtorP ctor (Rep s))
121+ , Generic t
122+ , s' ~ Proxied s
123+ , Generic s'
124+ , GAsConstructor' ctor (Rep s) a
125+ , GAsConstructor' ctor (Rep s') a'
126+ , GAsConstructor ctor (Rep s) (Rep t) a b
127+ , '(t, b) ~ Infer s' a' a (PickTv a' b)
128+ ) => PrismE s t a b
129+_CtorRaw = repIsoE . _GCtor @ctor
130+
116-- See Note [Uncluttering type signatures]
131-- See Note [Uncluttering type signatures]
117instance {-# OVERLAPPING #-} AsConstructor ctor (Void1 a) (Void1 b) a b where
132instance {-# OVERLAPPING #-} AsConstructor ctor (Void1 a) (Void1 b) a b where
118 _Ctor = undefined
133 _Ctor = undefined
src/Data/Generics/Sum/Internal/Constructors.hs+11−6
@@ -39,7 +39,7 @@ import GHC.TypeLits (Symbol)
39-- |As 'AsConstructor' but over generic representations as defined by
39-- |As 'AsConstructor' but over generic representations as defined by
40-- "GHC.Generics".
40-- "GHC.Generics".
41class GAsConstructor (ctor :: Symbol) s t a b | ctor s -> a, ctor t -> b where
41class GAsConstructor (ctor :: Symbol) s t a b | ctor s -> a, ctor t -> b where
42− _GCtor :: Prism (s x) (t x) a b
42+ _GCtor :: PrismE (s x) (t x) a b
43
43
44type GAsConstructor' ctor s a = GAsConstructor ctor s s a a
44type GAsConstructor' ctor s a = GAsConstructor ctor s s a a
45
45
@@ -50,19 +50,24 @@ instance
50 , ListTuple b bs
50 , ListTuple b bs
51 ) => GAsConstructor ctor (M1 C ('MetaCons ctor fixity fields) f) (M1 C ('MetaCons ctor fixity fields) g) a b where
51 ) => GAsConstructor ctor (M1 C ('MetaCons ctor fixity fields) f) (M1 C ('MetaCons ctor fixity fields) g) a b where
52
52
53− _GCtor = prism (M1 . gfromCollection . tupleToList) (Right . listToTuple . gtoCollection . unM1)
53+ _GCtor = prismE (M1 . gfromCollection . tupleToList) (Right . listToTuple . gtoCollection . unM1)
54+ {-# INLINE _GCtor #-}
54
55
55instance GSumAsConstructor ctor (HasCtorP ctor l) l r l' r' a b => GAsConstructor ctor (l :+: r) (l' :+: r') a b where
56instance GSumAsConstructor ctor (HasCtorP ctor l) l r l' r' a b => GAsConstructor ctor (l :+: r) (l' :+: r') a b where
56 _GCtor = _GSumCtor @ctor @(HasCtorP ctor l)
57 _GCtor = _GSumCtor @ctor @(HasCtorP ctor l)
58+ {-# INLINE _GCtor #-}
57
59
58instance GAsConstructor ctor f f' a b => GAsConstructor ctor (M1 D meta f) (M1 D meta f') a b where
60instance GAsConstructor ctor f f' a b => GAsConstructor ctor (M1 D meta f) (M1 D meta f') a b where
59− _GCtor = mIso . _GCtor @ctor
61+ _GCtor = mIsoE . _GCtor @ctor
62+ {-# INLINE _GCtor #-}
60
63
61class GSumAsConstructor (ctor :: Symbol) (contains :: Bool) l r l' r' a b | ctor l r -> a, ctor l' r' -> b where
64class GSumAsConstructor (ctor :: Symbol) (contains :: Bool) l r l' r' a b | ctor l r -> a, ctor l' r' -> b where
62− _GSumCtor :: Prism ((l :+: r) x) ((l' :+: r') x) a b
65+ _GSumCtor :: PrismE ((l :+: r) x) ((l' :+: r') x) a b
63
66
64instance GAsConstructor ctor l l' a b => GSumAsConstructor ctor 'True l r l' r a b where
67instance GAsConstructor ctor l l' a b => GSumAsConstructor ctor 'True l r l' r a b where
65− _GSumCtor = left . _GCtor @ctor
68+ _GSumCtor = leftE . _GCtor @ctor
69+ {-# INLINE _GSumCtor #-}
66
70
67instance GAsConstructor ctor r r' a b => GSumAsConstructor ctor 'False l r l r' a b where
71instance GAsConstructor ctor r r' a b => GSumAsConstructor ctor 'False l r l r' a b where
68− _GSumCtor = right . _GCtor @ctor
72+ _GSumCtor = rightE . _GCtor @ctor
73+ {-# INLINE _GSumCtor #-}
src/Data/Profunctor/Extra.hsnew file+589
@@ -0,0 +1,589 @@
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+
test/Spec.hs+8−6
@@ -41,10 +41,13 @@ type Prism' s a = Prism s s a a
41type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t
41type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t
42type Prism s t a b =
42type Prism s t a b =
43 forall p f . (Choice p, Applicative f) => p a (f b) -> p s (f t)
43 forall p f . (Choice p, Applicative f) => p a (f b) -> p s (f t)
44+
45+type PrismP s t a b =
46+ forall p . (Choice p) => p a b -> p s t
44type Traversal' s a = forall f. Applicative f => (a -> f a) -> s -> f s
47type Traversal' s a = forall f. Applicative f => (a -> f a) -> s -> f s
45
48
46−prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
49+prism :: (b -> t) -> (s -> Either t a) -> PrismP s t a b
47−prism bt seta = dimap seta (either pure (fmap bt)) . right'
50+prism bt seta = dimap seta (either id bt) . right'
48{-# INLINE prism #-}
51{-# INLINE prism #-}
49
52
50data Record4 a = MkRecord4
53data Record4 a = MkRecord4
@@ -93,7 +96,7 @@ subtypeLensManual f record
93
96
94data Sum1 = A Char | B Int | C () | D () deriving (Generic, Show)
97data Sum1 = A Char | B Int | C () | D () deriving (Generic, Show)
95
98
96−sum1PrismManual :: Prism' Sum1 Int
99+sum1PrismManual :: PrismP Sum1 Sum1 Int Int
97sum1PrismManual = prism g f
100sum1PrismManual = prism g f
98 where
101 where
99 f s1 = case s1 of
102 f s1 = case s1 of
@@ -130,7 +133,7 @@ typeChangingGenericPos = position @1
130typeChangingGenericCompose :: Lens (Record3 (Record3 a)) (Record3 (Record3 b)) a b
133typeChangingGenericCompose :: Lens (Record3 (Record3 a)) (Record3 (Record3 b)) a b
131typeChangingGenericCompose = field @"fieldA" . field @"fieldA"
134typeChangingGenericCompose = field @"fieldA" . field @"fieldA"
132
135
133−sum1PrismB :: Prism' Sum1 Int
136+sum1PrismB :: PrismP Sum1 Sum1 Int Int
134sum1PrismB = _Ctor @"B"
137sum1PrismB = _Ctor @"B"
135
138
136inspect $ 'fieldALensManual === 'fieldALensName
139inspect $ 'fieldALensManual === 'fieldALensName
@@ -141,5 +144,4 @@ inspect $ 'typeChangingManual === 'typeChangingGeneric
141inspect $ 'typeChangingManual === 'typeChangingGenericPos
144inspect $ 'typeChangingManual === 'typeChangingGenericPos
142inspect $ 'typeChangingManualCompose === 'typeChangingGenericCompose
145inspect $ 'typeChangingManualCompose === 'typeChangingGenericCompose
143inspect $ 'intTraversalManual === 'intTraversalDerived
146inspect $ 'intTraversalManual === 'intTraversalDerived
144−
145−--inspect $ 'sum1PrismManual === 'sum1PrismB
147+inspect $ 'sum1PrismManual === 'sum1PrismB