aad5b7c · generic-lens

git.iko.soy/generic-lens

Make type errors better (#20)

* Make type errors better Instead of simply reporting the failure, the type error now gives a more accurate description of what went wrong (e.g. list of constructors that contain no field named 'X', when looking at 'field @X'. * Also fixes a bug where partial fields were reported as not present at all. * Fix up haddock

commitaad5b7c8fceaf774c101095676421b5595f6447c authorCsongor Kiss <kiss.csongor.kiss@gmail.com> dateSat 9 Dec 2017, 00:55 (9 years ago) parent7c05cfc

16 files changed+321−161

compare with master

unifiedsplit

generic-lens.cabal+1−5 src/Data/Generics/Internal/Families.hs+19−1 src/Data/Generics/Internal/Families/Changing.hs+7−7 src/Data/Generics/Internal/Families/Collect.hs+100 src/Data/Generics/Internal/Families/Count.hs−75 src/Data/Generics/Product.hs+10−10 src/Data/Generics/Product/Any.hs+5−2 src/Data/Generics/Product/Fields.hs+50−14 src/Data/Generics/Product/Positions.hs+12−1 src/Data/Generics/Product/Subtype.hs+3−1 src/Data/Generics/Product/Typed.hs+53−14 src/Data/Generics/Sum.hs+8−8 src/Data/Generics/Sum/Any.hs+9−1 src/Data/Generics/Sum/Constructors.hs+13−1 src/Data/Generics/Sum/Subtype.hs+5−1 src/Data/Generics/Sum/Typed.hs+26−20

generic-lens.cabal+1−5

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

3535

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

3737 , Data.Generics.Internal.Families.Changing

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

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

3939 , Data.Generics.Internal.Families.Has

4040 , Data.Generics.Internal.HList

4141 , Data.Generics.Internal.Void

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

4444 , Data.Generics.Sum.Internal.Typed

4545 , Data.Generics.Sum.Internal.Subtype

4646

47− , Data.Generics.Internal.Families

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

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

50− , Data.Generics.Internal.HList

5147 , Data.Generics.Product.Internal.Fields

5248 , Data.Generics.Product.Internal.Positions

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

110-----------------------------------------------------------------------------

211-- |

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

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

1019-----------------------------------------------------------------------------

1120module Data.Generics.Internal.Families

1221 ( module Families

22+ , ShowConstuctors

1323 ) where

1424

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

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

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

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

2−{-# LANGUAGE FlexibleInstances #-}

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE FlexibleInstances #-}

34{-# LANGUAGE FunctionalDependencies #-}

4−{-# LANGUAGE DataKinds #-}

5−{-# LANGUAGE PolyKinds #-}

6−{-# LANGUAGE TypeFamilies #-}

7−{-# LANGUAGE TypeOperators #-}

8−{-# LANGUAGE UndecidableInstances #-}

5+{-# LANGUAGE PolyKinds #-}

6+{-# LANGUAGE TypeFamilies #-}

7+{-# LANGUAGE TypeOperators #-}

8+{-# LANGUAGE UndecidableInstances #-}

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

1111

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

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

1717

1818module Data.Generics.Product

1919 ( -- *Lenses

20− module Any

21− , module Field

22− , module Positions

23− , module Subtype

24− , module Typed

20+ module Data.Generics.Product.Any

21+ , module Data.Generics.Product.Fields

22+ , module Data.Generics.Product.Positions

23+ , module Data.Generics.Product.Subtype

24+ , module Data.Generics.Product.Typed

2525 ) where

2626

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

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

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

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

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

27+import Data.Generics.Product.Any

28+import Data.Generics.Product.Fields

29+import Data.Generics.Product.Positions

30+import Data.Generics.Product.Subtype

31+import Data.Generics.Product.Typed

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

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

2525module Data.Generics.Product.Any

2626 ( -- *Lenses

2727 --

28− -- $setup

28+ -- $setup

2929 HasAny (..)

3030 ) where

3131

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

3535import Data.Generics.Product.Typed

3636

3737-- $setup

38+-- == /Running example:/

39+--

3840-- >>> :set -XTypeApplications

3941-- >>> :set -XDataKinds

4042-- >>> :set -XDeriveGeneric

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

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

5254-- :}

5355

54−-- |Records that have generic lenses.

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

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

5758 -- 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

6061 --

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

6263 -- 50

64+ --

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

6466 -- "Tunyasz"

67+ --

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

6669 -- "London"

6770 the :: Lens s t a b

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

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

2828module Data.Generics.Product.Fields

2929 ( -- *Lenses

3030

31− -- $setup

31+ -- $setup

3232 HasField (..)

3333 , HasField'

3434

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

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

4747

4848-- $setup

49+-- == /Running example:/

50+--

4951-- >>> :set -XTypeApplications

5052-- >>> :set -XDataKinds

5153-- >>> :set -XDeriveGeneric

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

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

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

5759-- >>> :{

58−-- data Human a = Human

59−-- { name :: String

60−-- , age :: Int

61−-- , address :: String

62−-- , other :: a

63−-- }

60+-- data Human a

61+-- = Human

62+-- { name :: String

63+-- , age :: Int

64+-- , address :: String

65+-- , other :: a

66+-- }

67+-- | HumanNoAddress

68+-- { name :: String

69+-- , age :: Int

70+-- , other :: a

71+-- }

6472-- deriving (Generic, Show)

6573-- human :: Human Bool

6674-- 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

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

7583 -- 50

7684 --

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

85+ -- === /Type changing/

86+ --

7887 -- >>> :t human

7988 -- human :: Human Bool

89+ --

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

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

92+ --

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

8394 -- 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+ -- ...

84110 field :: Lens s t a b

85111

86112type HasField' field s a = HasField field s s a a

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

99125

100126instance -- see Note [Changing type parameters]

101127 ( Generic s

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

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

103129 , Generic t

104130 , s' ~ Proxied s

105131 , Generic s'

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

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

119145 field = undefined

120146

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

122− ErrorUnless field s 'False

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

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

123149 = TypeError

124150 ( 'Text "The type "

125151 ':<>: 'ShowType s

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

127− ':<>: 'ShowType field

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 "

159+ ':<>: 'ShowType s

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

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

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

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

128164 )

129165

130− ErrorUnless _ _ 'True

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

131167 = ()

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

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

2929module Data.Generics.Product.Positions

3030 ( -- *Lenses

3131

32− -- $setup

32+ -- $setup

3333 HasPosition (..)

3434 , HasPosition'

3535

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

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

4949

5050-- $setup

51+-- == /Running example:/

52+--

5153-- >>> :set -XTypeApplications

5254-- >>> :set -XDataKinds

5355-- >>> :set -XDeriveGeneric

56+-- >>> :set -XGADTs

57+-- >>> :set -XFlexibleContexts

5458-- >>> import GHC.Generics

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

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

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

7478 -- "Tunyasz"

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

7680 -- 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+ -- ...

7788 position :: Lens s t a b

7889

7990type HasPosition' i s a = HasPosition i s s a a

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

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

2828module Data.Generics.Product.Subtype

2929 ( -- *Lenses

3030 --

31− -- $setup

31+ -- $setup

3232 Subtype (..)

3333 ) where

3434

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

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

4040

4141-- $setup

42+-- == /Running example:/

43+--

4244-- >>> :set -XTypeApplications

4345-- >>> :set -XDataKinds

4446-- >>> :set -XDeriveGeneric

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

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

2626module Data.Generics.Product.Typed

2727 ( -- *Lenses

2828 --

29− -- $setup

29+ -- $setup

3030 HasType (..)

3131 ) where

3232

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

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

4141

4242-- $setup

43+-- == /Running example:/

44+--

4345-- >>> :set -XTypeApplications

4446-- >>> :set -XDataKinds

4547-- >>> :set -XDeriveGeneric

4648-- >>> import GHC.Generics

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

4850-- >>> :{

49−-- data Human = Human

50−-- { name :: String

51−-- , age :: Int

52−-- , address :: String

53−-- }

51+-- data Human

52+-- = Human

53+-- { name :: String

54+-- , age :: Int

55+-- , address :: String

56+-- , tall :: Bool

57+-- }

58+-- | HumanNoTall

59+-- { name :: String

60+-- , age :: Int

61+-- , address :: String

62+-- }

5463-- deriving (Generic, Show)

5564-- human :: Human

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

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

5766-- :}

5867

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

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

6372 --

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

6574 -- 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+ -- ...

6694 typed :: Lens' s a

6795 typed f t

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

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

79107

80108instance

81109 ( Generic s

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

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

83111 , GHasType (Rep s) a

84112 ) => HasType a s where

85113

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

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

90118 typed = undefined

91119

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

93− ErrorUnlessOne a s 'None

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

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

94122 = TypeError

95123 ( 'Text "The type "

96124 ':<>: 'ShowType s

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

98126 ':<>: 'ShowType a

99127 )

100128

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) _)

102140 = TypeError

103141 ( 'Text "The type "

104142 ':<>: 'ShowType s

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

106− ':<>: 'ShowType a

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

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

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

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

108147 )

109148

110− ErrorUnlessOne _ _ 'One

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

111150 = ()

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

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

1717

1818module Data.Generics.Sum

1919 ( -- *Prisms

20− module Any

21− , module Constructors

22− , module Subtype

23− , module Typed

20+ module Data.Generics.Sum.Any

21+ , module Data.Generics.Sum.Constructors

22+ , module Data.Generics.Sum.Subtype

23+ , module Data.Generics.Sum.Typed

2424 ) where

2525

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

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

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

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

26+import Data.Generics.Sum.Any

27+import Data.Generics.Sum.Constructors

28+import Data.Generics.Sum.Subtype

29+import Data.Generics.Sum.Typed

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

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

2424module Data.Generics.Sum.Any

2525 ( -- *Prisms

2626 --

27− -- $setup

27+ -- $setup

2828 AsAny (..)

2929 ) where

3030

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

3333import Data.Generics.Sum.Typed

3434

3535-- $setup

36+-- == /Running example:/

37+--

3638-- >>> :set -XTypeApplications

3739-- >>> :set -XDataKinds

3840-- >>> :set -XDeriveGeneric

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

6668 --

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

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

71+ --

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

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

74+ --

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

7276 -- Nothing

77+ --

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

7479 -- Just ("Mog",5)

80+ --

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

7682 -- Just ("Mog",5)

83+ --

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

7885 -- Cat "Garfield" 6

86+ --

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

8088 -- Just 2

8189 _As :: Prism' s a

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

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

2626module Data.Generics.Sum.Constructors

2727 ( -- *Prisms

2828

29− -- $setup

29+ -- $setup

3030 AsConstructor (..)

3131 ) where

3232

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

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

4141

4242-- $setup

43+-- == /Running example:/

44+--

4345-- >>> :set -XTypeApplications

4446-- >>> :set -XDataKinds

4547-- >>> :set -XDeriveGeneric

48+-- >>> :set -XFlexibleContexts

49+-- >>> :set -XTypeFamilies

4650-- >>> import GHC.Generics

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

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

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

8488 --

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

8690 -- 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+ -- ...

8799 _Ctor :: Prism s t a b

88100

89101instance

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

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

2222module Data.Generics.Sum.Subtype

2323 ( -- *Prisms

2424 --

25− -- $setup

25+ -- $setup

2626 AsSubtype (..)

2727 ) where

2828

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

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

3434

3535-- $setup

36+-- == /Running example:/

37+--

3638-- >>> :set -XTypeApplications

3739-- >>> :set -XDataKinds

3840-- >>> :set -XDeriveGeneric

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

7779 --

7880 -- >>> _Sub # dog4 :: Animal

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

82+ --

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

8184 -- Just (Cat4 "Mog" 5)

85+ --

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

8387 -- Nothing

8488 _Sub :: Prism' sup sub

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

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

3131

3232import Data.Kind

3333import GHC.Generics

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

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

3535import Data.Generics.Sum.Internal.Typed

3636

3737import Data.Generics.Internal.Families

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

4949-- = Dog Dog

5050-- | Cat Name Age

5151-- | Duck Age

52+-- | Turtle Age

5253-- deriving (Generic, Show)

5354-- data Dog

5455-- = MkDog

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

5758-- }

5859-- deriving (Generic, Show)

5960-- type Name = String

60−-- type Age = Int

61+-- newtype Age = Age Int deriving Show

6162-- dog, cat, duck :: Animal

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

63−-- cat = Cat "Mog" 5

64−-- duck = Duck 2

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

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

65+-- duck = Duck (Age 2)

6566-- :}

6667

6768

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

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

7273 --

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

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

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

76− -- Nothing

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

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

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

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

80− -- Just 2

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

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

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

8186 _Typed :: Prism' s a

8287

8388 -- |Inject by type.

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

8893

8994instance

9095 ( Generic s

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

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

9297 , GAsType (Rep s) a

9398 ) => AsType a s where

9499

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

109114 injectTyped = undefined

110115 projectTyped = undefined

111116

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

113− ErrorUnlessOne a s 'None

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

118+ ErrorUnlessOne _ _ '[_]

119+ = ()

120+

121+ ErrorUnlessOne a s '[]

114122 = TypeError

115123 ( 'Text "The type "

116124 ':<>: 'ShowType s

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

118126 ':<>: 'ShowType a

119127 )

120128

121− ErrorUnlessOne a s 'Multiple

129+ ErrorUnlessOne a s cs

122130 = TypeError

123131 ( 'Text "The type "

124132 ':<>: 'ShowType s

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

126− ':<>: 'ShowType a

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

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

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

136+ ':$$: ShowConstuctors cs

128137 )

129−

130− ErrorUnlessOne _ _ 'One

131− = ()