git.iko.soy/generic-lens
on master help sign in
More wip prisms
db73962Matthew Pickering
generic-lens.cabal+1
compare with master
unifiedsplit
@@ -83,6 +83,7 @@ test-suite generic-lens-test
83 , generic-lens
83 , generic-lens
84 , profunctors
84 , profunctors
85 , inspection-testing >= 0.1
85 , inspection-testing >= 0.1
86+ , dump-core
86
87
87 default-language: Haskell2010
88 default-language: Haskell2010
88 ghc-options: -Wall -O2
89 ghc-options: -Wall -O2
src/Data/Generics/Internal/Lens.hs+37−3
@@ -20,10 +20,11 @@ module Data.Generics.Internal.Lens where
20import Control.Applicative (Const(..))
20import Control.Applicative (Const(..))
21import Data.Functor.Identity (Identity(..))
21import Data.Functor.Identity (Identity(..))
22import Data.Monoid (First (..))
22import Data.Monoid (First (..))
23−import Data.Profunctor (Choice(right'), Profunctor(dimap))
23+import Data.Profunctor (Choice(right'), Profunctor(dimap, rmap))
24import Data.Profunctor.Unsafe ((#.), (.#))
24import Data.Profunctor.Unsafe ((#.), (.#))
25import Data.Tagged
25import Data.Tagged
26import GHC.Generics ((:*:)(..), (:+:)(..), Generic(..), M1(..), Rep)
26import GHC.Generics ((:*:)(..), (:+:)(..), Generic(..), M1(..), Rep)
27+import Boggle hiding (Dirty)
27
28
28-- | Type alias for lens
29-- | Type alias for lens
29type Lens' s a
30type Lens' s a
@@ -150,9 +151,24 @@ ravel coy f s = inj $ coy (\a -> proj (f a)) s
150
151
151-- Pull dimaps to left and rights to right
152-- Pull dimaps to left and rights to right
152
153
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+
153data PrismBoggle p a b where
167data 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)
155 DMap :: (c -> a) -> (b -> d) -> (p a b) -> PrismBoggle p c d
169 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)
156 Dirty :: p a b -> PrismBoggle p a b
172 Dirty :: p a b -> PrismBoggle p a b
157
173
158instance Choice p => Profunctor (PrismBoggle p) where
174instance Choice p => Profunctor (PrismBoggle p) where
@@ -165,9 +181,26 @@ instance Choice p => Choice (PrismBoggle p) where
165 right' (DMap f g pab) = DMap (fmap f) (fmap g) (right' pab)
181 right' (DMap f g pab) = DMap (fmap f) (fmap g) (right' pab)
166 right' (DRight pab) = DRight (right' pab)
182 right' (DRight pab) = DRight (right' pab)
167
183
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+
168projPrism :: p a b -> PrismBoggle p a b
198projPrism :: p a b -> PrismBoggle p a b
169projPrism pab = Dirty pab
199projPrism pab = Dirty pab
170
200
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+
171
204
172injPrism :: Choice p => PrismBoggle p a b -> p a b
205injPrism :: Choice p => PrismBoggle p a b -> p a b
173injPrism (Dirty pab) = pab
206injPrism (Dirty pab) = pab
@@ -177,5 +210,6 @@ injPrism (DRight pab) = right' pab
177prismRavel :: (Choice p, Applicative f)
210prismRavel :: (Choice p, Applicative f)
178 => (PrismBoggle p a (Boggle f b) -> PrismBoggle p s (Boggle f t))
211 => (PrismBoggle p a (Boggle f b) -> PrismBoggle p s (Boggle f t))
179 -> (p a (f b) -> p s (f t))
212 -> (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 #-}
181
215
src/Data/Generics/Product/Boggle.hs+5
@@ -76,3 +76,8 @@ instance GTraversable Par1 where
76instance Traversable t => GTraversable (Rec1 t) where
76instance Traversable t => GTraversable (Rec1 t) where
77 gtraverse f (Rec1 x) = Rec1 <$> liftBoggle (traverse f x)
77 gtraverse f (Rec1 x) = Rec1 <$> liftBoggle (traverse f x)
78 {-# INLINE gtraverse #-}
78 {-# INLINE gtraverse #-}
79+
80+
81+-------------------------------------------------------------------------------
82+
83+
src/Data/Generics/Sum/Constructors.hs+1−1
@@ -110,7 +110,7 @@ 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 eta = prismRavel (repIso . _GCtor @ctor) eta
113+ _Ctor eta = prismRavel (prismRavel (prismRavel (repIso . _GCtor @ctor))) eta
114 {-# INLINE _Ctor #-}
114 {-# INLINE _Ctor #-}
115
115
116-- See Note [Uncluttering type signatures]
116-- See Note [Uncluttering type signatures]
test/Spec.hs+14−8
@@ -41,6 +41,7 @@ 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+type Traversal' s a = forall f. Applicative f => (a -> f a) -> s -> f s
44
45
45prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
46prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
46prism bt seta = dimap seta (either pure (fmap bt)) . right'
47prism bt seta = dimap seta (either pure (fmap bt)) . right'
@@ -51,9 +52,16 @@ data Record4 a = MkRecord4
51 , fieldB :: a
52 , fieldB :: a
52 } deriving (Generic1)
53 } deriving (Generic1)
53
54
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+
55
64
56−type Traversal' s a = forall f. Applicative f => (a -> f a) -> s -> f s
57
65
58typeChangingManual :: Lens (Record3 a) (Record3 b) a b
66typeChangingManual :: Lens (Record3 a) (Record3 b) a b
59typeChangingManual f (MkRecord3 a b) = (\a' -> MkRecord3 a' b) <$> f a
67typeChangingManual f (MkRecord3 a b) = (\a' -> MkRecord3 a' b) <$> f a
@@ -63,11 +71,11 @@ typeChangingManualCompose = typeChangingManual . typeChangingManual
63
71
64newtype L s a = L (Lens' s a)
72newtype L s a = L (Lens' s a)
65
73
66−intTraversalManual :: Traversal' Record3 Int
74+intTraversalManual :: Traversal' Record5 Int
67−intTraversalManual f (MkRecord3 a b c d e f') =
75+intTraversalManual f (MkRecord5 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'
76+ (\a1 a2 a3 a4 -> MkRecord5 a1 a2 c a3 e a4) <$> f a <*> f b <*> f d <*> f f'
69
77
70−intTraversalDerived :: Traversal' Record3 Int
78+intTraversalDerived :: Traversal' Record5 Int
71intTraversalDerived = types
79intTraversalDerived = types
72
80
73
81
@@ -94,8 +102,6 @@ sum1PrismManual = prism g f
94 g = B
102 g = B
95
103
96
104
97−
98−
99--------------------------------------------------------------------------------
105--------------------------------------------------------------------------------
100-- * Tests
106-- * Tests
101-- The inspection-testing plugin checks that the following equalities hold, by
107-- The inspection-testing plugin checks that the following equalities hold, by