2b9efe8 · generic-lens

git.iko.soy/generic-lens

Add GenericN class

This allows us to remove 'unsafeCoerce' from 'HasParam'

commit2b9efe82f633ada893e9c0927ed88d81a6c7dbc1 authorCsongor Kiss <kiss.csongor.kiss@gmail.com> dateMon 5 Feb 2018, 11:49 (9 years ago) parenta31ae1e

7 files changed+122−33

compare with master

unifiedsplit

generic-lens.cabal+1 src/Data/Generics/Internal/GenericN.hs+70 src/Data/Generics/Internal/Profunctor/Iso.hs+5 src/Data/Generics/Internal/VL/Iso.hs+4 src/Data/Generics/Product/Internal/Param.hs+9−5 src/Data/Generics/Product/Param.hs+15−13 test/Spec.hs+18−15

generic-lens.cabal+1

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

3333 , Data.Generics.Product.Types

3434 , Data.Generics.Product.Constraints

3535 , Data.Generics.Product.List

36+ , Data.Generics.Internal.GenericN

3637

3738 , Data.Generics.Sum

3839 , 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(..))

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

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

2626import Data.Coerce

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

2728

2829type Iso s t a b

2930 = 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

4445kIso = iso unK1 K1

4546{-# INLINE kIso #-}

4647

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

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

50+{-# INLINE recIso #-}

51+

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

4853sumIso = iso back forth

4954 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

2222

2323import Data.Profunctor (Profunctor(..))

2424import GHC.Generics

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

2526

2627type Iso' s a

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

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

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

4142kIso = iso unK1 K1

4243

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

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

46+

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

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

4549

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

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

3434 ) where

3535

3636import GHC.Generics

37+import GHC.TypeLits (Nat)

3738import Data.Generics.Internal.VL.Iso

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

39+import Data.Generics.Internal.GenericN

3940

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

4142 gparam :: forall g x.

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

4344

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

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

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

5051

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

52+instance GHasParam p (Rec (param p) a) (Rec (param p) b) a b where

53+ gparam = recIso

5354

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

5559 gparam _ = pure

5660

5761instance 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 @@

2424--

2525--------------------------------------------------------------------------------

2626

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

2831

29−import Unsafe.Coerce (unsafeCoerce)

3032import GHC.TypeLits (Nat)

31−import GHC.Generics

33+import Data.Generics.Internal.Void

34+import Data.Generics.Internal.GenericN

3235import Data.Generics.Internal.Families.Changing

3336import Data.Generics.Product.Internal.Param

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

3438

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

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

3741

3842instance

3943 ( p ~ NatToPeano n

40− , Generic s

41− , Generic s'

42− , Generic t'

44+ , GenericN s

45+ , GenericN t

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

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

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

4548 , s ~ Infer t b' a

4649 , t ~ Infer s a' b

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

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

4851 ) => HasParam n s t a b where

4952

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

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

54+

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

56+ param = undefined

5557

test/Spec.hs+18−15

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

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

107107sum3Param2 = param @2

108108

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

110+sum3Param3 = param @3

111+

109112sum1PrismManual :: Prism Sum1 Sum1 Int Int

110113sum1PrismManual eta = prism g f eta

111114 where

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

202205

203206tests :: Test

204207tests = TestList $ map mkHUnitTest

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

221224 ]

222225

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