a31ae1e · generic-lens

git.iko.soy/generic-lens

Type-changing traversals over type parameters

commita31ae1eb836624b12e5af751418f30bf0fa792ed authorCsongor Kiss <kiss.csongor.kiss@gmail.com> dateMon 5 Feb 2018, 07:51 (9 years ago) parent95d451a

7 files changed+161−39

compare with master

unifiedsplit

generic-lens.cabal+2 src/Data/Generics/Internal/Families/Changing.hs+11−20 src/Data/Generics/Product.hs+2 src/Data/Generics/Product/Internal/Param.hs+62 src/Data/Generics/Product/Internal/Types.hs+13−17 src/Data/Generics/Product/Param.hs+55 test/Spec.hs+16−2

generic-lens.cabal+2

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

2626 exposed-modules: Data.Generics.Product

2727 , Data.Generics.Product.Any

2828 , Data.Generics.Product.Fields

29+ , Data.Generics.Product.Param

2930 , Data.Generics.Product.Positions

3031 , Data.Generics.Product.Subtype

3132 , Data.Generics.Product.Typed

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

6061 , Data.Generics.Product.Internal.Subtype

6162

6263 , Data.Generics.Product.Internal.Types

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

6365 , Data.Generics.Product.Internal.List

6466 , Data.Generics.Product.Internal.Keyed

6567

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

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

1111module Data.Generics.Internal.Families.Changing

1212 ( Proxied

1313 , Infer

14+ , PTag (..)

15+ , Peano (..)

16+ , NatToPeano

17+ , P

1418 ) where

1519

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

17−import Data.Type.Bool (If)

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

1821

1922{-

2023 Note [Changing type parameters]

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

6164 Sub :: Peano -> k -> Sub

6265

6366type 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

6569 Unify a a = '[]

6670 Unify a b = TypeError

6771 ( 'Text "Couldn't match type "

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

7074 ':<>: 'ShowType b

7175 )

7276

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−

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

9178 '[] ++ ys = ys

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

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

10087

10188data Peano = Z | S Peano

10289

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

91+ NatToPeano 0 = 'Z

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

93+

10394-- [TODO]: work this out

10495--

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

src/Data/Generics/Product.hs+2

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

2323 , module Data.Generics.Product.Subtype

2424 , module Data.Generics.Product.Typed

2525 , module Data.Generics.Product.Types

26+ , module Data.Generics.Product.Param

2627 , module Data.Generics.Product.List

2728 ) where

2829

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

3233import Data.Generics.Product.Subtype

3334import Data.Generics.Product.Typed

3435import Data.Generics.Product.Types

36+import Data.Generics.Product.Param

3537import 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 #-}

2−{-# LANGUAGE ConstraintKinds #-}

3−{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE FunctionalDependencies #-}

7−{-# LANGUAGE GADTs #-}

8−{-# LANGUAGE KindSignatures #-}

9−{-# LANGUAGE MultiParamTypeClasses #-}

10−{-# LANGUAGE PolyKinds #-}

11−{-# LANGUAGE Rank2Types #-}

12−{-# LANGUAGE ScopedTypeVariables #-}

13−{-# LANGUAGE TypeApplications #-}

14−{-# LANGUAGE TypeFamilies #-}

15−{-# LANGUAGE TypeFamilyDependencies #-}

16−{-# LANGUAGE TypeOperators #-}

17−{-# LANGUAGE UndecidableInstances #-}

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE ConstraintKinds #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE FunctionalDependencies #-}

7+{-# LANGUAGE GADTs #-}

8+{-# LANGUAGE Rank2Types #-}

9+{-# LANGUAGE ScopedTypeVariables #-}

10+{-# LANGUAGE TypeApplications #-}

11+{-# LANGUAGE TypeFamilyDependencies #-}

12+{-# LANGUAGE TypeOperators #-}

13+{-# LANGUAGE UndecidableInstances #-}

1814

1915-----------------------------------------------------------------------------

2016-- |

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

6363 , fieldF :: Int

6464 } deriving Generic

6565

66−

67−

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

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

7068

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

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

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

9492

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+

95109sum1PrismManual :: Prism Sum1 Sum1 Int Int

96110sum1PrismManual eta = prism g f eta

97111 where