git.iko.soy/generic-lens
on master help sign in
Minor cleanup
71eff67Csongor Kiss
src/Data/Generics/Internal/Lens.hs+4−1
compare with master
unifiedsplit
@@ -18,7 +18,7 @@ module Data.Generics.Internal.Lens where
18import Control.Applicative (Const(..))
18import Control.Applicative (Const(..))
19import Data.Functor.Identity (Identity(..))
19import Data.Functor.Identity (Identity(..))
20import Data.Profunctor (Choice(right'), Profunctor(dimap))
20import Data.Profunctor (Choice(right'), Profunctor(dimap))
21−import GHC.Generics ((:*:)(..), Generic(..), M1(..), Rep, (:+:)(..))
21+import GHC.Generics ((:*:)(..), Generic(..), K1(..), M1(..), Rep, (:+:)(..))
22
22
23-- | Type alias for lens
23-- | Type alias for lens
24type Lens' s a
24type Lens' s a
@@ -76,6 +76,9 @@ repIso = dimap from (fmap to)
76mIso :: Iso' (M1 i c f p) (f p)
76mIso :: Iso' (M1 i c f p) (f p)
77mIso = dimap unM1 (fmap M1)
77mIso = dimap unM1 (fmap M1)
78
78
79+kIso :: Iso' (K1 t a x) a
80+kIso = dimap unK1 (fmap K1)
81+
79sumIso :: Iso' ((a :+: b) x) (Either (a x) (b x))
82sumIso :: Iso' ((a :+: b) x) (Either (a x) (b x))
80sumIso = dimap f (fmap t)
83sumIso = dimap f (fmap t)
81 where f (L1 x) = Left x
84 where f (L1 x) = Left x
src/Data/Generics/Product/Fields.hs+5−8
@@ -89,14 +89,14 @@ class HasField (field :: Symbol) a s | s field -> a where
89
89
90instance
90instance
91 ( Generic s
91 ( Generic s
92− , ErrorUnlessJust field s (HasFieldP field (Rep s))
92+ , ErrorUnless field s (HasFieldP field (Rep s))
93 , GHasField field (Rep s) a
93 , GHasField field (Rep s) a
94 ) => HasField field a s where
94 ) => HasField field a s where
95
95
96 field = repIso . gfield @field
96 field = repIso . gfield @field
97
97
98−type family ErrorUnlessJust (field :: Symbol) (s :: Type) (contains :: Bool) :: Constraint where
98+type family ErrorUnless (field :: Symbol) (s :: Type) (contains :: Bool) :: Constraint where
99− ErrorUnlessJust field s 'False
99+ ErrorUnless field s 'False
100 = TypeError
100 = TypeError
101 ( 'Text "The type "
101 ( 'Text "The type "
102 ':<>: 'ShowType s
102 ':<>: 'ShowType s
@@ -104,7 +104,7 @@ type family ErrorUnlessJust (field :: Symbol) (s :: Type) (contains :: Bool) ::
104 ':<>: 'ShowType field
104 ':<>: 'ShowType field
105 )
105 )
106
106
107− ErrorUnlessJust _ _ 'True
107+ ErrorUnless _ _ 'True
108 = ()
108 = ()
109
109
110-- |As 'HasField' but over generic representations as defined by
110-- |As 'HasField' but over generic representations as defined by
@@ -123,10 +123,7 @@ instance (GHasField field l a, GHasField field r a)
123 gfield = combine (gfield @field @l) (gfield @field @r)
123 gfield = combine (gfield @field @l) (gfield @field @r)
124
124
125instance GHasField field (S1 ('MetaSel ('Just field) upkd str infstr) (Rec0 a)) a where
125instance GHasField field (S1 ('MetaSel ('Just field) upkd str infstr) (Rec0 a)) a where
126− gfield = mIso . gfield @field
126+ gfield = mIso . kIso
127−
128−instance GHasField field (K1 R a) a where
129− gfield f (K1 x) = fmap K1 (f x)
130
127
131instance GHasField field f a => GHasField field (M1 D meta f) a where
128instance GHasField field f a => GHasField field (M1 D meta f) a where
132 gfield = mIso . gfield @field
129 gfield = mIso . gfield @field
src/Data/Generics/Product/Positions.hs+5−8
@@ -90,14 +90,14 @@ class HasPosition (i :: Nat) a s | s i -> a where
90
90
91instance
91instance
92 ( Generic s
92 ( Generic s
93− , ErrorUnlessTrue i s (0 <? i && i <=? Size (Rep s))
93+ , ErrorUnless i s (0 <? i && i <=? Size (Rep s))
94 , GHasPosition 1 i (Rep s) a
94 , GHasPosition 1 i (Rep s) a
95 ) => HasPosition i a s where
95 ) => HasPosition i a s where
96
96
97 position = repIso . gposition @1 @i
97 position = repIso . gposition @1 @i
98
98
99−type family ErrorUnlessTrue (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint where
99+type family ErrorUnless (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint where
100− ErrorUnlessTrue i s 'False
100+ ErrorUnless i s 'False
101 = TypeError
101 = TypeError
102 ( 'Text "The type "
102 ( 'Text "The type "
103 ':<>: 'ShowType s
103 ':<>: 'ShowType s
@@ -105,7 +105,7 @@ type family ErrorUnlessTrue (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint
105 ':<>: 'ShowType i
105 ':<>: 'ShowType i
106 )
106 )
107
107
108− ErrorUnlessTrue _ _ 'True
108+ ErrorUnless _ _ 'True
109 = ()
109 = ()
110
110
111-- |As 'HasPosition' but over generic representations as defined by
111-- |As 'HasPosition' but over generic representations as defined by
@@ -114,10 +114,7 @@ class GHasPosition (offset :: Nat) (i :: Nat) (f :: Type -> Type) a | offset i f
114 gposition :: Lens' (f x) a
114 gposition :: Lens' (f x) a
115
115
116instance GHasPosition i i (S1 meta (Rec0 a)) a where
116instance GHasPosition i i (S1 meta (Rec0 a)) a where
117− gposition = mIso . gposition @i @i
117+ gposition = mIso . kIso
118−
119−instance GHasPosition offset i (K1 R a) a where
120− gposition f (K1 x) = fmap K1 (f x)
121
118
122instance GHasPosition offset i f a => GHasPosition offset i (M1 D meta f) a where
119instance GHasPosition offset i f a => GHasPosition offset i (M1 D meta f) a where
123 gposition = mIso . gposition @offset @i
120 gposition = mIso . gposition @offset @i
src/Data/Generics/Product/Typed.hs+1−7
@@ -121,16 +121,10 @@ instance GProductHasType l r a (HasTypeP a l)
121instance (GHasType l a, GHasType r a) => GHasType (l :+: r) a where
121instance (GHasType l a, GHasType r a) => GHasType (l :+: r) a where
122 gtyped = combine (gtyped @l) (gtyped @r)
122 gtyped = combine (gtyped @l) (gtyped @r)
123
123
124−instance GHasType (S1 meta (Rec0 a)) a where
125− gtyped = mIso . gtyped
126−
127instance GHasType (K1 R a) a where
124instance GHasType (K1 R a) a where
128 gtyped f (K1 x) = fmap K1 (f x)
125 gtyped f (K1 x) = fmap K1 (f x)
129
126
130−instance GHasType f a => GHasType (M1 D meta f) a where
127+instance GHasType f a => GHasType (M1 m meta f) a where
131− gtyped = mIso . gtyped
132−
133−instance GHasType f a => GHasType (M1 C meta f) a where
134 gtyped = mIso . gtyped
128 gtyped = mIso . gtyped
135
129
136class GProductHasType l r a (contains :: Bool) where
130class GProductHasType l r a (contains :: Bool) where