git.iko.soy/generic-lens
on master help sign in
WIP: Optimised prisms
commit339412968029ae9921d23546f5cabfa9d73690e6 authorMatthew Pickering <matthewtpickering@gmail.com> dateWed 20 Dec 2017, 16:44 (9 years ago) parent293657d
4 files changed+64−1
compare with master
unifiedsplit
generic-lens.cabal+1 src/Data/Generics/Internal/Lens.hs+34 src/Data/Generics/Sum/Constructors.hs+2−1 test/Spec.hs+27
generic-lens.cabal+1
@@ -69,6 +69,7 @@ test-suite generic-lens-test
6969
7070 build-depends: base >= 4.9 && <= 5.0
7171 , generic-lens
72+ , profunctors
7273 , inspection-testing >= 0.1
7374
7475 default-language: Haskell2010
src/Data/Generics/Internal/Lens.hs+34
@@ -141,3 +141,37 @@ proj fa = Coyoneda id fa
141141
142142ravel :: Functor f => ((a -> Coyoneda f b) -> s -> Coyoneda f t) -> (a -> f b) -> (s -> f t)
143143ravel 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
110110 , '(t, b) ~ Infer s' a' a (PickTv a' b)
111111 ) => AsConstructor ctor s t a b where
112112
113− _Ctor = repIso . _GCtor @ctor
113+ _Ctor eta = prismRavel (repIso . _GCtor @ctor) eta
114+ {-# INLINE _Ctor #-}
114115
115116-- See Note [Uncluttering type signatures]
116117instance {-# OVERLAPPING #-} AsConstructor ctor (Void1 a) (Void1 b) a b where
test/Spec.hs+27
@@ -13,7 +13,9 @@
1313module Main where
1414
1515import GHC.Generics
16+import Data.Profunctor
1617import Data.Generics.Product
18+import Data.Generics.Sum
1719import Test.Inspection
1820
1921main :: IO ()
@@ -34,7 +36,14 @@ data Record3 a = MkRecord3
3436 } deriving (Generic, Show)
3537
3638type Lens' s a = Lens s s a a
39+type Prism' s a = Prism s s a a
3740type 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 #-}
3847
3948fieldALensManual :: Lens' Record Int
4049fieldALensManual f (MkRecord a b) = (\a' -> MkRecord a' b) <$> f a
@@ -53,6 +62,19 @@ subtypeLensManual f record
5362 MkRecord _ b -> MkRecord (case ds of {MkRecord2 g1 -> g1}) b
5463 ) (f (MkRecord2 (case record of {MkRecord a _ -> a})))
5564
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+
5678--------------------------------------------------------------------------------
5779-- * Tests
5880-- The inspection-testing plugin checks that the following equalities hold, by
@@ -81,6 +103,9 @@ typeChangingGenericPos = position @1
81103typeChangingGenericCompose :: Lens (Record3 (Record3 a)) (Record3 (Record3 b)) a b
82104typeChangingGenericCompose = field @"fieldA" . field @"fieldA"
83105
106+sum1PrismB :: Prism' Sum1 Int
107+sum1PrismB = _Ctor @"B"
108+
84109inspect $ 'fieldALensManual === 'fieldALensName
85110inspect $ 'fieldALensManual === 'fieldALensType
86111inspect $ 'fieldALensManual === 'fieldALensPos
@@ -88,3 +113,5 @@ inspect $ 'subtypeLensManual === 'subtypeLensGeneric
88113inspect $ 'typeChangingManual === 'typeChangingGeneric
89114inspect $ 'typeChangingManual === 'typeChangingGenericPos
90115inspect $ 'typeChangingManualCompose === 'typeChangingGenericCompose
116+
117+--inspect $ 'sum1PrismManual === 'sum1PrismB