95d451a · generic-lens

git.iko.soy/generic-lens

on master help sign in

Add constrained traversals and multitraversals

95d451aCsongor Kiss9 years ago

generic-lens.cabal+1

compare with master

unifiedsplit

@@ -30,6 +30,7 @@ library

30 , Data.Generics.Product.Subtype

31 , Data.Generics.Product.Typed

32 , Data.Generics.Product.Types

33+ , Data.Generics.Product.Constraints

33 , Data.Generics.Product.List

34 , Data.Generics.Product.List

35 , Data.Generics.Sum

36 , Data.Generics.Sum

src/Data/Generics/Internal/VL/Iso.hs+3

@@ -37,6 +37,9 @@ repIso = iso from to

37mIso :: Iso (M1 i c f p) (M1 i c g p) (f p) (g p)

38mIso = iso unM1 M1

40+kIso :: Iso (K1 r a p) (K1 r b p) a b

41+kIso = iso unK1 K1

42+

40prodIso :: Iso ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)

43prodIso :: Iso ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)

41prodIso = iso (\(a :*: b) -> (a, b)) (\(a, b) -> (a :*: b))

44prodIso = iso (\(a :*: b) -> (a, b)) (\(a, b) -> (a :*: b))

src/Data/Generics/Internal/VL/Traversal.hs+21−7

@@ -1,3 +1,5 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE ConstraintKinds #-}

1{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

2{-# LANGUAGE NoMonomorphismRestriction #-}

4{-# LANGUAGE NoMonomorphismRestriction #-}

3{-# LANGUAGE Rank2Types #-}

5{-# LANGUAGE Rank2Types #-}

@@ -24,20 +26,32 @@ module Data.Generics.Internal.VL.Traversal where

24type Traversal' s a

26type Traversal' s a

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

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

29+type TraversalC' s c

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

31+

32+type LensLikeC f s c

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

34+

27type Traversal s t a b

35type Traversal s t a b

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

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

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

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

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

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

32− where

33− liftCurriedYoneda :: Applicative f => f a -> Curried (Yoneda f) a

34− liftCurriedYoneda fa = Curried (`yap` fa)

35− {-# INLINE liftCurriedYoneda #-}

36− yap :: Applicative f => Yoneda f (a -> b) -> f a -> Yoneda f b

37− yap (Yoneda k) fa = Yoneda (\ab_r -> k (ab_r .) <*> fa)

38− {-# INLINE yap #-}

39{-# INLINE confusing #-}

40{-# INLINE confusing #-}

42+-- fuse constrained traversals

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

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

45+{-# INLINE confusingC #-}

46+

47+liftCurriedYoneda :: Applicative f => f a -> Curried (Yoneda f) a

48+liftCurriedYoneda fa = Curried (`yap` fa)

49+{-# INLINE liftCurriedYoneda #-}

50+

51+yap :: Applicative f => Yoneda f (a -> b) -> f a -> Yoneda f b

52+yap (Yoneda k) fa = Yoneda (\ab_r -> k (ab_r .) <*> fa)

53+{-# INLINE yap #-}

54+

41newtype Curried f a =

55newtype Curried f a =

42 Curried { runCurried :: forall r. f (a -> r) -> f r }

56 Curried { runCurried :: forall r. f (a -> r) -> f r }

src/Data/Generics/Product/Constraints.hsnew file+45

@@ -0,0 +1,45 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE ConstraintKinds #-}

3+{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE KindSignatures #-}

5+{-# LANGUAGE MultiParamTypeClasses #-}

6+{-# LANGUAGE Rank2Types #-}

7+{-# LANGUAGE ScopedTypeVariables #-}

8+{-# LANGUAGE TypeApplications #-}

9+{-# LANGUAGE UndecidableInstances #-}

10+

11+-----------------------------------------------------------------------------

12+-- |

13+-- Module : Data.Generics.Product.Constraints

15+-- License : BSD3

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

17+-- Stability : experimental

18+-- Portability : non-portable

19+--

20+-- Constrained traversals.

21+--

22+-----------------------------------------------------------------------------

23+

24+module Data.Generics.Product.Constraints

25+ ( -- *Traversals

26+ --

27+ -- $example

28+ HasConstraints (..)

29+ ) where

30+

31+import Data.Generics.Product.Internal.Types

32+import Data.Kind (Constraint)

33+

34+import GHC.Generics (Generic (Rep), from, to)

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

36+

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

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

39+

40+instance

41+ ( Generic s

42+ , GHasConstraints c (Rep s)

43+ ) => HasConstraints c s where

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

45+ {-# INLINE constraints #-}

src/Data/Generics/Product/Internal/Types.hs+75−34

@@ -1,13 +1,20 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE ConstraintKinds #-}

2−{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE FunctionalDependencies #-}

7+{-# LANGUAGE GADTs #-}

5−{-# LANGUAGE KindSignatures #-}

8+{-# LANGUAGE KindSignatures #-}

6−{-# LANGUAGE MultiParamTypeClasses #-}

9+{-# LANGUAGE MultiParamTypeClasses #-}

10+{-# LANGUAGE PolyKinds #-}

11+{-# LANGUAGE Rank2Types #-}

7−{-# LANGUAGE ScopedTypeVariables #-}

12+{-# LANGUAGE ScopedTypeVariables #-}

13+{-# LANGUAGE TypeApplications #-}

8−{-# LANGUAGE TypeFamilies #-}

14+{-# LANGUAGE TypeFamilies #-}

15+{-# LANGUAGE TypeFamilyDependencies #-}

9−{-# LANGUAGE TypeOperators #-}

16+{-# LANGUAGE TypeOperators #-}

10−{-# LANGUAGE UndecidableInstances #-}

17+{-# LANGUAGE UndecidableInstances #-}

12-----------------------------------------------------------------------------

19-----------------------------------------------------------------------------

13-- |

20-- |

@@ -23,37 +30,71 @@

23-----------------------------------------------------------------------------

30-----------------------------------------------------------------------------

25module Data.Generics.Product.Internal.Types

32module Data.Generics.Product.Internal.Types

26− ( GHasTypes (..)

33+ ( GHasTypes

34+ , GHasConstraints (..)

35+ , gtypes

36+ , HList (..)

27 ) where

37 ) where

29−import Data.Kind (Type)

39+import Data.Kind (Type, Constraint)

30import GHC.Generics

40import GHC.Generics

41+import Data.Generics.Internal.VL.Iso

32−-- |As 'HasTypes' but over generic representations as defined by

43+-- | Constrained traversal.

33−-- "GHC.Generics".

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

34−class GHasTypes (f :: Type -> Type) a where

45+ cgtypes :: forall g x.

35− gtypes :: forall g x. Applicative g => (a -> g a) -> f x -> g (f x)

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

37−instance (GHasTypes l a, GHasTypes r a) => GHasTypes (l :*: r) a where

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

38− gtypes f (l :*: r) = (:*:) <$> gtypes f l <*> gtypes f r

49+ cgtypes f (l :*: r) = (:*:) <$> cgtypes @c f l <*> cgtypes @c f r

39− {-# INLINE gtypes #-}

41−instance (GHasTypes l a, GHasTypes r a) => GHasTypes (l :+: r) a where

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

42− gtypes f (L1 l) = L1 <$> gtypes f l

52+ cgtypes f (L1 l) = L1 <$> cgtypes @c f l

43− gtypes f (R1 r) = R1 <$> gtypes f r

53+ cgtypes f (R1 r) = R1 <$> cgtypes @c f r

45−instance GHasTypes (K1 R a) a where

55+instance c a => GHasConstraints c (K1 R a) where

46− gtypes f (K1 x) = fmap K1 (f x)

56+ cgtypes = kIso

47− {-# INLINE gtypes #-}

49−instance {-# OVERLAPPABLE #-} GHasTypes (K1 R a) b where

58+instance GHasConstraints c f => GHasConstraints c (M1 m meta f) where

50− gtypes _ k = pure k

59+ cgtypes f (M1 x) = M1 <$> cgtypes @c f x

51− {-# INLINE gtypes #-}

53−instance GHasTypes f a => GHasTypes (M1 m meta f) a where

61+instance GHasConstraints c U1 where

54− gtypes f (M1 x) = M1 <$> gtypes f x

62+ cgtypes _ _ = pure U1

55− {-# INLINE gtypes #-}

57−instance GHasTypes U1 a where

64+--------------------------------------------------------------------------------

58− gtypes _ U1 = pure U1

65+

59− {-# INLINE gtypes #-}

66+-- | Multi-traversal

67+type GHasTypes rep as = GHasConstraints (Contains as) rep

68+

69+-- Try to use a function from the list, or default to 'pure' if not present

70+gtypes

71+ :: forall as x f g.

72+ ( GHasTypes f as

73+ , Applicative g

74+ ) => HList (Functions as g) -> f x -> g (f x)

75+gtypes hl s = cgtypes @(Contains as) (pick hl) s

76+

77+--------------------------------------------------------------------------------

78+

79+data HList (ts :: [Type]) where

80+ HNil :: HList '[]

81+ (:>) :: a -> HList as -> HList (a ': as)

82+infixr 5 :>

83+

84+-- >>> :kind! Functions '[Int, Char, Bool] Maybe

85+-- '[Int -> Maybe Int, Char -> Maybe Char, Bool -> Maybe Bool]

86+type family Functions (ts :: [Type]) (g :: Type -> Type) = r | r -> ts where

87+ Functions '[] _ = '[]

88+ Functions (t ': ts) g = ((t -> g t) ': Functions ts g)

89+

90+class Contains as a where

91+ pick :: Applicative g => HList (Functions as g) -> a -> g a

92+

93+instance {-# OVERLAPPING #-} Contains (a ': as) a where

94+ pick (h :> _) = h

95+

96+instance Contains as a => Contains (b ': as) a where

97+ pick (_ :> hs) = pick hs

98+

99+instance Contains '[] a where

100+ pick _ = pure

src/Data/Generics/Product/Types.hs+4−10

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

1−{-# LANGUAGE AllowAmbiguousTypes #-}

2{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleInstances #-}

2{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE MultiParamTypeClasses #-}

3{-# LANGUAGE MultiParamTypeClasses #-}

6−{-# LANGUAGE ScopedTypeVariables #-}

7−{-# LANGUAGE TypeFamilies #-}

8−{-# LANGUAGE TypeOperators #-}

9{-# LANGUAGE UndecidableInstances #-}

4{-# LANGUAGE UndecidableInstances #-}

11-----------------------------------------------------------------------------

6-----------------------------------------------------------------------------

@@ -30,17 +25,16 @@ module Data.Generics.Product.Types

31import Data.Generics.Product.Internal.Types

26import Data.Generics.Product.Internal.Types

33−import GHC.Generics (Generic (Rep), from, to)

28+import GHC.Generics (Generic (Rep))

34import Data.Generics.Internal.VL.Traversal

29import Data.Generics.Internal.VL.Traversal

30+import Data.Generics.Internal.VL.Iso

36class HasTypes a s where

32class HasTypes a s where

37 types :: Traversal' s a

33 types :: Traversal' s a

39instance

35instance

40 ( Generic s

36 ( Generic s

41− , GHasTypes (Rep s) a

37+ , GHasTypes (Rep s) '[a]

42 ) => HasTypes a s where

38 ) => HasTypes a s where

43−

44− types = confusing (\f s -> to <$> gtypes f (from s))

39+ types = confusing (\f -> (repIso . gtypes) (f :> HNil))

45 {-# INLINE types #-}

40 {-# INLINE types #-}

46−

test/Spec.hs+5−1

@@ -202,4 +202,8 @@ tests = TestList $ map mkHUnitTest

202 , $(inspectTest $ 'sum2PrismManual === 'sum2TypePrism)

203 , $(inspectTest $ 'sum1PrismManualChar === 'sum1TypePrismChar)

204 , $(inspectTest $ 'sum2PrismManualChar === 'sum2TypePrismChar)

205− , $(inspectTest $ 'sum1PrismManual === 'sum1TypePrism) ]

205+ , $(inspectTest $ 'sum1PrismManual === 'sum1TypePrism)

206+ , $(inspectTest $ 'intTraversalManual === 'intTraversalDerived)

207+ ]

208+

209+-- TODO: add test for traversals over multiple types