437ac4c · generic-lens

git.iko.soy/generic-lens

on master help sign in

Merge

437ac4cCsongor Kiss9 years ago

.travis.yml+3

compare with master

unifiedsplit

@@ -32,6 +32,9 @@ matrix:

32 - compiler: "ghc-8.2.1"

33 # env: TEST=--disable-tests BENCH=--disable-benchmarks

34 addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.1], sources: [hvr-ghc]}}

35+ - compiler: "ghc-8.2.2"

36+ # env: TEST=--disable-tests BENCH=--disable-benchmarks

37+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.2], sources: [hvr-ghc]}}

36before_install:

39before_install:

37 - HC=${CC}

40 - HC=${CC}

ChangeLog.md+3−1

@@ -1,5 +1,7 @@

1## 0.5.1.0

2−- Add `IsLabel` orhpan instance in `Data.Generics.Labels`

2+- Infer input type from result type (#25)

3+- Allow changing of multiple type parameters (#24)

4+- Allow changing of type parameters that have kinds other than `*` (#23)

3- Fix error message in subtype lens

5- Fix error message in subtype lens

5## 0.5.0.0

7## 0.5.0.0

examples/Examples.hs+29−14

@@ -1,17 +1,18 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE DeriveGeneric #-}

4−{-# LANGUAGE DuplicateRecordFields #-}

4+{-# LANGUAGE DuplicateRecordFields #-}

5−{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleContexts #-}

6−{-# LANGUAGE GADTs #-}

6+{-# LANGUAGE GADTs #-}

7−{-# LANGUAGE NoMonomorphismRestriction #-}

7+{-# LANGUAGE NoMonomorphismRestriction #-}

8+{-# LANGUAGE OverloadedLabels #-}

8−{-# LANGUAGE PartialTypeSignatures #-}

9+{-# LANGUAGE PartialTypeSignatures #-}

9−{-# LANGUAGE Rank2Types #-}

10+{-# LANGUAGE Rank2Types #-}

10−{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE ScopedTypeVariables #-}

11−{-# LANGUAGE TypeApplications #-}

12+{-# LANGUAGE TypeApplications #-}

12−{-# LANGUAGE UndecidableInstances #-}

13+{-# LANGUAGE UndecidableInstances #-}

13−{-# OPTIONS_GHC -Wno-missing-signatures #-}

14+{-# OPTIONS_GHC -Wno-missing-signatures #-}

14−{-# OPTIONS_GHC -fno-warn-unused-imports #-}

15+{-# OPTIONS_GHC -fno-warn-unused-imports #-}

16module Examples where

17module Examples where

@@ -110,3 +111,17 @@ stuff' ::

110 , HasField "bar" a' b' s t

111 , HasField "bar" a' b' s t

111 ) => s' -> t'

112 ) => s' -> t'

112stuff' r = r & #test . #bar . position @15 .~ "hello"

113stuff' r = r & #test . #bar . position @15 .~ "hello"

114+

115+data Foo m s = Foo

116+ { foo1 :: m s

117+ , foo2 :: [s]

118+ } deriving Generic

119+

120+modifyFoo2 :: Foo (Either String) Int -> Foo Maybe Int

121+modifyFoo2 x = x & field @"foo1" .~ pure (1 :: Int)

122+

123+data Bar a b = Bar

124+ { barField :: (a, b)

125+ } deriving Generic

126+

127+modifiedBar = (Bar ("hello", "world")) & field @"barField" .~ ('c', 1 :: Int)

generic-lens.cabal+33−9

@@ -18,6 +18,10 @@ extra-source-files: ChangeLog.md

18 , examples/Examples.hs

19 , README.md

21+flag dump-core

22+ description: Dump HTML for the core generated by GHC during compilation

23+ default: False

24+

21library

25library

22 exposed-modules: Data.Generics.Product

26 exposed-modules: Data.Generics.Product

23 , Data.Generics.Product.Any

27 , Data.Generics.Product.Any

@@ -25,8 +29,8 @@ library

25 , Data.Generics.Product.Positions

29 , Data.Generics.Product.Positions

26 , Data.Generics.Product.Subtype

30 , Data.Generics.Product.Subtype

27 , Data.Generics.Product.Typed

31 , Data.Generics.Product.Typed

28− , Data.Generics.Labels

29 , Data.Generics.Product.Types

32 , Data.Generics.Product.Types

33+ , Data.Generics.Product.List

31 , Data.Generics.Sum

35 , Data.Generics.Sum

32 , Data.Generics.Sum.Any

36 , Data.Generics.Sum.Any

@@ -39,18 +43,18 @@ library

39 , Data.Generics.Internal.Families.Changing

43 , Data.Generics.Internal.Families.Changing

40 , Data.Generics.Internal.Families.Collect

44 , Data.Generics.Internal.Families.Collect

41 , Data.Generics.Internal.Families.Has

45 , Data.Generics.Internal.Families.Has

42− , Data.Generics.Internal.HList

43 , Data.Generics.Internal.Void

46 , Data.Generics.Internal.Void

45 , Data.Generics.Sum.Internal.Constructors

48 , Data.Generics.Sum.Internal.Constructors

46 , Data.Generics.Sum.Internal.Typed

49 , Data.Generics.Sum.Internal.Typed

47 , Data.Generics.Sum.Internal.Subtype

50 , Data.Generics.Sum.Internal.Subtype

49− , Data.Generics.Product.Internal.Fields

50 , Data.Generics.Product.Internal.Positions

52 , Data.Generics.Product.Internal.Positions

51 , Data.Generics.Product.Internal.Subtype

53 , Data.Generics.Product.Internal.Subtype

52− , Data.Generics.Product.Internal.Typed

54+

53 , Data.Generics.Product.Internal.Types

55 , Data.Generics.Product.Internal.Types

56+ , Data.Generics.Product.Internal.List

57+ , Data.Generics.Product.Internal.Keyed

55 build-depends: base >= 4.9 && <= 5.0

59 build-depends: base >= 4.9 && <= 5.0

56 , profunctors >= 5.0 && <= 6.0

60 , profunctors >= 5.0 && <= 6.0

@@ -58,15 +62,11 @@ library

59 hs-source-dirs: src

63 hs-source-dirs: src

60 default-language: Haskell2010

64 default-language: Haskell2010

61− ghc-options: -Wall -fsimpl-tick-factor=0 -ddump-simpl-stats -ddump-to-file

65+ ghc-options: -Wall

62 if flag(dump-core)

66 if flag(dump-core)

63 build-depends: dump-core

67 build-depends: dump-core

64 ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html

68 ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html

66−flag dump-core

67− description: Dump HTML for the core generated by GHC during compilation

68− default: False

69−

70source-repository head

71 type: git

72 location: https://github.com/kcsongor/generic-lens

@@ -89,6 +89,30 @@ test-suite generic-lens-test

89 build-depends: dump-core

90 ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html

92+test-suite generic-lens-test-25

93+ type: exitcode-stdio-1.0

94+ hs-source-dirs: test

95+ main-is: 25.hs

96+

97+ build-depends: base >= 4.9 && <= 5.0

98+ , generic-lens

99+ , lens

100+

101+ default-language: Haskell2010

102+ ghc-options: -Wall

103+

104+test-suite generic-lens-test-24

105+ type: exitcode-stdio-1.0

106+ hs-source-dirs: test

107+ main-is: 24.hs

108+

109+ build-depends: base >= 4.9 && <= 5.0

110+ , generic-lens

111+ , lens

112+

113+ default-language: Haskell2010

114+ ghc-options: -Wall

115+

92test-suite doctests

116test-suite doctests

93 default-language: Haskell2010

117 default-language: Haskell2010

94 type: exitcode-stdio-1.0

118 type: exitcode-stdio-1.0

src/Data/Generics/Internal/Families/Changing.hs+89−48

@@ -2,14 +2,18 @@

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FunctionalDependencies #-}

5+{-# LANGUAGE GADTs #-}

5{-# LANGUAGE PolyKinds #-}

6{-# LANGUAGE PolyKinds #-}

6{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE TypeOperators #-}

8{-# LANGUAGE TypeOperators #-}

8{-# LANGUAGE UndecidableInstances #-}

9{-# LANGUAGE UndecidableInstances #-}

10−module Data.Generics.Internal.Families.Changing where

11+module Data.Generics.Internal.Families.Changing

12+ ( Proxied

13+ , Infer

14+ ) where

12−import GHC.TypeLits (Nat, type (+))

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

14{-

18{-

15 Note [Changing type parameters]

19 Note [Changing type parameters]

@@ -35,53 +39,90 @@ import GHC.TypeLits (Nat, type (+))

35 If after doing the conversion on @s@, @field@'s type is @(P _ a), then @t@ is

39 If after doing the conversion on @s@, @field@'s type is @(P _ a), then @t@ is

36 @s[b/a]@, otherwise @t ~ s@ and @b ~ a@.

40 @s[b/a]@, otherwise @t ~ s@ and @b ~ a@.

37-}

41-}

38−data P (i :: Nat) a

40−type Proxied t = Proxied' t 0

43+-- `P` can be used in place of any type parameter, which means that it can have

44+-- any kind, not just *, so a data type won't work.

45+-- (this caused https://github.com/kcsongor/generic-lens/issues/23)

46+-- Instead, we use a matchable type family to wrap any `k` - however, we can no longer directly

47+-- pattern match on `P`, as it's not a type constructor. But we can still take it apart as a polymorphic

48+-- application form. In order to distinguish between applications of P and other type constructors, we use a tag, `PTag`

49+-- to fake a type constructor.

50+data PTag = PTag

51+type family P :: Peano -> k -> PTag -> k

53+type Proxied t = Proxied' t 'Z

54+

42−type family Proxied' (t :: k) (next :: Nat) :: k where

55+type family Proxied' (t :: k) (next :: Peano) :: k where

43− Proxied' (t a :: k) next = (Proxied' t (next + 1)) (P next a)

56+ Proxied' (t (a :: j) :: k) next = (Proxied' t ('S next)) (P next a 'PTag)

44 Proxied' t _ = t

57 Proxied' t _ = t

59+data Sub where

60+ Sub :: Peano -> k -> Sub

61+

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

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

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

65+ Unify a a = '[]

66+ Unify a b = TypeError

67+ ( 'Text "Couldn't match type "

68+ ':<>: 'ShowType a

69+ ':<>: 'Text " with "

70+ ':<>: 'ShowType b

71+ )

72+

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

74+ '[] ++ ys = ys

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

76+

77+type family Infer (s :: *) (a' :: *) (b :: *) :: * where

78+ Infer (s a) a' b

79+ = ReplaceArgs (s a) (Unify a' b)

80+ Infer s _ _ = s

81+

82+--------------------------------------------------------------------------------

83+

84+data Peano = Z | S Peano

85+

86+-- [TODO]: work this out

87+--

46−type family UnProxied (t :: k) :: k where

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

47− UnProxied (P _ a) = a

89+-- ArgKind (t (a :: k)) 'Z = k

48− UnProxied (t (P _ a) :: k) = UnProxied t a

90+-- ArgKind (t _) ('S pos) = ArgKind t pos

49− UnProxied t = t

91+--

50−

92+--type family ReplaceArg (t :: k) (pos :: Peano) (to :: ArgKind t pos) :: k where

93+-- ReplaceArg (t a) 'Z to = t to

94+-- ReplaceArg (t a) ('S pos) to = ReplaceArg t pos to a

95+-- ReplaceArg t _ _ = t

96+

51−type family Change (t :: k) (target :: Nat) (to :: j) :: k where

97+type family ReplaceArg (t :: k) (pos :: Peano) (to :: j) :: k where

52− Change (P target _) target to = (P target to)

98+ ReplaceArg (t a) 'Z to = t to

53− Change (t (P target _) :: k) target to = t (P target to)

99+ ReplaceArg (t a) ('S pos) to = ReplaceArg t pos to a

54− Change (t a :: k) target to = Change t target to a

100+ ReplaceArg t _ _ = t

55− Change t _ _ = t

101+

56−

102+type family ReplaceArgs (t :: k) (subs :: [Sub]) :: k where

57−type family UnApply (a :: k) :: [*] where

103+ ReplaceArgs t '[] = t

58− UnApply (f x) = x ': UnApply f

104+ ReplaceArgs t ('Sub n arg ': ss) = ReplaceArgs (ReplaceArg t n arg) ss

59− UnApply x = '[]

105+

60−

106+-- Note [CPP in instance constraints]

61−type family Unify a b :: [(*, *)] where

107+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

62− Unify (P n a') a = '[ '(P n a', a)]

108+--

63− Unify a b = Zip (UnApply a) (UnApply b)

109+-- In GHC 8.0.2, the calculated size of the expressions is too large for the

64−

110+-- inliner to consider them under the default -funfolding-use-threshold value

65−type family PSub (subs :: [(*, *)]) :: [(Nat, *)] where

111+-- (60).

66− PSub '[] = '[]

112+--

67− PSub ('(P n _, b) ': xs) = '(n, b) ': PSub xs

113+-- To reduce the size, the constraints

68− PSub (_ ': xs) = PSub xs

114+--

69−

115+-- ```

70−type family Zip (xs :: [k]) (ys :: [l]) :: [(k, l)] where

116+-- s' ~ Proxied s

71− Zip '[] '[] = '[]

117+-- t' ~ Proxied t

72− Zip (x ': xs) (y ': ys) = '(x, y) ': Zip xs ys

118+-- ```

73−

119+--

74−type family Infer (s :: *) (a' :: *) (a :: *) (w :: *) :: (*, *) where

120+-- are written as the following single equality:

75− Infer s' a' a w

121+--

76− = Infer' s' a' (PSub (Unify a' a)) w

122+-- ```

77−

123+-- '(s', t') ~ '(Proxied s, Proxied t)

78−type family Infer' (s :: *) (a' :: *) (subs :: [(Nat, k)]) w :: (*, *) where

124+-- ```

79− Infer' s' a' '[ '(p, _)] w

125+--

80− = '(UnProxied (Change s' p w), UnProxied (Change a' p w))

126+-- However, for some reason, this violates the functional dependencies on 8.2.2.

81− Infer' s' a' _ _

127+-- Therefore, when using a newer version of the compiler, the original constraints

82− = '(UnProxied s', UnProxied a')

128+-- are used, as the expression size is smaller under 8.2.2.

83−

84−type family PickTv (a :: k) (b :: k) :: * where

85− PickTv (P _ _) b = b

86− PickTv (f (P _ _)) (g b) = b

87− PickTv (f a) (g b) = PickTv f g

src/Data/Generics/Internal/Families/Collect.hs+3−2

@@ -28,7 +28,8 @@ import Data.Type.Equality (type (==))

28import GHC.Generics

29import GHC.TypeLits (Symbol, CmpSymbol)

31−import Data.Generics.Internal.HList

31+import Data.Generics.Product.Internal.List (type (++))

32+import Data.Generics.Internal.Families.Has (GTypes)

33data TypeStat

34data TypeStat

34 = TypeStat

35 = TypeStat

@@ -83,7 +84,7 @@ type family CollectPartialType t f :: [Symbol] where

83 CollectPartialType t (l :+: r)

84 CollectPartialType t (l :+: r)

84 = CollectPartialType t l ++ CollectPartialType t r

85 = CollectPartialType t l ++ CollectPartialType t r

85 CollectPartialType t (C1 ('MetaCons ctor _ _) f)

86 CollectPartialType t (C1 ('MetaCons ctor _ _) f)

86− = If (t == ListToTuple (GCollect f)) '[ctor] '[]

87+ = If (t == GTypes f) '[ctor] '[]

87 CollectPartialType t (D1 _ f)

88 CollectPartialType t (D1 _ f)

88 = CollectPartialType t f

89 = CollectPartialType t f

src/Data/Generics/Internal/Families/Has.hs+19−8

@@ -17,8 +17,9 @@

17module Data.Generics.Internal.Families.Has

18 ( HasTotalFieldP

19 , HasTotalTypeP

20− , HasPartialTypeTupleP

20+ , HasPartialTypeP

21 , HasCtorP

22+ , GTypes

22 ) where

23 ) where

24import Data.Type.Bool (type (||), type (&&))

25import Data.Type.Bool (type (||), type (&&))

@@ -26,7 +27,7 @@ import Data.Type.Equality (type (==))

26import GHC.Generics

27import GHC.Generics

27import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))

28import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))

29−import Data.Generics.Internal.HList

30+import Data.Generics.Product.Internal.List

31type family HasTotalFieldP (field :: Symbol) f :: Bool where

32type family HasTotalFieldP (field :: Symbol) f :: Bool where

32 HasTotalFieldP field (S1 ('MetaSel ('Just field) _ _ _) _)

33 HasTotalFieldP field (S1 ('MetaSel ('Just field) _ _ _) _)

@@ -78,12 +79,12 @@ type family HasTotalTypeP a f :: Bool where

78 ':<>: 'Text " is not a valid GHC.Generics representation type"

79 ':<>: 'Text " is not a valid GHC.Generics representation type"

79 )

80 )

81−type family HasPartialTypeTupleP a f :: Bool where

82+type family HasPartialTypeP a f :: Bool where

82− HasPartialTypeTupleP t (l :+: r)

83+ HasPartialTypeP t (l :+: r)

83− = HasPartialTypeTupleP t l || HasPartialTypeTupleP t r

84+ = HasPartialTypeP t l || HasPartialTypeP t r

84− HasPartialTypeTupleP t (C1 m f)

85+ HasPartialTypeP t (C1 m f)

85− = t == ListToTuple (GCollect f)

86+ = t == GTypes f

86− HasPartialTypeTupleP t _

87+ HasPartialTypeP t _

87 = 'False

88 = 'False

89type family HasCtorP (ctor :: Symbol) f :: Bool where

90type family HasCtorP (ctor :: Symbol) f :: Bool where

@@ -95,3 +96,13 @@ type family HasCtorP (ctor :: Symbol) f :: Bool where

95 = HasCtorP ctor f

96 = HasCtorP ctor f

96 HasCtorP ctor _

97 HasCtorP ctor _

97 = 'False

98 = 'False

99+

100+type family GTypes (rep :: * -> *) :: [((), *)] where

101+ GTypes (l :*: r)

102+ = GTypes l ++ GTypes r

103+ GTypes (Rec0 a)

104+ = '[ '( '(), a)]

105+ GTypes (M1 _ m a)

106+ = GTypes a

107+ GTypes U1 = '[]

108+

src/Data/Generics/Internal/HList.hsdeleted−239

@@ -1,239 +0,0 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE FlexibleInstances #-}

3−{-# LANGUAGE FunctionalDependencies #-}

4−{-# LANGUAGE GADTs #-}

5−{-# LANGUAGE KindSignatures #-}

6−{-# LANGUAGE MultiParamTypeClasses #-}

7−{-# LANGUAGE PolyKinds #-}

8−{-# LANGUAGE ScopedTypeVariables #-}

9−{-# LANGUAGE TypeFamilies #-}

10−{-# LANGUAGE TypeOperators #-}

11−{-# LANGUAGE UndecidableInstances #-}

12−

13−-----------------------------------------------------------------------------

14−-- |

15−-- Module : Data.Generics.Internal.HList

17−-- License : BSD3

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

19−-- Stability : experimental

20−-- Portability : non-portable

21−--

22−-----------------------------------------------------------------------------

23−module Data.Generics.Internal.HList

24− ( type (++)

25−

26− , ListTuple (..)

27−

28− , GCollectible (..)

29− ) where

30−

31−import Data.Kind (Type)

32−import GHC.Generics

33−

34−data HList (xs :: [Type]) where

35− Nil :: HList '[]

36− (:>) :: x -> HList xs -> HList (x ': xs)

37−

38−infixr 5 :>

39−

40−type family ((as :: [k]) ++ (bs :: [k])) :: [k] where

41− '[] ++ bs = bs

42− (a ': as) ++ bs = a ': as ++ bs

43−

44−append :: HList as -> HList bs -> HList (as ++ bs)

45−append Nil ys = ys

46−append (x :> xs) ys = x :> append xs ys

47−

48−head' :: HList (a ': as) -> a

49−head' (x :> _) = x

50−

51−--------------------------------------------------------------------------------

52−-- * Split HList

53−

54−class Splittable (as :: [Type]) (bs :: [Type]) (cs :: [Type]) | as bs -> cs, as cs -> bs where

55− split :: HList cs -> (HList as, HList bs)

56−

57−instance Splittable '[] bs bs where

58− split bs = (Nil, bs)

59−

60−instance Splittable as bs cs => Splittable (a ': as) bs (a ': cs) where

61− split (a :> as)

62− = (a :> as', bs)

63− where (as', bs) = split as

64−

65−--------------------------------------------------------------------------------

66−-- * Convert tuples to/from HLists

67−

68−class ListTuple (tuple :: Type) (as :: [Type]) | as -> tuple where

69− type ListToTuple as :: Type

70− tupleToList :: tuple -> HList as

71− listToTuple :: HList as -> tuple

72−

73−instance ListTuple () '[] where

74− type ListToTuple '[] = ()

75− tupleToList _ = Nil

76− listToTuple _ = ()

77−

78−instance ListTuple a '[a] where

79− type ListToTuple '[a] = a

80− tupleToList a

81− = a :> Nil

82− listToTuple (a :> Nil)

83− = a

84−

85−instance ListTuple (a, b) '[a, b] where

86− type ListToTuple '[a, b] = (a, b)

87− tupleToList (a, b)

88− = a :> b :> Nil

89− listToTuple (a :> b :> Nil)

90− = (a, b)

91−

92−instance ListTuple (a, b, c) '[a, b, c] where

93− type ListToTuple '[a, b, c] = (a, b, c)

94− tupleToList (a, b, c)

95− = a :> b :> c :> Nil

96− listToTuple (a :> b :> c :> Nil)

97− = (a, b, c)

98−

99−instance ListTuple (a, b, c, d) '[a, b, c, d] where

100− type ListToTuple '[a, b, c, d] = (a, b, c, d)

101− tupleToList (a, b, c, d)

102− = a :> b :> c :> d:> Nil

103− listToTuple (a :> b :> c :> d :> Nil)

104− = (a, b, c, d)

105−

106−instance ListTuple (a, b, c, d, e) '[a, b, c, d, e] where

107− type ListToTuple '[a, b, c, d, e] = (a, b, c, d, e)

108− tupleToList (a, b, c, d, e)

109− = a :> b :> c :> d:> e :> Nil

110− listToTuple (a :> b :> c :> d :> e :> Nil)

111− = (a, b, c, d, e)

112−

113−instance ListTuple (a, b, c, d, e, f) '[a, b, c, d, e, f] where

114− type ListToTuple '[a, b, c, d, e, f] = (a, b, c, d, e, f)

115− tupleToList (a, b, c, d, e, f)

116− = a :> b :> c :> d:> e :> f :> Nil

117− listToTuple (a :> b :> c :> d :> e :> f :> Nil)

118− = (a, b, c, d, e, f)

119−

120−instance ListTuple (a, b, c, d, e, f, g) '[a, b, c, d, e, f, g] where

121− type ListToTuple '[a, b, c, d, e, f, g] = (a, b, c, d, e, f, g)

122− tupleToList (a, b, c, d, e, f, g)

123− = a :> b :> c :> d:> e :> f :> g :> Nil

124− listToTuple (a :> b :> c :> d :> e :> f :> g :> Nil)

125− = (a, b, c, d, e, f, g)

126−

127−instance ListTuple (a, b, c, d, e, f, g, h) '[a, b, c, d, e, f, g, h] where

128− type ListToTuple '[a, b, c, d, e, f, g, h] = (a, b, c, d, e, f, g, h)

129− tupleToList (a, b, c, d, e, f, g, h)

130− = a :> b :> c :> d:> e :> f :> g :> h :> Nil

131− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> Nil)

132− = (a, b, c, d, e, f, g, h)

133−

134−instance ListTuple (a, b, c, d, e, f, g, h, j) '[a, b, c, d, e, f, g, h, j] where

135− type ListToTuple '[a, b, c, d, e, f, g, h, j] = (a, b, c, d, e, f, g, h, j)

136− tupleToList (a, b, c, d, e, f, g, h, j)

137− = a :> b :> c :> d:> e :> f :> g :> h :> j :> Nil

138− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> Nil)

139− = (a, b, c, d, e, f, g, h, j)

140−

141−instance ListTuple (a, b, c, d, e, f, g, h, j, k) '[a, b, c, d, e, f, g, h, j, k] where

142− type ListToTuple '[a, b, c, d, e, f, g, h, j, k] = (a, b, c, d, e, f, g, h, j, k)

143− tupleToList (a, b, c, d, e, f, g, h, j, k)

144− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> Nil

145− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> Nil)

146− = (a, b, c, d, e, f, g, h, j, k)

147−

148−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l) '[a, b, c, d, e, f, g, h, j, k, l] where

149− type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l] = (a, b, c, d, e, f, g, h, j, k, l)

150− tupleToList (a, b, c, d, e, f, g, h, j, k, l)

151− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> Nil

152− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> Nil)

153− = (a, b, c, d, e, f, g, h, j, k, l)

154−

155−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m) '[a, b, c, d, e, f, g, h, j, k, l, m] where

156− type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m] = (a, b, c, d, e, f, g, h, j, k, l, m)

157− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m)

158− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> Nil

159− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> Nil)

160− = (a, b, c, d, e, f, g, h, j, k, l, m)

161−

162−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n) '[a, b, c, d, e, f, g, h, j, k, l, m, n] where

163− type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n] = (a, b, c, d, e, f, g, h, j, k, l, m, n)

164− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n)

165− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil

166− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil)

167− = (a, b, c, d, e, f, g, h, j, k, l, m, n)

168−

169−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o] where

170− type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o)

171− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o)

172− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil

173− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil)

174− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o)

175−

176−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p] where

177− type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)

178− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)

179− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil

180− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil)

181− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)

182−

183−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q] where

184− type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)

185− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)

186− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil

187− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil)

188− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)

189−

190−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r] where

191− type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)

192− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)

193− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil

194− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil)

195− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)

196−

197−instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s] where

198− type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)

199− tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)

200− = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil

201− listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil)

202− = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)

203−

204−--------------------------------------------------------------------------------

205−

206−class GCollectible (f :: Type -> Type) (as :: [Type]) | f -> as where

207− type GCollect f :: [Type]

208− gtoCollection :: f x -> HList as

209− gfromCollection :: HList as -> f x

210−

211−instance

212− ( GCollectible l as

213− , GCollectible r bs

214− , cs ~ (as ++ bs)

215− , Splittable as bs cs

216− ) => GCollectible (l :*: r) cs where

217− type GCollect (l :*: r) = GCollect l ++ GCollect r

218−

219− gtoCollection (l :*: r)

220− = gtoCollection l `append` gtoCollection r

221−

222− gfromCollection cs

223− = gfromCollection as :*: gfromCollection bs

224− where (as, bs) = split cs

225−

226−instance GCollectible (Rec0 a) '[a] where

227− type GCollect (Rec0 a) = '[a]

228− gtoCollection = (:> Nil) . unK1

229− gfromCollection = K1 . head'

230−

231−instance GCollectible U1 '[] where

232− type GCollect U1 = '[]

233− gtoCollection U1 = Nil

234− gfromCollection Nil = U1

235−

236−instance GCollectible f as => GCollectible (M1 m meta f) as where

237− type GCollect (M1 m meta f) = GCollect f

238− gtoCollection = gtoCollection . unM1

239− gfromCollection = M1 . gfromCollection

src/Data/Generics/Internal/Lens.hs+173−106

@@ -1,7 +1,9 @@

1−{-# LANGUAGE LambdaCase #-}

1+{-# LANGUAGE GADTs #-}

2−{-# LANGUAGE GADTs #-}

2+{-# LANGUAGE LambdaCase #-}

3−{-# LANGUAGE Rank2Types #-}

3+{-# LANGUAGE Rank2Types #-}

4+{-# LANGUAGE TypeFamilies #-}

5+{-# LANGUAGE TypeFamilyDependencies #-}

4−{-# LANGUAGE TypeOperators #-}

6+{-# LANGUAGE TypeOperators #-}

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

8-----------------------------------------------------------------------------

7-- |

9-- |

@@ -20,10 +22,11 @@ module Data.Generics.Internal.Lens where

20import Control.Applicative (Const(..))

22import Control.Applicative (Const(..))

21import Data.Functor.Identity (Identity(..))

23import Data.Functor.Identity (Identity(..))

22import Data.Monoid (First (..))

24import Data.Monoid (First (..))

23−import Data.Profunctor (Choice(right'), Profunctor(dimap))

25+import Data.Profunctor (Choice(..), Profunctor(..))

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

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

25import Data.Tagged

27import Data.Tagged

26−import GHC.Generics ((:*:)(..), (:+:)(..), Generic(..), M1(..), Rep)

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

29+import Data.Coerce

28-- | Type alias for lens

31-- | Type alias for lens

29type Lens' s a

32type Lens' s a

@@ -39,6 +42,9 @@ type Traversal' s a

39type Traversal s t a b

42type Traversal s t a b

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

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

45+type LensLike f s t a b

46+ = (a -> f b) -> s -> f t

47+

42-- | Type alias for prism

48-- | Type alias for prism

43type Prism s t a b

49type Prism s t a b

44 = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)

50 = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)

@@ -85,20 +91,24 @@ infixr 8 #

85first :: Lens ((a :*: b) x) ((a' :*: b) x) (a x) (a' x)

91first :: Lens ((a :*: b) x) ((a' :*: b) x) (a x) (a' x)

86first f (a :*: b)

92first f (a :*: b)

87 = fmap (:*: b) (f a)

93 = fmap (:*: b) (f a)

94+{-# INLINE first #-}

89-- | Lens focusing on the second element of a product

96-- | Lens focusing on the second element of a product

90second :: Lens ((a :*: b) x) ((a :*: b') x) (b x) (b' x)

97second :: Lens ((a :*: b) x) ((a :*: b') x) (b x) (b' x)

91second f (a :*: b)

98second f (a :*: b)

92 = fmap (a :*:) (f b)

99 = fmap (a :*:) (f b)

100+{-# INLINE second #-}

101

94left :: Prism ((a :+: c) x) ((b :+: c) x) (a x) (b x)

102left :: Prism ((a :+: c) x) ((b :+: c) x) (a x) (b x)

95left = prism L1 $ gsum Right (Left . R1)

103left = prism L1 $ gsum Right (Left . R1)

104+{-# INLINE left #-}

105

97leftP :: PrismP ((a :+: c) x) ((b :+: c) x) (a x) (b x)

106leftP :: PrismP ((a :+: c) x) ((b :+: c) x) (a x) (b x)

98leftP = prismP L1 $ gsum Right (Left . R1)

107leftP = prismP L1 $ gsum Right (Left . R1)

108

100right :: Prism ((a :+: b) x) ((a :+: c) x) (b x) (c x)

109right :: Prism ((a :+: b) x) ((a :+: c) x) (b x) (c x)

101right = prism R1 $ gsum (Left . L1) Right

110right = prism R1 $ gsum (Left . L1) Right

111+{-# INLINE right #-}

102

112

103rightP :: PrismP ((a :+: b) x) ((a :+: c) x) (b x) (c x)

113rightP :: PrismP ((a :+: b) x) ((a :+: c) x) (b x) (c x)

104rightP = prismP R1 $ gsum (Left . L1) Right

114rightP = prismP R1 $ gsum (Left . L1) Right

@@ -106,10 +116,7 @@ rightP = prismP R1 $ gsum (Left . L1) Right

106gsum :: (a x -> c) -> (b x -> c) -> ((a :+: b) x) -> c

116gsum :: (a x -> c) -> (b x -> c) -> ((a :+: b) x) -> c

107gsum f _ (L1 x) = f x

117gsum f _ (L1 x) = f x

108gsum _ g (R1 y) = g y

118gsum _ g (R1 y) = g y

109−

119+{-# INLINE gsum #-}

110−combine :: Lens' (s x) a -> Lens' (t x) a -> Lens' ((s :+: t) x) a

111−combine sa _ f (L1 s) = fmap (\a -> L1 (set sa a s)) (f (s ^. sa))

112−combine _ ta f (R1 t) = fmap (\a -> R1 (set ta a t)) (f (t ^. ta))

113

120

114prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b

121prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b

115prism bt seta eta = dimap (\x -> plus pure id (seta x)) (either id (\x -> fmap bt x)) (right' eta)

122prism bt seta eta = dimap (\x -> plus pure id (seta x)) (either id (\x -> fmap bt x)) (right' eta)

@@ -123,10 +130,14 @@ plus :: (a -> b) -> (c -> d) -> Either a c -> Either b d

123plus f _ (Left x) = Left (f x)

130plus f _ (Left x) = Left (f x)

124plus _ g (Right y) = Right (g y)

131plus _ g (Right y) = Right (g y)

125

132

126−

127-- | A type and its generic representation are isomorphic

133-- | A type and its generic representation are isomorphic

128repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)

134repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)

129−repIso = dimap from (fmap to)

135+repIso = iso from to

136+{-# INLINE repIso #-}

137+

138+repLens :: (Generic a, Generic b) => Lens a b (Rep a x) (Rep b x)

139+repLens f s = repIso f s

140+{-# INLINE repLens #-}

130

141

131-- | A type and its generic representation are isomorphic

142-- | A type and its generic representation are isomorphic

132repIsoP :: (Generic a, Generic b) => IsoP a b (Rep a x) (Rep b x)

143repIsoP :: (Generic a, Generic b) => IsoP a b (Rep a x) (Rep b x)

@@ -134,9 +145,9 @@ repIsoP = dimap from to

134

145

135

146

136-- | 'M1' is just a wrapper around `f p`

147-- | 'M1' is just a wrapper around `f p`

137−--mIso :: Iso' (M1 i c f p) (f p)

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

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

139−mIso = dimap unM1 (fmap M1)

149+mIso = iso unM1 M1

150+{-# INLINE mIso #-}

140

151

141-- | 'M1' is just a wrapper around `f p`

152-- | 'M1' is just a wrapper around `f p`

142--mIso :: Iso' (M1 i c f p) (f p)

153--mIso :: Iso' (M1 i c f p) (f p)

@@ -147,21 +158,24 @@ mIsoP = dimap unM1 M1

147-- these functions eta-expanded allows the optimiser to inline these functions.

158-- these functions eta-expanded allows the optimiser to inline these functions.

148mLens :: Lens (M1 i c f p) (M1 i c g p) (f p) (g p)

159mLens :: Lens (M1 i c f p) (M1 i c g p) (f p) (g p)

149mLens f s = mIso f s

160mLens f s = mIso f s

161+{-# INLINE mLens #-}

150

162

151−repLens :: (Generic a, Generic b) => Lens a b (Rep a x) (Rep b x)

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

152−repLens f s = repIso f s

164+kIso = iso unK1 K1

165+{-# INLINE kIso #-}

153

166

154−sumIso :: Iso' ((a :+: b) x) (Either (a x) (b x))

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

155−sumIso = dimap f (fmap t)

168+sumIso = iso back forth

156− where f (L1 x) = Left x

169+ where forth (Left l) = (L1 l)

157− f (R1 x) = Right x

170+ forth (Right r) = (R1 r)

158− t (Left x) = L1 x

171+ back (L1 l) = (Left l)

159− t (Right x) = R1 x

172+ back (R1 r) = (Right r)

173+{-# INLINE sumIso #-}

160

174

161−_Left :: Prism' (Either a c) a

175+_Left :: Prism (Either a c) (Either b c) a b

162_Left = prism Left $ either Right (Left . Right)

176_Left = prism Left $ either Right (Left . Right)

163

177

164−_Right :: Prism' (Either c a) a

178+_Right :: Prism (Either c a) (Either c b) a b

165_Right = prism Right $ either (Left . Left) Right

179_Right = prism Right $ either (Left . Left) Right

166

180

167--------------------------------------------------------------------------------

181--------------------------------------------------------------------------------

@@ -181,72 +195,6 @@ proj fa = Coyoneda id fa

181ravel :: Functor f => ((a -> Coyoneda f b) -> s -> Coyoneda f t) -> (a -> f b) -> (s -> f t)

195ravel :: Functor f => ((a -> Coyoneda f b) -> s -> Coyoneda f t) -> (a -> f b) -> (s -> f t)

182ravel coy f s = inj $ coy (\a -> proj (f a)) s

196ravel coy f s = inj $ coy (\a -> proj (f a)) s

183

197

184−--------------------------------------------------------------------------------

185−

186−-- Pull dimaps to left and rights to right

187−

188−{-

189−instance Choice p => Profunctor (MergeRight p) where

190− dimap f g (MergeRight (Dirty pab)) = MergeRight (DMap f g pab)

191− dimap f g (MergeRight (DMap f' g' pab)) = MergeRight (DMap (f' . f) (g . g') pab)

192− dimap f g (MergeRight (DRight pab)) = MergeRight (DMap f g (right' pab))

193−

194−instance Choice p => Choice (MergeRight p) where

195− right' (MergeRight (Dirty pab)) = MergeRight (DRight pab)

196− right' (MergeRight (DMap f g pab)) = MergeRight (DMap (fmap f) (fmap g) (right' pab))

197− right' (MergeRight (DRight pab)) = MergeRight (DMap assoc' assoc (right' pab))

198− -}

199−{-

200−data PrismBoggle p a b where

201− DRight :: (p x y) -> PrismBoggle p (Either z x) (Either z y)

202− DMap :: (c -> a) -> (b -> d) -> (p a b) -> PrismBoggle p c d

203− Dirty :: p a b -> PrismBoggle p a b

204−

205−instance Choice p => Profunctor (PrismBoggle p) where

206− dimap f g (Dirty pab) = DMap f g pab

207− dimap f g (DMap f' g' pab) = DMap (f' . f) (g . g') pab

208− dimap f g (DRight pab) = DMap f g (right' pab)

209−

210−instance Choice p => Choice (PrismBoggle p) where

211− right' (Dirty pab) = DRight pab

212− right' (DMap f g pab) = DMap (fmap f) (fmap g) (right' pab)

213− right' (DRight pab) = DMap assoc assoc' (right' pab)

214−

215−assoc :: Either a (Either b c) -> Either (Either a b) c

216−assoc e = case e of

217− Left a -> Left (Left a)

218− Right ebc -> case ebc of

219− Left b -> Left (Right b)

220− Right c -> Right c

221−

222−assoc' :: Either (Either a b) c -> Either a (Either b c)

223−assoc' e = case e of

224− Right c -> Right (Right c)

225− Left eab -> case eab of

226− Left a -> Left a

227− Right b -> Right (Left b)

228−

229−projPrism :: p a b -> PrismBoggle p a b

230−projPrism pab = Dirty pab

231−

232−--rightFuse :: Choice p => p a b -> p (Either c (Either d a)) (Either c (Either d b))

233−rightFuse x = injPrism (injPrism (right' (right' (right' (projPrism (projPrism x))))))

234−

235−

236−injPrism :: Choice p => PrismBoggle p a b -> p a b

237−injPrism (Dirty pab) = pab

238−injPrism (DMap f g pab) = dimap f g pab

239−injPrism (DRight pab) = right' pab

240−-}

241−-- We don't need the full power of boggle, we just want to fuse together

242−-- two `fmaps`

243−{-

244−prismRavel ::

245− (forall p . (MProfunctor p, MRight p) => p a b -> p s t)

246− -> Prism s t a b

247−prismRavel l pab = wrappedProfunctor (lowerFusionStack (ddimap id lowerBoggle (wrappedVLMProfunctor (ravelFusionStack l (WrappedVLMProfunctor (ddimap id (liftBoggle) (liftFusionStack (WrappedProfunctor pab))))))))

248−-}

249−

250prismPRavel ::

198prismPRavel ::

251 (Market a b a b -> Market a b s t)

199 (Market a b a b -> Market a b s t)

252 -> PrismP s t a b

200 -> PrismP s t a b

@@ -259,16 +207,130 @@ prismRavel ::

259prismRavel l pab = (prism2prismvl $ l idPrism) pab

207prismRavel l pab = (prism2prismvl $ l idPrism) pab

260{-# INLINE prismRavel #-}

208{-# INLINE prismRavel #-}

261

209

262−------------------------------------------------------------------------------

210+newtype AlongsideLeft f b a = AlongsideLeft { getAlongsideLeft :: f (a, b) }

263−-- Prism: Market

211+newtype AlongsideRight f b a = AlongsideRight { getAlongsideRight :: f (b, a) }

264−------------------------------------------------------------------------------

265

212

266−-- | This type is used internally by the 'Control.Lens.Prism.Prism' code to

213+(??) :: Functor f => f (a -> b) -> a -> f b

267−-- provide efficient access to the two parts of a 'Prism'.

214+fab ?? a = fmap ($ a) fab

268−data Market a b s t = Market (b -> t) (s -> Either t a)

215+

216+instance Functor f => Functor (AlongsideLeft f b) where

217+ fmap f = AlongsideLeft . fmap (\(a, b) -> (f a, b)) . getAlongsideLeft

218+

219+instance Functor f => Functor (AlongsideRight f b) where

220+ fmap f = AlongsideRight . fmap (\(a, b) -> (a, f b)) . getAlongsideRight

221+

222+alongside :: LensLike (AlongsideLeft f b') s t a b

223+ -> LensLike (AlongsideRight f t) s' t' a' b'

224+ -> LensLike f (s, s') (t, t') (a, a') (b, b')

225+alongside l1 l2 f (a1, a2)

226+ = getAlongsideRight $ l2 ?? a2 $ \b2 -> AlongsideRight

227+ $ getAlongsideLeft $ l1 ?? a1 $ \b1 -> AlongsideLeft

228+ $ f (b1,b2)

229+{-# INLINE alongside #-}

230+

231+prodIso :: Iso ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)

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

233+{-# INLINE prodIso #-}

269

234

270−-- | @type 'Market'' a s t = 'Market' a a s t@

235+prodL :: Lens ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)

271−type Market' a = Market a a

236+prodL f s = prodIso f s

237+{-# INLINE prodL #-}

238+

239+prodR :: Lens (a' x, b' x) (a x, b x) ((a' :*: b') x) ((a :*: b) x)

240+prodR f s = fromIso prodIso f s

241+{-# INLINE prodR #-}

242+

243+assoc3 :: Iso ((a, b), c) ((a', b'), c') (a, (b, c)) (a', (b', c'))

244+assoc3 = iso (\((a, b), c) -> (a, (b, c))) (\(a, (b, c)) -> ((a, b), c))

245+{-# INLINE assoc3 #-}

246+

247+assoc3L :: Lens ((a, b), c) ((a', b'), c') (a, (b, c)) (a', (b', c'))

248+assoc3L f s = assoc3 f s

249+{-# INLINE assoc3L #-}

250+

251+assoc3R :: Lens (a', (b', c')) (a, (b, c)) ((a', b'), c') ((a, b), c)

252+assoc3R f s = fromIso assoc3 f s

253+{-# INLINE assoc3R #-}

254+

255+choosing :: Lens s t a b -> Lens s' t' a b -> Lens (Either s s') (Either t t') a b

256+choosing l _ f (Left a) = Left <$> l f a

257+choosing _ r f (Right a') = Right <$> r f a'

258+{-# INLINE choosing #-}

259+

260+--------------------------------------------------------------------------------

261+-- Iso stuff

262+

263+data Exchange a b s t = Exchange (s -> a) (b -> t)

264+

265+instance Functor (Exchange a b s) where

266+ fmap f (Exchange sa bt) = Exchange sa (f . bt)

267+ {-# INLINE fmap #-}

268+

269+instance Profunctor (Exchange a b) where

270+ dimap f g (Exchange sa bt) = Exchange (sa . f) (g . bt)

271+ {-# INLINE dimap #-}

272+ lmap f (Exchange sa bt) = Exchange (sa . f) bt

273+ {-# INLINE lmap #-}

274+ rmap f (Exchange sa bt) = Exchange sa (f . bt)

275+ {-# INLINE rmap #-}

276+ ( #. ) _ = coerce

277+ {-# INLINE ( #. ) #-}

278+ ( .# ) p _ = coerce p

279+ {-# INLINE ( .# ) #-}

280+

281+fromIso :: Iso s t a b -> Iso b a t s

282+fromIso l = withIso l $ \ sa bt -> iso bt sa

283+{-# INLINE fromIso #-}

284+

285+iso :: (s -> a) -> (b -> t) -> Iso s t a b

286+iso sa bt = dimap sa (fmap bt)

287+{-# INLINE iso #-}

288+

289+withIso :: Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r

290+withIso ai k = case ai (Exchange id Identity) of

291+ Exchange sa bt -> k sa (runIdentity #. bt)

292+

293+pairing :: Iso s t a b -> Iso s' t' a' b' -> Iso (s, s') (t, t') (a, a') (b, b')

294+pairing f g = withIso f $ \ sa bt -> withIso g $ \s'a' b't' ->

295+ iso (bmap sa s'a') (bmap bt b't')

296+ where bmap f' g' (a, b) = (f' a, g' b)

297+

298+--------------------------------------------------------------------------------

299+-- Prism stuff

300+

301+type APrism s t a b = Market a b a (Identity b) -> Market a b s (Identity t)

302+

303+-- without :: APrism s t a b

304+-- -> APrism u v c d

305+-- -> Prism (Either s u) (Either t v) (Either a c) (Either b d)

306+-- without k =

307+-- withPrism k $ \bt seta k' ->

308+-- withPrism k' $ \dv uevc ->

309+-- prism (bimapE bt dv) $ \su ->

310+-- case su of

311+-- Left s -> bimapE Left Left (seta s)

312+-- Right u -> bimapE Right Right (uevc u)

313+-- where bimapE :: (a -> b) -> (c -> d) -> Either a c -> Either b d

314+-- bimapE f _ (Left a) = Left (f a)

315+-- bimapE _ g (Right a) = Right (g a)

316+-- {-# INLINE bimapE #-}

317+

318+without' :: APrism s t a b -> APrism s t c d -> Prism s t (Either a c) (Either b d)

319+without' k =

320+ withPrism k $ \bt _ k' ->

321+ withPrism k' $ \dt setc ->

322+ prism (foldEither bt dt) $ \s -> fmap Right (setc s)

323+ where foldEither _ g (Right r) = g r

324+ foldEither f _ (Left l) = f l

325+

326+withPrism :: APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r

327+withPrism k f = case coerce (k (Market Identity Right)) of

328+ Market bt seta -> f bt seta

329+

330+--------------------------------------------------------------------------------

331+-- Market

332+

333+data Market a b s t = Market (b -> t) (s -> Either t a)

272

334

273instance Functor (Market a b s) where

335instance Functor (Market a b s) where

274 fmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta)

336 fmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta)

@@ -277,14 +339,22 @@ instance Functor (Market a b s) where

277instance Profunctor (Market a b) where

339instance Profunctor (Market a b) where

278 dimap f g (Market bt seta) = Market (g . bt) (either (Left . g) Right . seta . f)

340 dimap f g (Market bt seta) = Market (g . bt) (either (Left . g) Right . seta . f)

279 {-# INLINE dimap #-}

341 {-# INLINE dimap #-}

342+ lmap f (Market bt seta) = Market bt (seta . f)

343+ {-# INLINE lmap #-}

344+ rmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta)

345+ {-# INLINE rmap #-}

346+ ( #. ) _ = coerce

347+ {-# INLINE ( #. ) #-}

348+ ( .# ) p _ = coerce p

349+ {-# INLINE ( .# ) #-}

280

350

281instance Choice (Market a b) where

351instance Choice (Market a b) where

282− right' (Market bt seta) = Market (Right . bt) $ \cs -> case cs of

352+ left' (Market bt seta) = Market (Left . bt) $ \sc -> case sc of

283− Left c -> Left (Left c)

284− Right s -> case seta s of

353+ Left s -> case seta s of

285− Left t -> Left (Right t)

354+ Left t -> Left (Left t)

286 Right a -> Right a

355 Right a -> Right a

356+ Right c -> Left (Right c)

287− {-# INLINE right' #-}

357+ {-# INLINE left' #-}

288

358

289prism2prismp :: Market a b s t -> PrismP s t a b

359prism2prismp :: Market a b s t -> PrismP s t a b

290prism2prismp (Market bt seta) = prismP bt seta

360prism2prismp (Market bt seta) = prismP bt seta

@@ -381,6 +451,3 @@ instance Functor (Yoneda f) where

381instance Applicative f => Applicative (Yoneda f) where

451instance Applicative f => Applicative (Yoneda f) where

382 pure a = Yoneda (\f -> pure (f a))

452 pure a = Yoneda (\f -> pure (f a))

383 Yoneda m <*> Yoneda n = Yoneda (\f -> m (f .) <*> n id)

453 Yoneda m <*> Yoneda n = Yoneda (\f -> m (f .) <*> n id)

384−

385−

386−

src/Data/Generics/Internal/Void.hs+1

@@ -1,3 +1,4 @@

1+{-# LANGUAGE PolyKinds #-}

1module Data.Generics.Internal.Void where

2module Data.Generics.Internal.Void where

3{-

4{-

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.List

26 ) where

27 ) where

28import Data.Generics.Product.Any

29import Data.Generics.Product.Any

@@ -31,3 +32,4 @@ import Data.Generics.Product.Positions

31import Data.Generics.Product.Subtype

32import Data.Generics.Product.Subtype

32import Data.Generics.Product.Typed

33import Data.Generics.Product.Typed

33import Data.Generics.Product.Types

34import Data.Generics.Product.Types

35+import Data.Generics.Product.List

src/Data/Generics/Product/Fields.hs+18−11

@@ -1,4 +1,5 @@

1{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE CPP #-}

2{-# LANGUAGE ConstraintKinds #-}

3{-# LANGUAGE ConstraintKinds #-}

3{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE FlexibleInstances #-}

@@ -39,7 +40,7 @@ module Data.Generics.Product.Fields

39import Data.Generics.Internal.Families

40import Data.Generics.Internal.Families

40import Data.Generics.Internal.Lens

41import Data.Generics.Internal.Lens

41import Data.Generics.Internal.Void

42import Data.Generics.Internal.Void

42−import Data.Generics.Product.Internal.Fields

43+import Data.Generics.Product.Internal.Keyed

44import Data.Kind (Constraint, Type)

45import Data.Kind (Constraint, Type)

45import GHC.Generics

46import GHC.Generics

@@ -75,7 +76,7 @@ import GHC.TypeLits (Symbol, ErrorMessage(..), TypeError)

75-- :}

76-- :}

77-- |Records that have a field with a given name.

78-- |Records that have a field with a given name.

78−class HasField (field :: Symbol) s t a b | s field -> a, s field b -> t where

79+class HasField (field :: Symbol) s t a b | s field -> a, t field -> b, s field b -> t, t field a -> s where

79 -- |A lens that focuses on a field with a given name. Compatible with the

80 -- |A lens that focuses on a field with a given name. Compatible with the

80 -- lens package's 'Control.Lens.Lens' type.

81 -- lens package's 'Control.Lens.Lens' type.

81 --

82 --

@@ -127,20 +128,26 @@ instance -- see Note [Changing type parameters]

127 ( Generic s

128 ( Generic s

128 , ErrorUnless field s (CollectField field (Rep s))

129 , ErrorUnless field s (CollectField field (Rep s))

129 , Generic t

130 , Generic t

131+ -- see Note [CPP in instance constraints]

132+#if __GLASGOW_HASKELL__ < 802

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

134+#else

130 , s' ~ Proxied s

135 , s' ~ Proxied s

136+ , t' ~ Proxied t

137+#endif

131 , Generic s'

138 , Generic s'

139+ , Generic t'

132− , GHasField' field (Rep s) a

140+ , GHasKey' field (Rep s) a

133− , GHasField' field (Rep s') a'

141+ , GHasKey' field (Rep s') a'

142+ , GHasKey' field (Rep t') b'

134− , GHasField field (Rep s) (Rep t) a b

143+ , GHasKey field (Rep s) (Rep t) a b

135− , '(t, b) ~ Infer s' a' a (PickTv a' b)

144+ , t ~ Infer s a' b

145+ , s ~ Infer t b' a

136 ) => HasField field s t a b where

146 ) => HasField field s t a b where

137

147

138− field f s = ravel (repLens . gfield @field) f s

148+ field f s = ravel (repLens . gkey @field) f s

139−

140−-- See Note [Uncluttering type signatures]

141−instance {-# OVERLAPPING #-} HasField f (Void2 t a) t a b where

142− field = undefined

143

149

150+-- -- See Note [Uncluttering type signatures]

144instance {-# OVERLAPPING #-} HasField f (Void1 a) (Void1 b) a b where

151instance {-# OVERLAPPING #-} HasField f (Void1 a) (Void1 b) a b where

145 field = undefined

152 field = undefined

146

153

src/Data/Generics/Product/Internal/Fields.hsdeleted−77

@@ -1,77 +0,0 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE ConstraintKinds #-}

3−{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE FlexibleInstances #-}

5−{-# LANGUAGE FunctionalDependencies #-}

6−{-# LANGUAGE KindSignatures #-}

7−{-# LANGUAGE MultiParamTypeClasses #-}

8−{-# LANGUAGE Rank2Types #-}

9−{-# LANGUAGE ScopedTypeVariables #-}

10−{-# LANGUAGE TypeApplications #-}

11−{-# LANGUAGE TypeFamilies #-}

12−{-# LANGUAGE TypeOperators #-}

13−{-# LANGUAGE UndecidableInstances #-}

14−

15−-----------------------------------------------------------------------------

16−-- |

17−-- Module : Data.Generics.Product.Internal.Fields

19−-- License : BSD3

20−-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

21−-- Stability : experimental

22−-- Portability : non-portable

23−--

24−-- Derive record field getters and setters generically.

25−--

26−-----------------------------------------------------------------------------

27−

28−module Data.Generics.Product.Internal.Fields

29− ( GHasField (..)

30− , GHasField'

31− ) where

32−

33−import Data.Generics.Internal.Families

34−import Data.Generics.Internal.Lens

35−

36−import Data.Kind (Type)

37−import GHC.Generics

38−import GHC.TypeLits (Symbol)

39−

40−-- |As 'HasField' but over generic representations as defined by

41−-- "GHC.Generics".

42−class GHasField (field :: Symbol) (s :: Type -> Type) (t :: Type -> Type) a b | s field -> a, t field -> b where

43− gfield :: Lens (s x) (t x) a b

44−

45−type GHasField' field s a = GHasField field s s a a

46−

47−instance GProductHasField field l r l' r' a b (HasTotalFieldP field l)

48− => GHasField field (l :*: r) (l' :*: r') a b where

49−

50− gfield = gproductField @field @_ @_ @_ @_ @_ @_ @(HasTotalFieldP field l)

51−

52−instance (GHasField' field r a, GHasField' field l a, GHasField field l l' a b, GHasField field r r' a b)

53− => GHasField field (l :+: r) (l' :+: r') a b where

54−

55− gfield f (L1 s) = fmap (\a -> L1 (set (gfield @field) a s)) (f (s ^. gfield @field))

56− gfield f (R1 t) = fmap (\a -> R1 (set (gfield @field) a t)) (f (t ^. gfield @field))

57−

58−instance GHasField field (K1 R a) (K1 R b) a b where

59− gfield f (K1 x) = fmap K1 (f x)

60−

61−instance GHasField field (S1 ('MetaSel ('Just field) upkd str infstr) (Rec0 a)) (S1 ('MetaSel ('Just field) upkd str infstr) (Rec0 b)) a b where

62− gfield = mLens . gfield @field

63−

64−instance (Functor g, GHasField field f g a b) => GHasField field (M1 D meta f) (M1 D meta g) a b where

65− gfield = mLens . gfield @field

66−

67−instance GHasField field f g a b => GHasField field (M1 C meta f) (M1 C meta g) a b where

68− gfield = mLens . gfield @field

69−

70−class GProductHasField (field :: Symbol) l r l' r' a b (left :: Bool) | field l r -> a, field l' r' -> b where

71− gproductField :: Lens ((l :*: r) x) ((l' :*: r') x) a b

72−

73−instance GHasField field l l' a b => GProductHasField field l r l' r a b 'True where

74− gproductField = first . gfield @field

75−

76−instance GHasField field r r' a b => GProductHasField field l r l r' a b 'False where

77− gproductField = second . gfield @field

src/Data/Generics/Product/Internal/Keyed.hsnew file+53

@@ -0,0 +1,53 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE ConstraintKinds #-}

3+{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE FunctionalDependencies #-}

5+{-# LANGUAGE GADTs #-}

6+{-# LANGUAGE ScopedTypeVariables #-}

7+{-# LANGUAGE TupleSections #-}

8+{-# LANGUAGE TypeApplications #-}

9+{-# LANGUAGE TypeFamilies #-}

10+{-# LANGUAGE TypeInType #-}

11+{-# LANGUAGE TypeOperators #-}

12+{-# LANGUAGE UndecidableInstances #-}

13+

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

15+-- |

16+-- Module : Data.Generics.Product.Internal.Keyed

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

19+-- License : BSD3

20+-- Stability : experimental

21+-- Portability : non-portable

22+--

23+--------------------------------------------------------------------------------

24+

25+module Data.Generics.Product.Internal.Keyed

26+ ( GHasKey (..)

27+ , GHasKey'

28+ ) where

29+

30+import Data.Generics.Internal.Lens

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

32+import Data.Kind

33+import GHC.Generics

34+

35+class GHasKey (key :: k) (s :: Type -> Type) (t :: Type -> Type) a b | s key -> a, t key -> b where

36+ gkey :: Lens (s x) (t x) a b

37+

38+type GHasKey' key s a = GHasKey key s s a a

39+

40+instance (GHasKey key l l' a b, GHasKey key r r' a b) => GHasKey key (l :+: r) (l' :+: r') a b where

41+ gkey = sumIso . choosing (gkey @key) (gkey @key)

42+

43+instance (GHasKey key f g a b) => GHasKey key (M1 D meta f) (M1 D meta g) a b where

44+ gkey = mLens . gkey @key

45+

46+instance

47+ ( Elem as key i a

48+ , Elem bs key i b

49+ , IndexList i as bs a b

50+ , GIsList k f g as bs

51+ ) => GHasKey (key :: k) (M1 C meta f) (M1 C meta g) a b where

52+ gkey = mIso . (glist @k) . point @i

53+

src/Data/Generics/Product/Internal/List.hsnew file+343

@@ -0,0 +1,343 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE CPP #-}

3+{-# LANGUAGE ConstraintKinds #-}

4+{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE FunctionalDependencies #-}

6+{-# LANGUAGE GADTs #-}

7+{-# LANGUAGE ScopedTypeVariables #-}

8+{-# LANGUAGE TupleSections #-}

9+{-# LANGUAGE TypeApplications #-}

10+{-# LANGUAGE TypeFamilies #-}

11+{-# LANGUAGE TypeInType #-}

12+{-# LANGUAGE TypeOperators #-}

13+{-# LANGUAGE UndecidableInstances #-}

14+

15+#if __GLASGOW_HASKELL__ == 802

16+{-# OPTIONS_GHC -fno-solve-constant-dicts #-}

17+#endif

18+

19+

20+-----------------------------------------------------------------------------

21+-- |

22+-- Module : Data.Generics.Product.Internal.List

24+-- License : BSD3

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

26+-- Stability : experimental

27+-- Portability : non-portable

28+--

29+-- Derive an isomorphism between a product type and a flat HList.

30+--

31+-----------------------------------------------------------------------------

32+

33+module Data.Generics.Product.Internal.List

34+ ( GIsList (..)

35+ , IndexList (..)

36+ , List (..)

37+ , type (++)

38+ , Elem

39+ , ListTuple (..)

40+ , TupleToList

41+ , Permuting (..)

42+ , Appending (..)

43+ ) where

44+

45+import GHC.TypeLits

46+import Data.Generics.Internal.Lens

47+

48+import Data.Kind (Type)

49+import GHC.Generics

50+

51+data List (as :: [(m, Type)]) where

52+ Nil :: List '[]

53+ (:>) :: a -> List as -> List ('(s, a) ': as)

54+

55+infixr 5 :>

56+

57+type family ((as :: [k]) ++ (bs :: [k])) :: [k] where

58+ '[] ++ bs = bs

59+ (a ': as) ++ bs = a ': as ++ bs

60+

61+instance Monoid (List '[]) where

62+ mempty = Nil

63+ mappend _ _ = Nil

64+

65+instance (Monoid a, Monoid (List as)) => Monoid (List ('(k, a) ': as)) where

66+ mempty = mempty :> mempty

67+ mappend (x :> xs) (y :> ys) = mappend x y :> mappend xs ys

68+

69+class Elem (as :: [(k, Type)]) (key :: k) (i :: Nat) a | as key -> i a

70+instance {-# OVERLAPPING #-} pos ~ 0 => Elem ('(key, a) ': xs) key pos a

71+instance (Elem xs key i a, pos ~ (i + 1)) => Elem (x ': xs) key pos a

72+

73+class GIsList

74+ (m :: Type)

75+ (f :: Type -> Type)

76+ (g :: Type -> Type)

77+ (as :: [(m, Type)])

78+ (bs :: [(m, Type)]) | m f -> as, m g -> bs, bs f -> g, as g -> f where

79+

80+ glist :: Iso (f x) (g x) (List as) (List bs)

81+

82+ glistL :: Lens (f x) (g x) (List as) (List bs)

83+ glistL f s = glist @m f s

84+

85+ glistR :: Lens (List bs) (List as) (g x) (f x)

86+ glistR f s = fromIso (glist @m) f s

87+

88+instance

89+ ( GIsList m l l' as as'

90+ , GIsList m r r' bs bs'

91+ , Appending List as bs cs as' bs' cs'

92+ , cs ~ (as ++ bs)

93+ , cs' ~ (as' ++ bs')

94+ ) => GIsList m (l :*: r) (l' :*: r') cs cs' where

95+

96+ glist = prodIso . pairing (glist @m) (glist @m) . appending

97+

98+instance GIsList m f g as bs => GIsList m (M1 t meta f) (M1 t meta g) as bs where

99+ glist = mIso . glist @m

100+

101+instance {-# OVERLAPS #-}

102+ GIsList Symbol

103+ (S1 ('MetaSel ('Just field) u s i) (Rec0 a))

104+ (S1 ('MetaSel ('Just field) u s i) (Rec0 b))

105+ '[ '(field, a)] '[ '(field, b)] where

106+ glist = mIso . kIso . singleton

107+

108+instance GIsList Type (Rec0 a) (Rec0 a) '[ '(a, a)] '[ '(a, a)] where

109+ glist = kIso . singleton

110+

111+instance GIsList () (Rec0 a) (Rec0 b) '[ '( '(), a)] '[ '( '(), b)] where

112+ glist = kIso . singleton

113+

114+instance GIsList m U1 U1 '[] '[] where

115+ glist = iso (const Nil) (const U1)

116+

117+--------------------------------------------------------------------------------

118+-- as ++ bs == cs

119+-- as' + == cs'

120+class Appending f (as :: [k]) bs cs (as' :: [k]) bs' cs' | as bs cs cs' -> as' bs', as' bs' cs cs' -> as bs, as bs -> cs, as' bs' -> cs' where

121+ appending :: Iso (f as, f bs) (f as', f bs') (f cs) (f cs')

122+

123+instance Appending List '[] bs bs '[] bs' bs' where

124+ appending = iso snd (Nil,)

125+

126+instance Appending List as bs cs as' bs' cs'

127+ => Appending List ('(f, a) ': as) bs ('(f, a) ': cs) ('(f, a') ': as') bs' ('(f, a') ': cs') where

128+ appending = pairing (fromIso consing) id . assoc3 . pairing id appending . consing

129+

130+singleton :: Iso a b (List '[ '(field, a)]) (List '[ '(field, b)])

131+singleton = iso (:> Nil) (\(x :> _) -> x)

132+

133+consing :: Iso (a, List as) (b, List bs) (List ('(f, a) ': as)) (List ('(f, b) ': bs))

134+consing = iso (\(x, xs) -> x :> xs) (\(x :> xs) -> (x, xs))

135+

136+--------------------------------------------------------------------------------

137+

138+-- This ended up not being used now... still cool to have

139+flipping :: Iso' (List (a1 ': a2 ': as)) (List (a2 ': a1 ': as))

140+flipping = iso

141+ (\(a1 :> a2 :> as) -> a2 :> a1 :> as)

142+ (\(a2 :> a1 :> as) -> a1 :> a2 :> as)

143+

144+class Inserting f a as bs | bs a -> as where

145+ inserting :: Iso' (f (a ': as)) (f bs)

146+

147+instance Inserting f a as (a ': as) where

148+ inserting = id

149+

150+instance Inserting List a as bs => Inserting List a ('(fb, b) ': as) ('(fb, b) ': bs) where

151+ inserting = flipping . fromIso consing . pairing id (inserting @_ @a) . consing

152+

153+class Permuting f as bs where

154+ permuting :: Iso' (f as) (f bs)

155+

156+instance Permuting List '[] '[] where

157+ permuting = id

158+

159+instance (Permuting List as as', Inserting List '(fa, a) as' bs')

160+ => Permuting List ('(fa, a) ': as) bs' where

161+ permuting = fromIso consing . pairing id permuting . consing . (inserting @_ @'(fa, _))

162+

163+--------------------------------------------------------------------------------

164+class IndexList (i :: Nat) as bs a b | i as -> a, i bs -> b, i as b -> bs, i bs a -> as where

165+ point :: Lens (List as) (List bs) a b

166+

167+instance {-# OVERLAPPING #-}

168+ ( as ~ ('(f, a) ': as')

169+ , bs ~ ('(f, b) ': as')

170+ ) => IndexList 0 as bs a b where

171+ point f (x :> xs) = (:> xs) <$> f x

172+ {-# INLINE point #-}

173+

174+instance

175+ ( IndexList (n - 1) as' bs' a b

176+ , as ~ (x ': as')

177+ , bs ~ (x ': bs')

178+ ) => IndexList n as bs a b where

179+ point f (x :> xs) = (x :>) <$> point @(n - 1) f xs

180+ {-# INLINE point #-}

181+

182+--------------------------------------------------------------------------------

183+-- * Convert tuples to/from HLists

184+

185+class ListTuple (tuple :: Type) (as :: [(k, Type)]) | as -> tuple where

186+ type ListToTuple as :: Type

187+ tupled :: Iso' (List as) tuple

188+ tupled = iso listToTuple tupleToList

189+

190+ tupleToList :: tuple -> List as

191+ listToTuple :: List as -> tuple

192+

193+instance ListTuple () '[] where

194+ type ListToTuple '[] = ()

195+ tupleToList _ = Nil

196+ listToTuple _ = ()

197+

198+instance ListTuple a '[ '(fa, a)] where

199+ type ListToTuple '[ '(fa, a)] = a

200+ tupleToList a

201+ = a :> Nil

202+ listToTuple (a :> Nil)

203+ = a

204+

205+instance ListTuple (a, b) '[ '(fa, a), '(fb, b)] where

206+ type ListToTuple '[ '(fa, a), '(fb, b)] = (a, b)

207+ tupleToList (a, b)

208+ = a :> b :> Nil

209+ listToTuple (a :> b :> Nil)

210+ = (a, b)

211+

212+instance ListTuple (a, b, c) '[ '(fa, a), '(fb, b), '(fc, c)] where

213+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c)] = (a, b, c)

214+ tupleToList (a, b, c)

215+ = a :> b :> c :> Nil

216+ listToTuple (a :> b :> c :> Nil)

217+ = (a, b, c)

218+

219+instance ListTuple (a, b, c, d) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d)] where

220+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d)] = (a, b, c, d)

221+ tupleToList (a, b, c, d)

222+ = a :> b :> c :> d:> Nil

223+ listToTuple (a :> b :> c :> d :> Nil)

224+ = (a, b, c, d)

225+

226+instance ListTuple (a, b, c, d, e) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e)] where

227+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e)] = (a, b, c, d, e)

228+ tupleToList (a, b, c, d, e)

229+ = a :> b :> c :> d:> e :> Nil

230+ listToTuple (a :> b :> c :> d :> e :> Nil)

231+ = (a, b, c, d, e)

232+

233+instance ListTuple (a, b, c, d, e, f) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f)] where

234+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f)] = (a, b, c, d, e, f)

235+ tupleToList (a, b, c, d, e, f)

236+ = a :> b :> c :> d:> e :> f :> Nil

237+ listToTuple (a :> b :> c :> d :> e :> f :> Nil)

238+ = (a, b, c, d, e, f)

239+

240+instance ListTuple (a, b, c, d, e, f, g) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g)] where

241+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g)] = (a, b, c, d, e, f, g)

242+ tupleToList (a, b, c, d, e, f, g)

243+ = a :> b :> c :> d:> e :> f :> g :> Nil

244+ listToTuple (a :> b :> c :> d :> e :> f :> g :> Nil)

245+ = (a, b, c, d, e, f, g)

246+

247+instance ListTuple (a, b, c, d, e, f, g, h) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h)] where

248+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h)] = (a, b, c, d, e, f, g, h)

249+ tupleToList (a, b, c, d, e, f, g, h)

250+ = a :> b :> c :> d:> e :> f :> g :> h :> Nil

251+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> Nil)

252+ = (a, b, c, d, e, f, g, h)

253+

254+instance ListTuple (a, b, c, d, e, f, g, h, j) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j)] where

255+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j)] = (a, b, c, d, e, f, g, h, j)

256+ tupleToList (a, b, c, d, e, f, g, h, j)

257+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> Nil

258+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> Nil)

259+ = (a, b, c, d, e, f, g, h, j)

260+

261+instance ListTuple (a, b, c, d, e, f, g, h, j, k) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k)] where

262+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k)] = (a, b, c, d, e, f, g, h, j, k)

263+ tupleToList (a, b, c, d, e, f, g, h, j, k)

264+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> Nil

265+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> Nil)

266+ = (a, b, c, d, e, f, g, h, j, k)

267+

268+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l)] where

269+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l)] = (a, b, c, d, e, f, g, h, j, k, l)

270+ tupleToList (a, b, c, d, e, f, g, h, j, k, l)

271+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> Nil

272+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> Nil)

273+ = (a, b, c, d, e, f, g, h, j, k, l)

274+

275+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m)] where

276+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m)] = (a, b, c, d, e, f, g, h, j, k, l, m)

277+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m)

278+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> Nil

279+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> Nil)

280+ = (a, b, c, d, e, f, g, h, j, k, l, m)

281+

282+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n)] where

283+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n)] = (a, b, c, d, e, f, g, h, j, k, l, m, n)

284+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n)

285+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil

286+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil)

287+ = (a, b, c, d, e, f, g, h, j, k, l, m, n)

288+

289+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o)] where

290+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o)

291+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o)

292+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil

293+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil)

294+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o)

295+

296+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p)] where

297+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)

298+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)

299+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil

300+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil)

301+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)

302+

303+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q)] where

304+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)

305+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)

306+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil

307+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil)

308+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)

309+

310+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, r)] where

311+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, r)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)

312+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)

313+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil

314+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil)

315+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)

316+

317+instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, r), '(fs, s)] where

318+ type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, r), '(fs, s)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)

319+ tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)

320+ = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil

321+ listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil)

322+ = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)

323+

324+type family TupleToList a where

325+ TupleToList () = '[]

326+ TupleToList (a, b) = '[ '( '(), a), '( '(), b)]

327+ TupleToList (a, b, c) = '[ '( '(), a), '( '(), b), '( '(), c)]

328+ TupleToList (a, b, c, d) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d)]

329+ TupleToList (a, b, c, d, e) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e)]

330+ TupleToList (a, b, c, d, e, f) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f)]

331+ TupleToList (a, b, c, d, e, f, g) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g)]

332+ TupleToList (a, b, c, d, e, f, g, h) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h)]

333+ TupleToList (a, b, c, d, e, f, g, h, j) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j)]

334+ TupleToList (a, b, c, d, e, f, g, h, j, k) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k)]

335+ TupleToList (a, b, c, d, e, f, g, h, j, k, l) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l)]

336+ TupleToList (a, b, c, d, e, f, g, h, j, k, l, m) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m)]

337+ TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n)]

338+ TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n), '( '(), o)]

339+ TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n), '( '(), o), '( '(), p)]

340+ TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n), '( '(), o), '( '(), p), '( '(), q)]

341+ TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n), '( '(), o), '( '(), p), '( '(), q), '( '(), r)]

342+ TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n), '( '(), o), '( '(), p), '( '(), q), '( '(), r), '( '(), s)]

343+ TupleToList a = '[ '( '(), a)]

src/Data/Generics/Product/Internal/Positions.hs+12−22

@@ -35,40 +35,30 @@ module Data.Generics.Product.Internal.Positions

36import Data.Generics.Internal.Lens

38+import Data.Generics.Product.Internal.List

38import Data.Kind (Type)

39import Data.Kind (Type)

39import Data.Type.Bool (If, Not)

40import Data.Type.Bool (If, Not)

40import GHC.Generics

41import GHC.Generics

41−import GHC.TypeLits (type (<=?), type (+), Nat)

42+import GHC.TypeLits (type (<=?), type (+), type (-), Nat)

43-- |As 'HasPosition' but over generic representations as defined by

44-- |As 'HasPosition' but over generic representations as defined by

44-- "GHC.Generics".

45-- "GHC.Generics".

45−class GHasPosition (offset :: Nat) (i :: Nat) (s :: Type -> Type) (t :: Type -> Type) a b | s offset i -> a, s t offset i -> b where

46+class GHasPosition (i :: Nat) (s :: Type -> Type) (t :: Type -> Type) a b | s i -> a, t i -> b, s t i -> b where

46 gposition :: Lens (s x) (t x) a b

47 gposition :: Lens (s x) (t x) a b

48−type GHasPosition' i s a = GHasPosition 1 i s s a a

49+type GHasPosition' i s a = GHasPosition i s s a a

50−instance GHasPosition i i (K1 R a) (K1 R b) a b where

51+instance (GHasPosition i l l' a b, GHasPosition i r r' a b) => GHasPosition i (l :+: r) (l' :+: r') a b where

51− gposition f (K1 x) = fmap K1 (f x)

52+ gposition = sumIso . choosing (gposition @i) (gposition @i)

53−instance GHasPosition offset i s t a b => GHasPosition offset i (M1 m meta s) (M1 m meta t) a b where

54+instance GHasPosition i s t a b => GHasPosition i (M1 D meta s) (M1 D meta t) a b where

54− gposition = mLens . gposition @offset @i

55+ gposition = mLens . gposition @i

56instance

57instance

57− ( goLeft ~ (i <? (offset + Size l))

58+ ( IndexList (i - 1) as bs a b

58− , offset' ~ (If goLeft offset (offset + Size l))

59+ , GIsList () f g as bs

59− , GProductHasPosition offset' i l r l' r' a b goLeft

60− ) => GHasPosition offset i (l :*: r) (l' :*: r') a b where

60+ ) => GHasPosition i (M1 C meta f) (M1 C meta g) a b where

61−

61+ gposition = mIso . (glist @()) . point @(i - 1)

62− gposition = gproductPosition @offset' @i @_ @_ @_ @_ @_ @_ @goLeft

63−

64−class GProductHasPosition (offset :: Nat) (i :: Nat) l r l' r' a b (left :: Bool) | offset i l r -> a, offset i l r l' r' -> b where

65− gproductPosition :: Lens ((l :*: r) x) ((l' :*: r') x) a b

66−

67−instance GHasPosition offset i l l' a b => GProductHasPosition offset i l r l' r a b 'True where

68− gproductPosition = first . gposition @offset @i

69−

70−instance GHasPosition offset i r r' a b => GProductHasPosition offset i l r l r' a b 'False where

71− gproductPosition = second . gposition @offset @i

73type family Size f :: Nat where

63type family Size f :: Nat where

74 Size (l :*: r)

64 Size (l :*: r)

src/Data/Generics/Product/Internal/Subtype.hs+5−5

@@ -32,7 +32,7 @@ module Data.Generics.Product.Internal.Subtype

33import Data.Generics.Internal.Families

34import Data.Generics.Internal.Lens

35−import Data.Generics.Product.Internal.Fields

35+import Data.Generics.Product.Internal.Keyed

37import Data.Kind (Type)

38import GHC.Generics

@@ -47,10 +47,10 @@ instance (GUpcast sub a, GUpcast sub b) => GUpcast sub (a :*: b) where

47 gupcast rep = gupcast rep :*: gupcast rep

49instance

50− GHasField field sub sub t t

50+ GHasKey field sub sub t t

51 => GUpcast sub (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where

53− gupcast r = M1 (K1 (r ^. gfield @field))

53+ gupcast r = M1 (K1 (r ^. gkey @field))

55instance GUpcast sub sup => GUpcast sub (C1 c sup) where

56 gupcast = M1 . gupcast

@@ -84,9 +84,9 @@ class GSmashLeaf sub sup (w :: Bool) where

84 gsmashLeaf :: sup p -> sub p -> sub p

86instance

87− GHasField field sup sup t t

87+ GHasKey field sup sup t t

88 => GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'True where

89− gsmashLeaf sup _ = M1 (K1 (sup ^. gfield @field))

89+ gsmashLeaf sup _ = M1 (K1 (sup ^. gkey @field))

91instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'False where

92 gsmashLeaf _ = id

src/Data/Generics/Product/Internal/Typed.hsdeleted−62

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

1−{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE FlexibleInstances #-}

5−{-# LANGUAGE KindSignatures #-}

6−{-# LANGUAGE MultiParamTypeClasses #-}

7−{-# LANGUAGE ScopedTypeVariables #-}

8−{-# LANGUAGE TypeApplications #-}

9−{-# LANGUAGE TypeFamilies #-}

10−{-# LANGUAGE TypeOperators #-}

11−{-# LANGUAGE UndecidableInstances #-}

12−

13−-----------------------------------------------------------------------------

14−-- |

15−-- Module : Data.Generics.Product.Internal.Typed

17−-- License : BSD3

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

19−-- Stability : experimental

20−-- Portability : non-portable

21−--

22−-- Derive record field getters and setters generically.

23−--

24−-----------------------------------------------------------------------------

25−

26−module Data.Generics.Product.Internal.Typed

27− ( GHasType (..)

28− ) where

29−

30−import Data.Generics.Internal.Families

31−import Data.Generics.Internal.Lens

32−

33−import Data.Kind (Type)

34−import GHC.Generics

35−

36−-- |As 'HasType' but over generic representations as defined by

37−-- "GHC.Generics".

38−class GHasType (f :: Type -> Type) a where

39− gtyped :: Lens' (f x) a

40−

41−instance GProductHasType l r a (HasTotalTypeP a l)

42− => GHasType (l :*: r) a where

43−

44− gtyped = gproductTyped @_ @_ @_ @(HasTotalTypeP a l)

45−

46−instance (GHasType l a, GHasType r a) => GHasType (l :+: r) a where

47− gtyped = combine (gtyped @l) (gtyped @r)

48−

49−instance GHasType (K1 R a) a where

50− gtyped f (K1 x) = fmap K1 (f x)

51−

52−instance GHasType f a => GHasType (M1 m meta f) a where

53− gtyped = mLens . gtyped

54−

55−class GProductHasType l r a (contains :: Bool) where

56− gproductTyped :: Lens' ((l :*: r) x) a

57−

58−instance GHasType l a => GProductHasType l r a 'True where

59− gproductTyped = first . gtyped

60−

61−instance GHasType r a => GProductHasType l r a 'False where

62− gproductTyped = second . gtyped

src/Data/Generics/Product/List.hsnew file+77

@@ -0,0 +1,77 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE FunctionalDependencies #-}

5+{-# LANGUAGE MonoLocalBinds #-}

6+{-# LANGUAGE ScopedTypeVariables #-}

7+{-# LANGUAGE TypeApplications #-}

8+{-# LANGUAGE TypeInType #-}

9+{-# LANGUAGE UndecidableInstances #-}

10+

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

12+-- |

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

15+-- License : BSD3

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

17+-- Stability : experimental

18+-- Portability : non-portable

19+--

20+-- Derive an isomorphism between a product type and a flat HList.

21+--

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

23+

24+module Data.Generics.Product.List

25+ ( IsList (..)

26+ , IsRecord

27+ , IsRecord'

28+ ) where

29+

30+import Data.Generics.Internal.Lens

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

32+import Data.Kind

33+import GHC.Generics

34+import GHC.TypeLits

35+

36+class IsList

37+ (m :: Type)

38+ (f :: Type)

39+ (g :: Type)

40+ (as :: [(m, Type)])

41+ (bs :: [(m, Type)]) | m f -> as, m g -> bs where

42+ list :: Iso f g (List as) (List bs)

43+

44+instance

45+ ( Generic f

46+ , Generic g

47+ , GIsList m (Rep f) (Rep g) as bs

48+ ) => IsList m f g as bs where

49+ list = repIso . (glist @m)

50+

51+class IsList Symbol f g as bs => IsRecord f g (as :: [(Symbol, Type)]) (bs :: [(Symbol, Type)]) | f -> as, g -> bs

52+instance IsList Symbol f g as bs => IsRecord f g as bs

53+

54+class IsRecord f f as as => IsRecord' f (as :: [(Symbol, Type)]) | f -> as

55+instance IsRecord f f as as => IsRecord' f as

56+

57+-- example (TODO: move elsewhere)

58+--class PrintRecord (rl :: [(Symbol, Type)]) where

59+-- printRecord' :: List rl -> String

60+--

61+--instance PrintRecord '[] where

62+-- printRecord' _ = ""

63+--

64+--instance (KnownSymbol field, Show a, PrintRecord xs) => PrintRecord ('(field, a) ': xs) where

65+-- printRecord' (x :> xs) = show x ++ ", " ++ printRecord' xs

66+--

67+--printRecord :: (IsRecord' rec rl, PrintRecord rl) => rec -> String

68+--printRecord rec = printRecord' (rec ^. list)

69+--

70+--data MyRecord = MyRecord

71+-- { field1 :: Int

72+-- , field2 :: String

73+-- , field3 :: Bool

74+-- } deriving Generic

75+--

76+-- >>> printRecord (MyRecord 10 "hello" False)

77+-- "10, \"hello\", False, "

src/Data/Generics/Product/Positions.hs+16−5

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE AllowAmbiguousTypes #-}

2{-# LANGUAGE AllowAmbiguousTypes #-}

2{-# LANGUAGE ConstraintKinds #-}

3{-# LANGUAGE ConstraintKinds #-}

3{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE DataKinds #-}

@@ -70,7 +71,7 @@ import GHC.TypeLits (type (<=?), Nat, TypeError, ErrorMessage(..))

70-- :}

71-- :}

72-- |Records that have a field at a given position.

73-- |Records that have a field at a given position.

73−class HasPosition (i :: Nat) s t a b | s i -> a, s i b -> t where

74+class HasPosition (i :: Nat) s t a b | s i -> a, t i -> b, s i b -> t, t i a -> s where

74 -- |A lens that focuses on a field at a given position. Compatible with the

75 -- |A lens that focuses on a field at a given position. Compatible with the

75 -- lens package's 'Control.Lens.Lens' type.

76 -- lens package's 'Control.Lens.Lens' type.

76 --

77 --

@@ -99,17 +100,27 @@ instance -- see Note [Changing type parameters]

99 ( Generic s

100 ( Generic s

100 , ErrorUnless i s (0 <? i && i <=? Size (Rep s))

101 , ErrorUnless i s (0 <? i && i <=? Size (Rep s))

101 , Generic t

102 , Generic t

103+ -- see Note [CPP in instance constraints]

104+#if __GLASGOW_HASKELL__ < 802

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

106+#else

102 , s' ~ Proxied s

107 , s' ~ Proxied s

108+ , t' ~ Proxied t

109+#endif

110+ , Generic s'

111+ , Generic t'

103 , GHasPosition' i (Rep s) a

112 , GHasPosition' i (Rep s) a

104 , GHasPosition' i (Rep s') a'

113 , GHasPosition' i (Rep s') a'

105− , GHasPosition 1 i (Rep s) (Rep t) a b

114+ , GHasPosition i (Rep s) (Rep t) a b

106− , '(t, b) ~ Infer s' a' a (PickTv a' b)

115+ , t ~ Infer s a' b

116+ , GHasPosition' i (Rep t') b'

117+ , s ~ Infer t b' a

107 ) => HasPosition i s t a b where

118 ) => HasPosition i s t a b where

108

119

109− position f s = ravel (repLens . gposition @1 @i) f s

120+ position f s = ravel (repLens . gposition @i) f s

110

121

111-- See Note [Uncluttering type signatures]

122-- See Note [Uncluttering type signatures]

112−instance {-# OVERLAPPING #-} HasPosition f (Void2 a t) t a b where

123+instance {-# OVERLAPPING #-} HasPosition f (Void1 a) (Void1 b) a b where

113 position = undefined

124 position = undefined

114

125

115type family ErrorUnless (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint where

126type family ErrorUnless (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint where

src/Data/Generics/Product/Typed.hs+3−3

@@ -33,7 +33,7 @@ module Data.Generics.Product.Typed

33import Data.Generics.Internal.Families

34import Data.Generics.Internal.Lens

35import Data.Generics.Internal.Void

36−import Data.Generics.Product.Internal.Typed

36+import Data.Generics.Product.Internal.Keyed

38import Data.Kind (Constraint, Type)

39import GHC.Generics (Generic (Rep))

@@ -108,10 +108,10 @@ class HasType a s where

108instance

109 ( Generic s

110 , ErrorUnlessOne a s (CollectTotalType a (Rep s))

111− , GHasType (Rep s) a

111+ , GHasKey a (Rep s) (Rep s) a a

112 ) => HasType a s where

113

114− typed = ravel (repLens . gtyped)

114+ typed = ravel (repLens . gkey @a)

115

116-- See Note [Uncluttering type signatures]

117instance {-# OVERLAPPING #-} HasType a Void where

src/Data/Generics/Sum/Constructors.hs+11−15

@@ -1,4 +1,5 @@

1{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FunctionalDependencies #-}

5{-# LANGUAGE FunctionalDependencies #-}

@@ -29,7 +30,6 @@ module Data.Generics.Sum.Constructors

30 -- $setup

31 -- $setup

31 AsConstructor (..)

32 AsConstructor (..)

32− , _CtorRaw

33 ) where

35import Data.Generics.Internal.Families

@@ -104,30 +104,26 @@ instance

104 ( Generic s

105 , ErrorUnless ctor s (HasCtorP ctor (Rep s))

106 , Generic t

107+ -- see Note [CPP in instance constraints]

108+#if __GLASGOW_HASKELL__ < 802

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

110+#else

107 , s' ~ Proxied s

111 , s' ~ Proxied s

112+ , t' ~ Proxied t

113+#endif

108 , Generic s'

114 , Generic s'

115+ , Generic t'

109 , GAsConstructor' ctor (Rep s) a

116 , GAsConstructor' ctor (Rep s) a

110 , GAsConstructor' ctor (Rep s') a'

117 , GAsConstructor' ctor (Rep s') a'

111 , GAsConstructor ctor (Rep s) (Rep t) a b

118 , GAsConstructor ctor (Rep s) (Rep t) a b

112− , '(t, b) ~ Infer s' a' a (PickTv a' b)

119+ , t ~ Infer s a' b

120+ , GAsConstructor' ctor (Rep t') b'

121+ , s ~ Infer t b' a

113 ) => AsConstructor ctor s t a b where

122 ) => AsConstructor ctor s t a b where

114

123

115 _Ctor eta = prismRavel (repIsoP . _GCtor @ctor) eta

124 _Ctor eta = prismRavel (repIsoP . _GCtor @ctor) eta

116 {-# INLINE _Ctor #-}

125 {-# INLINE _Ctor #-}

117

126

118−-- Used for testing the optimisation passes

119−_CtorRaw :: forall ctor s t s' a' a b . ( Generic s

120− , ErrorUnless ctor s (HasCtorP ctor (Rep s))

121− , Generic t

122− , s' ~ Proxied s

123− , Generic s'

124− , GAsConstructor' ctor (Rep s) a

125− , GAsConstructor' ctor (Rep s') a'

126− , GAsConstructor ctor (Rep s) (Rep t) a b

127− , '(t, b) ~ Infer s' a' a (PickTv a' b)

128− ) => PrismP s t a b

129−_CtorRaw = repIsoP . _GCtor @ctor

130−

131-- See Note [Uncluttering type signatures]

127-- See Note [Uncluttering type signatures]

132instance {-# OVERLAPPING #-} AsConstructor ctor (Void1 a) (Void1 b) a b where

128instance {-# OVERLAPPING #-} AsConstructor ctor (Void1 a) (Void1 b) a b where

133 _Ctor = undefined

129 _Ctor = undefined

src/Data/Generics/Sum/Internal/Constructors.hs+8−5

@@ -30,11 +30,12 @@ module Data.Generics.Sum.Internal.Constructors

30 ) where

32import Data.Generics.Internal.Families

33−import Data.Generics.Internal.HList

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

34import Data.Generics.Internal.Lens

36import GHC.Generics

37import GHC.TypeLits (Symbol)

38+import Data.Kind

39-- |As 'AsConstructor' but over generic representations as defined by

40-- |As 'AsConstructor' but over generic representations as defined by

40-- "GHC.Generics".

41-- "GHC.Generics".

@@ -44,14 +45,16 @@ class GAsConstructor (ctor :: Symbol) s t a b | ctor s -> a, ctor t -> b where

44type GAsConstructor' ctor s a = GAsConstructor ctor s s a a

45type GAsConstructor' ctor s a = GAsConstructor ctor s s a a

46instance

47instance

47− ( GCollectible f as

48+ ( GIsList Type f f as as

48− , GCollectible g bs

49+ , GIsList Type g g bs bs

49 , ListTuple a as

50 , ListTuple a as

50 , ListTuple b bs

51 , ListTuple b bs

51 ) => GAsConstructor ctor (M1 C ('MetaCons ctor fixity fields) f) (M1 C ('MetaCons ctor fixity fields) g) a b where

52 ) => GAsConstructor ctor (M1 C ('MetaCons ctor fixity fields) f) (M1 C ('MetaCons ctor fixity fields) g) a b where

53− _GCtor = prismP (M1 . gfromCollection . tupleToList) (Right . listToTuple . gtoCollection . unM1)

54+-- _GCtor = prismP (M1 . gfromCollection . tupleToList) (Right . listToTuple . gtoCollection . unM1)

54− {-# INLINE _GCtor #-}

55+-- {-# INLINE _GCtor #-}

56+ _GCtor = prismP (M1 . (^. fromIso (glist @Type)) . tupleToList) (Right . listToTuple . (^. glist @Type) . unM1)

57+

56instance GSumAsConstructor ctor (HasCtorP ctor l) l r l' r' a b => GAsConstructor ctor (l :+: r) (l' :+: r') a b where

59instance GSumAsConstructor ctor (HasCtorP ctor l) l r l' r' a b => GAsConstructor ctor (l :+: r) (l' :+: r') a b where

57 _GCtor = _GSumCtor @ctor @(HasCtorP ctor l)

60 _GCtor = _GSumCtor @ctor @(HasCtorP ctor l)

src/Data/Generics/Sum/Internal/Subtype.hs+12−28

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

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE PolyKinds #-}

1{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FlexibleInstances #-}

3{-# LANGUAGE KindSignatures #-}

5{-# LANGUAGE KindSignatures #-}

@@ -25,7 +27,8 @@ module Data.Generics.Sum.Internal.Subtype

25 ( GAsSubtype (..)

27 ( GAsSubtype (..)

26 ) where

28 ) where

28−import Data.Generics.Internal.HList

30+import Data.Generics.Internal.Lens

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

29import Data.Generics.Sum.Internal.Typed

32import Data.Generics.Sum.Internal.Typed

31import Data.Kind

34import Data.Kind

@@ -34,41 +37,22 @@ import GHC.Generics

34-- |As 'AsSubtype' but over generic representations as defined by

37-- |As 'AsSubtype' but over generic representations as defined by

35-- "GHC.Generics".

38-- "GHC.Generics".

36class GAsSubtype (subf :: Type -> Type) (supf :: Type -> Type) where

39class GAsSubtype (subf :: Type -> Type) (supf :: Type -> Type) where

37− ginjectSub :: subf x -> supf x

40+ _GSub :: Prism' (supf x) (subf x)

38− gprojectSub :: supf x -> Either (supf x) (subf x)

40instance

42instance

41 ( GAsSubtype l supf

43 ( GAsSubtype l supf

42 , GAsSubtype r supf

44 , GAsSubtype r supf

43 ) => GAsSubtype (l :+: r) supf where

45 ) => GAsSubtype (l :+: r) supf where

44−

46+ _GSub = without' _GSub _GSub . fromIso sumIso

45− ginjectSub x = case x of

46− L1 l -> ginjectSub l

47− R1 r -> ginjectSub r

48− gprojectSub x

49− = case gprojectSub x of

50− Right y -> Right (L1 y)

51− _ -> fmap R1 (gprojectSub x)

53instance

48instance

49+ ( GIsList () subf subf as as

54− ( GAsType supf a

50+ , GAsType supf as

55− , GCollectible subf as

56− , ListTuple a as

57 ) => GAsSubtype (C1 meta subf) supf where

51 ) => GAsSubtype (C1 meta subf) supf where

52+ _GSub = _GTyped . fromIso (glist @()) . fromIso mIso

59− ginjectSub

60− = ginjectTyped . listToTuple . gtoCollection . unM1

61− gprojectSub

62− = fmap (M1 . gfromCollection . tupleToList) . gprojectTyped

63−

64−instance GAsType supf a => GAsSubtype (S1 meta (Rec0 a)) supf where

54+-- instance GAsType supf a => GAsSubtype (S1 meta (Rec0 a)) supf where

65− ginjectSub

55+-- _GSub = _GTyped . fromIso (mIso . kIso)

66− = ginjectTyped @supf . unK1 . unM1

67− gprojectSub

68− = fmap (M1 . K1) . gprojectTyped @supf

70instance GAsSubtype subf supf => GAsSubtype (D1 meta subf) supf where

57instance GAsSubtype subf supf => GAsSubtype (D1 meta subf) supf where

71− ginjectSub

58+ _GSub = _GSub . fromIso mIso

72− = ginjectSub . unM1

73− gprojectSub

74− = fmap M1 . gprojectSub

src/Data/Generics/Sum/Internal/Typed.hs+24−53

@@ -1,14 +1,14 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE FlexibleInstances #-}

5−{-# LANGUAGE KindSignatures #-}

5+{-# LANGUAGE KindSignatures #-}

6−{-# LANGUAGE MultiParamTypeClasses #-}

6+{-# LANGUAGE MultiParamTypeClasses #-}

7−{-# LANGUAGE ScopedTypeVariables #-}

7+{-# LANGUAGE ScopedTypeVariables #-}

8−{-# LANGUAGE TypeApplications #-}

8+{-# LANGUAGE TypeApplications #-}

9−{-# LANGUAGE TypeFamilies #-}

9+{-# LANGUAGE TypeFamilies #-}

10−{-# LANGUAGE TypeOperators #-}

10+{-# LANGUAGE TypeOperators #-}

11−{-# LANGUAGE UndecidableInstances #-}

11+{-# LANGUAGE UndecidableInstances #-}

13-----------------------------------------------------------------------------

14-- |

@@ -31,58 +31,29 @@ import Data.Kind

31import GHC.Generics

33import Data.Generics.Internal.Families

34−import Data.Generics.Internal.HList

34+import Data.Generics.Product.Internal.List

35import Data.Generics.Internal.Lens

37-- |As 'AsType' but over generic representations as defined by "GHC.Generics".

38−class GAsType (f :: Type -> Type) a where

38+class GAsType (f :: Type -> Type) (as :: [((), Type)]) where

39− _GTyped :: Prism' (f x) a

39+ _GTyped :: Prism' (f x) (List as)

40− _GTyped = prism ginjectTyped gprojectTyped

41−

42− ginjectTyped :: a -> f x

43− gprojectTyped :: f x -> Either (f x) a

45instance

41instance

46− ( GCollectible f as

42+ ( GIsList () f f as as

47− , ListTuple a as

48− ) => GAsType (M1 C meta f) a where

43+ ) => GAsType (M1 C meta f) as where

49−

44+ _GTyped = mIso . glist @()

50− ginjectTyped

51− = M1 . gfromCollection . tupleToList

52− gprojectTyped

53− = Right . listToTuple . gtoCollection . unM1

55−instance GSumAsType (HasPartialTypeTupleP a l) l r a => GAsType (l :+: r) a where

46+instance GSumAsType (HasPartialTypeP a l) l r a => GAsType (l :+: r) a where

56− ginjectTyped

47+ _GTyped = _GSumTyped @(HasPartialTypeP a l)

57− = ginjectSumTyped @(HasPartialTypeTupleP a l) @l @r @a

58− gprojectTyped

59− = gprojectSumTyped @(HasPartialTypeTupleP a l) @l @r @a

61instance GAsType f a => GAsType (M1 D meta f) a where

49instance GAsType f a => GAsType (M1 D meta f) a where

62− ginjectTyped

50+ _GTyped = mIso . _GTyped

63− = M1 . ginjectTyped

64− gprojectTyped

65− = either (Left . M1) Right . gprojectTyped . unM1

66−

67−class GSumAsType (contains :: Bool) l r a where

68− _GSumTyped :: Prism' ((l :+: r) x) a

69− _GSumTyped = prism (ginjectSumTyped @contains) (gprojectSumTyped @contains)

71− ginjectSumTyped :: a -> (l :+: r) x

52+class GSumAsType (contains :: Bool) l r (a :: [((), Type)]) where

72− gprojectSumTyped :: (l :+: r) x -> Either ((l :+: r) x) a

53+ _GSumTyped :: Prism' ((l :+: r) x) (List a)

74instance GAsType l a => GSumAsType 'True l r a where

55instance GAsType l a => GSumAsType 'True l r a where

75− ginjectSumTyped

56+ _GSumTyped = left . _GTyped

76− = L1 . ginjectTyped

77− gprojectSumTyped x

78− = case x of

79− L1 l -> either (Left . L1) Right (gprojectTyped l)

80− R1 _ -> Left x

82instance GAsType r a => GSumAsType 'False l r a where

58instance GAsType r a => GSumAsType 'False l r a where

83− ginjectSumTyped

59+ _GSumTyped = right . _GTyped

84− = R1 . ginjectTyped

85− gprojectSumTyped x

86− = case x of

87− R1 r -> either (Left . R1) Right (gprojectTyped r)

88− L1 _ -> Left x

src/Data/Generics/Sum/Subtype.hs+6−4

@@ -1,3 +1,4 @@

1+{-# LANGUAGE TypeApplications #-}

1{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE FlexibleInstances #-}

3{-# LANGUAGE FlexibleInstances #-}

3{-# LANGUAGE MultiParamTypeClasses #-}

4{-# LANGUAGE MultiParamTypeClasses #-}

@@ -30,7 +31,7 @@ import Data.Generics.Internal.Lens

30import Data.Generics.Internal.Void

31import Data.Generics.Internal.Void

31import Data.Generics.Sum.Internal.Subtype

32import Data.Generics.Sum.Internal.Subtype

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

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

35-- $setup

36-- $setup

36-- == /Running example:/

37-- == /Running example:/

@@ -91,11 +92,13 @@ class AsSubtype sub sup where

92 -- |Injects a subtype into a supertype (upcast).

93 -- |Injects a subtype into a supertype (upcast).

93 injectSub :: sub -> sup

94 injectSub :: sub -> sup

95+ injectSub = (_Sub @sub @sup #)

95 -- |Projects a subtype from a supertype (downcast).

97 -- |Projects a subtype from a supertype (downcast).

96 projectSub :: sup -> Either sup sub

98 projectSub :: sup -> Either sup sub

99+ projectSub = withPrism (_Sub @sub @sup) (\_ b -> b)

100

98− {-# MINIMAL injectSub, projectSub #-}

101+ {-# MINIMAL (injectSub, projectSub) | _Sub #-}

102

100instance

103instance

101 ( Generic sub

104 ( Generic sub

@@ -103,8 +106,7 @@ instance

103 , GAsSubtype (Rep sub) (Rep sup)

106 , GAsSubtype (Rep sub) (Rep sup)

104 ) => AsSubtype sub sup where

107 ) => AsSubtype sub sup where

105

108

106− injectSub = to . ginjectSub . from

109+ _Sub = repIso . _GSub . fromIso repIso

107− projectSub = either (Left . to) (Right . to) . gprojectSub . from

108

110

109-- See Note [Uncluttering type signatures]

111-- See Note [Uncluttering type signatures]

110instance {-# OVERLAPPING #-} AsSubtype a Void where

112instance {-# OVERLAPPING #-} AsSubtype a Void where

src/Data/Generics/Sum/Typed.hs+18−9

@@ -1,3 +1,4 @@

1+{-# LANGUAGE TypeApplications #-}

1{-# LANGUAGE AllowAmbiguousTypes #-}

2{-# LANGUAGE AllowAmbiguousTypes #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleContexts #-}

@@ -37,6 +38,7 @@ import Data.Generics.Sum.Internal.Typed

37import Data.Generics.Internal.Families

38import Data.Generics.Internal.Families

38import Data.Generics.Internal.Lens

39import Data.Generics.Internal.Lens

39import Data.Generics.Internal.Void

40import Data.Generics.Internal.Void

41+import Data.Generics.Product.Internal.List

41-- $setup

43-- $setup

42-- >>> :set -XTypeApplications

44-- >>> :set -XTypeApplications

@@ -87,23 +89,30 @@ class AsType a s where

88 -- |Inject by type.

90 -- |Inject by type.

89 injectTyped :: a -> s

91 injectTyped :: a -> s

92+ injectTyped

93+ = (_Typed #)

91 -- |Project by type.

95 -- |Project by type.

92 projectTyped :: s -> Maybe a

96 projectTyped :: s -> Maybe a

97+ projectTyped

98+ = either (const Nothing) Just . (withPrism _Typed (\_ b -> b))

94instance

100instance

95 ( Generic s

101 ( Generic s

96− , ErrorUnlessOne a s (CollectPartialType a (Rep s))

102+ , ErrorUnlessOne a s (CollectPartialType as (Rep s))

103+ , as ~ TupleToList a

104+ , ListTuple a as

97− , GAsType (Rep s) a

105+ , GAsType (Rep s) as

98 ) => AsType a s where

106 ) => AsType a s where

107

100− _Typed

108+-- _Typed

101− = prism injectTyped (either (Left . to) Right . gprojectTyped . from)

109+-- = prism injectTyped (either (Left . to) Right . gprojectTyped . from)

102− {-# INLINE _Typed #-}

110+-- {-# INLINE _Typed #-}

103− injectTyped

111+-- injectTyped

104− = to . ginjectTyped

112+-- = to . ginjectTyped

105− projectTyped

113+-- projectTyped

106− = either (const Nothing) Just . gprojectTyped . from

114+-- = either (const Nothing) Just . gprojectTyped . from

115+ _Typed = repIso . _GTyped @_ @as . tupled

107

116

108-- See Note [Uncluttering type signatures]

117-- See Note [Uncluttering type signatures]

109instance {-# OVERLAPPING #-} AsType a Void where

118instance {-# OVERLAPPING #-} AsType a Void where

test/24.hsnew file+47

@@ -0,0 +1,47 @@

1+{-# LANGUAGE DataKinds, DeriveGeneric, TypeApplications #-}

3+module Main where

5+-- Test case from #24, comments preserved

6+import Control.Lens

7+import Data.Generics.Product.Fields

8+import Data.Generics.Product.Positions

9+import GHC.Generics

10+

11+data Foo a b = Foo { x1 :: a, x2 :: b } deriving (Generic, Show)

12+

13+data Bar a b = Bar { x3 :: Foo a b, x4 :: Int } deriving (Generic, Show)

14+

15+tup :: ((Int, Char), Int)

16+tup = ((1, 'a'), 2)

17+tup2, tup3, tup4 :: ((Char, Char), Int)

18+tup2 = tup & _1 . _1 %~ toEnum -- Works.

19+tup3 = tup & x %~ toEnum -- Works also with type annotation.

20+ where x :: Lens ((Int, Char), Int) ((Char, Char), Int) Int Char

21+ x = _1 . _1

22+-- Works.

23+tup4 = tup & position @1 . position @1 %~ toEnum

24+

25+foo :: Foo Int Char

26+foo = Foo 1 'a'

27+foo2, foo3 :: Foo Char Char

28+foo2 = foo & field @"x1" %~ toEnum -- Works when there's just one 'field'.

29+foo3 = foo & position @1 %~ toEnum -- Works when there's just one 'position'.

30+

31+bar :: Bar Int Char

32+bar = Bar (Foo 1 'a') 2

33+bar2, bar3, bar4 :: Bar Char Char

34+-- Doesn't work, error at first 'field' (Couldn't match type ‘Int’ with ‘Char’ arising from a use of ‘field’).

35+bar2 = bar & field @"x3" . field @"x1" %~ toEnum

36+-- Type annotation doesn't help.

37+bar3 = bar & l %~ toEnum

38+ where l :: Lens (Bar Int Char) (Bar Char Char) Int Char

39+ l = field @"x3" . field @"x1"

40+-- Doesn't work, error at first 'position' (Couldn't match type ‘Int’ with ‘Char’ arising from a use of ‘position’).

41+bar4 = bar & position @1 . position @1 %~ toEnum

42+-- Works if we stick to simple Lens' (modify to the same type).

43+bar5 :: Bar Int Char

44+bar5 = bar & field @"x3" . field @"x1" %~ (+1)

45+

46+main :: IO ()

47+main = print bar5

test/25.hsnew file+33

@@ -0,0 +1,33 @@

1+{-# LANGUAGE DuplicateRecordFields #-}

2+{-# LANGUAGE TypeApplications #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE DeriveGeneric #-}

5+{-# OPTIONS_GHC -Wall #-}

7+module Main where

9+import Control.Lens

10+import Data.Generics.Product

11+import GHC.Generics

12+

13+data Record1 = Record1

14+ { field1 :: Int

15+ , field2 :: Double

16+ } deriving (Generic)

17+

18+class Default a where

19+ def :: a

20+

21+instance Default Record1 where

22+ def = Record1 0 0.0

23+

24+f :: Record1 -> Int

25+f r = r ^. field @"field1"

26+

27+main :: IO ()

28+main = do

29+ print $ f def

30+ print $ f ( field @"field1" .~ 1 $ (def :: Record1))

31+ print $ f ( field @"field1" .~ 2 $ Record1 0 0.0)

32+ print $ f ( field @"field1" .~ (1 :: Int) $ def)

33+ print $ f ( position @1 .~ (1 :: Int) $ def)

test/Spec.hs+4−3

@@ -1,4 +1,5 @@

1{-# OPTIONS_GHC -O -fplugin Test.Inspection.Plugin #-}

2+{-# OPTIONS_GHC -dsuppress-all #-}

3{-# LANGUAGE AllowAmbiguousTypes #-}

4{-# LANGUAGE AllowAmbiguousTypes #-}

4{-# LANGUAGE DataKinds #-}

5{-# LANGUAGE DataKinds #-}

@@ -159,8 +160,8 @@ typeChangingGenericCompose = field @"fieldA" . field @"fieldA"

159sum1PrismB :: Prism Sum1 Sum1 Int Int

160sum1PrismB :: Prism Sum1 Sum1 Int Int

160sum1PrismB = _Ctor @"B"

161sum1PrismB = _Ctor @"B"

161

162

162−sum1PrismBP :: PrismP Sum1 Sum1 Int Int

163+--sum1PrismBP :: PrismP Sum1 Sum1 Int Int

163−sum1PrismBP = prismPRavel (_CtorRaw @"B")

164+--sum1PrismBP = prismPRavel (_CtorRaw @"B")

164

165

165subtypePrismGeneric :: Prism Sum1 Sum1 Sum2 Sum2

166subtypePrismGeneric :: Prism Sum1 Sum1 Sum2 Sum2

166subtypePrismGeneric = _Sub

167subtypePrismGeneric = _Sub

@@ -178,6 +179,6 @@ tests = TestList $ map mkHUnitTest

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

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

179 , $(inspectTest $ 'intTraversalManual === 'intTraversalDerived)

180 , $(inspectTest $ 'intTraversalManual === 'intTraversalDerived)

180 , $(inspectTest $ 'sum1PrismManual === 'sum1PrismB)

181 , $(inspectTest $ 'sum1PrismManual === 'sum1PrismB)

181− , $(inspectTest $ 'sum1PrismPManual === 'sum1PrismBP)

182+ -- , $(inspectTest $ 'sum1PrismPManual === 'sum1PrismBP)

182 , $(inspectTest $ 'subtypePrismManual === 'subtypePrismGeneric)

183 , $(inspectTest $ 'subtypePrismManual === 'subtypePrismGeneric)

183 , $(inspectTest $ 'sum1PrismManual === 'sum1TypePrism) ]

184 , $(inspectTest $ 'sum1PrismManual === 'sum1TypePrism) ]