git.iko.soy/generic-lens
on master help sign in
WIP: Optimised prisms
3394129Matthew Pickering
generic-lens.cabal+1
compare with master
unifiedsplit
@@ -69,6 +69,7 @@ test-suite generic-lens-test
69
69
70 build-depends: base >= 4.9 && <= 5.0
70 build-depends: base >= 4.9 && <= 5.0
71 , generic-lens
71 , generic-lens
72+ , profunctors
72 , inspection-testing >= 0.1
73 , inspection-testing >= 0.1
73
74
74 default-language: Haskell2010
75 default-language: Haskell2010
src/Data/Generics/Internal/Lens.hs+34
@@ -141,3 +141,37 @@ proj fa = Coyoneda id fa
141
141
142ravel :: Functor f => ((a -> Coyoneda f b) -> s -> Coyoneda f t) -> (a -> f b) -> (s -> f t)
142ravel :: Functor f => ((a -> Coyoneda f b) -> s -> Coyoneda f t) -> (a -> f b) -> (s -> f t)
143ravel coy f s = inj $ coy (\a -> proj (f a)) s
143ravel coy f s = inj $ coy (\a -> proj (f a)) s
144+
145+--------------------------------------------------------------------------------
146+
147+-- Pull dimaps to left and rights to right
148+
149+data PrismBoggle p a b where
150+ DRight :: (p x y) -> PrismBoggle p (Either z x) (Either z y)
151+ DMap :: (c -> a) -> (b -> d) -> (p a b) -> PrismBoggle p c d
152+ Dirty :: p a b -> PrismBoggle p a b
153+
154+instance Choice p => Profunctor (PrismBoggle p) where
155+ dimap f g (Dirty pab) = DMap f g pab
156+ dimap f g (DMap f' g' pab) = DMap (f' . f) (g . g') pab
157+ dimap f g (DRight pab) = DMap f g (right' pab)
158+
159+instance Choice p => Choice (PrismBoggle p) where
160+ right' (Dirty pab) = DRight pab
161+ right' (DMap f g pab) = DMap (fmap f) (fmap g) (right' pab)
162+ right' (DRight pab) = DRight (right' pab)
163+
164+projPrism :: p a b -> PrismBoggle p a b
165+projPrism pab = Dirty pab
166+
167+
168+injPrism :: Choice p => PrismBoggle p a b -> p a b
169+injPrism (Dirty pab) = pab
170+injPrism (DMap f g pab) = dimap f g pab
171+injPrism (DRight pab) = right' pab
172+
173+prismRavel :: (Choice p, Applicative f)
174+ => (PrismBoggle p a (Boggle f b) -> PrismBoggle p s (Boggle f t))
175+ -> (p a (f b) -> p s (f t))
176+prismRavel coy pafb = (rmap inj (injPrism (coy (projPrism (rmap proj pafb)))))
177+
src/Data/Generics/Sum/Constructors.hs+2−1
@@ -110,7 +110,8 @@ instance
110 , '(t, b) ~ Infer s' a' a (PickTv a' b)
110 , '(t, b) ~ Infer s' a' a (PickTv a' b)
111 ) => AsConstructor ctor s t a b where
111 ) => AsConstructor ctor s t a b where
112
112
113− _Ctor = repIso . _GCtor @ctor
113+ _Ctor eta = prismRavel (repIso . _GCtor @ctor) eta
114+ {-# INLINE _Ctor #-}
114
115
115-- See Note [Uncluttering type signatures]
116-- See Note [Uncluttering type signatures]
116instance {-# OVERLAPPING #-} AsConstructor ctor (Void1 a) (Void1 b) a b where
117instance {-# OVERLAPPING #-} AsConstructor ctor (Void1 a) (Void1 b) a b where
test/Spec.hs+27
@@ -13,7 +13,9 @@
13module Main where
13module Main where
14
14
15import GHC.Generics
15import GHC.Generics
16+import Data.Profunctor
16import Data.Generics.Product
17import Data.Generics.Product
18+import Data.Generics.Sum
17import Test.Inspection
19import Test.Inspection
18
20
19main :: IO ()
21main :: IO ()
@@ -34,7 +36,14 @@ data Record3 a = MkRecord3
34 } deriving (Generic, Show)
36 } deriving (Generic, Show)
35
37
36type Lens' s a = Lens s s a a
38type Lens' s a = Lens s s a a
39+type Prism' s a = Prism s s a a
37type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t
40type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t
41+type Prism s t a b =
42+ forall p f . (Choice p, Applicative f) => p a (f b) -> p s (f t)
43+
44+prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
45+prism bt seta = dimap seta (either pure (fmap bt)) . right'
46+{-# INLINE prism #-}
38
47
39fieldALensManual :: Lens' Record Int
48fieldALensManual :: Lens' Record Int
40fieldALensManual f (MkRecord a b) = (\a' -> MkRecord a' b) <$> f a
49fieldALensManual f (MkRecord a b) = (\a' -> MkRecord a' b) <$> f a
@@ -53,6 +62,19 @@ subtypeLensManual f record
53 MkRecord _ b -> MkRecord (case ds of {MkRecord2 g1 -> g1}) b
62 MkRecord _ b -> MkRecord (case ds of {MkRecord2 g1 -> g1}) b
54 ) (f (MkRecord2 (case record of {MkRecord a _ -> a})))
63 ) (f (MkRecord2 (case record of {MkRecord a _ -> a})))
55
64
65+data Sum1 = A Char | B Int | C () | D () deriving (Generic, Show)
66+
67+sum1PrismManual :: Prism' Sum1 Int
68+sum1PrismManual = prism g f
69+ where
70+ f s1 = case s1 of
71+ B i -> Right i
72+ s -> Left s
73+ g = B
74+
75+
76+
77+
56--------------------------------------------------------------------------------
78--------------------------------------------------------------------------------
57-- * Tests
79-- * Tests
58-- The inspection-testing plugin checks that the following equalities hold, by
80-- The inspection-testing plugin checks that the following equalities hold, by
@@ -81,6 +103,9 @@ typeChangingGenericPos = position @1
81typeChangingGenericCompose :: Lens (Record3 (Record3 a)) (Record3 (Record3 b)) a b
103typeChangingGenericCompose :: Lens (Record3 (Record3 a)) (Record3 (Record3 b)) a b
82typeChangingGenericCompose = field @"fieldA" . field @"fieldA"
104typeChangingGenericCompose = field @"fieldA" . field @"fieldA"
83
105
106+sum1PrismB :: Prism' Sum1 Int
107+sum1PrismB = _Ctor @"B"
108+
84inspect $ 'fieldALensManual === 'fieldALensName
109inspect $ 'fieldALensManual === 'fieldALensName
85inspect $ 'fieldALensManual === 'fieldALensType
110inspect $ 'fieldALensManual === 'fieldALensType
86inspect $ 'fieldALensManual === 'fieldALensPos
111inspect $ 'fieldALensManual === 'fieldALensPos
@@ -88,3 +113,5 @@ inspect $ 'subtypeLensManual === 'subtypeLensGeneric
88inspect $ 'typeChangingManual === 'typeChangingGeneric
113inspect $ 'typeChangingManual === 'typeChangingGeneric
89inspect $ 'typeChangingManual === 'typeChangingGenericPos
114inspect $ 'typeChangingManual === 'typeChangingGenericPos
90inspect $ 'typeChangingManualCompose === 'typeChangingGenericCompose
115inspect $ 'typeChangingManualCompose === 'typeChangingGenericCompose
116+
117+--inspect $ 'sum1PrismManual === 'sum1PrismB