41c3a70 · generic-lens

git.iko.soy/generic-lens

Constrained traversal, README

commit41c3a70cd08b8aadc4e9318f44020448cb9a1760 authorCsongor Kiss <kiss.csongor.kiss@gmail.com> dateThu 5 Apr 2018, 02:32 (9 years ago) parentaf5e8e8

6 files changed+156−25

compare with master

unifiedsplit

README.md+67−5 examples/Biscuits.hs+8 src/Data/Generics/Internal/VL/Traversal.hs+10−5 src/Data/Generics/Product.hs+2 src/Data/Generics/Product/Constraints.hs+17−5 src/Data/Generics/Product/Internal/Constraints.hs+52−10

README.md+67−5

@@ -40,6 +40,7 @@ Table of contents

4040A typical module using `generic-lens` will usually have the following

4141extensions turned on:

4242```haskell

43+{-# LANGUAGE AllowAmbiguousTypes #-}

4344{-# LANGUAGE DataKinds #-}

4445{-# LANGUAGE DeriveGeneric #-}

4546{-# LANGUAGE DuplicateRecordFields #-}

@@ -232,22 +233,83 @@ Human {name = "Tunyasz", age = 60, address = "London"}

232233

233234Traversals allow multiple values to be queried or updated at the same time.

234235

236+As a running example, consider a data type of weighted trees. There are two

237+type parameters, which correspond to the type of elements and weights in the

238+tree:

239+```haskell

240+data WTree a w

241+ = Leaf a

242+ | Fork (WTree a w) (WTree a w)

243+ | WithWeight (WTree a w) w

244+ deriving (Generic, Show)

245+

246+mytree :: WTree Int Int

247+mytree = Fork (WithWeight (Leaf 42) 1)

248+ (WithWeight (Fork (Leaf 88) (Leaf 37)) 2)

249+```

250+

235251### By type

252+Focus on all values of a given type.

253+

236254```haskell

237−types :: HasTypes s a => Traversal s s a a

255+types :: HasTypes s a => Traversal' s a

238256```

239−TODO.

257+

258+```haskell

259+>>> toListOf (types @Int) myTree

260+[42,1,88,37,2]

261+```

262+

263+Note that this traversal is `deep': the subtrees are recursively traversed.

240264

241265### By parameter

242−TODO.

266+As the above example shows, the `types` traversal is limited in that it cannot

267+distinguish between the two types of `Int`s: the weights and the values.

268+

269+Instead, the `param` traversal allows specifying types that correspond to a

270+certain type parameter.

243271```haskell

244272param :: HasParam pos s t a b => Traversal s t a b

245273```

246274

275+```haskell

276+>>> toListOf (param @1) myTree

277+[42,88,37]

278+```

279+

280+Here, the numbering starts from 0, with 0 being the rightmost parameter.

281+Because `param` is guaranteed to focus on parametric values, it allows the type

282+to be changed as well.

283+

284+For example, we can implement `Functor` for `WTree` as simply as:

285+

286+```haskell

287+instance Functor (WTree a) where

288+ fmap = over (param @0)

289+```

290+

247291### By constraint

248−TODO.

292+The most general type of traversal: we can apply a given function to every

293+value in a structure, by requiring that all values have an instance for some

294+type class.

295+

296+```haskell

297+constraints :: HasConstraints c s t => Applicative g => (forall a b . c a b => a -> g b) -> s -> g t

298+constraints' :: HasConstraints' c s => Applicative g => (forall a . c a => a -> g b) -> s -> g s

299+```

300+

301+Consider the `Numbers` type, which contains three different numeric types:

302+```haskell

303+data Numbers = Numbers Int Float Double

304+ deriving (Show, Generic)

305+

306+numbers = Numbers 10 20.0 30.0

307+```

308+

309+With `constraints'`, we can uniformly add 20 to each number in one go:

249310```haskell

250−constraints :: HasConstraints c s t => Applicative g => (forall a b . c a b => a -> g b) -> s -> g t

311+>>> constraints' @Num (\x -> pure (x + 20)) numbers

312+Numbers 30 40.0 50.0

251313```

252314

253315## Prisms

examples/Biscuits.hs+8

@@ -140,3 +140,11 @@ treeIncParam = over (param @0) (+ 1)

140140

141141instance Functor Invoice where

142142 fmap = over (param @0)

143+

144+data Numbers = Numbers Int Float Double

145+ deriving (Show, Generic)

146+

147+-- |

148+-- >>> constraints' @Num (\x -> pure (x + 20)) numbers

149+-- Numbers 30 40.0 50.0

150+numbers = Numbers 10 20.0 30.0

src/Data/Generics/Internal/VL/Traversal.hs+10−5

@@ -22,25 +22,30 @@

2222-----------------------------------------------------------------------------

2323module Data.Generics.Internal.VL.Traversal where

2424

25+import Data.Kind (Constraint)

26+

2527-- | Type alias for traversal

2628type Traversal' s a

2729 = forall f. Applicative f => (a -> f a) -> s -> f s

2830

29−type TraversalC' s c

30− = forall f. Applicative f => LensLikeC f s c

31+type TraversalC (c :: * -> * -> Constraint) s t

32+ = forall f. Applicative f => (forall a b. c a b => a -> f b) -> s -> f t

3133

32−type LensLikeC f s c

33− = (forall a. c a => a -> f a) -> s -> f s

34+type TraversalC' (c :: * -> Constraint) s

35+ = forall f. Applicative f => (forall a. c a => a -> f a) -> s -> f s

3436

3537type Traversal s t a b

3638 = forall f. Applicative f => (a -> f b) -> s -> f t

3739

40+type LensLikeC c f s

41+ = (forall a. c a => a -> f a) -> s -> f s

42+

3843confusing :: Applicative f => Traversal s t a b -> (a -> f b) -> s -> f t

3944confusing t = \f -> lowerYoneda . lowerCurried . t (liftCurriedYoneda . f)

4045{-# INLINE confusing #-}

4146

4247-- fuse constrained traversals

43−confusingC :: forall c f s. Applicative f => TraversalC' s c -> LensLikeC f s c

48+confusingC :: forall c f s. Applicative f => TraversalC' c s -> LensLikeC c f s

4449confusingC t = \f -> lowerYoneda . lowerCurried . t (liftCurriedYoneda . f)

4550{-# INLINE confusingC #-}

4651

src/Data/Generics/Product.hs+2

@@ -26,6 +26,7 @@ module Data.Generics.Product

2626 -- *Traversals

2727 , module Data.Generics.Product.Types

2828 , module Data.Generics.Product.Param

29+ , module Data.Generics.Product.Constraints

2930 ) where

3031

3132import Data.Generics.Product.Any

@@ -34,5 +35,6 @@ import Data.Generics.Product.Positions

3435import Data.Generics.Product.Subtype

3536import Data.Generics.Product.Typed

3637import Data.Generics.Product.Types

38+import Data.Generics.Product.Constraints

3739import Data.Generics.Product.Param

3840import Data.Generics.Product.List

src/Data/Generics/Product/Constraints.hs+17−5

@@ -26,6 +26,7 @@ module Data.Generics.Product.Constraints

2626 --

2727 -- $example

2828 HasConstraints (..)

29+ , HasConstraints' (..)

2930 ) where

3031

3132import Data.Generics.Product.Internal.Constraints

@@ -34,12 +35,23 @@ import Data.Kind (Constraint)

3435import GHC.Generics (Generic (Rep), from, to)

3536import Data.Generics.Internal.VL.Traversal

3637

37−class HasConstraints (c :: * -> Constraint) s where

38− constraints :: Applicative g => (forall a. c a => a -> g a) -> s -> g s

38+class HasConstraints' (c :: * -> Constraint) s where

39+ constraints' :: TraversalC' c s

3940

4041instance

4142 ( Generic s

42− , GHasConstraints c (Rep s)

43− ) => HasConstraints c s where

44− constraints = confusingC @c (\f s -> to <$> gconstraints @c f (from s))

43+ , GHasConstraints' c (Rep s)

44+ ) => HasConstraints' c s where

45+ constraints' = confusingC @c (\f s -> to <$> gconstraints' @c f (from s))

46+ {-# INLINE constraints' #-}

47+

48+class HasConstraints (c :: * -> * -> Constraint) s t where

49+ constraints :: TraversalC c s t

50+

51+instance

52+ ( Generic s

53+ , Generic t

54+ , GHasConstraints c (Rep s) (Rep t)

55+ ) => HasConstraints c s t where

56+ constraints f s = to <$> gconstraints @c f (from s)

4557 {-# INLINE constraints #-}

src/Data/Generics/Product/Internal/Constraints.hs+52−10

@@ -30,34 +30,76 @@

3030module Data.Generics.Product.Internal.Constraints

3131 (

3232 GHasConstraints (..)

33+ , GHasConstraints' (..)

3334 , HList (..)

3435 ) where

3536

3637import Data.Kind (Type, Constraint)

3738import GHC.Generics

3839import Data.Generics.Internal.VL.Iso

40+import Data.Generics.Internal.VL.Traversal

3941

4042-- | Constrained traversal.

41−class GHasConstraints (c :: * -> Constraint) (f :: * -> *) where

42− gconstraints :: forall g x.

43+class GHasConstraints' (c :: * -> Constraint) (f :: * -> *) where

44+ gconstraints' :: forall g x.

4345 Applicative g => (forall a. c a => a -> g a) -> f x -> g (f x)

4446

45−instance (GHasConstraints c l, GHasConstraints c r) => GHasConstraints c (l :*: r) where

46− gconstraints f (l :*: r) = (:*:) <$> gconstraints @c f l <*> gconstraints @c f r

47+instance

48+ ( GHasConstraints' c l

49+ , GHasConstraints' c r

50+ ) => GHasConstraints' c (l :*: r) where

51+ gconstraints' f (l :*: r)

52+ = (:*:) <$> gconstraints' @c f l <*> gconstraints' @c f r

4753

48−instance (GHasConstraints c l, GHasConstraints c r) => GHasConstraints c (l :+: r) where

54+instance

55+ ( GHasConstraints' c l

56+ , GHasConstraints' c r

57+ ) => GHasConstraints' c (l :+: r) where

58+ gconstraints' f (L1 l) = L1 <$> gconstraints' @c f l

59+ gconstraints' f (R1 r) = R1 <$> gconstraints' @c f r

60+

61+instance c a => GHasConstraints' c (Rec0 a) where

62+ gconstraints' = kIso

63+

64+instance GHasConstraints' c f

65+ => GHasConstraints' c (M1 m meta f) where

66+ gconstraints' f (M1 x) = M1 <$> gconstraints' @c f x

67+

68+instance GHasConstraints' c U1 where

69+ gconstraints' _ _ = pure U1

70+

71+--------------------------------------------------------------------------------

72+

73+class GHasConstraints (c :: * -> * -> Constraint) s t where

74+ gconstraints :: TraversalC c (s x) (t x)

75+

76+instance

77+ ( GHasConstraints c l l'

78+ , GHasConstraints c r r'

79+ ) => GHasConstraints c (l :*: r) (l' :*: r') where

80+ gconstraints f (l :*: r)

81+ = (:*:) <$> gconstraints @c f l <*> gconstraints @c f r

82+

83+instance

84+ ( GHasConstraints c l l'

85+ , GHasConstraints c r r'

86+ ) => GHasConstraints c (l :+: r) (l' :+: r') where

4987 gconstraints f (L1 l) = L1 <$> gconstraints @c f l

5088 gconstraints f (R1 r) = R1 <$> gconstraints @c f r

5189

52−instance c a => GHasConstraints c (K1 R a) where

53− gconstraints = kIso

54−

55−instance GHasConstraints c f => GHasConstraints c (M1 m meta f) where

90+instance GHasConstraints c s t

91+ => GHasConstraints c (M1 i m s) (M1 i m t) where

5692 gconstraints f (M1 x) = M1 <$> gconstraints @c f x

5793

58−instance GHasConstraints c U1 where

94+instance GHasConstraints c U1 U1 where

5995 gconstraints _ _ = pure U1

6096

97+instance GHasConstraints c V1 V1 where

98+ gconstraints _ = pure

99+

100+instance c a b => GHasConstraints c (Rec0 a) (Rec0 b) where

101+ gconstraints = kIso

102+

61103--------------------------------------------------------------------------------

62104

63105-- | Multi-traversal