ff78ef1 · generic-lens

git.iko.soy/generic-lens

Infer original type from return type (fixes #25)

With type-changing lenses, updating a field can change the type of the original structure. Previously, only the resulting type was inferred, but the original type can also be inferred from the result type.

commitff78ef18830f05e83ee5ac8b61905e858a82c399 authorCsongor Kiss <kiss.csongor.kiss@gmail.com> dateThu 28 Dec 2017, 11:06 (9 years ago) parentc0e2c24

6 files changed+73−11

compare with master

unifiedsplit

generic-lens.cabal+12 src/Data/Generics/Internal/Families/Changing.hs+5 src/Data/Generics/Product/Fields.hs+8−6 src/Data/Generics/Product/Positions.hs+9−4 src/Data/Generics/Sum/Constructors.hs+6−1 test/25.hs+33

generic-lens.cabal+12

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

7474 default-language: Haskell2010

7575 ghc-options: -Wall

7676

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+

7789test-suite doctests

7890 default-language: Haskell2010

7991 type: exitcode-stdio-1.0

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

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

1111module Data.Generics.Internal.Families.Changing

1212 ( Proxied

1313 , Infer

14+ , HasParams

1415 ) where

1516

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

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

9192 '[] ++ ys = ys

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

9394

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

96+ HasParams (a b) = 'True

97+ HasParams _ = 'False

98+

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

95100 Infer s a' b

96101 = ReplaceArgs s (Unify a' b)

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

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

4444import Data.Kind (Constraint, Type)

4545import GHC.Generics

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

47+import Data.Type.Bool (If)

4748

4849-- $setup

4950-- == /Running example:/

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

7576-- :}

7677

7778-- |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

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

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

8182 --

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

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

129130 , Generic t

130131 , s' ~ Proxied s

132+ , t' ~ Proxied t

131133 , Generic s'

134+ , Generic t'

132135 , GHasField' field (Rep s) a

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

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

134138 , 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

136141 ) => HasField field s t a b where

137142

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

139144

140−-- See Note [Uncluttering type signatures]

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

142− field = undefined

143−

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

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

145147 field = undefined

146148

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

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

4343import Data.Generics.Product.Internal.Positions

4444

4545import Data.Kind (Constraint, Type)

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

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

4747import GHC.Generics

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

4949

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

7070-- :}

7171

7272-- |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

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

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

7676 --

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

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

101101 , Generic t

102102 , s' ~ Proxied s

103+ , t' ~ Proxied t

104+ , Generic s'

105+ , Generic t'

103106 , GHasPosition' i (Rep s) a

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

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

105109 , 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

107112 ) => HasPosition i s t a b where

108113

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

110115

111116-- 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

113118 position = undefined

114119

115120type 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

3838import Data.Kind (Constraint, Type)

3939import GHC.Generics (Generic (Rep))

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

41+import Data.Type.Bool (If)

4142

4243-- $setup

4344-- == /Running example:/

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

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

104105 , Generic t

105106 , s' ~ Proxied s

107+ , t' ~ Proxied s

106108 , Generic s'

109+ , Generic t'

107110 , GAsConstructor' ctor (Rep s) a

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

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

109113 , 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

111116 ) => AsConstructor ctor s t a b where

112117

113118 _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 #-}

7+module Main where

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)