7686468 · generic-lens

git.iko.soy/generic-lens

on master help sign in

Move get* and set* functions to the type classes

7686468Csongor Kiss9 years ago

src/Data/Generics/Product.hs+1−7

compare with master

unifiedsplit

@@ -19,18 +19,12 @@ module Data.Generics.Product

19 HasAny (..)

21 , HasField (..)

22− , setField

23− , getField

24−

25 , HasPosition (..)

22 , HasPosition (..)

26− , setPosition

27− , getPosition

28−

29 , HasType (..)

23 , HasType (..)

31 -- * Subtype relationship

25 -- * Subtype relationship

32 , Subtype (..)

26 , Subtype (..)

33− , super

27+

34 ) where

28 ) where

36import Data.Generics.Product.Any

30import Data.Generics.Product.Any

src/Data/Generics/Product/Fields.hs+18−18

@@ -29,10 +29,6 @@ module Data.Generics.Product.Fields

29 -- $example

30 HasField (..)

32− -- *Getter and setter functions

33− , getField

34− , setField

35−

36 -- *Internals

32 -- *Internals

37 , GHasField (..)

33 , GHasField (..)

38 ) where

34 ) where

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

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

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

63-- @

59-- @

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−

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

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

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

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

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

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

@@ -86,6 +68,24 @@ class HasField (field :: Symbol) a s | s field -> a where

86 -- >>> human & field @"name" .~ "Tamas"

68 -- >>> human & field @"name" .~ "Tamas"

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

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

88 field :: Lens' s a

70 field :: Lens' s a

71+ field f s

72+ = fmap (flip (setField @field) s) (f (getField @field s))

73+

74+ -- | Get 'field'

75+ --

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

77+ -- "Tunyasz"

78+ getField :: s -> a

79+ getField s = s ^. field @field

80+

81+ -- | Set 'field'

82+ --

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

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

85+ setField :: a -> s -> s

86+ setField = set (field @field)

87+

88+ {-# MINIMAL field | setField, getField #-}

90instance

91 ( Generic s

src/Data/Generics/Product/Numbered.hsdeleted−177

@@ -1,177 +0,0 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE FlexibleInstances #-}

4−{-# LANGUAGE FunctionalDependencies #-}

5−{-# LANGUAGE KindSignatures #-}

6−{-# LANGUAGE MultiParamTypeClasses #-}

7−{-# LANGUAGE PolyKinds #-}

8−{-# LANGUAGE ScopedTypeVariables #-}

9−{-# LANGUAGE TypeApplications #-}

10−{-# LANGUAGE TypeFamilies #-}

11−{-# LANGUAGE TypeOperators #-}

12−{-# LANGUAGE UndecidableInstances #-}

13−

14−-----------------------------------------------------------------------------

15−-- |

16−-- Module : Data.Generics.Record.HasField

18−-- License : BSD3

19−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

20−-- Stability : experimental

21−-- Portability : non-portable

22−--

23−-- Derive positional product type getters and setters generically.

24−--

25−-----------------------------------------------------------------------------

26−

27−module Data.Generics.Product.Positions

28− ( -- *Lenses

29−

30− -- $example

31− HasPosition (..)

32− , setPosition

33− , getPosition

34−

35− -- *Internals

36− , GHasPosition (..)

37− ) where

38−

39−import Data.Generics.Internal.Lens

40−

41−import Data.Kind (Constraint, Type)

42−import GHC.Generics

43−import GHC.TypeLits

44−

45−-- $example

46−-- @

47−-- module Example where

48−--

49−-- import Data.Generics.Product

50−-- import GHC.Generics

51−--

52−-- data Human = Human

53−-- { name :: String

54−-- , age :: Int

55−-- , address :: String

56−-- }

57−-- deriving (Generic, Show)

58−--

59−-- human :: Human

60−-- human = Human \"Tunyasz\" 50 \"London\"

61−-- @

62−

63−-- | Get positional field

64−--

65−-- >>> getPosition @1 human

66−-- "Tunyasz"

67−getPosition :: forall i a s. HasPosition i a s => s -> a

68−getPosition s = s ^. position @i

69−

70−-- | Set positional field

71−--

72−-- >>> setPosition @2 (setField @1 "Tamas" human) 30

73−-- Human "Tamas" 30 "London"

74−setPosition :: forall i a s. HasPosition i a s => a -> s -> s

75−setPosition = set (position @i)

76−

77−-- |Records that have a field at a given position.

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

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

80− -- lens package's 'Control.Lens.Lens' type.

81− --

82− -- >>> human ^. position @1

83− -- "Tunyasz"

84− -- >>> human & position @2 .~ "Berlin"

85− -- Human {name = "Tunyasz", age = 50, address = "Berlin"}

86− position :: Lens' s a

87−

88−instance

89− ( Generic s

90− , ErrorUnlessTrue i s (0 <? i && i <=? Size (Rep s))

91− , GHasPosition 1 i (Rep s) a

92− ) => HasPosition i a s where

93−

94− position = repIso . gposition @1 @i

95−

96−type family ErrorUnlessTrue (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint where

97− ErrorUnlessTrue i s 'False

98− = TypeError

99− ( 'Text "The type "

100− ':<>: 'ShowType s

101− ':<>: 'Text " does not contain a field at position "

102− ':<>: 'ShowType i

103− )

104−

105− ErrorUnlessTrue _ _ 'True

106− = ()

107−

108−-- |As 'HasPosition' but over generic representations as defined by

109−-- "GHC.Generics".

110−class GHasPosition (offset :: Nat) (i :: Nat) (f :: Type -> Type) a | offset i f -> a where

111− gposition :: Lens' (f x) a

112−

113−instance GHasPosition i i (S1 meta (Rec0 a)) a where

114− gposition = mIso . gposition @i @i

115−

116−instance GHasPosition offset i (K1 R a) a where

117− gposition f (K1 x) = fmap K1 (f x)

118−

119−instance GHasPosition offset i f a => GHasPosition offset i (M1 D meta f) a where

120− gposition = mIso . gposition @offset @i

121−

122−instance GHasPosition offset i f a => GHasPosition offset i (M1 C meta f) a where

123− gposition = mIso . gposition @offset @i

124−

125−instance

126− ( goLeft ~ (i <? (offset + Size l))

127− , offset' ~ (If goLeft offset (offset + Size l))

128− , GProductHasPosition offset' i l r a goLeft

129− ) => GHasPosition offset i (l :*: r) a where

130−

131− gposition = gproductPosition @offset' @i @_ @_ @_ @goLeft

132−

133−

134−class GProductHasPosition (offset :: Nat) (i :: Nat) l r a (left :: Bool) | offset i l r left -> a where

135− gproductPosition :: Lens' ((l :*: r) x) a

136−

137−instance GHasPosition offset i l a => GProductHasPosition offset i l r a 'True where

138− gproductPosition = first . gposition @offset @i

139−

140−instance GHasPosition offset i r a => GProductHasPosition offset i l r a 'False where

141− gproductPosition = second . gposition @offset @i

142−

143−type family Size f :: Nat where

144− Size (l :*: r)

145− = Size l + Size r

146− Size (l :+: r)

147− = Size l + Size r

148− Size (D1 meta f)

149− = Size f

150− Size (C1 meta f)

151− = Size f

152− Size f

153− = 1

154−

155−--------------------------------------------------------------------------------

156−

157−type family Not (b :: Bool) where

158− Not 'True = 'False

159− Not 'False = 'True

160−

161−type family (<?) (x :: Nat) (y :: Nat) :: Bool where

162− x <? y = Not (y <=? x)

163−

164−infixl 4 <?

165−

166−type family If (c :: Bool) (x :: k) (y :: k) :: k where

167− If 'True x _ = x

168− If 'False _ y = y

169−

170−type family Min (a :: Nat) (b :: Nat) :: Nat where

171− Min a b = If (a <? b) a b

172−

173−type family (a :: Bool) && (b :: Bool) :: Bool where

174− 'True && 'True = 'True

175− _ && _ = 'False

176−

177−infix 3 &&

src/Data/Generics/Product/Positions.hs+19−16

@@ -29,8 +29,6 @@ module Data.Generics.Product.Positions

30 -- $example

31 HasPosition (..)

32− , setPosition

33− , getPosition

35 -- *Internals

33 -- *Internals

36 , GHasPosition (..)

34 , GHasPosition (..)

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

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

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

61-- @

59-- @

63−-- | Get positional field

64−--

65−-- >>> getPosition @1 human

66−-- "Tunyasz"

67−getPosition :: forall i a s. HasPosition i a s => s -> a

68−getPosition s = s ^. position @i

69−

70−-- | Set positional field

71−--

72−-- >>> setPosition @2 (setField @1 "Tamas" human) 30

73−-- Human "Tamas" 30 "London"

74−setPosition :: forall i a s. HasPosition i a s => a -> s -> s

75−setPosition = set (position @i)

76−

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

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

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

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

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

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

@@ -84,6 +68,25 @@ class HasPosition (i :: Nat) a s | s i -> a where

84 -- >>> human & position @2 .~ "Berlin"

68 -- >>> human & position @2 .~ "Berlin"

85 -- Human {name = "Tunyasz", age = 50, address = "Berlin"}

69 -- Human {name = "Tunyasz", age = 50, address = "Berlin"}

86 position :: Lens' s a

70 position :: Lens' s a

71+ position f s

72+ = fmap (flip (setPosition @i) s) (f (getPosition @i s))

73+ -- = fmap (setPosition s) (f (getPosition s))

74+

75+ -- |Get positional field

76+ --

77+ -- >>> getPosition @1 human

78+ -- "Tunyasz"

79+ getPosition :: s -> a

80+ getPosition s = s ^. position @i

81+

82+ -- |Set positional field

83+ --

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

85+ -- Human "Tamas" 30 "London"

86+ setPosition :: a -> s -> s

87+ setPosition = set (position @i)

88+

89+ {-# MINIMAL position | setPosition, getPosition #-}

88instance

91instance

89 ( Generic s

92 ( Generic s

src/Data/Generics/Product/Subtype.hs+56−32

@@ -1,14 +1,16 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE FlexibleContexts #-}

3−{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE FlexibleInstances #-}

4−{-# LANGUAGE MultiParamTypeClasses #-}

5+{-# LANGUAGE MultiParamTypeClasses #-}

6+{-# LANGUAGE NoMonomorphismRestriction #-}

5−{-# LANGUAGE PolyKinds #-}

7+{-# LANGUAGE PolyKinds #-}

6−{-# LANGUAGE Rank2Types #-}

8+{-# LANGUAGE Rank2Types #-}

7−{-# LANGUAGE ScopedTypeVariables #-}

9+{-# LANGUAGE ScopedTypeVariables #-}

8−{-# LANGUAGE TypeApplications #-}

10+{-# LANGUAGE TypeApplications #-}

9−{-# LANGUAGE TypeFamilies #-}

11+{-# LANGUAGE TypeFamilies #-}

10−{-# LANGUAGE TypeOperators #-}

12+{-# LANGUAGE TypeOperators #-}

11−{-# LANGUAGE UndecidableInstances #-}

13+{-# LANGUAGE UndecidableInstances #-}

13-----------------------------------------------------------------------------

15-----------------------------------------------------------------------------

14-- |

16-- |

@@ -49,7 +51,6 @@

49-----------------------------------------------------------------------------

51-----------------------------------------------------------------------------

50module Data.Generics.Product.Subtype

52module Data.Generics.Product.Subtype

51 ( Subtype (..)

53 ( Subtype (..)

52− , super

53 ) where

54 ) where

55import Data.Generics.Product.Fields

56import Data.Generics.Product.Fields

@@ -65,34 +66,45 @@ import GHC.Generics

65-- @sub@ is a (structural) `subtype' of @sup@, if its fields are a subset of

66-- @sub@ is a (structural) `subtype' of @sup@, if its fields are a subset of

66-- those of @sup@.

67-- those of @sup@.

67--

68--

68−class Subtype sub sup where

69+class Subtype sup sub where

70+ -- | Structural subtype lens. Given a subtype relationship @sub :< sup@,

71+ -- we can focus on the @sub@ structure of @sup@.

72+ --

73+ -- >>> human ^. super @Animal

74+ -- Animal {name = "Tunyasz", age = 50}

75+ --

76+ -- >>> set (super @Animal) (Animal "dog" 10) human

77+ -- Human {name = "dog", age = 10, address = "London"}

78+ super :: Lens' sub sup

79+ super f sub

80+ = fmap (`smash` sub) (f (upcast sub))

81+

69 -- | Cast the more specific subtype to the more general supertype

82 -- | Cast the more specific subtype to the more general supertype

70 --

83 --

71 -- >>> upcast human :: Animal

84 -- >>> upcast human :: Animal

72 -- Animal {name = "Tunyasz", age = 50}

85 -- Animal {name = "Tunyasz", age = 50}

73 --

86 --

74 upcast :: sub -> sup

87 upcast :: sub -> sup

88+ upcast s = s ^. super @sup

89+

75 -- | Plug a smaller structure into a larger one

90 -- | Plug a smaller structure into a larger one

76 --

91 --

77 -- >>> smash (Animal "dog" 10) human

92 -- >>> smash (Animal "dog" 10) human

78 -- Human {name = "dog", age = 10, address = "London"}

93 -- Human {name = "dog", age = 10, address = "London"}

79 smash :: sup -> sub -> sub

94 smash :: sup -> sub -> sub

95+ smash = set (super @sup)

81−-- | Instances are created by the compiler

97+ {-# MINIMAL super | smash, upcast #-}

82−instance (GSmash (Rep a) (Rep b), GUpcast (Rep a) (Rep b), Generic a, Generic b) => Subtype a b where

83− upcast = to . gupcast . from

84− smash p b = to $ gsmash (from p) (from b)

86−-- | Structural subtype lens. Given a subtype relationship @sub :< sup@,

99+-- | Instances are created by the compiler

87−-- we can focus on the @sub@ structure of @sup@.

100+instance

88−--

101+ ( GSmash (Rep a) (Rep b)

89−-- >>> human ^. super @Animal

102+ , GUpcast (Rep a) (Rep b)

90−-- Animal {name = "Tunyasz", age = 50}

103+ , Generic a

91−--

104+ , Generic b

92−-- >>> set (super @Animal) (Animal "dog" 10) human

105+ ) => Subtype b a where

93−-- Human {name = "dog", age = 10, address = "London"}

106+ smash p b = to $ gsmash (from p) (from b)

94−super :: forall sup sub. Subtype sub sup => Lens' sub sup

107+ upcast = to . gupcast . from

95−super f sub = fmap (`smash` sub) (f (upcast sub))

108

97--------------------------------------------------------------------------------

109--------------------------------------------------------------------------------

98-- * Generic upcasting

110-- * Generic upcasting

@@ -104,10 +116,16 @@ class GUpcast (sub :: Type -> Type) (sup :: Type -> Type) where

104instance (GUpcast sub a, GUpcast sub b) => GUpcast sub (a :*: b) where

116instance (GUpcast sub a, GUpcast sub b) => GUpcast sub (a :*: b) where

105 gupcast rep = gupcast rep :*: gupcast rep

117 gupcast rep = gupcast rep :*: gupcast rep

106

118

119+instance

120+ GHasField field sub t

107−instance {-# OVERLAPPING #-} GHasField field sub t => GUpcast sub (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where

121+ => GUpcast sub (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where

122+

108 gupcast r = M1 (K1 (r ^. gfield @field))

123 gupcast r = M1 (K1 (r ^. gfield @field))

109

124

110−instance GUpcast sub sup => GUpcast sub (M1 i c sup) where

125+instance GUpcast sub sup => GUpcast sub (C1 c sup) where

126+ gupcast = M1 . gupcast

127+

128+instance GUpcast sub sup => GUpcast sub (D1 c sup) where

111 gupcast = M1 . gupcast

129 gupcast = M1 . gupcast

112

130

113--------------------------------------------------------------------------------

131--------------------------------------------------------------------------------

@@ -119,19 +137,25 @@ class GSmash sub sup where

119instance (GSmash a sup, GSmash b sup) => GSmash (a :*: b) sup where

137instance (GSmash a sup, GSmash b sup) => GSmash (a :*: b) sup where

120 gsmash rep (a :*: b) = gsmash rep a :*: gsmash rep b

138 gsmash rep (a :*: b) = gsmash rep a :*: gsmash rep b

121

139

122−instance {-# OVERLAPPING #-}

140+instance

123 ( leaf ~ (S1 ('MetaSel ('Just field) p f b) t)

141 ( leaf ~ (S1 ('MetaSel ('Just field) p f b) t)

124 , GSmashLeaf leaf sup (HasFieldP field sup)

142 , GSmashLeaf leaf sup (HasFieldP field sup)

125 ) => GSmash (S1 ('MetaSel ('Just field) p f b) t) sup where

143 ) => GSmash (S1 ('MetaSel ('Just field) p f b) t) sup where

144+

126 gsmash = gsmashLeaf @_ @_ @(HasFieldP field sup)

145 gsmash = gsmashLeaf @_ @_ @(HasFieldP field sup)

127

146

128−instance GSmash sub sup => GSmash (M1 i c sub) sup where

147+instance GSmash sub sup => GSmash (C1 c sub) sup where

148+ gsmash sup (M1 sub) = M1 (gsmash sup sub)

149+

150+instance GSmash sub sup => GSmash (D1 c sub) sup where

129 gsmash sup (M1 sub) = M1 (gsmash sup sub)

151 gsmash sup (M1 sub) = M1 (gsmash sup sub)

130

152

131class GSmashLeaf sub sup (w :: Bool) where

153class GSmashLeaf sub sup (w :: Bool) where

132 gsmashLeaf :: sup p -> sub p -> sub p

154 gsmashLeaf :: sup p -> sub p -> sub p

133

155

156+instance

157+ GHasField field sup t

134−instance (GHasField field sup t) => GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'True where

158+ => GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'True where

135 gsmashLeaf sup (M1 (K1 _)) = M1 (K1 (sup ^. gfield @field))

159 gsmashLeaf sup (M1 (K1 _)) = M1 (K1 (sup ^. gfield @field))

136

160

137instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'False where

161instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'False where

src/Data/Generics/Product/Typed.hs+12

@@ -66,6 +66,18 @@ class HasType a s where

66 -- >>> human ^. typed @Int

67 -- 50

68 typed :: Lens' s a

69+ typed f t

70+ = fmap (flip (setTyped @a) t) (f (getTyped @a t))

71+

72+ -- |Get field at type

73+ getTyped :: s -> a

74+ getTyped s = s ^. typed @a

75+

76+ -- |Set field at type

77+ setTyped :: a -> s -> s

78+ setTyped = set (typed @a)

79+

80+ {-# MINIMAL typed | setTyped, getTyped #-}

70instance

82instance

71 ( Generic s

83 ( Generic s