git.iko.soy/generic-lens
on master help sign in
More wip prisms
commitdb739624bb82855ce982f284a1cf4f77c5c61334 authorMatthew Pickering <matthewtpickering@gmail.com> dateWed 20 Dec 2017, 18:16 (9 years ago) parent5106556
5 files changed+58−12
compare with master
unifiedsplit
generic-lens.cabal+1 src/Data/Generics/Internal/Lens.hs+37−3 src/Data/Generics/Product/Boggle.hs+5 src/Data/Generics/Sum/Constructors.hs+1−1 test/Spec.hs+14−8
generic-lens.cabal+1
@@ -83,6 +83,7 @@ test-suite generic-lens-test
8383 , generic-lens
8484 , profunctors
8585 , inspection-testing >= 0.1
86+ , dump-core
8687
8788 default-language: Haskell2010
8889 ghc-options: -Wall -O2
src/Data/Generics/Internal/Lens.hs+37−3
@@ -20,10 +20,11 @@ module Data.Generics.Internal.Lens where
2020import Control.Applicative (Const(..))
2121import Data.Functor.Identity (Identity(..))
2222import Data.Monoid (First (..))
23−import Data.Profunctor (Choice(right'), Profunctor(dimap))
23+import Data.Profunctor (Choice(right'), Profunctor(dimap, rmap))
2424import Data.Profunctor.Unsafe ((#.), (.#))
2525import Data.Tagged
2626import GHC.Generics ((:*:)(..), (:+:)(..), Generic(..), M1(..), Rep)
27+import Boggle hiding (Dirty)
2728
2829-- | Type alias for lens
2930type Lens' s a
@@ -150,9 +151,24 @@ ravel coy f s = inj $ coy (\a -> proj (f a)) s
150151
151152-- Pull dimaps to left and rights to right
152153
154+newtype MergeRight p a b = MergeRight (PrismBoggle p a b)
155+{-
156+instance Choice p => Profunctor (MergeRight p) where
157+ dimap f g (MergeRight (Dirty pab)) = MergeRight (DMap f g pab)
158+ dimap f g (MergeRight (DMap f' g' pab)) = MergeRight (DMap (f' . f) (g . g') pab)
159+ dimap f g (MergeRight (DRight pab)) = MergeRight (DMap f g (right' pab))
160+
161+instance Choice p => Choice (MergeRight p) where
162+ right' (MergeRight (Dirty pab)) = MergeRight (DRight pab)
163+ right' (MergeRight (DMap f g pab)) = MergeRight (DMap (fmap f) (fmap g) (right' pab))
164+ right' (MergeRight (DRight pab)) = MergeRight (DMap assoc' assoc (right' pab))
165+ -}
166+
153167data PrismBoggle p a b where
154− DRight :: (p x y) -> PrismBoggle p (Either z x) (Either z y)
168+ DRight :: Bool -> (p x y) -> PrismBoggle p (Either z x) (Either z y)
155169 DMap :: (c -> a) -> (b -> d) -> (p a b) -> PrismBoggle p c d
170+ --DAssoc :: p (Either (Either a b) c) (Either (Either a b) c) -> PrismBoggle p (Either a (Either b c)) (Either a (Either b c))
171+-- DAssoc :: p (Either a (Either b c)) (Either a (Either b c)) -> PrismBoggle p (Either (Either a b)c) (Either (Either a b) c)
156172 Dirty :: p a b -> PrismBoggle p a b
157173
158174instance Choice p => Profunctor (PrismBoggle p) where
@@ -165,9 +181,26 @@ instance Choice p => Choice (PrismBoggle p) where
165181 right' (DMap f g pab) = DMap (fmap f) (fmap g) (right' pab)
166182 right' (DRight pab) = DRight (right' pab)
167183
184+assoc :: Either a (Either b c) -> Either (Either a b) c
185+assoc e = case e of
186+ Left a -> Left (Left a)
187+ Right ebc -> case ebc of
188+ Left b -> Left (Right b)
189+ Right c -> Right c
190+
191+assoc' :: Either (Either a b) c -> Either a (Either b c)
192+assoc' e = case e of
193+ Right c -> Right (Right c)
194+ Left eab -> case eab of
195+ Left a -> Left a
196+ Right b -> Right (Left b)
197+
168198projPrism :: p a b -> PrismBoggle p a b
169199projPrism pab = Dirty pab
170200
201+--rightFuse :: Choice p => p a b -> p (Either c (Either d a)) (Either c (Either d b))
202+rightFuse x = injPrism (projPrism (injPrism (right' (right' (right' (projPrism x))))))
203+
171204
172205injPrism :: Choice p => PrismBoggle p a b -> p a b
173206injPrism (Dirty pab) = pab
@@ -177,5 +210,6 @@ injPrism (DRight pab) = right' pab
177210prismRavel :: (Choice p, Applicative f)
178211 => (PrismBoggle p a (Boggle f b) -> PrismBoggle p s (Boggle f t))
179212 -> (p a (f b) -> p s (f t))
180−prismRavel coy pafb = (rmap inj (injPrism (coy (projPrism (rmap proj pafb)))))
213+prismRavel coy pafb = injPrism (dimap id lowerBoggle (coy (dimap id liftBoggle (projPrism pafb))))
214+{-# INLINE prismRavel #-}
181215
src/Data/Generics/Product/Boggle.hs+5
@@ -76,3 +76,8 @@ instance GTraversable Par1 where
7676instance Traversable t => GTraversable (Rec1 t) where
7777 gtraverse f (Rec1 x) = Rec1 <$> liftBoggle (traverse f x)
7878 {-# INLINE gtraverse #-}
79+
80+
81+-------------------------------------------------------------------------------
82+
83+
src/Data/Generics/Sum/Constructors.hs+1−1
@@ -110,7 +110,7 @@ instance
110110 , '(t, b) ~ Infer s' a' a (PickTv a' b)
111111 ) => AsConstructor ctor s t a b where
112112
113− _Ctor eta = prismRavel (repIso . _GCtor @ctor) eta
113+ _Ctor eta = prismRavel (prismRavel (prismRavel (repIso . _GCtor @ctor))) eta
114114 {-# INLINE _Ctor #-}
115115
116116-- See Note [Uncluttering type signatures]
test/Spec.hs+14−8
@@ -41,6 +41,7 @@ type Prism' s a = Prism s s a a
4141type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t
4242type Prism s t a b =
4343 forall p f . (Choice p, Applicative f) => p a (f b) -> p s (f t)
44+type Traversal' s a = forall f. Applicative f => (a -> f a) -> s -> f s
4445
4546prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
4647prism bt seta = dimap seta (either pure (fmap bt)) . right'
@@ -51,9 +52,16 @@ data Record4 a = MkRecord4
5152 , fieldB :: a
5253 } deriving (Generic1)
5354
54−type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s
55+data Record5 = MkRecord5
56+ { fieldA :: Int
57+ , fieldB :: Int
58+ , fieldC :: String
59+ , fieldD :: Int
60+ , fieldE :: Char
61+ , fieldF :: Int
62+ } deriving Generic
63+
5564
56−type Traversal' s a = forall f. Applicative f => (a -> f a) -> s -> f s
5765
5866typeChangingManual :: Lens (Record3 a) (Record3 b) a b
5967typeChangingManual f (MkRecord3 a b) = (\a' -> MkRecord3 a' b) <$> f a
@@ -63,11 +71,11 @@ typeChangingManualCompose = typeChangingManual . typeChangingManual
6371
6472newtype L s a = L (Lens' s a)
6573
66−intTraversalManual :: Traversal' Record3 Int
67−intTraversalManual f (MkRecord3 a b c d e f') =
68− (\a1 a2 a3 a4 -> MkRecord3 a1 a2 c a3 e a4) <$> f a <*> f b <*> f d <*> f f'
74+intTraversalManual :: Traversal' Record5 Int
75+intTraversalManual f (MkRecord5 a b c d e f') =
76+ (\a1 a2 a3 a4 -> MkRecord5 a1 a2 c a3 e a4) <$> f a <*> f b <*> f d <*> f f'
6977
70−intTraversalDerived :: Traversal' Record3 Int
78+intTraversalDerived :: Traversal' Record5 Int
7179intTraversalDerived = types
7280
7381
@@ -94,8 +102,6 @@ sum1PrismManual = prism g f
94102 g = B
95103
96104
97−
98−
99105--------------------------------------------------------------------------------
100106-- * Tests
101107-- The inspection-testing plugin checks that the following equalities hold, by