b611659 · generic-lens

generic-lens.cabal+2−2

compare with master

unifiedsplit

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

1name: generic-lens

2

3−version: 0.2.0.0

3+version: 0.3.0.0

4

5synopsis: Generic data-structure operations exposed as lenses.

6

@@ -45,7 +45,7 @@ library

45

46 other-modules: Data.Generics.Internal.Families

47 , Data.Generics.Internal.Families.Count

48− , Data.Generics.Internal.Families.Find

48+ , Data.Generics.Internal.Families.Has

49

50 , Data.Generics.Record.Internal.Contains

51

src/Data/Generics/Internal/Families.hs+1−1

@@ -3,4 +3,4 @@ module Data.Generics.Internal.Families

3 ) where

4

5import Data.Generics.Internal.Families.Count as Families

6−import Data.Generics.Internal.Families.Find as Families

6+import Data.Generics.Internal.Families.Has as Families

src/Data/Generics/Internal/Families/Find.hsdeleted−75

@@ -1,75 +0,0 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE PolyKinds #-}

3−{-# LANGUAGE TypeFamilies #-}

4−{-# LANGUAGE TypeOperators #-}

5−{-# LANGUAGE UndecidableInstances #-}

6−

7−module Data.Generics.Internal.Families.Find

8− ( FindField

9− , FindType

10− ) where

11−

12−import Data.Kind (Type)

13−import GHC.Generics

14−import GHC.TypeLits

15−

16−-- | Look up a record field by name in the generic representation, and return

17−-- its corresponding type, if exists.

18−type family FindField (field :: Symbol) f :: Maybe Type where

19− FindField field (S1 ('MetaSel ('Just field) _ _ _) (Rec0 t))

20− = 'Just t

21− FindField field (l :*: r)

22− = FindField field l <|> FindField field r

23− FindField field (l :+: r)

24− = FindField field l <&> FindField field r

25− FindField field (S1 _ _)

26− = 'Nothing

27− FindField field (C1 m f)

28− = FindField field f

29− FindField field (D1 m f)

30− = FindField field f

31− FindField field (Rec0 _)

32− = 'Nothing

33− FindField field U1

34− = 'Nothing

35− FindField field V1

36− = 'Nothing

37− FindField field f

38− = TypeError

39− ( 'ShowType f

40− ':<>: 'Text " is not a valid GHC.Generics representation type"

41− )

42−

43−type family FindType a f :: Maybe Type where

44− FindType t (S1 meta (Rec0 t))

45− = 'Just t

46− FindType t (l :*: r)

47− = FindType t l <|> FindType t r

48− FindType t (l :+: r)

49− = FindType t l <&> FindType t r

50− FindType t (S1 _ _)

51− = 'Nothing

52− FindType t (C1 m f)

53− = FindType t f

54− FindType t (D1 m f)

55− = FindType t f

56− FindType t (Rec0 _)

57− = 'Nothing

58− FindType t U1

59− = 'Nothing

60− FindType t V1

61− = 'Nothing

62− FindType t f

63− = TypeError

64− ( 'ShowType f

65− ':<>: 'Text " is not a valid GHC.Generics representation type"

66− )

67−

68−-- | Type-level alternative monomorphised to @Maybe@.

69−type family (a :: Maybe k) <|> (b :: Maybe k) :: Maybe k where

70− 'Just a <|> _ = 'Just a

71− _ <|> b = b

72−

73−type family (a :: Maybe k) <&> (b :: Maybe k) :: Maybe k where

74− 'Just a <&> 'Just a = 'Just a

75− _ <&> _ = 'Nothing

src/Data/Generics/Internal/Families/Has.hsnew file+71

@@ -0,0 +1,71 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE PolyKinds #-}

3+{-# LANGUAGE TypeFamilies #-}

4+{-# LANGUAGE TypeOperators #-}

5+{-# LANGUAGE UndecidableInstances #-}

6+

7+module Data.Generics.Internal.Families.Has

8+ ( HasFieldP

9+ , HasTypeP

10+ ) where

11+

12+import GHC.Generics

13+import GHC.TypeLits

14+

15+type family HasFieldP (field :: Symbol) f :: Bool where

16+ HasFieldP field (S1 ('MetaSel ('Just field) _ _ _) (Rec0 t))

17+ = 'True

18+ HasFieldP field (l :*: r)

19+ = HasFieldP field l || HasFieldP field r

20+ HasFieldP field (l :+: r)

21+ = HasFieldP field l && HasFieldP field r

22+ HasFieldP field (S1 _ _)

23+ = 'False

24+ HasFieldP field (C1 _ f)

25+ = HasFieldP field f

26+ HasFieldP field (D1 _ f)

27+ = HasFieldP field f

28+ HasFieldP field (Rec0 _)

29+ = 'False

30+ HasFieldP field U1

31+ = 'False

32+ HasFieldP field V1

33+ = 'False

34+ HasFieldP field f

35+ = TypeError

36+ ( 'ShowType f

37+ ':<>: 'Text " is not a valid GHC.Generics representation type"

38+ )

39+

40+type family HasTypeP a f :: Bool where

41+ HasTypeP t (S1 meta (Rec0 t))

42+ = 'True

43+ HasTypeP t (l :*: r)

44+ = HasTypeP t l || HasTypeP t r

45+ HasTypeP t (l :+: r)

46+ = HasTypeP t l && HasTypeP t r

47+ HasTypeP t (S1 _ _)

48+ = 'False

49+ HasTypeP t (C1 m f)

50+ = HasTypeP t f

51+ HasTypeP t (D1 m f)

52+ = HasTypeP t f

53+ HasTypeP t (Rec0 _)

54+ = 'False

55+ HasTypeP t U1

56+ = 'False

57+ HasTypeP t V1

58+ = 'False

59+ HasTypeP t f

60+ = TypeError

61+ ( 'ShowType f

62+ ':<>: 'Text " is not a valid GHC.Generics representation type"

63+ )

64+

65+type family (a :: Bool) || (b :: Bool) :: Bool where

66+ 'True || _ = 'True

67+ _ || b = b

68+

69+type family (a :: Bool) && (b :: Bool) :: Bool where

70+ 'True && 'True = 'True

71+ _ && _ = 'False

src/Data/Generics/Product.hs+7

@@ -17,8 +17,15 @@

17module Data.Generics.Product

18 ( -- * Lenses

19 HasAny (..)

20+

20 , HasField (..)

21 , HasField (..)

22+ , setField

23+ , getField

24+

21 , HasPosition (..)

25 , HasPosition (..)

26+ , setPosition

27+ , getPosition

28+

22 , HasType (..)

29 , HasType (..)

23 ) where

30 ) where

24

31

src/Data/Generics/Product/Fields.hs+32−16

@@ -25,10 +25,14 @@

25

26module Data.Generics.Product.Fields

27 ( -- *Lenses

28− --

28+

29 -- $example

30 HasField (..)

31

32+ -- *Getter and setter functions

33+ , getField

34+ , setField

35+

32 -- *Internals

36 -- *Internals

33 , GHasField (..)

37 , GHasField (..)

34 ) where

38 ) where

@@ -58,6 +62,20 @@ import GHC.TypeLits

58-- human = Human \"Tunyasz\" 50 \"London\"

62-- human = Human \"Tunyasz\" 50 \"London\"

59-- @

63-- @

60

64

65+-- | Get 'field'

66+--

67+-- >>> getField @"name" human

68+-- "Tunyasz"

69+getField :: forall field a s. HasField field a s => s -> a

70+getField s = s ^. field @field

71+

72+-- | Set 'field'

73+--

74+-- >>> setField @"age" (setField @"name" "Tamas" human) 30

75+-- Human {name = "Tamas", age = 30, address = "London"}

76+setField :: forall field a s. HasField field a s => a -> s -> s

77+setField = set (field @field)

78+

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

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

62class HasField (field :: Symbol) a s | s field -> a where

80class HasField (field :: Symbol) a s | s field -> a where

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

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

@@ -69,18 +87,16 @@ class HasField (field :: Symbol) a s | s field -> a where

69 -- Human {name = "Tamas", age = 50, address = "London"}

87 -- Human {name = "Tamas", age = 50, address = "London"}

70 field :: Lens' s a

88 field :: Lens' s a

71

89

72−instance (Generic s,

90+instance

73− found ~ FindField field (Rep s),

91+ ( Generic s

74− ErrorUnlessJust field s found,

92+ , ErrorUnlessJust field s (HasFieldP field (Rep s))

75− found ~ 'Just a,

76− GHasField field (Rep s) a)

93+ , GHasField field (Rep s) a

77−

78− => HasField field a s where

94+ ) => HasField field a s where

79

95

80 field = repIso . gfield @field

96 field = repIso . gfield @field

81

97

82−type family ErrorUnlessJust (field :: Symbol) (s :: Type) (found :: Maybe Type) :: Constraint where

98+type family ErrorUnlessJust (field :: Symbol) (s :: Type) (contains :: Bool) :: Constraint where

83− ErrorUnlessJust field s 'Nothing

99+ ErrorUnlessJust field s 'False

84 = TypeError

100 = TypeError

85 ( 'Text "The type "

101 ( 'Text "The type "

86 ':<>: 'ShowType s

102 ':<>: 'ShowType s

@@ -88,7 +104,7 @@ type family ErrorUnlessJust (field :: Symbol) (s :: Type) (found :: Maybe Type)

88 ':<>: 'ShowType field

104 ':<>: 'ShowType field

89 )

105 )

90

106

91− ErrorUnlessJust _ _ ('Just _)

107+ ErrorUnlessJust _ _ 'True

92 = ()

108 = ()

93

109

94-- |As 'HasField' but over generic representations as defined by

110-- |As 'HasField' but over generic representations as defined by

@@ -96,10 +112,10 @@ type family ErrorUnlessJust (field :: Symbol) (s :: Type) (found :: Maybe Type)

96class GHasField (field :: Symbol) (f :: Type -> Type) a | field f -> a where

112class GHasField (field :: Symbol) (f :: Type -> Type) a | field f -> a where

97 gfield :: Lens' (f x) a

113 gfield :: Lens' (f x) a

98

114

99−instance GProductHasField field l r a (FindField field l)

115+instance GProductHasField field l r a (HasFieldP field l)

100 => GHasField field (l :*: r) a where

116 => GHasField field (l :*: r) a where

101

117

102− gfield = gproductField @field @_ @_ @_ @(FindField field l)

118+ gfield = gproductField @field @_ @_ @_ @(HasFieldP field l)

103

119

104instance (GHasField field l a, GHasField field r a)

120instance (GHasField field l a, GHasField field r a)

105 => GHasField field (l :+: r) a where

121 => GHasField field (l :+: r) a where

@@ -118,11 +134,11 @@ instance GHasField field f a => GHasField field (M1 D meta f) a where

118instance GHasField field f a => GHasField field (M1 C meta f) a where

134instance GHasField field f a => GHasField field (M1 C meta f) a where

119 gfield = mIso . gfield @field

135 gfield = mIso . gfield @field

120

136

121−class GProductHasField (field :: Symbol) l r a (found :: Maybe Type) | field l r -> a where

137+class GProductHasField (field :: Symbol) l r a (contains :: Bool) | contains field l r -> a where

122 gproductField :: Lens' ((l :*: r) x) a

138 gproductField :: Lens' ((l :*: r) x) a

123

139

124−instance GHasField field l a => GProductHasField field l r a ('Just a) where

140+instance GHasField field l a => GProductHasField field l r a 'True where

125 gproductField = first . gfield @field

141 gproductField = first . gfield @field

126

142

127−instance GHasField field r a => GProductHasField field l r a 'Nothing where

143+instance GHasField field r a => GProductHasField field l r a 'False where

128 gproductField = second . gfield @field

144 gproductField = second . gfield @field

src/Data/Generics/Product/Numbered.hs+22−8

@@ -25,9 +25,11 @@

25

26module Data.Generics.Product.Numbered

27 ( -- *Lenses

28− --

28+

29 -- $example

30 HasPosition (..)

31+ , setPosition

32+ , getPosition

31

33

32 -- *Internals

34 -- *Internals

33 , GHasPosition (..)

35 , GHasPosition (..)

@@ -57,6 +59,20 @@ import GHC.TypeLits

57-- human = Human \"Tunyasz\" 50 \"London\"

59-- human = Human \"Tunyasz\" 50 \"London\"

58-- @

60-- @

59

61

62+-- | Get positional field

63+--

64+-- >>> getPosition @1 human

65+-- "Tunyasz"

66+getPosition :: forall i a s. HasPosition i a s => s -> a

67+getPosition s = s ^. numbered @i

68+

69+-- | Set positional field

70+--

71+-- >>> setPosition @2 (setField @1 "Tamas" human) 30

72+-- Human "Tamas" 30 "London"

73+setPosition :: forall i a s. HasPosition i a s => a -> s -> s

74+setPosition = set (numbered @i)

75+

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

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

61class HasPosition (i :: Nat) a s | s i -> a where

77class HasPosition (i :: Nat) a s | s i -> a where

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

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

@@ -72,13 +88,11 @@ class HasPosition (i :: Nat) a s | s i -> a where

72type BaseIndex

88type BaseIndex

73 = 1

89 = 1

74

90

75−instance (Generic s,

91+instance

76− hasP ~ HasPositionP BaseIndex i (Rep s),

92+ ( Generic s

77− ErrorUnlessTrue i s hasP,

93+ , ErrorUnlessTrue i s (HasPositionP BaseIndex i (Rep s))

78− hasP ~ 'True,

79− GHasPosition BaseIndex i (Rep s) a)

94+ , GHasPosition BaseIndex i (Rep s) a

80−

81− => HasPosition i a s where

95+ ) => HasPosition i a s where

82

96

83 numbered = repIso . gnumbered @BaseIndex @i

97 numbered = repIso . gnumbered @BaseIndex @i

84

98

src/Data/Generics/Product/Typed.hs+10−11

@@ -67,12 +67,11 @@ class HasType a s where

67 -- 50

68 typed :: Lens' s a

69

70−instance (Generic s,

70+instance

71− FindType a (Rep s) ~ 'Just a,

71+ ( Generic s

72− ErrorUnlessOne a s (CountType a (Rep s)),

72+ , ErrorUnlessOne a s (CountType a (Rep s))

73− GHasType (Rep s) a)

73+ , GHasType (Rep s) a

74−

75− => HasType a s where

74+ ) => HasType a s where

76

75

77 typed = repIso . gtyped

76 typed = repIso . gtyped

78

77

@@ -102,10 +101,10 @@ type family ErrorUnlessOne (a :: Type) (s :: Type) (count :: Count) :: Constrain

102class GHasType (f :: Type -> Type) a where

101class GHasType (f :: Type -> Type) a where

103 gtyped :: Lens' (f x) a

102 gtyped :: Lens' (f x) a

104

103

105−instance GProductHasType l r a (FindType a l)

104+instance GProductHasType l r a (HasTypeP a l)

106 => GHasType (l :*: r) a where

105 => GHasType (l :*: r) a where

107

106

108− gtyped = gproductTyped @_ @_ @_ @(FindType a l)

107+ gtyped = gproductTyped @_ @_ @_ @(HasTypeP a l)

109

108

110instance (GHasType l a, GHasType r a) => GHasType (l :+: r) a where

109instance (GHasType l a, GHasType r a) => GHasType (l :+: r) a where

111 gtyped = combine (gtyped @l) (gtyped @r)

110 gtyped = combine (gtyped @l) (gtyped @r)

@@ -122,11 +121,11 @@ instance GHasType f a => GHasType (M1 D meta f) a where

122instance GHasType f a => GHasType (M1 C meta f) a where

121instance GHasType f a => GHasType (M1 C meta f) a where

123 gtyped = mIso . gtyped

122 gtyped = mIso . gtyped

124

123

125−class GProductHasType l r a (found :: Maybe Type) where

124+class GProductHasType l r a (contains :: Bool) where

126 gproductTyped :: Lens' ((l :*: r) x) a

125 gproductTyped :: Lens' ((l :*: r) x) a

127

126

128−instance GHasType l a => GProductHasType l r a ('Just a) where

127+instance GHasType l a => GProductHasType l r a 'True where

129 gproductTyped = first . gtyped

128 gproductTyped = first . gtyped

130

129

131−instance GHasType r a => GProductHasType l r a 'Nothing where

130+instance GHasType r a => GProductHasType l r a 'False where

132 gproductTyped = second . gtyped

131 gproductTyped = second . gtyped