8e3bbed · generic-lens

git.iko.soy/generic-lens

Improve error message for subtype lens

Show a list of missing fields

commit8e3bbedfa5d34d6023dc2d88cf77e9dff90b45d6 authorCsongor Kiss <kiss.csongor.kiss@gmail.com> dateSun 10 Dec 2017, 18:13 (9 years ago) parent94d377a

7 files changed+81−25

compare with master

unifiedsplit

examples/Examples.hs+14−14 src/Data/Generics/Internal/Families.hs+5−5 src/Data/Generics/Internal/Families/Collect.hs+33−1 src/Data/Generics/Product/Fields.hs+1−1 src/Data/Generics/Product/Subtype.hs+25−1 src/Data/Generics/Product/Typed.hs+2−2 src/Data/Generics/Sum/Typed.hs+1−1

examples/Examples.hs+14−14

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

1−{-# LANGUAGE GADTs #-}

2−{-# LANGUAGE ScopedTypeVariables #-}

3−{-# LANGUAGE Rank2Types #-}

4−{-# LANGUAGE AllowAmbiguousTypes #-}

5−{-# LANGUAGE DataKinds #-}

6−{-# LANGUAGE DeriveGeneric #-}

7−{-# LANGUAGE DuplicateRecordFields #-}

8−{-# LANGUAGE FlexibleContexts #-}

9−{-# LANGUAGE NoMonomorphismRestriction #-}

10−{-# LANGUAGE PartialTypeSignatures #-}

11−{-# LANGUAGE TypeApplications #-}

12−{-# LANGUAGE UndecidableInstances #-}

13−

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

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE DeriveGeneric #-}

4+{-# LANGUAGE DuplicateRecordFields #-}

5+{-# LANGUAGE FlexibleContexts #-}

6+{-# LANGUAGE GADTs #-}

7+{-# LANGUAGE NoMonomorphismRestriction #-}

8+{-# LANGUAGE PartialTypeSignatures #-}

9+{-# LANGUAGE Rank2Types #-}

10+{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE TypeApplications #-}

12+{-# LANGUAGE UndecidableInstances #-}

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

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

1515

1616module Examples where

1717

src/Data/Generics/Internal/Families.hs+5−5

@@ -19,7 +19,7 @@

1919-----------------------------------------------------------------------------

2020module Data.Generics.Internal.Families

2121 ( module Families

22− , ShowConstuctors

22+ , ShowSymbols

2323 ) where

2424

2525import Data.Generics.Internal.Families.Collect as Families

@@ -28,8 +28,8 @@ import Data.Generics.Internal.Families.Changing as Families

2828

2929import GHC.TypeLits (ErrorMessage (..), Symbol)

3030

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

32− ShowConstuctors '[]

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

32+ ShowSymbols '[]

3333 = 'Text ""

34− ShowConstuctors (c ': cs)

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

34+ ShowSymbols (c ': cs)

35+ = 'Text "• " ':<>: 'Text c ':$$: ShowSymbols cs

src/Data/Generics/Internal/Families/Collect.hs+33−1

@@ -18,13 +18,15 @@ module Data.Generics.Internal.Families.Collect

1818 ( CollectTotalType

1919 , CollectPartialType

2020 , CollectField

21+ , CollectFieldsOrdered

2122 , TypeStat (..)

23+ , type (\\)

2224 ) where

2325

2426import Data.Type.Bool (If)

2527import Data.Type.Equality (type (==))

2628import GHC.Generics

27−import GHC.TypeLits (Symbol)

29+import GHC.TypeLits (Symbol, CmpSymbol)

2830

2931import Data.Generics.Internal.HList

3032

@@ -98,3 +100,33 @@ type family (a :: Count) <|> (b :: Count) :: Count where

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

99101 a <&> a = a

100102 _ <&> _ = 'Multiple

103+

104+type family CollectFieldsOrdered (r :: * -> *) :: [Symbol] where

105+ CollectFieldsOrdered (l :*: r)

106+ = Merge (CollectFieldsOrdered l) (CollectFieldsOrdered r)

107+ CollectFieldsOrdered (S1 ('MetaSel ('Just name) _ _ _) _)

108+ = '[name]

109+ CollectFieldsOrdered (M1 _ m a)

110+ = CollectFieldsOrdered a

111+ CollectFieldsOrdered _

112+ = '[]

113+

114+type family Merge (xs :: [Symbol]) (ys :: [Symbol]) :: [Symbol] where

115+ Merge xs '[] = xs

116+ Merge '[] ys = ys

117+ Merge (x ': xs) (y ': ys) = Merge' (CmpSymbol x y) x y xs ys

118+

119+type family Merge' (ord :: Ordering) (x :: Symbol) (y :: Symbol) (xs :: [Symbol]) (ys :: [Symbol]) :: [Symbol] where

120+ Merge' 'LT x y xs ys = x ': Merge xs (y ': ys)

121+ Merge' _ x y xs ys = y ': Merge (x ': xs) ys

122+

123+type family (xs :: [Symbol]) \\ (ys :: [Symbol]) :: [Symbol] where

124+ xs \\ '[] = xs

125+ '[] \\ xs = '[]

126+ (x ': xs) \\ (y ': ys) = Sub' (CmpSymbol x y) x y xs ys

127+

128+infixr 5 \\

129+type family Sub' (ord :: Ordering) (x :: Symbol) (y :: Symbol) (xs :: [Symbol]) (ys :: [Symbol]) :: [Symbol] where

130+ Sub' 'LT x y xs ys = x ': (xs \\ y ': ys)

131+ Sub' 'GT x _ xs ys = (x ': xs) \\ ys

132+ Sub' 'EQ _ _ xs ys = xs \\ ys

src/Data/Generics/Product/Fields.hs+1−1

@@ -160,7 +160,7 @@ type family ErrorUnless (field :: Symbol) (s :: Type) (stat :: TypeStat) :: Cons

160160 ':$$: 'Text " contain a field named '"

161161 ':<>: 'Text field ':<>: 'Text "'."

162162 ':$$: 'Text "The offending constructors are:"

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

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

164164 )

165165

166166 ErrorUnless _ _ ('TypeStat '[] '[] _)

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

@@ -32,11 +32,14 @@ module Data.Generics.Product.Subtype

3232 Subtype (..)

3333 ) where

3434

35+import Data.Generics.Internal.Families

3536import Data.Generics.Internal.Lens

3637import Data.Generics.Internal.Void

3738import Data.Generics.Product.Internal.Subtype

3839

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

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

42+import Data.Kind (Type, Constraint)

4043

4144-- $setup

4245-- == /Running example:/

@@ -86,6 +89,12 @@ class Subtype sup sub where

8689 -- >>> upcast human :: Animal

8790 -- Animal {name = "Tunyasz", age = 50}

8891 --

92+ -- >>> upcast (upcast human :: Animal) :: Human

93+ -- ...

94+ -- ... The type 'Human' is not a subtype of 'Animal'.

95+ -- ... The following fields are missing from 'Human':

96+ -- ... address

97+ -- ...

8998 upcast :: sub -> sup

9099 upcast s = s ^. super @sup

91100

@@ -98,12 +107,12 @@ class Subtype sup sub where

98107

99108 {-# MINIMAL super | smash, upcast #-}

100109

101−-- TODO: improve type error by showing a diff of fields

102110instance

103111 ( Generic a

104112 , Generic b

105113 , GSmash (Rep a) (Rep b)

106114 , GUpcast (Rep a) (Rep b)

115+ , ErrorUnless b a (CollectFieldsOrdered (Rep b) \\ CollectFieldsOrdered (Rep a))

107116 ) => Subtype b a where

108117 smash p b = to $ gsmash (from p) (from b)

109118 upcast = to . gupcast . from

@@ -113,3 +122,18 @@ instance {-# OVERLAPPING #-} Subtype a Void where

113122 super = undefined

114123instance {-# OVERLAPPING #-} Subtype Void a where

115124 super = undefined

125+

126+type family ErrorUnless (sub :: Type) (sup :: Type) (diff :: [Symbol]) :: Constraint where

127+ ErrorUnless _ _ '[]

128+ = ()

129+

130+ ErrorUnless sub sup fs

131+ = TypeError

132+ ( 'Text "The type '"

133+ ':<>: 'ShowType sub

134+ ':<>: 'Text "' is not a subtype of '"

135+ ':<>: 'ShowType sup ':<>: 'Text "'."

136+ ':$$: 'Text "The following fields are missing from '"

137+ ':<>: 'ShowType sub ':<>: 'Text "':"

138+ ':$$: ShowSymbols fs

139+ )

src/Data/Generics/Product/Typed.hs+2−2

@@ -133,7 +133,7 @@ type family ErrorUnlessOne (a :: Type) (s :: Type) (stat :: TypeStat) :: Constra

133133 ':<>: 'Text " contain a field of type "

134134 ':<>: 'ShowType a ':<>: 'Text "."

135135 ':$$: 'Text "The offending constructors are:"

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

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

137137 )

138138

139139 ErrorUnlessOne a s ('TypeStat _ (m ': ms) _)

@@ -143,7 +143,7 @@ type family ErrorUnlessOne (a :: Type) (s :: Type) (stat :: TypeStat) :: Constra

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

144144 ':<>: 'ShowType a ':<>: 'Text "."

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

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

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

147147 )

148148

149149 ErrorUnlessOne _ _ ('TypeStat '[] '[] _)

src/Data/Generics/Sum/Typed.hs+1−1

@@ -133,5 +133,5 @@ type family ErrorUnlessOne (a :: Type) (s :: Type) (ctors :: [Symbol]) :: Constr

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

134134 ':<>: 'ShowType a ':<>: 'Text "."

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

136− ':$$: ShowConstuctors cs

136+ ':$$: ShowSymbols cs

137137 )