b611659 · generic-lens

git.iko.soy/generic-lens

* Add back get* and set* functions

* Use Bools instead of Maybes as the result of the generic lookups

commitb61165962c9ce32d1c25d067acf4e96f0b304c9c authorCsongor Kiss <kiss.csongor.kiss@gmail.com> dateSun 30 Jul 2017, 16:40 (9 years ago) parente6300f1

8 files changed+145−113

compare with master

unifiedsplit

generic-lens.cabal+2−2 src/Data/Generics/Internal/Families.hs+1−1 src/Data/Generics/Internal/Families/Find.hs−75 src/Data/Generics/Internal/Families/Has.hs+71 src/Data/Generics/Product.hs+7 src/Data/Generics/Product/Fields.hs+32−16 src/Data/Generics/Product/Numbered.hs+22−8 src/Data/Generics/Product/Typed.hs+10−11

generic-lens.cabal+2−2

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

11name: generic-lens

3−version: 0.2.0.0

3+version: 0.3.0.0

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

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

4545

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

4747 , Data.Generics.Internal.Families.Count

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

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

4949

5050 , Data.Generics.Record.Internal.Contains

5151

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

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

33 ) where

55import 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 #-}

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

1717module Data.Generics.Product

1818 ( -- * Lenses

1919 HasAny (..)

20+

2021 , HasField (..)

22+ , setField

23+ , getField

24+

2125 , HasPosition (..)

26+ , setPosition

27+ , getPosition

28+

2229 , HasType (..)

2330 ) where

2431

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

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

2525

2626module Data.Generics.Product.Fields

2727 ( -- *Lenses

28− --

28+

2929 -- $example

3030 HasField (..)

3131

32+ -- *Getter and setter functions

33+ , getField

34+ , setField

35+

3236 -- *Internals

3337 , GHasField (..)

3438 ) where

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

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

5963-- @

6064

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+

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

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

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

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

7088 field :: Lens' s a

7189

72−instance (Generic s,

73− found ~ FindField field (Rep s),

74− ErrorUnlessJust field s found,

75− found ~ 'Just a,

76− GHasField field (Rep s) a)

77−

78− => HasField field a s where

90+instance

91+ ( Generic s

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

93+ , GHasField field (Rep s) a

94+ ) => HasField field a s where

7995

8096 field = repIso . gfield @field

8197

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

83− ErrorUnlessJust field s 'Nothing

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

99+ ErrorUnlessJust field s 'False

84100 = TypeError

85101 ( 'Text "The type "

86102 ':<>: 'ShowType s

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

88104 ':<>: 'ShowType field

89105 )

90106

91− ErrorUnlessJust _ _ ('Just _)

107+ ErrorUnlessJust _ _ 'True

92108 = ()

93109

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

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

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

97113 gfield :: Lens' (f x) a

98114

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

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

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

101117

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

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

103119

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

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

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

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

119135 gfield = mIso . gfield @field

120136

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

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

123139

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

125141 gproductField = first . gfield @field

126142

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

128144 gproductField = second . gfield @field

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

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

2525

2626module Data.Generics.Product.Numbered

2727 ( -- *Lenses

28− --

28+

2929 -- $example

3030 HasPosition (..)

31+ , setPosition

32+ , getPosition

3133

3234 -- *Internals

3335 , GHasPosition (..)

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

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

5860-- @

5961

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+

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

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

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

7288type BaseIndex

7389 = 1

7490

75−instance (Generic s,

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

77− ErrorUnlessTrue i s hasP,

78− hasP ~ 'True,

79− GHasPosition BaseIndex i (Rep s) a)

80−

81− => HasPosition i a s where

91+instance

92+ ( Generic s

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

94+ , GHasPosition BaseIndex i (Rep s) a

95+ ) => HasPosition i a s where

8296

8397 numbered = repIso . gnumbered @BaseIndex @i

8498

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

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

6767 -- 50

6868 typed :: Lens' s a

6969

70−instance (Generic s,

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

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

73− GHasType (Rep s) a)

74−

75− => HasType a s where

70+instance

71+ ( Generic s

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

73+ , GHasType (Rep s) a

74+ ) => HasType a s where

7675

7776 typed = repIso . gtyped

7877

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

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

103102 gtyped :: Lens' (f x) a

104103

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

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

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

107106

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

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

109108

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

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

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

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

123122 gtyped = mIso . gtyped

124123

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

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

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

127126

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

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

129128 gproductTyped = first . gtyped

130129

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

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

132131 gproductTyped = second . gtyped