8e3bbed · generic-lens

examples/Examples.hs+14−14

compare with master

unifiedsplit

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

1−{-# LANGUAGE GADTs #-}

2−{-# LANGUAGE ScopedTypeVariables #-}

3−{-# LANGUAGE Rank2Types #-}

4−{-# LANGUAGE AllowAmbiguousTypes #-}

1+{-# LANGUAGE AllowAmbiguousTypes #-}

5−{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE DataKinds #-}

6−{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE DeriveGeneric #-}

7−{-# LANGUAGE DuplicateRecordFields #-}

4+{-# LANGUAGE DuplicateRecordFields #-}

8−{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleContexts #-}

6+{-# LANGUAGE GADTs #-}

9−{-# LANGUAGE NoMonomorphismRestriction #-}

7+{-# LANGUAGE NoMonomorphismRestriction #-}

10−{-# LANGUAGE PartialTypeSignatures #-}

8+{-# LANGUAGE PartialTypeSignatures #-}

9+{-# LANGUAGE Rank2Types #-}

10+{-# LANGUAGE ScopedTypeVariables #-}

11−{-# LANGUAGE TypeApplications #-}

11+{-# LANGUAGE TypeApplications #-}

12−{-# LANGUAGE UndecidableInstances #-}

12+{-# LANGUAGE UndecidableInstances #-}

13−

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

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

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

15

16module Examples where

17

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

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

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

20module Data.Generics.Internal.Families

21 ( module Families

22− , ShowConstuctors

22+ , ShowSymbols

23 ) where

24

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

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

28

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

30

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

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

32− ShowConstuctors '[]

32+ ShowSymbols '[]

33 = 'Text ""

34− ShowConstuctors (c ': cs)

34+ ShowSymbols (c ': cs)

35− = 'Text "* " ':<>: 'Text c ':$$: ShowConstuctors 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

18 ( CollectTotalType

19 , CollectPartialType

20 , CollectField

21+ , CollectFieldsOrdered

21 , TypeStat (..)

22 , TypeStat (..)

23+ , type (\\)

22 ) where

24 ) where

23

25

24import Data.Type.Bool (If)

26import Data.Type.Bool (If)

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

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

26import GHC.Generics

28import GHC.Generics

27−import GHC.TypeLits (Symbol)

29+import GHC.TypeLits (Symbol, CmpSymbol)

28

30

29import Data.Generics.Internal.HList

31import Data.Generics.Internal.HList

30

32

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

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

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

99 a <&> a = a

101 a <&> a = a

100 _ <&> _ = 'Multiple

102 _ <&> _ = '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

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

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

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

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

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

164 )

165

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

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

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

32 Subtype (..)

33 ) where

34

35+import Data.Generics.Internal.Families

35import Data.Generics.Internal.Lens

36import Data.Generics.Internal.Lens

36import Data.Generics.Internal.Void

37import Data.Generics.Internal.Void

37import Data.Generics.Product.Internal.Subtype

38import Data.Generics.Product.Internal.Subtype

38

39

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

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

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

42+import Data.Kind (Type, Constraint)

40

43

41-- $setup

44-- $setup

42-- == /Running example:/

45-- == /Running example:/

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

86 -- >>> upcast human :: Animal

89 -- >>> upcast human :: Animal

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

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

88 --

91 --

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

89 upcast :: sub -> sup

98 upcast :: sub -> sup

90 upcast s = s ^. super @sup

99 upcast s = s ^. super @sup

91

100

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

98

107

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

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

100

109

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

102instance

110instance

103 ( Generic a

111 ( Generic a

104 , Generic b

112 , Generic b

105 , GSmash (Rep a) (Rep b)

113 , GSmash (Rep a) (Rep b)

106 , GUpcast (Rep a) (Rep b)

114 , GUpcast (Rep a) (Rep b)

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

107 ) => Subtype b a where

116 ) => Subtype b a where

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

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

109 upcast = to . gupcast . from

118 upcast = to . gupcast . from

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

113 super = undefined

122 super = undefined

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

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

115 super = undefined

124 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

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

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

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

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

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

137 )

138

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

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

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

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

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

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

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

147 )

148

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

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

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

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

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

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

136− ':$$: ShowConstuctors cs

136+ ':$$: ShowSymbols cs

137 )