4eb9475 · generic-lens

examples/Examples.hs+38−10

compare with master

unifiedsplit

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

1−{-# LANGUAGE DataKinds #-}

1+{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE DeriveGeneric #-}

2+{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE DuplicateRecordFields #-}

3+{-# LANGUAGE DuplicateRecordFields #-}

4−{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE NoMonomorphismRestriction #-}

6+{-# LANGUAGE PartialTypeSignatures #-}

5−{-# LANGUAGE TypeApplications #-}

7+{-# LANGUAGE TypeApplications #-}

6−{-# LANGUAGE UndecidableInstances #-}

8+{-# LANGUAGE UndecidableInstances #-}

7

9

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

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

9

11

10module Examples where

12module Examples where

11

13

12−import GHC.Generics

14+import Data.Function ((&))

15+import Data.Generics.Internal.Lens

13import Data.Generics.Product

16import Data.Generics.Product

14−import Control.Lens

17+import Data.Generics.Sum

18+import GHC.Generics

15

19

16data Animal = Animal

20data Animal = Animal

17 { name :: String

21 { name :: String

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

47-- changedA :: Test Int String

51-- changedA :: Test Int String

48-- >>> changedA

52-- >>> changedA

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

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

51

55

52-- changedB :: Test String Int

56-- changedB :: Test String Int

53-- >>> changedB

57-- >>> changedB

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

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

56

60

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

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

58-- type error

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

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−

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

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

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

77 Zip '[] '[] = '[]

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

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

82

79

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−

90type family IfEq a b t f where

80type family IfEq a b t f where

91 IfEq a a t _ = t

81 IfEq a a t _ = t

92 IfEq _ _ _ f = f

82 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

44import Data.Kind (Constraint, Type)

45import GHC.Generics

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

47−import Data.Type.Bool (If)

48

47

49-- $setup

48-- $setup

50-- >>> :set -XTypeApplications

49-- >>> :set -XTypeApplications

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

79 -- >>> :t human

78 -- >>> :t human

80 -- human :: Human Bool

79 -- human :: Human Bool

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

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

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

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

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

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

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

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

85 field :: Lens s t a b

84 field :: Lens s t a b

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

107 , GHasField' field (Rep s) a

106 , GHasField' field (Rep s) a

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

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

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

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

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

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

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

115 ) => HasField field s t a b where

110 ) => HasField field s t a b where

116

111

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

112 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

43import Data.Generics.Product.Internal.Positions

44

45import Data.Kind (Constraint, Type)

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

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

47import GHC.Generics

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

49

@@ -92,11 +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− , aa ~ PSub (Unify a' a)

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

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

100 ) => HasPosition i s t a b where

96 ) => HasPosition i s t a b where

101

97

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

98 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

38import Data.Kind (Constraint, Type)

39import GHC.Generics (Generic (Rep))

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

41−import Data.Type.Bool (If)

42

41

43-- $setup

42-- $setup

44-- >>> :set -XTypeApplications

43-- >>> :set -XTypeApplications

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

96 , GAsConstructor' ctor (Rep s) a

95 , GAsConstructor' ctor (Rep s) a

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

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

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

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

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

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

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

103 ) => AsConstructor ctor s t a b where

99 ) => AsConstructor ctor s t a b where

104

100

105 _Ctor = repIso . _GCtor @ctor

101 _Ctor = repIso . _GCtor @ctor

stack.yaml+1−1

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

1−resolver: nightly-2017-11-25

1+resolver: lts-9.2

2

3packages:

4- '.'

test/Spec.hs+1

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

87inspect $ 'subtypeLensManual === 'subtypeLensGeneric

88inspect $ 'typeChangingManual === 'typeChangingGeneric

89inspect $ 'typeChangingManual === 'typeChangingGenericPos

90+inspect $ 'typeChangingManualCompose === 'typeChangingManualCompose