a31ae1e · generic-lens

generic-lens.cabal+2

compare with master

unifiedsplit

@@ -26,6 +26,7 @@ library

26 exposed-modules: Data.Generics.Product

27 , Data.Generics.Product.Any

28 , Data.Generics.Product.Fields

29+ , Data.Generics.Product.Param

29 , Data.Generics.Product.Positions

30 , Data.Generics.Product.Positions

30 , Data.Generics.Product.Subtype

31 , Data.Generics.Product.Subtype

31 , Data.Generics.Product.Typed

32 , Data.Generics.Product.Typed

@@ -60,6 +61,7 @@ library

60 , Data.Generics.Product.Internal.Subtype

61 , Data.Generics.Product.Internal.Subtype

61

62

62 , Data.Generics.Product.Internal.Types

63 , Data.Generics.Product.Internal.Types

64+ , Data.Generics.Product.Internal.Param

63 , Data.Generics.Product.Internal.List

65 , Data.Generics.Product.Internal.List

64 , Data.Generics.Product.Internal.Keyed

66 , Data.Generics.Product.Internal.Keyed

65

67

src/Data/Generics/Internal/Families/Changing.hs+11−20

@@ -11,10 +11,13 @@

11module Data.Generics.Internal.Families.Changing

12 ( Proxied

13 , Infer

14+ , PTag (..)

15+ , Peano (..)

16+ , NatToPeano

17+ , P

14 ) where

18 ) where

15

19

16−import GHC.TypeLits (TypeError, ErrorMessage (..))

20+import GHC.TypeLits (Nat, type (-), TypeError, ErrorMessage (..))

17−import Data.Type.Bool (If)

18

21

19{-

22{-

20 Note [Changing type parameters]

23 Note [Changing type parameters]

@@ -61,7 +64,8 @@ data Sub where

61 Sub :: Peano -> k -> Sub

64 Sub :: Peano -> k -> Sub

62

65

63type family Unify (a :: k) (b :: k) :: [Sub] where

66type family Unify (a :: k) (b :: k) :: [Sub] where

64− Unify (a b) a' = If (IsPTag b) '[HandleP (a b) a'] (HandleOther (a b) a')

67+ Unify (p n _ 'PTag) a' = '[ 'Sub n a']

68+ Unify (a x) (b y) = Unify x y ++ Unify a b

65 Unify a a = '[]

69 Unify a a = '[]

66 Unify a b = TypeError

70 Unify a b = TypeError

67 ( 'Text "Couldn't match type "

71 ( 'Text "Couldn't match type "

@@ -70,23 +74,6 @@ type family Unify (a :: k) (b :: k) :: [Sub] where

70 ':<>: 'ShowType b

74 ':<>: 'ShowType b

71 )

75 )

72

76

73−type family HandleP a b where

74− HandleP (p n _ 'PTag) a' = 'Sub n a'

75−

76−type family HandleOther a b where

77− HandleOther (a x) (b y) = Unify x y ++ Unify a b

78− HandleOther a a = '[]

79− HandleOther a b = TypeError

80− ( 'Text "Couldn't match type "

81− ':<>: 'ShowType a

82− ':<>: 'Text " with "

83− ':<>: 'ShowType b

84− )

85−

86−type family IsPTag (a :: k) :: Bool where

87− IsPTag 'PTag = 'True

88− IsPTag _ = 'False

89−

90type family (xs :: [k]) ++ (ys :: [k]) :: [k] where

77type family (xs :: [k]) ++ (ys :: [k]) :: [k] where

91 '[] ++ ys = ys

78 '[] ++ ys = ys

92 (x ': xs) ++ ys = x ': (xs ++ ys)

79 (x ': xs) ++ ys = x ': (xs ++ ys)

@@ -100,6 +87,10 @@ type family Infer (s :: *) (a' :: *) (b :: *) :: * where

100

87

101data Peano = Z | S Peano

88data Peano = Z | S Peano

102

89

90+type family NatToPeano (n :: Nat) :: Peano where

91+ NatToPeano 0 = 'Z

92+ NatToPeano n = 'S (NatToPeano (n - 1))

93+

103-- [TODO]: work this out

94-- [TODO]: work this out

104--

95--

105--type family ArgKind (t :: k) (pos :: Peano) :: * where

96--type family ArgKind (t :: k) (pos :: Peano) :: * where

src/Data/Generics/Product.hs+2

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

23 , module Data.Generics.Product.Subtype

24 , module Data.Generics.Product.Typed

25 , module Data.Generics.Product.Types

26+ , module Data.Generics.Product.Param

26 , module Data.Generics.Product.List

27 , module Data.Generics.Product.List

27 ) where

28 ) where

28

29

@@ -32,4 +33,5 @@ import Data.Generics.Product.Positions

32import Data.Generics.Product.Subtype

33import Data.Generics.Product.Subtype

33import Data.Generics.Product.Typed

34import Data.Generics.Product.Typed

34import Data.Generics.Product.Types

35import Data.Generics.Product.Types

36+import Data.Generics.Product.Param

35import Data.Generics.Product.List

37import Data.Generics.Product.List

src/Data/Generics/Product/Internal/Param.hsnew file+62

@@ -0,0 +1,62 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE ConstraintKinds #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE FunctionalDependencies #-}

7+{-# LANGUAGE GADTs #-}

8+{-# LANGUAGE MultiParamTypeClasses #-}

9+{-# LANGUAGE NoMonomorphismRestriction #-}

10+{-# LANGUAGE Rank2Types #-}

11+{-# LANGUAGE ScopedTypeVariables #-}

12+{-# LANGUAGE TypeApplications #-}

13+{-# LANGUAGE TypeFamilyDependencies #-}

14+{-# LANGUAGE TypeOperators #-}

15+{-# LANGUAGE UndecidableInstances #-}

16+

17+{-# LANGUAGE DeriveGeneric #-}

18+

19+-----------------------------------------------------------------------------

20+-- |

21+-- Module : Data.Generics.Product.Internal.Param

23+-- License : BSD3

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

25+-- Stability : experimental

26+-- Portability : non-portable

27+--

28+-- Derive traversals of a given type in a product.

29+--

30+-----------------------------------------------------------------------------

31+

32+module Data.Generics.Product.Internal.Param

33+ ( GHasParam (..)

34+ ) where

35+

36+import GHC.Generics

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

38+import Data.Generics.Internal.Families.Changing

39+

40+class GHasParam (p :: Peano) s t a b | p t a -> s, p s b -> t where

41+ gparam :: forall g x.

42+ Applicative g => (a -> g b) -> s x -> g (t x)

43+

44+instance (GHasParam p l l' a b, GHasParam p r r' a b) => GHasParam p (l :*: r) (l' :*: r') a b where

45+ gparam f (l :*: r) = (:*:) <$> gparam @p f l <*> gparam @p f r

46+

47+instance (GHasParam p l l' a b, GHasParam p r r' a b) => GHasParam p (l :+: r) (l' :+: r') a b where

48+ gparam f (L1 l) = L1 <$> gparam @p f l

49+ gparam f (R1 r) = R1 <$> gparam @p f r

50+

51+instance GHasParam p (K1 R (param p a 'PTag)) (K1 R (param p b 'PTag)) (param p a 'PTag) (param p b 'PTag) where

52+ gparam = kIso

53+

54+instance {-# OVERLAPPABLE #-} (a ~ b) => GHasParam p (K1 R a) (K1 R b) c d where

55+ gparam _ = pure

56+

57+instance GHasParam p s t a b => GHasParam p (M1 m meta s) (M1 m meta t) a b where

58+ gparam f (M1 x) = M1 <$> gparam @p f x

59+

60+instance GHasParam p U1 U1 a b where

61+ gparam _ _ = pure U1

62+

src/Data/Generics/Product/Internal/Types.hs+13−17

@@ -1,20 +1,16 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE ConstraintKinds #-}

2+{-# LANGUAGE ConstraintKinds #-}

3−{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE FunctionalDependencies #-}

6+{-# LANGUAGE FunctionalDependencies #-}

7−{-# LANGUAGE GADTs #-}

7+{-# LANGUAGE GADTs #-}

8−{-# LANGUAGE KindSignatures #-}

9−{-# LANGUAGE MultiParamTypeClasses #-}

10−{-# LANGUAGE PolyKinds #-}

11−{-# LANGUAGE Rank2Types #-}

8+{-# LANGUAGE Rank2Types #-}

12−{-# LANGUAGE ScopedTypeVariables #-}

9+{-# LANGUAGE ScopedTypeVariables #-}

13−{-# LANGUAGE TypeApplications #-}

10+{-# LANGUAGE TypeApplications #-}

14−{-# LANGUAGE TypeFamilies #-}

15−{-# LANGUAGE TypeFamilyDependencies #-}

11+{-# LANGUAGE TypeFamilyDependencies #-}

16−{-# LANGUAGE TypeOperators #-}

12+{-# LANGUAGE TypeOperators #-}

17−{-# LANGUAGE UndecidableInstances #-}

13+{-# LANGUAGE UndecidableInstances #-}

18

14

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

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

20-- |

16-- |

src/Data/Generics/Product/Param.hsnew file+55

@@ -0,0 +1,55 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE FunctionalDependencies #-}

6+{-# LANGUAGE GADTs #-}

7+{-# LANGUAGE KindSignatures #-}

8+{-# LANGUAGE ScopedTypeVariables #-}

9+{-# LANGUAGE TypeApplications #-}

10+{-# LANGUAGE UndecidableInstances #-}

11+

12+{-# LANGUAGE DeriveGeneric #-}

13+

14+--------------------------------------------------------------------------------

15+-- |

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

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

19+-- License : BSD3

20+-- Stability : experimental

21+-- Portability : non-portable

22+--

23+-- Derive traversal over type parameters

24+--

25+--------------------------------------------------------------------------------

26+

27+module Data.Generics.Product.Param where

28+

29+import Unsafe.Coerce (unsafeCoerce)

30+import GHC.TypeLits (Nat)

31+import GHC.Generics

32+import Data.Generics.Internal.Families.Changing

33+import Data.Generics.Product.Internal.Param

34+

35+class HasParam (p :: Nat) s t a b | p t a b -> s, p s a b -> t where

36+ param :: Applicative g => (a -> g b) -> s -> g t

37+

38+instance

39+ ( p ~ NatToPeano n

40+ , Generic s

41+ , Generic s'

42+ , Generic t'

43+ , '(a', b') ~ '(P p a 'PTag, P p b 'PTag)

44+ , '(s', t') ~ '(Proxied s, Proxied t)

45+ , s ~ Infer t b' a

46+ , t ~ Infer s a' b

47+ , GHasParam p (Rep s') (Rep t') a' b'

48+ ) => HasParam n s t a b where

49+

50+ -- TODO: I think unsafeCoerce is not necessary

51+ param f s

52+ = (unsafeCoerce @t' @t . to) <$> gparam @p (lift f) (from (unsafeCoerce @s @s' s))

53+ where lift :: (a -> g b) -> P p a 'PTag -> g (P p b 'PTag)

54+ lift = unsafeCoerce

55+

test/Spec.hs+16−2

@@ -63,8 +63,6 @@ data Record5 = MkRecord5

63 , fieldF :: Int

64 } deriving Generic

65

66−

67−

68typeChangingManual :: Lens (Record3 a) (Record3 b) a b

66typeChangingManual :: Lens (Record3 a) (Record3 b) a b

69typeChangingManual f (MkRecord3 a b) = (\a' -> MkRecord3 a' b) <$> f a

67typeChangingManual f (MkRecord3 a b) = (\a' -> MkRecord3 a' b) <$> f a

70

68

@@ -92,6 +90,22 @@ subtypeLensManual f record

92data Sum1 = A Char | B Int | C () | D () deriving (Generic, Show)

90data Sum1 = A Char | B Int | C () | D () deriving (Generic, Show)

93data Sum2 = A2 Char | B2 Int deriving (Generic, Show)

91data Sum2 = A2 Char | B2 Int deriving (Generic, Show)

94

92

93+data Sum3 a b c

94+ = A3 a a

95+ | B3 b a a b

96+ | C3 c a

97+ deriving Generic

98+

99+-- TODO: these compile, but aren't wired in to inspection-testing yet

100+sum3Param0 :: Traversal (Sum3 a b xxx) (Sum3 a b yyy) xxx yyy

101+sum3Param0 = param @0

102+

103+sum3Param1 :: Traversal (Sum3 a xxx c) (Sum3 a yyy c) xxx yyy

104+sum3Param1 = param @1

105+

106+sum3Param2 :: Traversal (Sum3 xxx b c) (Sum3 yyy b c) xxx yyy

107+sum3Param2 = param @2

108+

95sum1PrismManual :: Prism Sum1 Sum1 Int Int

109sum1PrismManual :: Prism Sum1 Sum1 Int Int

96sum1PrismManual eta = prism g f eta

110sum1PrismManual eta = prism g f eta

97 where

111 where