904a9ae · generic-lens

examples/Examples.hs+21−3

compare with master

unifiedsplit

@@ -1,3 +1,7 @@

1+{-# LANGUAGE GADTs #-}

2+{-# LANGUAGE ScopedTypeVariables #-}

3+{-# LANGUAGE Rank2Types #-}

4+{-# LANGUAGE AllowAmbiguousTypes #-}

1{-# LANGUAGE DataKinds #-}

5{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DeriveGeneric #-}

6{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE DuplicateRecordFields #-}

7{-# LANGUAGE DuplicateRecordFields #-}

@@ -76,11 +80,25 @@ data Dog a

76 deriving (Generic, Show)

80 deriving (Generic, Show)

77type Name = String

81type Name = String

78type Age = Int

82type Age = Int

79−dog, cat, duck :: Animal2 Int

83+dog :: Animal2 Int

80dog = Dog (MkDog "Shep" 3 30)

84dog = Dog (MkDog "Shep" 3 30)

81−cat = Cat "Mog" 5

82−duck = Duck 2

83

85

86+-- TODO: the error message for this case is ugly

87+-- data Dog a

88+-- = MkDog

89+-- { name :: Name

90+-- , age :: Age

91+-- , fieldA :: a

92+-- , fieldA' :: a

93+-- }

94+-- deriving (Generic, Show)

84

95

85--dog' :: Animal2 String

96--dog' :: Animal2 String

86dog' = dog & _Ctor @"Dog" . field @"fieldA" .~ "now it's a String"

97dog' = dog & _Ctor @"Dog" . field @"fieldA" .~ "now it's a String"

98+

99+stuff ::

100+ ( HasPosition 15 s t a String

101+ , HasField "test" s' t' a' b'

102+ , HasField "bar" a' b' s t

103+ ) => s' -> t'

104+stuff r = r & field @"test" . field @"bar" . position @15 .~ "hello"

examples/StarWars.hs+1−1

@@ -59,7 +59,7 @@ c3po = Droid

59 , primaryFunction = "protocol and human relations"

60 }

61

62−getName :: HasField "name" a r => r -> a

62+getName :: HasField' "name" r a => r -> a

63getName = getField @"name"

64

65-- upcast :: Subtype a b => a -> b

src/Data/Generics/Internal/Families/Changing.hs+7

@@ -1,3 +1,6 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE FunctionalDependencies #-}

1{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE PolyKinds #-}

5{-# LANGUAGE PolyKinds #-}

3{-# LANGUAGE TypeFamilies #-}

6{-# LANGUAGE TypeFamilies #-}

@@ -91,3 +94,7 @@ type family Infer' (s :: *) (a' :: *) (subs :: [(Nat, k)]) w :: (*, *) where

91 Infer' s' a' _ _

94 Infer' s' a' _ _

92 = '(UnProxied s', UnProxied a')

95 = '(UnProxied s', UnProxied a')

93

96

97+type family PickTv (a :: k) (b :: k) :: * where

98+ PickTv (P _ _) b = b

99+ PickTv (f (P _ _)) (g b) = b

100+ PickTv (f a) (g b) = PickTv f g

src/Data/Generics/Product.hs+10−13

@@ -17,18 +17,15 @@

17

18module Data.Generics.Product

19 ( -- *Lenses

20− HasAny (..)

20+ module Any

21−

21+ , module Field

22− , HasField (..)

22+ , module Positions

23− , HasPosition (..)

24− , HasType (..)

25−

26− -- *Subtype relationships

23+ , module Subtype

27− , Subtype (..)

24+ , module Typed

28 ) where

25 ) where

29

26

30−import Data.Generics.Product.Any

27+import Data.Generics.Product.Any as Any

31−import Data.Generics.Product.Fields

28+import Data.Generics.Product.Fields as Field

32−import Data.Generics.Product.Positions

29+import Data.Generics.Product.Positions as Positions

33−import Data.Generics.Product.Subtype

30+import Data.Generics.Product.Subtype as Subtype

34−import Data.Generics.Product.Typed

31+import Data.Generics.Product.Typed as Typed

src/Data/Generics/Product/Fields.hs+5−2

@@ -67,7 +67,7 @@ import GHC.TypeLits (Symbol, ErrorMessage(..), TypeError)

67-- :}

68

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

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

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

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

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

73 --

@@ -106,7 +106,7 @@ instance -- see Note [Changing type parameters]

106 , GHasField' field (Rep s) a

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

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

109− , '(t, b) ~ Infer s' a' a p

109+ , '(t, b) ~ Infer s' a' a (PickTv a' b)

110 ) => HasField field s t a b where

111

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

@@ -115,6 +115,9 @@ instance -- see Note [Changing type parameters]

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

116 field = undefined

117

118+instance {-# OVERLAPPING #-} HasField f (Void1 a) (Void1 b) a b where

119+ field = undefined

120+

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

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

119 ErrorUnless field s 'False

122 ErrorUnless field s 'False

120 = TypeError

123 = TypeError

src/Data/Generics/Product/Positions.hs+2−2

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

66-- :}

67

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

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

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

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

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

72 --

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

92 , GHasPosition' i (Rep s) a

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

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

95− , '(t, b) ~ Infer s' a' a p

95+ , '(t, b) ~ Infer s' a' a (PickTv a' b)

96 ) => HasPosition i s t a b where

97

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

src/Data/Generics/Sum.hs+8−9

@@ -17,14 +17,13 @@

17

18module Data.Generics.Sum

19 ( -- *Prisms

20− AsAny (..)

20+ module Any

21−

21+ , module Constructors

22− , AsConstructor (..)

22+ , module Subtype

23− , AsSubtype (..)

23+ , module Typed

24− , AsType (..)

25 ) where

24 ) where

26

25

27−import Data.Generics.Sum.Any

26+import Data.Generics.Sum.Any as Any

28−import Data.Generics.Sum.Constructors

27+import Data.Generics.Sum.Constructors as Constructors

29−import Data.Generics.Sum.Subtype

28+import Data.Generics.Sum.Subtype as Subtype

30−import Data.Generics.Sum.Typed

29+import Data.Generics.Sum.Typed as Typed

src/Data/Generics/Sum/Constructors.hs+1−1

@@ -95,7 +95,7 @@ instance

95 , GAsConstructor' ctor (Rep s) a

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

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

98− , '(t, b) ~ Infer s' a' a p

98+ , '(t, b) ~ Infer s' a' a (PickTv a' b)

99 ) => AsConstructor ctor s t a b where

100

101 _Ctor = repIso . _GCtor @ctor