522da2d · generic-lens

git.iko.soy/generic-lens

on master help sign in

Clean up positional lenses, update README

522da2dCsongor Kiss9 years ago

README.md+10−7

compare with master

unifiedsplit

@@ -34,10 +34,10 @@ sally = Person "Sally" 25

34>>> setField @"age" 26 sally

35Person { name = "Sally", age = 26 }

37−>>> sally ^. label @"name"

37+>>> sally ^. field @"name"

38"Sally"

40−>>> sally & label @"name" .~ "Tamas"

40+>>> sally & field @"name" .~ "Tamas"

41Person { name = "Tamas", age = 25 }

43```

@@ -56,16 +56,16 @@ polygon = Polygon (Point 1 5 3) (Point 2 4 2) (Point 5 7 (-2))

57```haskell

59−>>> getFieldAt @2 polygon

59+>>> getPosition @2 polygon

60Point 2 4 2

62−>>> setFieldAt @1 (Point 26 5 3) polygon

62+>>> setPosition @1 (Point 26 5 3) polygon

63Polygon (Point 26 5 3) (Point 2 4 2) (Point 5 7 (-2))

65−>>> polygon ^. itemAt @1 . itemAt @2

65+>>> polygon ^. position @1 . position @2

665

68−>>> polygon & itemAt @3 . itemAt @2 %~ (+10)

68+>>> polygon & position @3 . position @2 %~ (+10)

69Polygon (Point 1 5 3) (Point 2 4 2) (Point 5 17 (-2))

71```

@@ -73,10 +73,13 @@ Polygon (Point 1 5 3) (Point 2 4 2) (Point 5 17 (-2))

73Since tuples are an instance of Generic, positional lenses can be used with them.

75```haskell

76−>>> (("hello", True), 5) ^. itemAt @1 . itemAt @2

76+>>> (("hello", True), 5) ^. position @1 . position @2

77True

78```

80+## Typed fields

81+- TODO

82+

80## Structural subtyping

83## Structural subtyping

82A record is a (structural) `subtype' of another, if its fields are a superset of

85A record is a (structural) `subtype' of another, if its fields are a superset of

generic-lens.cabal+1−1

@@ -35,7 +35,7 @@ library

35 exposed-modules: Data.Generics.Product

36 , Data.Generics.Product.Any

37 , Data.Generics.Product.Fields

38− , Data.Generics.Product.Numbered

38+ , Data.Generics.Product.Positions

39 , Data.Generics.Product.Typed

41 , Data.Generics.Record

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

@@ -31,5 +31,5 @@ module Data.Generics.Product

32import Data.Generics.Product.Any

33import Data.Generics.Product.Fields

34−import Data.Generics.Product.Numbered

34+import Data.Generics.Product.Positions

35import Data.Generics.Product.Typed

src/Data/Generics/Product/Any.hs+4−4

@@ -9,14 +9,14 @@

10-----------------------------------------------------------------------------

11-- |

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

12+-- Module : Data.Generics.Product.Any

14-- License : BSD3

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

16-- Stability : experimental

17-- Portability : non-portable

18--

19−-- Derive a variety of record lenses generically.

19+-- Derive a variety of lenses generically.

20--

21-----------------------------------------------------------------------------

@@ -29,7 +29,7 @@ module Data.Generics.Product.Any

30import Data.Generics.Internal.Lens

31import Data.Generics.Product.Fields

32−import Data.Generics.Product.Numbered

32+import Data.Generics.Product.Positions

33import Data.Generics.Product.Typed

35-- $example

@@ -66,7 +66,7 @@ class HasAny (sel :: k) a s | s sel k -> a where

66 the :: Lens' s a

68instance HasPosition i a s => HasAny i a s where

69− the = numbered @i

69+ the = position @i

71instance HasField field a s => HasAny field a s where

72 the = field @field

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

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

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

135 gfield = mIso . gfield @field

136

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

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

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

139

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

src/Data/Generics/Product/Numbered.hs → src/Data/Generics/Product/Positions.hsrenamed+67−92

@@ -4,6 +4,7 @@

4{-# LANGUAGE FunctionalDependencies #-}

5{-# LANGUAGE KindSignatures #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

7+{-# LANGUAGE PolyKinds #-}

7{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE TypeApplications #-}

9{-# LANGUAGE TypeApplications #-}

9{-# LANGUAGE TypeFamilies #-}

10{-# LANGUAGE TypeFamilies #-}

@@ -12,7 +13,7 @@

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

14-----------------------------------------------------------------------------

14-- |

15-- |

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

16+-- Module : Data.Generics.Product.Positions

17-- License : BSD3

18-- License : BSD3

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

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

@@ -23,7 +24,7 @@

23--

24--

24-----------------------------------------------------------------------------

25-----------------------------------------------------------------------------

26−module Data.Generics.Product.Numbered

27+module Data.Generics.Product.Positions

27 ( -- *Lenses

28 ( -- *Lenses

29 -- $example

30 -- $example

@@ -64,37 +65,33 @@ import GHC.TypeLits

64-- >>> getPosition @1 human

65-- >>> getPosition @1 human

65-- "Tunyasz"

66-- "Tunyasz"

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

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

67−getPosition s = s ^. numbered @i

68+getPosition s = s ^. position @i

69-- | Set positional field

70-- | Set positional field

70--

71--

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

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

72-- Human "Tamas" 30 "London"

73-- Human "Tamas" 30 "London"

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

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

74−setPosition = set (numbered @i)

75+setPosition = set (position @i)

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

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

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

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

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

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

79 -- lens package's 'Control.Lens.Lens' type.

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

80 --

81 --

81− -- >>> human ^. numbered @1

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

82 -- "Tunyasz"

83 -- "Tunyasz"

83− -- >>> human & numbered @2 .~ "Berlin"

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

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

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

85− numbered :: Lens' s a

86+ position :: Lens' s a

86−

87−-- |The base index from which positions are counted.

88−type BaseIndex

89− = 1

91instance

88instance

92 ( Generic s

89 ( Generic s

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

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

94− , GHasPosition BaseIndex i (Rep s) a

91+ , GHasPosition 1 i (Rep s) a

95 ) => HasPosition i a s where

92 ) => HasPosition i a s where

97− numbered = repIso . gnumbered @BaseIndex @i

94+ position = repIso . gposition @1 @i

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

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

100 ErrorUnlessTrue i s 'False

97 ErrorUnlessTrue i s 'False

@@ -111,92 +108,70 @@ type family ErrorUnlessTrue (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint

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

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

112-- "GHC.Generics".

109-- "GHC.Generics".

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

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

114− gnumbered :: Lens' (f x) a

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

115

112

116instance GHasPosition i i (S1 meta (Rec0 a)) a where

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

117− gnumbered = mIso . gnumbered @i @i

114+ gposition = mIso . gposition @i @i

118

115

119instance GHasPosition offset i (K1 R a) a where

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

120− gnumbered f (K1 x) = fmap K1 (f x)

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

121

118

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

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

123− gnumbered = mIso . gnumbered @offset @i

120+ gposition = mIso . gposition @offset @i

124

121

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

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

126− gnumbered = mIso . gnumbered @offset @i

123+ gposition = mIso . gposition @offset @i

127−

124+

128−instance (dir ~ ChooseDirection offset i l r,

125+instance

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

129− offset' ~ Offset dir offset (SizeOf l),

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

130− GProductHasPosition offset' i l r a dir)

128+ , GProductHasPosition offset' i l r a goLeft

131−

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

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

133−

130+

134− gnumbered = gproductNumbered @offset' @i @_ @_ @_ @dir

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

135−

132+

133+

136−class GProductHasPosition (offset :: Nat) (i :: Nat) l r a (dir :: Direction) | offset i l r dir -> a where

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

137− gproductNumbered :: Lens' ((l :*: r) x) a

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

138−

139−instance GHasPosition offset i l a => GProductHasPosition offset i l r a 'GoLeft where

140− gproductNumbered = first . gnumbered @offset @i

141−

142−instance GHasPosition offset i r a => GProductHasPosition offset i l r a 'GoRight where

143− gproductNumbered = second . gnumbered @offset @i

144−

145−data Direction

146− = GoLeft

147− | GoRight

148−

149−type family ChooseDirection offset i l r :: Direction where

150− ChooseDirection offset i l r

151− = ChooseDirection' (HasPositionP offset i l) (HasPositionP (offset + SizeOf l) i r)

152−

153−type family ChooseDirection' (lHas :: Bool) (rHas :: Bool) :: Direction where

154− ChooseDirection' 'True _

155− = 'GoLeft

156− ChooseDirection' _ 'True

157− = 'GoRight

158−

159−type family HasPositionP (offset :: Nat) (i :: Nat) f :: Bool where

160− HasPositionP offset i (D1 meta f)

161− = HasPositionP offset i f

162− HasPositionP n n (S1 _ _)

163− = 'True

164− HasPositionP _ _ (S1 _ _)

165− = 'False

166− HasPositionP offset i (l :*: r)

167− = HasPositionP offset i l || HasPositionP (offset + SizeOf l) i r

168− HasPositionP offset i (C1 meta f)

169− = HasPositionP offset i f

170− HasPositionP offset i (Rec0 _)

171− = 'False

172− HasPositionP offset i U1

173− = 'False

174− HasPositionP offset i V1

175− = 'False

176− HasPositionP offset i f

177− = TypeError

178− ( 'Text "Cannot determine if the type "

179− ':<>: 'ShowType f

180− ':<>: 'Text " has position "

181− ':<>: 'ShowType i

182− ':<>: 'Text " starting from offset "

183− ':<>: 'ShowType offset

184− )

185

136

186−type family (x :: Bool) || (y :: Bool) :: Bool where

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

187− 'True || _ = 'True

138+ gproductPosition = first . gposition @offset @i

188− _ || y = y

139+

189−

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

141+ gproductPosition = second . gposition @offset @i

142+

190−type family SizeOf f :: Nat where

143+type family Size f :: Nat where

191− SizeOf (l :*: r)

144+ Size (l :*: r)

192− = SizeOf l + SizeOf r

145+ = Size l + Size r

146+ Size (l :+: r)

147+ = Size l + Size r

193− SizeOf (D1 meta f)

148+ Size (D1 meta f)

194− = SizeOf f

149+ = Size f

195− SizeOf (C1 meta f)

150+ Size (C1 meta f)

196− = SizeOf f

151+ = Size f

197− SizeOf f

152+ Size f

198 = 1

153 = 1

199

154

200−type family Offset (dir :: Direction) (offset :: Nat) (sizeOfLeft :: Nat) :: Nat where

155+--------------------------------------------------------------------------------

201− Offset 'GoLeft offset _ = offset

156+

202− Offset 'GoRight offset sl = offset + sl

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