aad5b7c · generic-lens

generic-lens.cabal+1−5

compare with master

unifiedsplit

@@ -35,7 +35,7 @@ library

35

36 other-modules: Data.Generics.Internal.Families

37 , Data.Generics.Internal.Families.Changing

38− , Data.Generics.Internal.Families.Count

38+ , Data.Generics.Internal.Families.Collect

39 , Data.Generics.Internal.Families.Has

40 , Data.Generics.Internal.HList

41 , Data.Generics.Internal.Void

@@ -44,10 +44,6 @@ library

44 , Data.Generics.Sum.Internal.Typed

45 , Data.Generics.Sum.Internal.Subtype

46

47− , Data.Generics.Internal.Families

48− , Data.Generics.Internal.Families.Count

49− , Data.Generics.Internal.Families.Has

50− , Data.Generics.Internal.HList

51 , Data.Generics.Product.Internal.Fields

47 , Data.Generics.Product.Internal.Fields

52 , Data.Generics.Product.Internal.Positions

48 , Data.Generics.Product.Internal.Positions

53 , Data.Generics.Product.Internal.Subtype

49 , Data.Generics.Product.Internal.Subtype

src/Data/Generics/Internal/Families.hs+19−1

@@ -1,3 +1,12 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE KindSignatures #-}

5+{-# LANGUAGE MultiParamTypeClasses #-}

6+{-# LANGUAGE TypeApplications #-}

7+{-# LANGUAGE TypeFamilies #-}

8+{-# LANGUAGE TypeOperators #-}

9+

1-----------------------------------------------------------------------------

10-----------------------------------------------------------------------------

2-- |

11-- |

3-- Module : Data.Generics.Internal.Families

12-- Module : Data.Generics.Internal.Families

@@ -10,8 +19,17 @@

10-----------------------------------------------------------------------------

19-----------------------------------------------------------------------------

11module Data.Generics.Internal.Families

20module Data.Generics.Internal.Families

12 ( module Families

21 ( module Families

22+ , ShowConstuctors

13 ) where

23 ) where

14

24

15−import Data.Generics.Internal.Families.Count as Families

25+import Data.Generics.Internal.Families.Collect as Families

16import Data.Generics.Internal.Families.Has as Families

26import Data.Generics.Internal.Families.Has as Families

17import Data.Generics.Internal.Families.Changing as Families

27import Data.Generics.Internal.Families.Changing as Families

28+

29+import GHC.TypeLits (ErrorMessage (..), Symbol)

30+

31+type family ShowConstuctors (ctors :: [Symbol]) :: ErrorMessage where

32+ ShowConstuctors '[]

33+ = 'Text ""

34+ ShowConstuctors (c ': cs)

35+ = 'Text "* " ':<>: 'Text c ':$$: ShowConstuctors cs

src/Data/Generics/Internal/Families/Changing.hs+7−7

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

1−{-# LANGUAGE AllowAmbiguousTypes #-}

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE FlexibleInstances #-}

3{-# LANGUAGE FunctionalDependencies #-}

4{-# LANGUAGE FunctionalDependencies #-}

4−{-# LANGUAGE DataKinds #-}

5−{-# LANGUAGE PolyKinds #-}

5+{-# LANGUAGE PolyKinds #-}

6−{-# LANGUAGE TypeFamilies #-}

6+{-# LANGUAGE TypeFamilies #-}

7−{-# LANGUAGE TypeOperators #-}

7+{-# LANGUAGE TypeOperators #-}

8−{-# LANGUAGE UndecidableInstances #-}

8+{-# LANGUAGE UndecidableInstances #-}

9

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

11

src/Data/Generics/Internal/Families/Collect.hsnew file+100

@@ -0,0 +1,100 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE PolyKinds #-}

3+{-# LANGUAGE TypeFamilies #-}

4+{-# LANGUAGE TypeOperators #-}

5+{-# LANGUAGE UndecidableInstances #-}

6+

7+-----------------------------------------------------------------------------

8+-- |

9+-- Module : Data.Generics.Internal.Families.Collect

11+-- License : BSD3

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

13+-- Stability : experimental

14+-- Portability : non-portable

15+--

16+-----------------------------------------------------------------------------

17+module Data.Generics.Internal.Families.Collect

18+ ( CollectTotalType

19+ , CollectPartialType

20+ , CollectField

21+ , TypeStat (..)

22+ ) where

23+

24+import Data.Type.Bool (If)

25+import Data.Type.Equality (type (==))

26+import GHC.Generics

27+import GHC.TypeLits (Symbol)

28+

29+import Data.Generics.Internal.HList

30+

31+data TypeStat

32+ = TypeStat

33+ { _containsNone :: [Symbol]

34+ , _containsMultiple :: [Symbol]

35+ , _containsOne :: [Symbol]

36+ }

37+

38+type EmptyStat = 'TypeStat '[] '[] '[]

39+

40+type family CollectTotalType t f :: TypeStat where

41+ CollectTotalType t (C1 ('MetaCons ctor _ _) f)

42+ = AddToStat ctor (CountType t f) EmptyStat

43+ CollectTotalType t (M1 _ _ r)

44+ = CollectTotalType t r

45+ CollectTotalType t (l :+: r)

46+ = MergeStat (CollectTotalType t l) (CollectTotalType t r)

47+

48+type family CollectField t f :: TypeStat where

49+ CollectField t (C1 ('MetaCons ctor _ _) f)

50+ = AddToStat ctor (CountField t f) EmptyStat

51+ CollectField t (M1 _ _ r)

52+ = CollectField t r

53+ CollectField t (l :+: r)

54+ = MergeStat (CollectField t l) (CollectField t r)

55+

56+type family AddToStat (ctor :: Symbol) (count :: Count) (st :: TypeStat) :: TypeStat where

57+ AddToStat ctor 'None ('TypeStat n m o) = 'TypeStat (ctor ': n) m o

58+ AddToStat ctor 'Multiple ('TypeStat n m o) = 'TypeStat n (ctor ': m) o

59+ AddToStat ctor 'One ('TypeStat n m o) = 'TypeStat n m (ctor ': o)

60+

61+type family MergeStat (st1 :: TypeStat) (st2 :: TypeStat) :: TypeStat where

62+ MergeStat ('TypeStat n m o) ('TypeStat n' m' o') = 'TypeStat (n ++ n') (m ++ m') (o ++ o')

63+

64+type family CountType t f :: Count where

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

66+ = 'One

67+ CountType t (l :*: r)

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

69+ CountType t _

70+ = 'None

71+

72+type family CountField (field :: Symbol) f :: Count where

73+ CountField field (S1 ('MetaSel ('Just field) _ _ _) _)

74+ = 'One

75+ CountField field (l :*: r)

76+ = CountField field l <|> CountField field r

77+ CountField _ _

78+ = 'None

79+

80+type family CollectPartialType t f :: [Symbol] where

81+ CollectPartialType t (l :+: r)

82+ = CollectPartialType t l ++ CollectPartialType t r

83+ CollectPartialType t (C1 ('MetaCons ctor _ _) f)

84+ = If (t == ListToTuple (GCollect f)) '[ctor] '[]

85+ CollectPartialType t (D1 _ f)

86+ = CollectPartialType t f

87+

88+data Count

89+ = None

90+ | One

91+ | Multiple

92+

93+type family (a :: Count) <|> (b :: Count) :: Count where

94+ 'None <|> b = b

95+ a <|> 'None = a

96+ a <|> b = 'Multiple

97+

98+type family (a :: Count) <&> (b :: Count) :: Count where

99+ a <&> a = a

100+ _ <&> _ = 'Multiple

src/Data/Generics/Internal/Families/Count.hsdeleted−75

@@ -1,75 +0,0 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE PolyKinds #-}

3−{-# LANGUAGE TypeFamilies #-}

4−{-# LANGUAGE TypeOperators #-}

5−{-# LANGUAGE UndecidableInstances #-}

6−

7−-----------------------------------------------------------------------------

8−-- |

9−-- Module : Data.Generics.Internal.Families.Count

11−-- License : BSD3

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

13−-- Stability : experimental

14−-- Portability : non-portable

15−--

16−-----------------------------------------------------------------------------

17−module Data.Generics.Internal.Families.Count

18− ( CountTotalType

19− , CountPartialType

20− , Count (..)

21− ) where

22−

23−import Data.Type.Bool (If)

24−import Data.Type.Equality (type (==))

25−import GHC.Generics

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

27−

28−import Data.Generics.Internal.HList

29−

30−type family CountTotalType t f :: Count where

31− CountTotalType t (S1 _ (Rec0 t))

32− = 'One

33− CountTotalType t (l :*: r)

34− = CountTotalType t l <|> CountTotalType t r

35− CountTotalType t (l :+: r)

36− = CountTotalType t l <&> CountTotalType t r

37− CountTotalType t (S1 _ _)

38− = 'None

39− CountTotalType t (C1 _ f)

40− = CountTotalType t f

41− CountTotalType t (D1 _ f)

42− = CountTotalType t f

43− CountTotalType t (Rec0 _)

44− = 'None

45− CountTotalType t U1

46− = 'None

47− CountTotalType t V1

48− = 'None

49− CountTotalType t f

50− = TypeError

51− ( 'ShowType f

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

53− )

54−

55−type family CountPartialType t f :: Count where

56− CountPartialType t (l :+: r)

57− = CountPartialType t l <|> CountPartialType t r

58− CountPartialType t (C1 m f)

59− = If (t == ListToTuple (GCollect f)) 'One 'None

60− CountPartialType t (D1 _ f)

61− = CountPartialType t f

62−

63−data Count

64− = None

65− | One

66− | Multiple

67−

68−type family (a :: Count) <|> (b :: Count) :: Count where

69− 'None <|> b = b

70− a <|> 'None = a

71− a <|> b = 'Multiple

72−

73−type family (a :: Count) <&> (b :: Count) :: Count where

74− a <&> a = a

75− _ <&> _ = 'Multiple

src/Data/Generics/Product.hs+10−10

@@ -17,15 +17,15 @@

17

18module Data.Generics.Product

19 ( -- *Lenses

20− module Any

20+ module Data.Generics.Product.Any

21− , module Field

21+ , module Data.Generics.Product.Fields

22− , module Positions

22+ , module Data.Generics.Product.Positions

23− , module Subtype

23+ , module Data.Generics.Product.Subtype

24− , module Typed

24+ , module Data.Generics.Product.Typed

25 ) where

26

27−import Data.Generics.Product.Any as Any

27+import Data.Generics.Product.Any

28−import Data.Generics.Product.Fields as Field

28+import Data.Generics.Product.Fields

29−import Data.Generics.Product.Positions as Positions

29+import Data.Generics.Product.Positions

30−import Data.Generics.Product.Subtype as Subtype

30+import Data.Generics.Product.Subtype

31−import Data.Generics.Product.Typed as Typed

31+import Data.Generics.Product.Typed

src/Data/Generics/Product/Any.hs+5−2

@@ -25,7 +25,7 @@

25module Data.Generics.Product.Any

26 ( -- *Lenses

27 --

28− -- $setup

28+ -- $setup

29 HasAny (..)

30 ) where

31

@@ -35,6 +35,8 @@ import Data.Generics.Product.Positions

35import Data.Generics.Product.Typed

36

37-- $setup

38+-- == /Running example:/

39+--

38-- >>> :set -XTypeApplications

40-- >>> :set -XTypeApplications

39-- >>> :set -XDataKinds

41-- >>> :set -XDataKinds

40-- >>> :set -XDeriveGeneric

42-- >>> :set -XDeriveGeneric

@@ -51,7 +53,6 @@ import Data.Generics.Product.Typed

51-- human = Human "Tunyasz" 50 "London"

53-- human = Human "Tunyasz" 50 "London"

52-- :}

54-- :}

53

55

54−-- |Records that have generic lenses.

55class HasAny (sel :: k) s t a b | s sel k -> a where

56class HasAny (sel :: k) s t a b | s sel k -> a where

56 -- |A lens that focuses on a part of a product as identified by some

57 -- |A lens that focuses on a part of a product as identified by some

57 -- selector. Currently supported selectors are field names, positions and

58 -- selector. Currently supported selectors are field names, positions and

@@ -60,8 +61,10 @@ class HasAny (sel :: k) s t a b | s sel k -> a where

60 --

61 --

61 -- >>> human ^. the @Int

62 -- >>> human ^. the @Int

62 -- 50

63 -- 50

64+ --

63 -- >>> human ^. the @"name"

65 -- >>> human ^. the @"name"

64 -- "Tunyasz"

66 -- "Tunyasz"

67+ --

65 -- >>> human ^. the @3

68 -- >>> human ^. the @3

66 -- "London"

69 -- "London"

67 the :: Lens s t a b

70 the :: Lens s t a b

src/Data/Generics/Product/Fields.hs+50−14

@@ -28,7 +28,7 @@

28module Data.Generics.Product.Fields

29 ( -- *Lenses

30

31− -- $setup

31+ -- $setup

32 HasField (..)

33 , HasField'

34

@@ -46,6 +46,8 @@ import GHC.Generics

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

47

48-- $setup

49+-- == /Running example:/

50+--

49-- >>> :set -XTypeApplications

51-- >>> :set -XTypeApplications

50-- >>> :set -XDataKinds

52-- >>> :set -XDataKinds

51-- >>> :set -XDeriveGeneric

53-- >>> :set -XDeriveGeneric

@@ -55,12 +57,18 @@ import GHC.TypeLits (Symbol, ErrorMessage(..), TypeError)

55-- >>> :m +Data.Generics.Internal.Lens

57-- >>> :m +Data.Generics.Internal.Lens

56-- >>> :m +Data.Function

58-- >>> :m +Data.Function

57-- >>> :{

59-- >>> :{

58−-- data Human a = Human

60+-- data Human a

61+-- = Human

59−-- { name :: String

62+-- { name :: String

60−-- , age :: Int

63+-- , age :: Int

61−-- , address :: String

64+-- , address :: String

65+-- , other :: a

66+-- }

67+-- | HumanNoAddress

68+-- { name :: String

69+-- , age :: Int

62−-- , other :: a

70+-- , other :: a

63−-- }

71+-- }

64-- deriving (Generic, Show)

72-- deriving (Generic, Show)

65-- human :: Human Bool

73-- human :: Human Bool

66-- human = Human { name = "Tunyasz", age = 50, address = "London", other = False }

74-- human = Human { name = "Tunyasz", age = 50, address = "London", other = False }

@@ -74,13 +82,31 @@ class HasField (field :: Symbol) s t a b | s field -> a, s field b -> t where

74 -- >>> human ^. field @"age"

82 -- >>> human ^. field @"age"

75 -- 50

83 -- 50

76 --

84 --

77− -- If the field's type comes from a type parameter, it can be changed:

85+ -- === /Type changing/

86+ --

78 -- >>> :t human

87 -- >>> :t human

79 -- human :: Human Bool

88 -- human :: Human Bool

89+ --

80 -- >>> :t human & field @"other" .~ (42 :: Int)

90 -- >>> :t human & field @"other" .~ (42 :: Int)

81 -- human & field @"other" .~ (42 :: Int) :: Human Int

91 -- human & field @"other" .~ (42 :: Int) :: Human Int

92+ --

82 -- >>> human & field @"other" .~ 42

93 -- >>> human & field @"other" .~ 42

83 -- Human {name = "Tunyasz", age = 50, address = "London", other = 42}

94 -- Human {name = "Tunyasz", age = 50, address = "London", other = 42}

95+ --

96+ -- === /Type errors/

97+ --

98+ -- >>> human & field @"weight" .~ 42

99+ -- ...

100+ -- ... The type Human Bool does not contain a field named 'weight'.

101+ -- ...

102+ --

103+ -- >>> human & field @"address" .~ ""

104+ -- ...

105+ -- ... Not all constructors of the type Human Bool

106+ -- ... contain a field named 'address'.

107+ -- ... The offending constructors are:

108+ -- ... HumanNoAddress

109+ -- ...

84 field :: Lens s t a b

110 field :: Lens s t a b

85

111

86type HasField' field s a = HasField field s s a a

112type HasField' field s a = HasField field s s a a

@@ -99,7 +125,7 @@ setField = set (field @f)

99

125

100instance -- see Note [Changing type parameters]

126instance -- see Note [Changing type parameters]

101 ( Generic s

127 ( Generic s

102− , ErrorUnless field s (HasTotalFieldP field (Rep s))

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

103 , Generic t

129 , Generic t

104 , s' ~ Proxied s

130 , s' ~ Proxied s

105 , Generic s'

131 , Generic s'

@@ -118,14 +144,24 @@ instance {-# OVERLAPPING #-} HasField f (Void2 t a) t a b where

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

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

119 field = undefined

145 field = undefined

120

146

121−type family ErrorUnless (field :: Symbol) (s :: Type) (contains :: Bool) :: Constraint where

147+type family ErrorUnless (field :: Symbol) (s :: Type) (stat :: TypeStat) :: Constraint where

122− ErrorUnless field s 'False

148+ ErrorUnless field s ('TypeStat _ _ '[])

123 = TypeError

149 = TypeError

124 ( 'Text "The type "

150 ( 'Text "The type "

125 ':<>: 'ShowType s

151 ':<>: 'ShowType s

126− ':<>: 'Text " does not contain a field named "

152+ ':<>: 'Text " does not contain a field named '"

153+ ':<>: 'Text field ':<>: 'Text "'."

154+ )

155+

156+ ErrorUnless field s ('TypeStat (n ': ns) _ _)

157+ = TypeError

158+ ( 'Text "Not all constructors of the type "

127− ':<>: 'ShowType field

159+ ':<>: 'ShowType s

160+ ':$$: 'Text " contain a field named '"

161+ ':<>: 'Text field ':<>: 'Text "'."

162+ ':$$: 'Text "The offending constructors are:"

163+ ':$$: ShowConstuctors (n ': ns)

128 )

164 )

129

165

130− ErrorUnless _ _ 'True

166+ ErrorUnless _ _ ('TypeStat '[] '[] _)

131 = ()

167 = ()

src/Data/Generics/Product/Positions.hs+12−1

@@ -29,7 +29,7 @@

29module Data.Generics.Product.Positions

30 ( -- *Lenses

31

32− -- $setup

32+ -- $setup

33 HasPosition (..)

34 , HasPosition'

35

@@ -48,9 +48,13 @@ import GHC.Generics

48import GHC.TypeLits (type (<=?), Nat, TypeError, ErrorMessage(..))

49

50-- $setup

51+-- == /Running example:/

52+--

51-- >>> :set -XTypeApplications

53-- >>> :set -XTypeApplications

52-- >>> :set -XDataKinds

54-- >>> :set -XDataKinds

53-- >>> :set -XDeriveGeneric

55-- >>> :set -XDeriveGeneric

56+-- >>> :set -XGADTs

57+-- >>> :set -XFlexibleContexts

54-- >>> import GHC.Generics

58-- >>> import GHC.Generics

55-- >>> :m +Data.Generics.Internal.Lens

59-- >>> :m +Data.Generics.Internal.Lens

56-- >>> :m +Data.Function

60-- >>> :m +Data.Function

@@ -74,6 +78,13 @@ class HasPosition (i :: Nat) s t a b | s i -> a, s i b -> t where

74 -- "Tunyasz"

78 -- "Tunyasz"

75 -- >>> human & position @3 .~ "Berlin"

79 -- >>> human & position @3 .~ "Berlin"

76 -- Human {name = "Tunyasz", age = 50, address = "Berlin"}

80 -- Human {name = "Tunyasz", age = 50, address = "Berlin"}

81+ --

82+ -- === /Type errors/

83+ --

84+ -- >>> human & position @4 .~ "Berlin"

85+ -- ...

86+ -- ... The type Human does not contain a field at position 4

87+ -- ...

77 position :: Lens s t a b

88 position :: Lens s t a b

78

89

79type HasPosition' i s a = HasPosition i s s a a

90type HasPosition' i s a = HasPosition i s s a a

src/Data/Generics/Product/Subtype.hs+3−1

@@ -28,7 +28,7 @@

28module Data.Generics.Product.Subtype

29 ( -- *Lenses

30 --

31− -- $setup

31+ -- $setup

32 Subtype (..)

33 ) where

34

@@ -39,6 +39,8 @@ import Data.Generics.Product.Internal.Subtype

39import GHC.Generics (Generic (Rep, to, from) )

40

41-- $setup

42+-- == /Running example:/

43+--

42-- >>> :set -XTypeApplications

44-- >>> :set -XTypeApplications

43-- >>> :set -XDataKinds

45-- >>> :set -XDataKinds

44-- >>> :set -XDeriveGeneric

46-- >>> :set -XDeriveGeneric

src/Data/Generics/Product/Typed.hs+53−14

@@ -26,7 +26,7 @@

26module Data.Generics.Product.Typed

27 ( -- *Lenses

28 --

29− -- $setup

29+ -- $setup

30 HasType (..)

31 ) where

32

@@ -40,20 +40,29 @@ import GHC.Generics (Generic (Rep))

40import GHC.TypeLits (TypeError, ErrorMessage (..))

41

42-- $setup

43+-- == /Running example:/

44+--

43-- >>> :set -XTypeApplications

45-- >>> :set -XTypeApplications

44-- >>> :set -XDataKinds

46-- >>> :set -XDataKinds

45-- >>> :set -XDeriveGeneric

47-- >>> :set -XDeriveGeneric

46-- >>> import GHC.Generics

48-- >>> import GHC.Generics

47-- >>> :m +Data.Generics.Internal.Lens

49-- >>> :m +Data.Generics.Internal.Lens

48-- >>> :{

50-- >>> :{

49−-- data Human = Human

51+-- data Human

52+-- = Human

53+-- { name :: String

54+-- , age :: Int

55+-- , address :: String

56+-- , tall :: Bool

57+-- }

58+-- | HumanNoTall

50−-- { name :: String

59+-- { name :: String

51−-- , age :: Int

60+-- , age :: Int

52−-- , address :: String

61+-- , address :: String

53−-- }

62+-- }

54-- deriving (Generic, Show)

63-- deriving (Generic, Show)

55-- human :: Human

64-- human :: Human

56−-- human = Human "Tunyasz" 50 "London"

65+-- human = Human "Tunyasz" 50 "London" False

57-- :}

66-- :}

58

67

59-- |Records that have a field with a unique type.

68-- |Records that have a field with a unique type.

@@ -63,6 +72,25 @@ class HasType a s where

63 --

72 --

64 -- >>> human ^. typed @Int

73 -- >>> human ^. typed @Int

65 -- 50

74 -- 50

75+ --

76+ -- === /Type errors/

77+ --

78+ -- >>> human ^. typed @String

79+ -- ...

80+ -- ...

81+ -- ... The type Human contains multiple values of type [Char].

82+ -- ... The choice of value is thus ambiguous. The offending constructors are:

83+ -- ... Human

84+ -- ... HumanNoTall

85+ -- ...

86+ --

87+ -- >>> human ^. typed @Bool

88+ -- ...

89+ -- ...

90+ -- ... Not all constructors of the type Human contain a field of type Bool.

91+ -- ... The offending constructors are:

92+ -- ... HumanNoTall

93+ -- ...

66 typed :: Lens' s a

94 typed :: Lens' s a

67 typed f t

95 typed f t

68 = fmap (flip (setTyped @a) t) (f (getTyped @a t))

96 = fmap (flip (setTyped @a) t) (f (getTyped @a t))

@@ -79,7 +107,7 @@ class HasType a s where

79

107

80instance

108instance

81 ( Generic s

109 ( Generic s

82− , ErrorUnlessOne a s (CountTotalType a (Rep s))

110+ , ErrorUnlessOne a s (CollectTotalType a (Rep s))

83 , GHasType (Rep s) a

111 , GHasType (Rep s) a

84 ) => HasType a s where

112 ) => HasType a s where

85

113

@@ -89,8 +117,8 @@ instance

89instance {-# OVERLAPPING #-} HasType a Void where

117instance {-# OVERLAPPING #-} HasType a Void where

90 typed = undefined

118 typed = undefined

91

119

92−type family ErrorUnlessOne (a :: Type) (s :: Type) (count :: Count) :: Constraint where

120+type family ErrorUnlessOne (a :: Type) (s :: Type) (stat :: TypeStat) :: Constraint where

93− ErrorUnlessOne a s 'None

121+ ErrorUnlessOne a s ('TypeStat '[_] '[] '[])

94 = TypeError

122 = TypeError

95 ( 'Text "The type "

123 ( 'Text "The type "

96 ':<>: 'ShowType s

124 ':<>: 'ShowType s

@@ -98,14 +126,25 @@ type family ErrorUnlessOne (a :: Type) (s :: Type) (count :: Count) :: Constrain

98 ':<>: 'ShowType a

126 ':<>: 'ShowType a

99 )

127 )

100

128

101− ErrorUnlessOne a s 'Multiple

129+ ErrorUnlessOne a s ('TypeStat (n ': ns) _ _)

130+ = TypeError

131+ ( 'Text "Not all constructors of the type "

132+ ':<>: 'ShowType s

133+ ':<>: 'Text " contain a field of type "

134+ ':<>: 'ShowType a ':<>: 'Text "."

135+ ':$$: 'Text "The offending constructors are:"

136+ ':$$: ShowConstuctors (n ': ns)

137+ )

138+

139+ ErrorUnlessOne a s ('TypeStat _ (m ': ms) _)

102 = TypeError

140 = TypeError

103 ( 'Text "The type "

141 ( 'Text "The type "

104 ':<>: 'ShowType s

142 ':<>: 'ShowType s

105 ':<>: 'Text " contains multiple values of type "

143 ':<>: 'Text " contains multiple values of type "

106− ':<>: 'ShowType a

144+ ':<>: 'ShowType a ':<>: 'Text "."

107− ':<>: 'Text "; the choice of value is thus ambiguous"

145+ ':$$: 'Text "The choice of value is thus ambiguous. The offending constructors are:"

146+ ':$$: ShowConstuctors (m ': ms)

108 )

147 )

109

148

110− ErrorUnlessOne _ _ 'One

149+ ErrorUnlessOne _ _ ('TypeStat '[] '[] _)

111 = ()

150 = ()

src/Data/Generics/Sum.hs+8−8

@@ -17,13 +17,13 @@

17

18module Data.Generics.Sum

19 ( -- *Prisms

20− module Any

20+ module Data.Generics.Sum.Any

21− , module Constructors

21+ , module Data.Generics.Sum.Constructors

22− , module Subtype

22+ , module Data.Generics.Sum.Subtype

23− , module Typed

23+ , module Data.Generics.Sum.Typed

24 ) where

25

26−import Data.Generics.Sum.Any as Any

26+import Data.Generics.Sum.Any

27−import Data.Generics.Sum.Constructors as Constructors

27+import Data.Generics.Sum.Constructors

28−import Data.Generics.Sum.Subtype as Subtype

28+import Data.Generics.Sum.Subtype

29−import Data.Generics.Sum.Typed as Typed

29+import Data.Generics.Sum.Typed

src/Data/Generics/Sum/Any.hs+9−1

@@ -24,7 +24,7 @@

24module Data.Generics.Sum.Any

25 ( -- *Prisms

26 --

27− -- $setup

27+ -- $setup

28 AsAny (..)

29 ) where

30

@@ -33,6 +33,8 @@ import Data.Generics.Sum.Constructors

33import Data.Generics.Sum.Typed

34

35-- $setup

36+-- == /Running example:/

37+--

36-- >>> :set -XTypeApplications

38-- >>> :set -XTypeApplications

37-- >>> :set -XDataKinds

39-- >>> :set -XDataKinds

38-- >>> :set -XDeriveGeneric

40-- >>> :set -XDeriveGeneric

@@ -66,16 +68,22 @@ class AsAny (sel :: k) a s | s sel k -> a where

66 --

68 --

67 -- >>> dog ^? _As @"Dog"

69 -- >>> dog ^? _As @"Dog"

68 -- Just (MkDog {name = "Shep", age = 3})

70 -- Just (MkDog {name = "Shep", age = 3})

71+ --

69 -- >>> dog ^? _As @Dog

72 -- >>> dog ^? _As @Dog

70 -- Just (MkDog {name = "Shep", age = 3})

73 -- Just (MkDog {name = "Shep", age = 3})

74+ --

71 -- >>> dog ^? _As @"Cat"

75 -- >>> dog ^? _As @"Cat"

72 -- Nothing

76 -- Nothing

77+ --

73 -- >>> cat ^? _As @(Name, Age)

78 -- >>> cat ^? _As @(Name, Age)

74 -- Just ("Mog",5)

79 -- Just ("Mog",5)

80+ --

75 -- >>> cat ^? _As @"Cat"

81 -- >>> cat ^? _As @"Cat"

76 -- Just ("Mog",5)

82 -- Just ("Mog",5)

83+ --

77 -- >>> _As @"Cat" # ("Garfield", 6) :: Animal

84 -- >>> _As @"Cat" # ("Garfield", 6) :: Animal

78 -- Cat "Garfield" 6

85 -- Cat "Garfield" 6

86+ --

79 -- >>> duck ^? _As @Age

87 -- >>> duck ^? _As @Age

80 -- Just 2

88 -- Just 2

81 _As :: Prism' s a

89 _As :: Prism' s a

src/Data/Generics/Sum/Constructors.hs+13−1

@@ -26,7 +26,7 @@

26module Data.Generics.Sum.Constructors

27 ( -- *Prisms

28

29− -- $setup

29+ -- $setup

30 AsConstructor (..)

31 ) where

32

@@ -40,9 +40,13 @@ import GHC.Generics (Generic (Rep))

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

41

42-- $setup

43+-- == /Running example:/

44+--

43-- >>> :set -XTypeApplications

45-- >>> :set -XTypeApplications

44-- >>> :set -XDataKinds

46-- >>> :set -XDataKinds

45-- >>> :set -XDeriveGeneric

47-- >>> :set -XDeriveGeneric

48+-- >>> :set -XFlexibleContexts

49+-- >>> :set -XTypeFamilies

46-- >>> import GHC.Generics

50-- >>> import GHC.Generics

47-- >>> :m +Data.Generics.Internal.Lens

51-- >>> :m +Data.Generics.Internal.Lens

48-- >>> :m +Data.Generics.Product.Fields

52-- >>> :m +Data.Generics.Product.Fields

@@ -84,6 +88,14 @@ class AsConstructor (ctor :: Symbol) s t a b | ctor s -> a, ctor t -> b where

84 --

88 --

85 -- >>> _Ctor @"Cat" # ("Garfield", 6) :: Animal Int

89 -- >>> _Ctor @"Cat" # ("Garfield", 6) :: Animal Int

86 -- Cat "Garfield" 6

90 -- Cat "Garfield" 6

91+ --

92+ -- === /Type errors/

93+ --

94+ -- >>> cat ^? _Ctor @"Turtle"

95+ -- ...

96+ -- ...

97+ -- ... The type Animal Int does not contain a constructor named "Turtle"

98+ -- ...

87 _Ctor :: Prism s t a b

99 _Ctor :: Prism s t a b

88

100

89instance

101instance

src/Data/Generics/Sum/Subtype.hs+5−1

@@ -22,7 +22,7 @@

22module Data.Generics.Sum.Subtype

23 ( -- *Prisms

24 --

25− -- $setup

25+ -- $setup

26 AsSubtype (..)

27 ) where

28

@@ -33,6 +33,8 @@ import Data.Generics.Sum.Internal.Subtype

33import GHC.Generics (Generic (Rep, to, from))

34

35-- $setup

36+-- == /Running example:/

37+--

36-- >>> :set -XTypeApplications

38-- >>> :set -XTypeApplications

37-- >>> :set -XDataKinds

39-- >>> :set -XDataKinds

38-- >>> :set -XDeriveGeneric

40-- >>> :set -XDeriveGeneric

@@ -77,8 +79,10 @@ class AsSubtype sub sup where

77 --

79 --

78 -- >>> _Sub # dog4 :: Animal

80 -- >>> _Sub # dog4 :: Animal

79 -- Dog (MkDog {name = "Snowy", age = 4})

81 -- Dog (MkDog {name = "Snowy", age = 4})

82+ --

80 -- >>> cat ^? _Sub :: Maybe FourLeggedAnimal

83 -- >>> cat ^? _Sub :: Maybe FourLeggedAnimal

81 -- Just (Cat4 "Mog" 5)

84 -- Just (Cat4 "Mog" 5)

85+ --

82 -- >>> duck ^? _Sub :: Maybe FourLeggedAnimal

86 -- >>> duck ^? _Sub :: Maybe FourLeggedAnimal

83 -- Nothing

87 -- Nothing

84 _Sub :: Prism' sup sub

88 _Sub :: Prism' sup sub

src/Data/Generics/Sum/Typed.hs+26−20

@@ -31,7 +31,7 @@ module Data.Generics.Sum.Typed

31

32import Data.Kind

33import GHC.Generics

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

34+import GHC.TypeLits (TypeError, ErrorMessage (..), Symbol)

35import Data.Generics.Sum.Internal.Typed

36

37import Data.Generics.Internal.Families

@@ -49,6 +49,7 @@ import Data.Generics.Internal.Void

49-- = Dog Dog

50-- | Cat Name Age

51-- | Duck Age

52+-- | Turtle Age

52-- deriving (Generic, Show)

53-- deriving (Generic, Show)

53-- data Dog

54-- data Dog

54-- = MkDog

55-- = MkDog

@@ -57,11 +58,11 @@ import Data.Generics.Internal.Void

57-- }

58-- }

58-- deriving (Generic, Show)

59-- deriving (Generic, Show)

59-- type Name = String

60-- type Name = String

60−-- type Age = Int

61+-- newtype Age = Age Int deriving Show

61-- dog, cat, duck :: Animal

62-- dog, cat, duck :: Animal

62−-- dog = Dog (MkDog "Shep" 3)

63+-- dog = Dog (MkDog "Shep" (Age 3))

63−-- cat = Cat "Mog" 5

64+-- cat = Cat "Mog" (Age 5)

64−-- duck = Duck 2

65+-- duck = Duck (Age 2)

65-- :}

66-- :}

66

67

68

@@ -71,13 +72,17 @@ class AsType a s where

71 -- its field. Compatible with the lens package's 'Control.Lens.Prism' type.

72 -- its field. Compatible with the lens package's 'Control.Lens.Prism' type.

72 --

73 --

73 -- >>> dog ^? _Typed @Dog

74 -- >>> dog ^? _Typed @Dog

74− -- Just (MkDog {name = "Shep", age = 3})

75+ -- Just (MkDog {name = "Shep", age = Age 3})

75− -- >>> dog ^? _Typed @Age

76− -- Nothing

77 -- >>> cat ^? _Typed @(Name, Age)

76 -- >>> cat ^? _Typed @(Name, Age)

78− -- Just ("Mog",5)

77+ -- Just ("Mog",Age 5)

79− -- >>> duck ^? _Typed @Age

78+ -- >>> dog ^? _Typed @Age

80− -- Just 2

79+ -- ...

80+ -- ...

81+ -- ... The type Animal contains multiple constructors whose fields are of type Age.

82+ -- ... The choice of constructor is thus ambiguous, could be any of:

83+ -- ... Duck

84+ -- ... Turtle

85+ -- ...

81 _Typed :: Prism' s a

86 _Typed :: Prism' s a

82

87

83 -- |Inject by type.

88 -- |Inject by type.

@@ -88,7 +93,7 @@ class AsType a s where

88

93

89instance

94instance

90 ( Generic s

95 ( Generic s

91− , ErrorUnlessOne a s (CountPartialType a (Rep s))

96+ , ErrorUnlessOne a s (CollectPartialType a (Rep s))

92 , GAsType (Rep s) a

97 , GAsType (Rep s) a

93 ) => AsType a s where

98 ) => AsType a s where

94

99

@@ -109,8 +114,11 @@ instance {-# OVERLAPPING #-} AsType Void a where

109 injectTyped = undefined

114 injectTyped = undefined

110 projectTyped = undefined

115 projectTyped = undefined

111

116

112−type family ErrorUnlessOne (a :: Type) (s :: Type) (count :: Count) :: Constraint where

117+type family ErrorUnlessOne (a :: Type) (s :: Type) (ctors :: [Symbol]) :: Constraint where

113− ErrorUnlessOne a s 'None

118+ ErrorUnlessOne _ _ '[_]

119+ = ()

120+

121+ ErrorUnlessOne a s '[]

114 = TypeError

122 = TypeError

115 ( 'Text "The type "

123 ( 'Text "The type "

116 ':<>: 'ShowType s

124 ':<>: 'ShowType s

@@ -118,14 +126,12 @@ type family ErrorUnlessOne (a :: Type) (s :: Type) (count :: Count) :: Constrain

118 ':<>: 'ShowType a

126 ':<>: 'ShowType a

119 )

127 )

120

128

121− ErrorUnlessOne a s 'Multiple

129+ ErrorUnlessOne a s cs

122 = TypeError

130 = TypeError

123 ( 'Text "The type "

131 ( 'Text "The type "

124 ':<>: 'ShowType s

132 ':<>: 'ShowType s

125 ':<>: 'Text " contains multiple constructors whose fields are of type "

133 ':<>: 'Text " contains multiple constructors whose fields are of type "

126− ':<>: 'ShowType a

134+ ':<>: 'ShowType a ':<>: 'Text "."

127− ':<>: 'Text "; the choice of constructor is thus ambiguous"

135+ ':$$: 'Text "The choice of constructor is thus ambiguous, could be any of:"

136+ ':$$: ShowConstuctors cs

128 )

137 )

129−

130− ErrorUnlessOne _ _ 'One

131− = ()