ff78ef1 · generic-lens

generic-lens.cabal+12

compare with master

unifiedsplit

@@ -74,6 +74,18 @@ test-suite generic-lens-test

74 default-language: Haskell2010

75 ghc-options: -Wall

76

77+test-suite generic-lens-test-25

78+ type: exitcode-stdio-1.0

79+ hs-source-dirs: test

80+ main-is: 25.hs

81+

82+ build-depends: base >= 4.9 && <= 5.0

83+ , generic-lens

84+ , lens

85+

86+ default-language: Haskell2010

87+ ghc-options: -Wall

88+

77test-suite doctests

89test-suite doctests

78 default-language: Haskell2010

90 default-language: Haskell2010

79 type: exitcode-stdio-1.0

91 type: exitcode-stdio-1.0

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

@@ -11,6 +11,7 @@

11module Data.Generics.Internal.Families.Changing

12 ( Proxied

13 , Infer

14+ , HasParams

14 ) where

15 ) where

15

16

16import GHC.TypeLits (TypeError, ErrorMessage (..))

17import GHC.TypeLits (TypeError, ErrorMessage (..))

@@ -91,6 +92,10 @@ type family (xs :: [k]) ++ (ys :: [k]) :: [k] where

91 '[] ++ ys = ys

92 '[] ++ ys = ys

92 (x ': xs) ++ ys = x ': (xs ++ ys)

93 (x ': xs) ++ ys = x ': (xs ++ ys)

93

94

95+type family HasParams (a :: *) :: Bool where

96+ HasParams (a b) = 'True

97+ HasParams _ = 'False

98+

94type family Infer (s :: *) (a' :: *) (b :: *) :: * where

99type family Infer (s :: *) (a' :: *) (b :: *) :: * where

95 Infer s a' b

100 Infer s a' b

96 = ReplaceArgs s (Unify a' b)

101 = ReplaceArgs s (Unify a' b)

src/Data/Generics/Product/Fields.hs+8−6

@@ -44,6 +44,7 @@ import Data.Generics.Product.Internal.Fields

44import Data.Kind (Constraint, Type)

45import GHC.Generics

46import GHC.TypeLits (Symbol, ErrorMessage(..), TypeError)

47+import Data.Type.Bool (If)

47

48

48-- $setup

49-- $setup

49-- == /Running example:/

50-- == /Running example:/

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

75-- :}

76-- :}

76

77

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

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

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

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

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

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

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

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

81 --

82 --

@@ -128,19 +129,20 @@ instance -- see Note [Changing type parameters]

128 , ErrorUnless field s (CollectField field (Rep s))

129 , ErrorUnless field s (CollectField field (Rep s))

129 , Generic t

130 , Generic t

130 , s' ~ Proxied s

131 , s' ~ Proxied s

132+ , t' ~ Proxied t

131 , Generic s'

133 , Generic s'

134+ , Generic t'

132 , GHasField' field (Rep s) a

135 , GHasField' field (Rep s) a

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

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

137+ , GHasField' field (Rep t') b'

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

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

135− , t ~ Infer s a' b

139+ , t ~ If (HasParams s) (Infer s a' b) s

140+ , s ~ If (HasParams t) (Infer t b' a) t

136 ) => HasField field s t a b where

141 ) => HasField field s t a b where

137

142

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

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

139

144

140−-- See Note [Uncluttering type signatures]

145+-- -- See Note [Uncluttering type signatures]

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

142− field = undefined

143−

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

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

145 field = undefined

147 field = undefined

146

148

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

@@ -43,7 +43,7 @@ import Data.Generics.Internal.Families

43import Data.Generics.Product.Internal.Positions

44

45import Data.Kind (Constraint, Type)

46−import Data.Type.Bool (type (&&))

46+import Data.Type.Bool (type (&&), If)

47import GHC.Generics

48import GHC.TypeLits (type (<=?), Nat, TypeError, ErrorMessage(..))

49

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

70-- :}

71

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

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

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

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

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

76 --

@@ -100,16 +100,21 @@ instance -- see Note [Changing type parameters]

100 , ErrorUnless i s (0 <? i && i <=? Size (Rep s))

101 , Generic t

102 , s' ~ Proxied s

103+ , t' ~ Proxied t

104+ , Generic s'

105+ , Generic t'

103 , GHasPosition' i (Rep s) a

106 , GHasPosition' i (Rep s) a

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

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

108+ , GHasPosition' i (Rep t') b'

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

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

106− , t ~ Infer s a' b

110+ , t ~ If (HasParams s) (Infer s a' b) s

111+ , s ~ If (HasParams t) (Infer t b' a) t

107 ) => HasPosition i s t a b where

112 ) => HasPosition i s t a b where

108

113

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

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

110

115

111-- See Note [Uncluttering type signatures]

116-- See Note [Uncluttering type signatures]

112−instance {-# OVERLAPPING #-} HasPosition f (Void2 a t) t a b where

117+instance {-# OVERLAPPING #-} HasPosition f (Void1 a) (Void1 b) a b where

113 position = undefined

118 position = undefined

114

119

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

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

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

@@ -38,6 +38,7 @@ import Data.Generics.Sum.Internal.Constructors

38import Data.Kind (Constraint, Type)

39import GHC.Generics (Generic (Rep))

40import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))

41+import Data.Type.Bool (If)

41

42

42-- $setup

43-- $setup

43-- == /Running example:/

44-- == /Running example:/

@@ -103,11 +104,15 @@ instance

103 , ErrorUnless ctor s (HasCtorP ctor (Rep s))

104 , ErrorUnless ctor s (HasCtorP ctor (Rep s))

104 , Generic t

105 , Generic t

105 , s' ~ Proxied s

106 , s' ~ Proxied s

107+ , t' ~ Proxied s

106 , Generic s'

108 , Generic s'

109+ , Generic t'

107 , GAsConstructor' ctor (Rep s) a

110 , GAsConstructor' ctor (Rep s) a

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

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

112+ , GAsConstructor' ctor (Rep t') b'

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

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

110− , t ~ Infer s' a' b

114+ , t ~ If (HasParams s) (Infer s a' b) s

115+ , s ~ If (HasParams t) (Infer t b' a) t

111 ) => AsConstructor ctor s t a b where

116 ) => AsConstructor ctor s t a b where

112

117

113 _Ctor = repIso . _GCtor @ctor

118 _Ctor = repIso . _GCtor @ctor

test/25.hsnew file+33

@@ -0,0 +1,33 @@

1+{-# LANGUAGE DuplicateRecordFields #-}

2+{-# LANGUAGE TypeApplications #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE DeriveGeneric #-}

5+{-# OPTIONS_GHC -Wall #-}

6+

7+module Main where

8+

9+import Control.Lens

10+import Data.Generics.Product

11+import GHC.Generics

12+

13+data Record1 = Record1

14+ { field1 :: Int

15+ , field2 :: Double

16+ } deriving (Generic)

17+

18+class Default a where

19+ def :: a

20+

21+instance Default Record1 where

22+ def = Record1 0 0.0

23+

24+f :: Record1 -> Int

25+f r = r ^. field @"field1"

26+

27+main :: IO ()

28+main = do

29+ print $ f def

30+ print $ f ( field @"field1" .~ 1 $ (def :: Record1))

31+ print $ f ( field @"field1" .~ 2 $ Record1 0 0.0)

32+ print $ f ( field @"field1" .~ (1 :: Int) $ def)

33+ print $ f ( position @1 .~ (1 :: Int) $ def)