4cc2db3 · generic-lens

git.iko.soy/generic-lens

Improve type-changing lenses

Previously, type-changing lenses could only change fields whose types exactly matched a type parameter, eg: data Dog a = Dog { thing :: a } Now, it's also possible to change fields that mention the type variable (at most one type variable): data Person a = Person { dog :: Dog a } This means that type-changing lenses can be composed too.

commit4cc2db32e300c597990441e7c17cfa8b16fb0dd3 authorCsongor Kiss <kiss.csongor.kiss@gmail.com> dateSun 3 Dec 2017, 16:26 (9 years ago) parentb4f07fe

8 files changed+79−30

compare with master

unifiedsplit

src/Data/Generics/Internal/Families/Changing.hs+39−5 src/Data/Generics/Internal/Void.hs+2 src/Data/Generics/Product/Any.hs+1−1 src/Data/Generics/Product/Fields.hs+7−4 src/Data/Generics/Product/Internal/Fields.hs+1−1 src/Data/Generics/Product/Positions.hs+7−4 src/Data/Generics/Sum/Constructors.hs+18−13 src/Data/Generics/Sum/Internal/Constructors.hs+4−2

src/Data/Generics/Internal/Families/Changing.hs+39−5

@@ -41,18 +41,52 @@ type family Proxied' (t :: k) (next :: Nat) :: k where

4141 Proxied' t _ = t

4242

4343type family UnProxied (t :: k) :: k where

44+ UnProxied (P _ a) = a

4445 UnProxied (t (P _ a) :: k) = UnProxied t a

4546 UnProxied t = t

4647

4748type family Change (t :: k) (target :: Nat) (to :: j) :: k where

49+ Change (P target _) target to = (P target to)

4850 Change (t (P target _) :: k) target to = t (P target to)

4951 Change (t a :: k) target to = Change t target to a

5052 Change t _ _ = t

5153

52−type family IsParam a where

53− IsParam (P _ _) = 'True

54− IsParam _ = 'False

54+-- TODO: document this

55+data Skolem

5556

56−type family IndexOf a where

57− IndexOf (P i a) = i

57+type family Generalise (t :: k) (w :: *) :: k where

58+ Generalise Skolem w = w

59+ Generalise (t Skolem :: k) w = t w

60+ Generalise (t a) w = (Generalise t w) a

61+ Generalise t _ = t

5862

63+type family UnApply (a :: k) :: [*] where

64+ UnApply (f x) = x ': UnApply f

65+ UnApply x = '[]

66+

67+type family Unify a b :: [(*, *)] where

68+ Unify (P n a') a = '[ '(P n a', a)]

69+ Unify a b = Zip (UnApply a) (UnApply b)

70+

71+type family PSub (subs :: [(*, *)]) :: [(Nat, *)] where

72+ PSub '[] = '[]

73+ PSub ('(P n _, b) ': xs) = '(n, b) ': PSub xs

74+ PSub (_ ': xs) = PSub xs

75+

76+type family Fst (a :: (k, l)) :: k where

77+ Fst '(f, _) = f

78+

79+type family Zip (xs :: [k]) (ys :: [l]) :: [(k, l)] where

80+ Zip '[] '[] = '[]

81+ Zip (x ': xs) (y ': ys) = '(x, y) ': Zip xs ys

82+

83+type family IsSingleton (xs :: [k]) :: Bool where

84+ IsSingleton '[_] = 'True

85+ IsSingleton _ = 'False

86+

87+type family Head (xs :: [k]) :: k where

88+ Head (x ': _) = x

89+

90+type family IfEq a b t f where

91+ IfEq a a t _ = t

92+ IfEq _ _ _ f = f

src/Data/Generics/Internal/Void.hs+2

@@ -14,3 +14,5 @@ module Data.Generics.Internal.Void where

1414 machinery has sufficient information to reduce to sensible types.

1515-}

1616data Void

17+data Void1 a

18+data Void2 a b

src/Data/Generics/Product/Any.hs+1−1

@@ -52,7 +52,7 @@ import Data.Generics.Product.Typed

5252-- :}

5353

5454-- |Records that have generic lenses.

55−class HasAny (sel :: k) s t a b | s sel k -> a, s sel k b -> t where

55+class HasAny (sel :: k) s t a b | s sel k -> a where

5656 -- |A lens that focuses on a part of a product as identified by some

5757 -- selector. Currently supported selectors are field names, positions and

5858 -- unique types. Compatible with the lens package's 'Control.Lens.Lens'

src/Data/Generics/Product/Fields.hs+7−4

@@ -68,7 +68,7 @@ import Data.Type.Bool (If)

6868-- :}

6969

7070-- |Records that have a field with a given name.

71−class HasField (field :: Symbol) s t a b | s field b -> t, s field -> a where

71+class HasField (field :: Symbol) s t a b | s field -> a where

7272 -- |A lens that focuses on a field with a given name. Compatible with the

7373 -- lens package's 'Control.Lens.Lens' type.

7474 --

@@ -107,14 +107,17 @@ instance -- see Note [Changing type parameters]

107107 , GHasField' field (Rep s) a

108108 , GHasField' field (Rep s') a'

109109 , GHasField field (Rep s) (Rep t) a b

110− , '(t', b') ~ If (IsParam a') '(Change s' (IndexOf a') b, P (IndexOf a') b) '(s', b)

111− , t ~ UnProxied t'

110+ , aa ~ PSub (Unify a' a)

111+ , '(t', b') ~ If (IsSingleton aa) '(Change s' (Fst (Head aa)) Skolem, Change a' (Fst (Head aa)) Skolem) '(s', a')

112+ , t'' ~ UnProxied t'

113+ , b'' ~ UnProxied b'

114+ , '(b, t) ~ If (IsSingleton aa) '(Generalise b'' p, Generalise t'' p) '(b'', t'')

112115 ) => HasField field s t a b where

113116

114117 field f s = ravel (repLens . gfield @field) f s

115118

116119-- See Note [Uncluttering type signatures]

117−instance {-# OVERLAPPING #-} HasField f Void Void Void Void where

120+instance {-# OVERLAPPING #-} HasField f (Void2 t a) t a b where

118121 field = undefined

119122

120123type family ErrorUnless (field :: Symbol) (s :: Type) (contains :: Bool) :: Constraint where

src/Data/Generics/Product/Internal/Fields.hs+1−1

@@ -49,7 +49,7 @@ instance GProductHasField field l r l' r' a b (HasTotalFieldP field l)

4949

5050 gfield = gproductField @field @_ @_ @_ @_ @_ @_ @(HasTotalFieldP field l)

5151

52−instance (GHasField field r r a a, GHasField field l l a a, GHasField field l l' a b, GHasField field r r' a b)

52+instance (GHasField' field r a, GHasField' field l a, GHasField field l l' a b, GHasField field r r' a b)

5353 => GHasField field (l :+: r) (l' :+: r') a b where

5454

5555 gfield f (L1 s) = fmap (\a -> L1 (set (gfield @field) a s)) (f (s ^. gfield @field))

src/Data/Generics/Product/Positions.hs+7−4

@@ -66,7 +66,7 @@ import GHC.TypeLits (type (<=?), Nat, TypeError, ErrorMessage(..))

6666-- :}

6767

6868-- |Records that have a field at a given position.

69−class HasPosition (i :: Nat) s t a b | s i -> a, s i b -> t where

69+class HasPosition (i :: Nat) s t a b | s i -> a where

7070 -- |A lens that focuses on a field at a given position. Compatible with the

7171 -- lens package's 'Control.Lens.Lens' type.

7272 --

@@ -92,14 +92,17 @@ instance -- see Note [Changing type parameters]

9292 , GHasPosition' i (Rep s) a

9393 , GHasPosition' i (Rep s') a'

9494 , GHasPosition 1 i (Rep s) (Rep t) a b

95− , '(t', b') ~ If (IsParam a') '(Change s' (IndexOf a') b, P (IndexOf a') b) '(s', b)

96− , t ~ UnProxied t'

95+ , aa ~ PSub (Unify a' a)

96+ , '(t', b') ~ If (IsSingleton aa) '(Change s' (Fst (Head aa)) Skolem, Change a' (Fst (Head aa)) Skolem) '(s', a')

97+ , t'' ~ UnProxied t'

98+ , b'' ~ UnProxied b'

99+ , '(b, t) ~ If (IsSingleton aa) '(Generalise b'' p, Generalise t'' p) '(b'', t'')

97100 ) => HasPosition i s t a b where

98101

99102 position f s = ravel (repLens . gposition @1 @i) f s

100103

101104-- See Note [Uncluttering type signatures]

102−instance {-# OVERLAPPING #-} HasPosition f Void Void Void Void where

105+instance {-# OVERLAPPING #-} HasPosition f (Void2 a t) t a b where

103106 position = undefined

104107

105108type family ErrorUnless (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint where

src/Data/Generics/Sum/Constructors.hs+18−13

@@ -46,33 +46,36 @@ import Data.Type.Bool (If)

4646-- >>> :set -XDeriveGeneric

4747-- >>> import GHC.Generics

4848-- >>> :m +Data.Generics.Internal.Lens

49+-- >>> :m +Data.Generics.Product.Fields

50+-- >>> :m +Data.Function

4951-- >>> :{

50−-- data Animal

51−-- = Dog Dog

52+-- data Animal a

53+-- = Dog (Dog a)

5254-- | Cat Name Age

5355-- | Duck Age

5456-- deriving (Generic, Show)

55−-- data Dog

57+-- data Dog a

5658-- = MkDog

57−-- { name :: Name

58−-- , age :: Age

59+-- { name :: Name

60+-- , age :: Age

61+-- , fieldA :: a

5962-- }

6063-- deriving (Generic, Show)

6164-- type Name = String

6265-- type Age = Int

63−-- dog, cat, duck :: Animal

64−-- dog = Dog (MkDog "Shep" 3)

66+-- dog, cat, duck :: Animal Int

67+-- dog = Dog (MkDog "Shep" 3 30)

6568-- cat = Cat "Mog" 5

6669-- duck = Duck 2

6770-- :}

6871

6972-- |Sums that have a constructor with a given name.

70−class AsConstructor (ctor :: Symbol) s t a b | s ctor -> a where

73+class AsConstructor (ctor :: Symbol) s t a b | ctor s -> a, ctor t -> b where

7174 -- |A prism that projects a named constructor from a sum. Compatible with the

7275 -- lens package's 'Control.Lens.Prism' type.

7376 --

7477 -- >>> dog ^? _Ctor @"Dog"

75− -- Just (MkDog {name = "Shep", age = 3})

78+ -- Just (MkDog {name = "Shep", age = 3, fieldA = 30})

7679 --

7780 -- >>> dog ^? _Ctor @"Cat"

7881 -- Nothing

@@ -80,7 +83,7 @@ class AsConstructor (ctor :: Symbol) s t a b | s ctor -> a where

8083 -- >>> cat ^? _Ctor @"Cat"

8184 -- Just ("Mog",5)

8285 --

83− -- >>> _Ctor @"Cat" # ("Garfield", 6) :: Animal

86+ -- >>> _Ctor @"Cat" # ("Garfield", 6) :: Animal Int

8487 -- Cat "Garfield" 6

8588 _Ctor :: Prism s t a b

8689

@@ -93,14 +96,16 @@ instance

9396 , GAsConstructor' ctor (Rep s) a

9497 , GAsConstructor' ctor (Rep s') a'

9598 , GAsConstructor ctor (Rep s) (Rep t) a b

96− , '(t', b') ~ If (IsParam a') '(Change s' (IndexOf a') b, P (IndexOf a') b) '(s', b)

97− , t ~ UnProxied t'

99+ , aa ~ PSub (Unify a' a)

100+ , '(t', b') ~ IfEq a a' '(s', a') (If (IsSingleton aa) '(Change s' (Fst (Head aa)) Skolem, Change a' (Fst (Head aa)) Skolem) '(s', a'))

101+ , b ~ Generalise (UnProxied b') p

102+ , t ~ Generalise (UnProxied t') p

98103 ) => AsConstructor ctor s t a b where

99104

100105 _Ctor = repIso . _GCtor @ctor

101106

102107-- See Note [Uncluttering type signatures]

103−instance {-# OVERLAPPING #-} AsConstructor ctor Void Void Void Void where

108+instance {-# OVERLAPPING #-} AsConstructor ctor (Void1 a) (Void1 b) a b where

104109 _Ctor = undefined

105110

106111type family ErrorUnless (ctor :: Symbol) (s :: Type) (contains :: Bool) :: Constraint where

src/Data/Generics/Sum/Internal/Constructors.hs+4−2

@@ -45,10 +45,12 @@ type GAsConstructor' ctor s a = GAsConstructor ctor s s a a

4545

4646instance

4747 ( GCollectible f as

48+ , GCollectible g bs

4849 , ListTuple a as

49− ) => GAsConstructor ctor (M1 C ('MetaCons ctor fixity fields) f) (M1 C ('MetaCons ctor fixity fields) f) a a where

50+ , ListTuple b bs

51+ ) => GAsConstructor ctor (M1 C ('MetaCons ctor fixity fields) f) (M1 C ('MetaCons ctor fixity fields) g) a b where

5052

51− _GCtor = prism (M1 . gfromCollection . tupleToList) (Right . listToTuple @_ @as . gtoCollection . unM1)

53+ _GCtor = prism (M1 . gfromCollection . tupleToList) (Right . listToTuple . gtoCollection . unM1)

5254

5355instance GSumAsConstructor ctor (HasCtorP ctor l) l r l' r' a b => GAsConstructor ctor (l :+: r) (l' :+: r') a b where

5456 _GCtor = _GSumCtor @ctor @(HasCtorP ctor l)