2b9efe8 · generic-lens

generic-lens.cabal+1

compare with master

unifiedsplit

@@ -33,6 +33,7 @@ library

33 , Data.Generics.Product.Types

34 , Data.Generics.Product.Constraints

35 , Data.Generics.Product.List

36+ , Data.Generics.Internal.GenericN

36

37

37 , Data.Generics.Sum

38 , Data.Generics.Sum

38 , Data.Generics.Sum.Any

39 , Data.Generics.Sum.Any

src/Data/Generics/Internal/GenericN.hsnew file+70

@@ -0,0 +1,70 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE InstanceSigs #-}

5+{-# LANGUAGE PolyKinds #-}

6+{-# LANGUAGE ScopedTypeVariables #-}

7+{-# LANGUAGE TypeFamilies #-}

8+{-# LANGUAGE TypeOperators #-}

9+{-# LANGUAGE UndecidableInstances #-}

10+

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

12+-- |

13+-- Module : Data.Generics.Internal.GenericN

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

16+-- License : BSD3

17+-- Stability : experimental

18+-- Portability : non-portable

19+--

20+-- Generic representation of types with multiple parameters

21+--

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

23+

24+module Data.Generics.Internal.GenericN

25+ ( Param

26+ , Rec (Rec, unRec)

27+ , GenericN (..)

28+ ) where

29+

30+import Data.Kind

31+import GHC.Generics

32+import GHC.TypeLits

33+import Data.Coerce

34+

35+type family Param :: Nat -> k where

36+

37+type family Indexed (t :: k) (i :: Nat) :: k where

38+ Indexed (t a) i = Indexed t (i + 1) (Param i)

39+ Indexed t _ = t

40+

41+newtype Rec (p :: Type) a x = Rec { unRec :: K1 R a x }

42+

43+type family Zip (a :: Type -> Type) (b :: Type -> Type) :: Type -> Type where

44+ Zip (M1 mt m s) (M1 mt m t)

45+ = M1 mt m (Zip s t)

46+ Zip (l :+: r) (l' :+: r')

47+ = Zip l l' :+: Zip r r'

48+ Zip (l :*: r) (l' :*: r')

49+ = Zip l l' :*: Zip r r'

50+ Zip (Rec0 p) (Rec0 a)

51+ = Rec p a

52+

53+class

54+ ( Coercible (Rep a) (RepN a)

55+ , Generic a

56+ ) => GenericN (a :: Type) where

57+ type family RepN (a :: Type) :: Type -> Type

58+ type instance RepN a = Zip (Rep (Indexed a 0)) (Rep a)

59+ toN :: RepN a x -> a

60+ fromN :: a -> RepN a x

61+

62+instance

63+ ( Coercible (Rep a) (RepN a)

64+ , Generic a

65+ ) => GenericN a where

66+ toN :: forall x. RepN a x -> a

67+ toN = coerce (to :: Rep a x -> a)

68+

69+ fromN :: forall x. a -> RepN a x

70+ fromN = coerce (from :: a -> Rep a x)

src/Data/Generics/Internal/Profunctor/Iso.hs+5

@@ -24,6 +24,7 @@ import Data.Profunctor (Profunctor(..))

24import Data.Profunctor.Unsafe ((#.), (.#))

25import GHC.Generics ((:*:)(..), (:+:)(..), Generic(..), M1(..), K1(..), Rep)

26import Data.Coerce

27+import Data.Generics.Internal.GenericN (Rec (..))

27

28

28type Iso s t a b

29type Iso s t a b

29 = forall p. (Profunctor p) => p a b -> p s t

30 = forall p. (Profunctor p) => p a b -> p s t

@@ -44,6 +45,10 @@ kIso :: Iso (K1 r a p) (K1 r b p) a b

44kIso = iso unK1 K1

45kIso = iso unK1 K1

45{-# INLINE kIso #-}

46{-# INLINE kIso #-}

46

47

48+recIso :: Iso (Rec r a p) (Rec r b p) a b

49+recIso = iso (unK1 . unRec) (Rec . K1)

50+{-# INLINE recIso #-}

51+

47sumIso :: Iso ((a :+: b) x) ((a' :+: b') x) (Either (a x) (b x)) (Either (a' x) (b' x))

52sumIso :: Iso ((a :+: b) x) ((a' :+: b') x) (Either (a x) (b x)) (Either (a' x) (b' x))

48sumIso = iso back forth

53sumIso = iso back forth

49 where forth (Left l) = L1 l

54 where forth (Left l) = L1 l

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

@@ -22,6 +22,7 @@ module Data.Generics.Internal.VL.Iso where

22

23import Data.Profunctor (Profunctor(..))

24import GHC.Generics

25+import Data.Generics.Internal.GenericN (Rec (..))

25

26

26type Iso' s a

27type Iso' s a

27 = forall p f. (Profunctor p, Functor f) => p a (f a) -> p s (f s)

28 = forall p f. (Profunctor p, Functor f) => p a (f a) -> p s (f s)

@@ -40,6 +41,9 @@ mIso = iso unM1 M1

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

41kIso :: Iso (K1 r a p) (K1 r b p) a b

41kIso = iso unK1 K1

42kIso = iso unK1 K1

42

43

44+recIso :: Iso (Rec r a p) (Rec r b p) a b

45+recIso = iso (unK1 . unRec) (Rec . K1)

46+

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

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

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

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

45

49

src/Data/Generics/Product/Internal/Param.hs+9−5

@@ -34,10 +34,11 @@ module Data.Generics.Product.Internal.Param

34 ) where

35

36import GHC.Generics

37+import GHC.TypeLits (Nat)

37import Data.Generics.Internal.VL.Iso

38import Data.Generics.Internal.VL.Iso

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

39+import Data.Generics.Internal.GenericN

39

40

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

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

41 gparam :: forall g x.

42 gparam :: forall g x.

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

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

43

44

@@ -48,10 +49,13 @@ instance (GHasParam p l l' a b, GHasParam p r r' a b) => GHasParam p (l :+: r) (

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

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

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

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

50

51

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+instance GHasParam p (Rec (param p) a) (Rec (param p) b) a b where

52− gparam = kIso

53+ gparam = recIso

53

54

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

55+instance {-# OVERLAPPABLE #-}

56+ ( a ~ b

57+ , p1 ~ p2

58+ ) => GHasParam p (Rec p1 a) (Rec p2 b) c d where

55 gparam _ = pure

59 gparam _ = pure

56

60

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

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

src/Data/Generics/Product/Param.hs+15−13

@@ -24,32 +24,34 @@

24--

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

26

27−module Data.Generics.Product.Param where

27+module Data.Generics.Product.Param

28+ ( Rec (Rec) -- TODO: this has to be re-exported so the constructor is visible for Coercible... is there a better way?

29+ , HasParam (..)

30+ ) where

28

31

29−import Unsafe.Coerce (unsafeCoerce)

30import GHC.TypeLits (Nat)

32import GHC.TypeLits (Nat)

31−import GHC.Generics

33+import Data.Generics.Internal.Void

34+import Data.Generics.Internal.GenericN

32import Data.Generics.Internal.Families.Changing

35import Data.Generics.Internal.Families.Changing

33import Data.Generics.Product.Internal.Param

36import Data.Generics.Product.Internal.Param

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

34

38

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

39class 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

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

37

41

38instance

42instance

39 ( p ~ NatToPeano n

43 ( p ~ NatToPeano n

40− , Generic s

44+ , GenericN s

41− , Generic s'

45+ , GenericN t

42− , Generic t'

46+ -- TODO: merge the old 'Changing' code with 'GenericN'

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

47 , '(a', b') ~ '(P p a 'PTag, P p b 'PTag)

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

45 , s ~ Infer t b' a

48 , s ~ Infer t b' a

46 , t ~ Infer s a' b

49 , t ~ Infer s a' b

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

50+ , GHasParam n (RepN s) (RepN t) a b

48 ) => HasParam n s t a b where

51 ) => HasParam n s t a b where

49

52

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

53+ param = confusing (\f s -> toN <$> gparam @n f (fromN s))

51− param f s

54+

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

55+instance {-# OVERLAPPING #-} HasParam p (Void1 a) (Void1 b) a b where

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

56+ param = undefined

54− lift = unsafeCoerce

55

57

test/Spec.hs+18−15

@@ -106,6 +106,9 @@ sum3Param1 = param @1

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

107sum3Param2 = param @2

108

109+sum3Param3 :: Traversal (Sum3 a b c) (Sum3 a b c) xxx yyy

110+sum3Param3 = param @3

111+

109sum1PrismManual :: Prism Sum1 Sum1 Int Int

112sum1PrismManual :: Prism Sum1 Sum1 Int Int

110sum1PrismManual eta = prism g f eta

113sum1PrismManual eta = prism g f eta

111 where

114 where

@@ -202,22 +205,22 @@ sum2TypePrismChar = _Typed @Char

202

205

203tests :: Test

206tests :: Test

204tests = TestList $ map mkHUnitTest

207tests = TestList $ map mkHUnitTest

205− [ $(inspectTest $ 'fieldALensManual === 'fieldALensName)

208+ [ $(inspectTest $ 'fieldALensManual === 'fieldALensName)

206− , $(inspectTest $ 'fieldALensManual === 'fieldALensType)

209+ , $(inspectTest $ 'fieldALensManual === 'fieldALensType)

207− , $(inspectTest $ 'fieldALensManual === 'fieldALensPos)

210+ , $(inspectTest $ 'fieldALensManual === 'fieldALensPos)

208− , $(inspectTest $ 'subtypeLensManual === 'subtypeLensGeneric)

211+ , $(inspectTest $ 'subtypeLensManual === 'subtypeLensGeneric)

209− , $(inspectTest $ 'typeChangingManual === 'typeChangingGeneric)

212+ , $(inspectTest $ 'typeChangingManual === 'typeChangingGeneric)

210− , $(inspectTest $ 'typeChangingManual === 'typeChangingGenericPos)

213+ , $(inspectTest $ 'typeChangingManual === 'typeChangingGenericPos)

211 , $(inspectTest $ 'typeChangingManualCompose === 'typeChangingGenericCompose)

214 , $(inspectTest $ 'typeChangingManualCompose === 'typeChangingGenericCompose)

212− , $(inspectTest $ 'intTraversalManual === 'intTraversalDerived)

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

213− , $(inspectTest $ 'sum1PrismManual === 'sum1PrismB)

216+ , $(inspectTest $ 'sum1PrismManual === 'sum1PrismB)

214− , $(inspectTest $ 'subtypePrismManual === 'subtypePrismGeneric)

217+ , $(inspectTest $ 'subtypePrismManual === 'subtypePrismGeneric)

215− , $(inspectTest $ 'sum2PrismManualChar === 'sum2TypePrismChar)

218+ , $(inspectTest $ 'sum2PrismManualChar === 'sum2TypePrismChar)

216− , $(inspectTest $ 'sum2PrismManual === 'sum2TypePrism)

219+ , $(inspectTest $ 'sum2PrismManual === 'sum2TypePrism)

217− , $(inspectTest $ 'sum1PrismManualChar === 'sum1TypePrismChar)

220+ , $(inspectTest $ 'sum1PrismManualChar === 'sum1TypePrismChar)

218− , $(inspectTest $ 'sum2PrismManualChar === 'sum2TypePrismChar)

221+ , $(inspectTest $ 'sum2PrismManualChar === 'sum2TypePrismChar)

219− , $(inspectTest $ 'sum1PrismManual === 'sum1TypePrism)

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

220− , $(inspectTest $ 'intTraversalManual === 'intTraversalDerived)

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

221 ]

224 ]

222

225

223-- TODO: add test for traversals over multiple types

226-- TODO: add test for traversals over multiple types