6bd22ca · generic-lens

generic-lens.cabal+10−3

compare with master

unifiedsplit

@@ -32,15 +32,22 @@ cabal-version: >= 1.10

32

33

34library

35− exposed-modules: Data.Generics.Record

35+ exposed-modules: Data.Generics.Product

36− , Data.Generics.Product

36+ , Data.Generics.Product.Fields

37+ , Data.Generics.Product.Typed

38+

39+ , Data.Generics.Record

37 , Data.Generics.Record.Subtype

40 , Data.Generics.Record.Subtype

38 , Data.Generics.Record.HasField

41 , Data.Generics.Record.HasField

39 , Data.Generics.Product.HasFieldAt

42 , Data.Generics.Product.HasFieldAt

40 , Data.Generics.Internal.Lens

43 , Data.Generics.Internal.Lens

41 , Data.Generics.Sum.HasConstructor

44 , Data.Generics.Sum.HasConstructor

42

45

43− other-modules: Data.Generics.Record.Internal.Contains

46+ other-modules: Data.Generics.Internal.Families

47+ , Data.Generics.Internal.Families.Count

48+ , Data.Generics.Internal.Families.Find

49+

50+ , Data.Generics.Record.Internal.Contains

44

51

45 other-extensions: AllowAmbiguousTypes

52 other-extensions: AllowAmbiguousTypes

46 , DataKinds

53 , DataKinds

src/Data/Generics/Internal/Families.hsnew file+6

@@ -0,0 +1,6 @@

1+module Data.Generics.Internal.Families

2+ ( module Families

3+ ) where

4+

5+import Data.Generics.Internal.Families.Count as Families

6+import Data.Generics.Internal.Families.Find as Families

src/Data/Generics/Internal/Families/Count.hsnew file+51

@@ -0,0 +1,51 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE PolyKinds #-}

3+{-# LANGUAGE TypeFamilies #-}

4+{-# LANGUAGE TypeOperators #-}

5+{-# LANGUAGE UndecidableInstances #-}

6+

7+module Data.Generics.Internal.Families.Count

8+ ( CountType

9+ ) where

10+

11+import GHC.Generics

12+import GHC.TypeLits

13+

14+type family CountType t f :: Counted where

15+ CountType t (S1 _ (Rec0 t))

16+ = 'One

17+ CountType t (l :*: r)

18+ = CountType t l <|> CountType t r

19+ CountType t (l :+: r)

20+ = CountType t l <&> CountType t r

21+ CountType t (S1 _ _)

22+ = 'None

23+ CountType t (C1 _ f)

24+ = CountType t f

25+ CountType t (D1 _ f)

26+ = CountType t f

27+ CountType t (Rec0 _)

28+ = 'None

29+ CountType t U1

30+ = 'None

31+ CountType t V1

32+ = 'None

33+ CountType t f

34+ = TypeError

35+ ( 'ShowType f

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

37+ )

38+

39+data Counted

40+ = None

41+ | One

42+ | Multiple

43+

44+type family (a :: Counted) <|> (b :: Counted) :: Counted where

45+ 'None <|> b = b

46+ a <|> 'None = a

47+ a <|> b = 'Multiple

48+

49+type family (a :: Counted) <&> (b :: Counted) :: Counted where

50+ a <&> a = a

51+ _ <&> _ = 'Multiple

src/Data/Generics/Internal/Families/Find.hsnew file+49

@@ -0,0 +1,49 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE PolyKinds #-}

3+{-# LANGUAGE TypeFamilies #-}

4+{-# LANGUAGE TypeOperators #-}

5+{-# LANGUAGE UndecidableInstances #-}

6+

7+module Data.Generics.Internal.Families.Find

8+ ( FindField

9+ ) where

10+

11+import Data.Kind (Type)

12+import GHC.Generics

13+import GHC.TypeLits

14+

15+-- | Look up a record field by name in the generic representation, and return

16+-- its corresponding type, if exists.

17+type family FindField (field :: Symbol) f :: Maybe Type where

18+ FindField field (S1 ('MetaSel ('Just field) _ _ _) (Rec0 t))

19+ = 'Just t

20+ FindField field (l :*: r)

21+ = FindField field l <|> FindField field r

22+ FindField field (l :+: r)

23+ = FindField field l <&> FindField field r

24+ FindField field (S1 _ _)

25+ = 'Nothing

26+ FindField field (C1 m f)

27+ = FindField field f

28+ FindField field (D1 m f)

29+ = FindField field f

30+ FindField field (Rec0 _)

31+ = 'Nothing

32+ FindField field U1

33+ = 'Nothing

34+ FindField field V1

35+ = 'Nothing

36+ FindField field f

37+ = TypeError

38+ ( 'ShowType f

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

40+ )

41+

42+-- | Type-level alternative monomorphised to @Maybe@.

43+type family (a :: Maybe k) <|> (b :: Maybe k) :: Maybe k where

44+ 'Just a <|> _ = 'Just a

45+ _ <|> b = b

46+

47+type family (a :: Maybe k) <&> (b :: Maybe k) :: Maybe k where

48+ 'Just a <&> 'Just a = 'Just a

49+ _ <&> _ = 'Nothing

src/Data/Generics/Internal/Lens.hs+5−15

@@ -15,18 +15,10 @@

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

16module Data.Generics.Internal.Lens where

17

18−import Control.Applicative ( Const (..) )

18+import Control.Applicative (Const(..))

19+import Data.Functor.Identity (Identity(..))

20+import Data.Profunctor (Choice(right'), Profunctor(dimap))

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

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

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

21−

22−-- | Identity functor

23−newtype Identity a

24− = Identity { runIdentity :: a }

25−

26−-- | Functor instance

27−instance Functor Identity where

28− fmap f (Identity a)

29− = Identity (f a)

30

22

31-- | Type alias for lens

23-- | Type alias for lens

32type Lens' s a

24type Lens' s a

@@ -36,7 +28,6 @@ type Lens' s a

36type Prism' s a

28type Prism' s a

37 = forall p f. (Choice p, Applicative f) => p a (f a) -> p s (f s)

29 = forall p f. (Choice p, Applicative f) => p a (f a) -> p s (f s)

38

30

39−

40type Iso' s a

31type Iso' s a

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

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

42

33

@@ -70,7 +61,7 @@ right = prism R1 $ \x -> case x of

70 L1 _ -> Left x

61 L1 _ -> Left x

71 R1 a -> Right a

62 R1 a -> Right a

72

63

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

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

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

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

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

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

76

67

@@ -97,4 +88,3 @@ _Left = prism Left $ either Right (Left . Right)

97

88

98_Right :: Prism' (Either c a) a

89_Right :: Prism' (Either c a) a

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

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

100−

src/Data/Generics/Product/Fields.hsnew file+60

@@ -0,0 +1,60 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE FunctionalDependencies #-}

5+{-# LANGUAGE KindSignatures #-}

6+{-# LANGUAGE MultiParamTypeClasses #-}

7+{-# LANGUAGE ScopedTypeVariables #-}

8+{-# LANGUAGE TypeApplications #-}

9+{-# LANGUAGE TypeOperators #-}

10+{-# LANGUAGE UndecidableInstances #-}

11+

12+module Data.Generics.Product.Fields

13+ ( HasField (..)

14+

15+ , GHasField (..)

16+ ) where

17+

18+import Data.Generics.Internal.Families

19+import Data.Generics.Internal.Lens

20+

21+import Data.Kind (Type)

22+import GHC.Generics

23+import GHC.TypeLits

24+

25+class HasField (field :: Symbol) a s | s field -> a where

26+ field :: Lens' s a

27+

28+class GHasField (field :: Symbol) (f :: Type -> Type) a | field f -> a where

29+ gfield :: Lens' (f x) a

30+

31+instance GProductHasField field l r a (FindField field l)

32+ => GHasField field (l :*: r) a where

33+

34+ gfield = gproductField @field @_ @_ @_ @(FindField field l)

35+

36+instance (GHasField field l a, GHasField field r a)

37+ => GHasField field (l :+: r) a where

38+

39+ gfield = combine (gfield @field @l) (gfield @field @r)

40+

41+instance GHasField field (S1 ('MetaSel ('Just field) upkd str infstr) (Rec0 a)) a where

42+ gfield = mIso . gfield @field

43+

44+instance GHasField field (K1 R a) a where

45+ gfield f (K1 x) = fmap K1 (f x)

46+

47+instance GHasField field f a => GHasField field (M1 D meta f) a where

48+ gfield = mIso . gfield @field

49+

50+instance GHasField field f a => GHasField field (M1 C meta f) a where

51+ gfield = mIso . gfield @field

52+

53+class GProductHasField (field :: Symbol) l r a (contains :: Maybe Type) | field l r -> a where

54+ gproductField :: Lens' ((l :*: r) x) a

55+

56+instance GHasField field l a => GProductHasField field l r a ('Just a) where

57+ gproductField = first . gfield @field

58+

59+instance GHasField field r a => GProductHasField field l r a 'Nothing where

60+ gproductField = second . gfield @field

src/Data/Generics/Product/HasFieldAt.hs+14−14

@@ -1,14 +1,14 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FunctionalDependencies #-}

5−{-# LANGUAGE PolyKinds #-}

5+{-# LANGUAGE PolyKinds #-}

6−{-# LANGUAGE Rank2Types #-}

6+{-# LANGUAGE Rank2Types #-}

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

12

13-----------------------------------------------------------------------------

14-- |

@@ -103,9 +103,9 @@ type family Search offset index f g :: Choice where

103 Search offset index f g = Choose (ContainsAt offset index f) (ContainsAt (offset + Size f) index g)

104

105type family Choose f g :: Choice where

106− Choose 'True _ = 'GoLeft

106+ Choose 'True _ = 'GoLeft

107 Choose _ 'True = 'GoRight

108− Choose _ _ = TypeError ('Text "Could not find type")

108+ Choose _ _ = TypeError ('Text "Could not find type")

109

110-- | Try find a field by position in the generic representation.

111type family ContainsAt (offset :: Nat) (index :: Nat) f :: Bool where

@@ -157,8 +157,8 @@ class GHasFieldAt (offset :: Nat) (index :: Nat) (s :: Type -> Type) a | offset

157instance

158 ( choice ~ (Search offset index s s')

159 , offset' ~ Offset offset choice (Size s)

160− , GHasFieldAtProd offset' index s s' a choice

160+ , GHasFieldAtProd offset' index s s' a choice

161− )

161+ )

162 => GHasFieldAt offset index (s :*: s') a where

163 gItemAt = prodItemAt @offset' @index @_ @_ @_ @choice

164

src/Data/Generics/Product/Typed.hsnew file+39

@@ -0,0 +1,39 @@

1+{-# LANGUAGE FlexibleInstances #-}

2+{-# LANGUAGE KindSignatures #-}

3+{-# LANGUAGE MultiParamTypeClasses #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

5+{-# LANGUAGE TypeApplications #-}

6+{-# LANGUAGE TypeOperators #-}

7+

8+module Data.Generics.Product.Typed

9+ ( HasType (..)

10+

11+ ) where

12+

13+import Data.Generics.Internal.Families

14+import Data.Generics.Internal.Lens

15+

16+import Data.Kind (Type)

17+import GHC.Generics

18+import GHC.TypeLits

19+

20+class HasType a s where

21+ typed :: Lens' s a

22+

23+class GHasType (f :: Type -> Type) a where

24+ gtyped :: Lens' (f x) a

25+

26+instance (GHasType l a, GHasType r a) => GHasType (l :+: r) a where

27+ gtyped = combine (gtyped @l) (gtyped @r)

28+

29+instance GHasType (S1 meta (Rec0 a)) a where

30+ gtyped = mIso . gtyped

31+

32+instance GHasType (K1 R a) a where

33+ gtyped f (K1 x) = fmap K1 (f x)

34+

35+instance GHasType f a => GHasType (M1 D meta f) a where

36+ gtyped = mIso . gtyped

37+

38+instance GHasType f a => GHasType (M1 C meta f) a where

39+ gtyped = mIso . gtyped

src/Data/Generics/Record/HasField.hs+12−12

@@ -94,29 +94,20 @@ class HasField (field :: Symbol) a s | s field -> a where

94-- field.

95instance

96 ( Generic s

97− , Contains field (Rep s) ~ 'Just a -- this is needed for the fundep

97+ , ContainsField field (Rep s) ~ 'Just a -- this is needed for the fundep

98 , GHasField field (Rep s) a

99 ) => HasField field a s where

100 label = repIso . glabel @field

101

102

103−class GHasFieldProd field a b ret (w :: Maybe Type) | field a b -> ret where

104− prodLabel :: Lens' ((a :*: b) x) ret

105−

106−instance (GHasField field f ret) => GHasFieldProd field f g ret ('Just ret) where

107− prodLabel = first . glabel @field

108−

109−instance (GHasField field g ret) => GHasFieldProd field f g ret 'Nothing where

110− prodLabel = second . glabel @field

111−

112--------------------------------------------------------------------------------

103--------------------------------------------------------------------------------

113

104

114-- | Like 'HasField', but on the generic representation

105-- | Like 'HasField', but on the generic representation

115class GHasField (field :: Symbol) (s :: Type -> Type) a | field s -> a where

106class GHasField (field :: Symbol) (s :: Type -> Type) a | field s -> a where

116 glabel :: Lens' (s x) a

107 glabel :: Lens' (s x) a

117

108

118−instance (GHasFieldProd field s s' a (Contains field s)) => GHasField field (s :*: s') a where

109+instance (GHasFieldProd field s s' a (ContainsField field s)) => GHasField field (s :*: s') a where

119− glabel = prodLabel @field @_ @_ @_ @(Contains field s)

110+ glabel = prodLabel @field @_ @_ @_ @(ContainsField field s)

120

111

121instance (GHasField field s a, GHasField field s' a) => GHasField field (s :+: s') a where

112instance (GHasField field s a, GHasField field s' a) => GHasField field (s :+: s') a where

122 glabel = combine (glabel @field @s) (glabel @field @s')

113 glabel = combine (glabel @field @s) (glabel @field @s')

@@ -132,3 +123,12 @@ instance GHasField field s a => GHasField field (M1 D c s) a where

132

123

133instance GHasField field s a => GHasField field (M1 C c s) a where

124instance GHasField field s a => GHasField field (M1 C c s) a where

134 glabel = mIso . glabel @field

125 glabel = mIso . glabel @field

126+

127+class GHasFieldProd field a b ret (w :: Maybe Type) | field a b -> ret where

128+ prodLabel :: Lens' ((a :*: b) x) ret

129+

130+instance (GHasField field f ret) => GHasFieldProd field f g ret ('Just ret) where

131+ prodLabel = first . glabel @field

132+

133+instance (GHasField field g ret) => GHasFieldProd field f g ret 'Nothing where

134+ prodLabel = second . glabel @field

src/Data/Generics/Record/Internal/Contains.hs+33−31

@@ -1,11 +1,11 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE FlexibleInstances #-}

4−{-# LANGUAGE PolyKinds #-}

4+{-# LANGUAGE PolyKinds #-}

5−{-# LANGUAGE Rank2Types #-}

5+{-# LANGUAGE Rank2Types #-}

6−{-# LANGUAGE ScopedTypeVariables #-}

6+{-# LANGUAGE ScopedTypeVariables #-}

7−{-# LANGUAGE TypeFamilies #-}

7+{-# LANGUAGE TypeFamilies #-}

8−{-# LANGUAGE TypeOperators #-}

8+{-# LANGUAGE TypeOperators #-}

9{-# LANGUAGE UndecidableInstances #-}

10

11-----------------------------------------------------------------------------

@@ -21,43 +21,45 @@

21--

22-----------------------------------------------------------------------------

23module Data.Generics.Record.Internal.Contains

24− ( Contains

24+ ( ContainsField

25 ) where

26

27−import Data.Kind (Type)

27+import Data.Kind (Type)

28import GHC.Generics

29−

30import GHC.TypeLits

29import GHC.TypeLits

31

30

32-- | Look up a record field by name in the generic representation, and return

31-- | Look up a record field by name in the generic representation, and return

33-- its corresponding type, if exists.

32-- its corresponding type, if exists.

34−type family Contains (field :: Symbol) f :: Maybe Type where

33+type family ContainsField (field :: Symbol) f :: Maybe Type where

35− Contains field (S1 ('MetaSel ('Just field) _ _ _) (Rec0 t))

34+ ContainsField field (S1 ('MetaSel ('Just field) _ _ _) (Rec0 t))

36 = 'Just t

35 = 'Just t

37− Contains field (f :*: g)

36+ ContainsField field (f :*: g)

38− = Contains field f <|> Contains field g

37+ = ContainsField field f <|> ContainsField field g

39− Contains field (f :+: g)

38+ ContainsField field (f :+: g)

40− = Contains field f <&> Contains field g

39+ = ContainsField field f <&> ContainsField field g

41− Contains field (S1 _ _)

40+ ContainsField field (S1 _ _)

42 = 'Nothing

41 = 'Nothing

43− Contains field (C1 m f)

42+ ContainsField field (C1 m f)

44− = Contains field f

43+ = ContainsField field f

45− Contains field (D1 m f)

44+ ContainsField field (D1 m f)

46− = Contains field f

45+ = ContainsField field f

47− Contains field (Rec0 _)

46+ ContainsField field (Rec0 _)

48 = 'Nothing

47 = 'Nothing

49− Contains field U1

48+ ContainsField field U1

50 = 'Nothing

49 = 'Nothing

51− Contains field V1

50+ ContainsField field V1

52 = 'Nothing

51 = 'Nothing

52+ ContainsField x t

53− Contains x t = TypeError ('ShowType t)

53+ = TypeError

54+ ( 'ShowType t

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

56+ )

54

57

55-- | Type-level alternative

58-- | Type-level alternative

56type family (a :: Maybe k) <|> (b :: Maybe k) :: Maybe k where

59type family (a :: Maybe k) <|> (b :: Maybe k) :: Maybe k where

57− 'Just x <|> _ = 'Just x

60+ 'Just x <|> _ = 'Just x

58− _ <|> b = b

61+ _ <|> b = b

59

62

60type family (a :: Maybe k) <&> (b :: Maybe k) :: Maybe k where

63type family (a :: Maybe k) <&> (b :: Maybe k) :: Maybe k where

61− 'Just x <&> 'Just x = 'Just x

64+ 'Just x <&> 'Just x = 'Just x

62− _ <&> _ = 'Nothing

65+ _ <&> _ = 'Nothing

63−

src/Data/Generics/Record/Subtype.hs+2−2

@@ -121,9 +121,9 @@ instance (GSmash a sup, GSmash b sup) => GSmash (a :*: b) sup where

121

122instance {-# OVERLAPPING #-}

123 ( leaf ~ (S1 ('MetaSel ('Just field) p f b) t)

124− , GSmashLeaf leaf sup (Contains field sup)

124+ , GSmashLeaf leaf sup (ContainsField field sup)

125 ) => GSmash (S1 ('MetaSel ('Just field) p f b) t) sup where

126− gsmash = gsmashLeaf @_ @_ @(Contains field sup)

126+ gsmash = gsmashLeaf @_ @_ @(ContainsField field sup)

127

128instance GSmash sub sup => GSmash (M1 i c sub) sup where

129 gsmash sup (M1 sub) = M1 (gsmash sup sub)