git.iko.soy/generic-lens
on master help sign in
Add non-type-changing variant of optics (fixes #40)
3d9c1aeCsongor Kiss
src/Data/Generics/Product/Fields.hs+13−4
compare with master
unifiedsplit
@@ -111,19 +111,28 @@ class HasField (field :: Symbol) s t a b | s field -> a, t field -> b, s field b
111 -- ...
111 -- ...
112 field :: VL.Lens s t a b
112 field :: VL.Lens s t a b
113
113
114−type HasField' field s a = HasField field s s a a
114+class HasField' (field :: Symbol) s a | s field -> a where
115+ field' :: VL.Lens s s a a
115
116
116-- |
117-- |
117-- >>> getField @"age" human
118-- >>> getField @"age" human
118-- 50
119-- 50
119getField :: forall f a s. HasField' f s a => s -> a
120getField :: forall f a s. HasField' f s a => s -> a
120−getField = VL.view (field @f)
121+getField = VL.view (field' @f)
121
122
122-- |
123-- |
123-- >>> setField @"age" 60 human
124-- >>> setField @"age" 60 human
124-- Human {name = "Tunyasz", age = 60, address = "London", other = False}
125-- Human {name = "Tunyasz", age = 60, address = "London", other = False}
125setField :: forall f s a. HasField' f s a => a -> s -> s
126setField :: forall f s a. HasField' f s a => a -> s -> s
126−setField = VL.set (field @f)
127+setField = VL.set (field' @f)
128+
129+instance
130+ ( Generic s
131+ , ErrorUnless field s (CollectField field (Rep s))
132+ , GHasKey' field (Rep s) a
133+ ) => HasField' field s a where
134+ field' f s = VL.ravel (repLens . gkey @field) f s
135+ {-# INLINE field' #-}
127
136
128instance -- see Note [Changing type parameters]
137instance -- see Note [Changing type parameters]
129 ( Generic s
138 ( Generic s
@@ -145,8 +154,8 @@ instance -- see Note [Changing type parameters]
145 , t ~ Infer s a' b
154 , t ~ Infer s a' b
146 , s ~ Infer t b' a
155 , s ~ Infer t b' a
147 ) => HasField field s t a b where
156 ) => HasField field s t a b where
148−
149 field f s = VL.ravel (repLens . gkey @field) f s
157 field f s = VL.ravel (repLens . gkey @field) f s
158+ {-# INLINE field #-}
150
159
151-- -- See Note [Uncluttering type signatures]
160-- -- See Note [Uncluttering type signatures]
152instance {-# OVERLAPPING #-} HasField f (Void1 a) (Void1 b) a b where
161instance {-# OVERLAPPING #-} HasField f (Void1 a) (Void1 b) a b where
src/Data/Generics/Product/Positions.hs+12−3
@@ -89,13 +89,22 @@ class HasPosition (i :: Nat) s t a b | s i -> a, t i -> b, s i b -> t, t i a ->
89 -- ...
89 -- ...
90 position :: VL.Lens s t a b
90 position :: VL.Lens s t a b
91
91
92−type HasPosition' i s a = HasPosition i s s a a
92+class HasPosition' (i :: Nat) s a | s i -> a where
93+ position' :: VL.Lens s s a a
93
94
94getPosition :: forall i s a. HasPosition' i s a => s -> a
95getPosition :: forall i s a. HasPosition' i s a => s -> a
95−getPosition s = s ^. position @i
96+getPosition s = s ^. position' @i
96
97
97setPosition :: forall i s a. HasPosition' i s a => a -> s -> s
98setPosition :: forall i s a. HasPosition' i s a => a -> s -> s
98−setPosition = VL.set (position @i)
99+setPosition = VL.set (position' @i)
100+
101+instance
102+ ( Generic s
103+ , ErrorUnless i s (0 <? i && i <=? Size (Rep s))
104+ , GHasPosition' i (Rep s) a
105+ ) => HasPosition' i s a where
106+ position' f s = VL.ravel (repLens . gposition @i) f s
107+ {-# INLINE position' #-}
99
108
100instance -- see Note [Changing type parameters]
109instance -- see Note [Changing type parameters]
101 ( Generic s
110 ( Generic s
src/Data/Generics/Sum/Constructors.hs+12
@@ -30,6 +30,7 @@ module Data.Generics.Sum.Constructors
30
30
31 -- $setup
31 -- $setup
32 AsConstructor (..)
32 AsConstructor (..)
33+ , AsConstructor' (..)
33 ) where
34 ) where
34
35
35import Data.Generics.Internal.Families
36import Data.Generics.Internal.Families
@@ -102,6 +103,17 @@ class AsConstructor (ctor :: Symbol) s t a b | ctor s -> a, ctor t -> b where
102 -- ...
103 -- ...
103 _Ctor :: Prism s t a b
104 _Ctor :: Prism s t a b
104
105
106+class AsConstructor' (ctor :: Symbol) s a | ctor s -> a where
107+ _Ctor' :: Prism s s a a
108+
109+instance
110+ ( Generic s
111+ , ErrorUnless ctor s (HasCtorP ctor (Rep s))
112+ , GAsConstructor' ctor (Rep s) a
113+ ) => AsConstructor' ctor s a where
114+ _Ctor' eta = prismRavel (prismPRavel (repIso . _GCtor @ctor)) eta
115+ {-# INLINE _Ctor' #-}
116+
105instance
117instance
106 ( Generic s
118 ( Generic s
107 , ErrorUnless ctor s (HasCtorP ctor (Rep s))
119 , ErrorUnless ctor s (HasCtorP ctor (Rep s))