4eb9475 · generic-lens

git.iko.soy/generic-lens

Fix inference

commit4eb94754e92e3abdde4e286762e0440d52540bc2 authorCsongor Kiss <kiss.csongor.kiss@gmail.com> dateSun 3 Dec 2017, 19:27 (9 years ago) parentadfa23e

7 files changed+56−39

compare with master

unifiedsplit

examples/Examples.hs+38−10 src/Data/Generics/Internal/Families/Changing.hs+11−10 src/Data/Generics/Product/Fields.hs+2−7 src/Data/Generics/Product/Positions.hs+2−6 src/Data/Generics/Sum/Constructors.hs+1−5 stack.yaml+1−1 test/Spec.hs+1

examples/Examples.hs+38−10

@@ -1,17 +1,21 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE DuplicateRecordFields #-}

4−{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE TypeApplications #-}

6−{-# LANGUAGE UndecidableInstances #-}

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE DuplicateRecordFields #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE NoMonomorphismRestriction #-}

6+{-# LANGUAGE PartialTypeSignatures #-}

7+{-# LANGUAGE TypeApplications #-}

8+{-# LANGUAGE UndecidableInstances #-}

810{-# OPTIONS_GHC -fno-warn-unused-imports #-}

911

1012module Examples where

1113

12−import GHC.Generics

14+import Data.Function ((&))

15+import Data.Generics.Internal.Lens

1316import Data.Generics.Product

14−import Control.Lens

17+import Data.Generics.Sum

18+import GHC.Generics

1519

1620data Animal = Animal

1721 { name :: String

@@ -47,12 +51,36 @@ data Test a b = Test { fieldInt :: Int, fieldA :: a, fieldB :: b } deriving (Gen

4751-- changedA :: Test Int String

4852-- >>> changedA

4953-- Test {fieldInt = 10, fieldA = 10, fieldB = "world"}

50−changedA = set (field @"fieldA") (10 :: Int) (Test 10 "hello" "world")

54+changedA = Test 10 "hello" "world" & field @"fieldA" .~ (10 :: Int)

5155

5256-- changedB :: Test String Int

5357-- >>> changedB

5458-- Test {fieldInt = 10, fieldA = "hello", fieldB = 10}

55−changedB = set (field @"fieldB") (10 :: Int) (Test 10 "hello" "world")

59+changedB = (Test 10 "hello" "world") & field @"fieldB" .~ (10 :: Int)

5660

5761--changedInt = set (field @"fieldInt") ("hello") (Test 10 "hello" "world")

5862-- type error

63+

64+data Animal2 a

65+ = Dog (Dog a)

66+ | Cat Name Age

67+ | Duck Age

68+ deriving (Generic, Show)

69+

70+data Dog a

71+ = MkDog

72+ { name :: Name

73+ , age :: Age

74+ , fieldA :: a

75+ }

76+ deriving (Generic, Show)

77+type Name = String

78+type Age = Int

79+dog, cat, duck :: Animal2 Int

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

81+cat = Cat "Mog" 5

82+duck = Duck 2

83+

84+

85+--dog' :: Animal2 String

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

src/Data/Generics/Internal/Families/Changing.hs+11−10

@@ -73,20 +73,21 @@ type family PSub (subs :: [(*, *)]) :: [(Nat, *)] where

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

7474 PSub (_ ': xs) = PSub xs

7575

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

77− Fst '(f, _) = f

78−

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

8077 Zip '[] '[] = '[]

8178 Zip (x ': xs) (y ': ys) = '(x, y) ': Zip xs ys

8279

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−

9080type family IfEq a b t f where

9181 IfEq a a t _ = t

9282 IfEq _ _ _ f = f

83+

84+type family Infer (s :: *) (a' :: *) (a :: *) (w :: *) :: (*, *) where

85+ Infer s' a' a w

86+ = Infer' s' a' (PSub (Unify a' a)) w

87+

88+type family Infer' (s :: *) (a' :: *) (subs :: [(Nat, k)]) w :: (*, *) where

89+ Infer' s' a' '[ '(p, _)] w

90+ = '(Generalise (UnProxied (Change s' p Skolem)) w, Generalise (UnProxied (Change a' p Skolem)) w)

91+ Infer' s' a' _ _

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

93+

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

@@ -44,7 +44,6 @@ 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)

4847

4948-- $setup

5049-- >>> :set -XTypeApplications

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

7978 -- >>> :t human

8079 -- human :: Human Bool

8180 -- >>> :t human & field @"other" .~ 42

82− -- human & field @"other" .~ 42 :: Num b => Human b

81+ -- human & field @"other" .~ 42 :: Num p => Human p

8382 -- >>> human & field @"other" .~ 42

8483 -- Human {name = "Tunyasz", age = 50, address = "London", other = 42}

8584 field :: Lens s t a b

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

107106 , GHasField' field (Rep s) a

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

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

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'')

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

115110 ) => HasField field s t a b where

116111

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

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

@@ -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 (&&), If)

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

4747import GHC.Generics

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

4949

@@ -92,11 +92,7 @@ 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− , 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'')

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

10096 ) => HasPosition i s t a b where

10197

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

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

@@ -38,7 +38,6 @@ 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)

4241

4342-- $setup

4443-- >>> :set -XTypeApplications

@@ -96,10 +95,7 @@ instance

9695 , GAsConstructor' ctor (Rep s) a

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

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

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

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

10399 ) => AsConstructor ctor s t a b where

104100

105101 _Ctor = repIso . _GCtor @ctor

stack.yaml+1−1

@@ -1,4 +1,4 @@

1−resolver: nightly-2017-11-25

1+resolver: lts-9.2

33packages:

44- '.'

test/Spec.hs+1

@@ -87,3 +87,4 @@ inspect $ 'fieldALensManual === 'fieldALensPos

8787inspect $ 'subtypeLensManual === 'subtypeLensGeneric

8888inspect $ 'typeChangingManual === 'typeChangingGeneric

8989inspect $ 'typeChangingManual === 'typeChangingGenericPos

90+inspect $ 'typeChangingManualCompose === 'typeChangingManualCompose