cf20ae3 · generic-lens

git.iko.soy/generic-lens

Merge pull request #77 from kcsongor/type-errors

Better type errors for missing instances

commitcf20ae3a0f27d25edf97c79b6635f7c79c9bc941 authorCsongor Kiss <kiss.csongor.kiss@gmail.com> dateTue 15 Jan 2019, 13:47 (8 years ago) parent7883568 3f54d20

13 files changed+189−41

compare with master

unifiedsplit

.travis.yml+9−9 ChangeLog.md+1 generic-lens.cabal+1 src/Data/GenericLens/Internal.hs+2 src/Data/Generics/Internal/Errors.hs+59 src/Data/Generics/Product/Fields.hs+18−11 src/Data/Generics/Product/Param.hs+9−2 src/Data/Generics/Product/Positions.hs+23−8 src/Data/Generics/Product/Subtype.hs+11 src/Data/Generics/Product/Typed.hs+4 src/Data/Generics/Product/Types.hs+32−4 src/Data/Generics/Sum/Constructors.hs+16−7 src/Data/Generics/Sum/Typed.hs+4

.travis.yml+9−9

@@ -60,9 +60,9 @@ install:

6060 (cd "."; autoreconf -i);

6161 fi

6262 - rm -f cabal.project.freeze

63− - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all

64− - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all

65− - rm -rf "."/.ghc.environment.* "."/dist

63+ - cabal build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all

64+ - cabal build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all

65+ - rm -rf "."/.ghc.environment.* "."/dist-newstyle

6666 - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)

6767

6868# Here starts the actual work to be performed for the package under test;

@@ -70,26 +70,26 @@ install:

7070script:

7171 # test that source-distributions can be generated

7272 - (cd "."; cabal sdist)

73− - mv "."/dist/generic-lens-*.tar.gz ${DISTDIR}/

73+ - mv "."/dist-newstyle/sdist/generic-lens-*.tar.gz ${DISTDIR}/

7474 - cd ${DISTDIR}

7575 - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;

7676 - "echo 'packages: generic-lens-*/*.cabal' > cabal.project"

7777 - "echo 'write-ghc-environment-files: always' >> cabal.project"

7878 # this builds all libraries and executables (without tests/benchmarks)

79− - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all

79+ - cabal build -w ${HC} --disable-tests --disable-benchmarks all

8080

8181 # Build with installed constraints for packages in global-db

8282 - if $INSTALLED; then

83− echo cabal new-build -w ${HC} --disable-tests --disable-benchmarks $(${HCPKG} list --global --simple-output --names-only | sed 's/$[a-zA-Z0-9-]\{1,\}$ */--constraint="\1 installed" /g') all | sh;

83+ echo cabal build -w ${HC} --disable-tests --disable-benchmarks $(${HCPKG} list --global --simple-output --names-only | sed 's/$[a-zA-Z0-9-]\{1,\}$ */--constraint="\1 installed" /g') all | sh;

8484 else echo "Not building with installed constraints"; fi

8585

8686 # build & run tests, build benchmarks

87− - cabal new-build -w ${HC} ${TEST} ${BENCH} all

88− - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} all; fi

87+ - cabal build -w ${HC} ${TEST} ${BENCH} all

88+ - if [ "x$TEST" = "x--enable-tests" ]; then cabal test -w ${HC} ${TEST} all; fi

8989

9090 # haddock

9191 - rm -rf ./dist-newstyle

92− - if $HADDOCK; then cabal new-haddock -w ${HC} --disable-tests --disable-benchmarks all; else echo "Skipping haddock generation";fi

92+ - if $HADDOCK; then cabal haddock -w ${HC} --disable-tests --disable-benchmarks all; else echo "Skipping haddock generation";fi

9393

9494# REGENDATA ["generic-lens.cabal"]

9595# EOF

ChangeLog.md+1

@@ -1,5 +1,6 @@

11## 1.2.0.0

22- Add `HasTypesUsing` and `HasTypesCustom` for custom traversals (Lysxia)

3+- Improve type errors when no Generic instance is defined

45### Breaking API changes

56- `HasType` now includes a reflexive case so that every type 'contains' itself (Matt Parsons)

generic-lens.cabal+1

@@ -56,6 +56,7 @@ library

5656 , Data.Generics.Internal.Families.Changing

5757 , Data.Generics.Internal.Families.Collect

5858 , Data.Generics.Internal.Families.Has

59+ , Data.Generics.Internal.Errors

5960 , Data.Generics.Internal.Void

6061

6162 , Data.Generics.Sum.Internal.Constructors

src/Data/GenericLens/Internal.hs+2

@@ -18,6 +18,7 @@ module Data.GenericLens.Internal

1818 , module Data.Generics.Internal.Families.Collect

1919 , module Data.Generics.Internal.Families.Has

2020 , module Data.Generics.Internal.Void

21+ , module Data.Generics.Internal.Errors

2122

2223 , module Data.Generics.Sum.Internal.Constructors

2324 , module Data.Generics.Sum.Internal.Typed

@@ -35,6 +36,7 @@ import Data.Generics.Internal.Families.Changing

3536import Data.Generics.Internal.Families.Collect

3637import Data.Generics.Internal.Families.Has

3738import Data.Generics.Internal.Void

39+import Data.Generics.Internal.Errors

3840

3941import Data.Generics.Sum.Internal.Constructors

4042import Data.Generics.Sum.Internal.Typed

src/Data/Generics/Internal/Errors.hsnew file+59

@@ -0,0 +1,59 @@

1+{-# LANGUAGE UndecidableInstances #-}

2+{-# LANGUAGE TypeFamilies #-}

3+{-# LANGUAGE KindSignatures #-}

4+{-# LANGUAGE PolyKinds #-}

5+{-# LANGUAGE DataKinds #-}

6+{-# LANGUAGE TypeOperators #-}

7+{-# LANGUAGE KindSignatures #-}

9+-------------------------------------------------------------------------------

10+---- |

11+---- Module : Data.Generics.Internal.Errors

13+---- License : BSD3

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

15+---- Stability : experimental

16+---- Portability : non-portable

17+----

18+---- Provide more legible type errors as described in

19+---- (https://kcsongor.github.io/report-stuck-families/)[this blog post].

20+-------------------------------------------------------------------------------

21+

22+module Data.Generics.Internal.Errors

23+ ( NoGeneric

24+ , Defined

25+ , Defined_list

26+

27+ , QuoteType

28+ , PrettyError

29+ ) where

30+

31+import GHC.Generics

32+import GHC.TypeLits

33+import Data.Kind

34+

35+type family NoGeneric (a :: Type) (ctxt :: [ErrorMessage]) :: Constraint where

36+ NoGeneric a ctxt = PrettyError ('Text "No instance for " ':<>: QuoteType (Generic a)

37+ ': ctxt)

38+type family PrettyError (ctxt :: [ErrorMessage]) :: k where

39+ PrettyError '[] = TypeError ('Text "")

40+ PrettyError (c ': cs) = TypeError ('Text "| " ':<>: c ':$$: PrettyLines cs)

41+

42+type family PrettyLines (ctxt :: [ErrorMessage]) :: ErrorMessage where

43+ PrettyLines '[] = 'Text ""

44+ PrettyLines (c ': cs) = 'Text "| " ':<>: c ':$$: PrettyLines cs

45+

46+type family Defined (break :: Type -> Type) (err :: Constraint) (a :: k) :: k where

47+ Defined Void1 _ _ = Any

48+ Defined _ _ k = k

49+

50+type family Defined_list (break :: [*]) (err :: Constraint) (a :: k) :: k where

51+ Defined_list '[Void] _ _ = Any

52+ Defined_list _ _ k = k

53+

54+data Void1 a

55+data Void

56+type family Any :: k

57+

58+type family QuoteType (typ :: k) :: ErrorMessage where

59+ QuoteType typ = 'Text "‘" ':<>: 'ShowType typ ':<>: 'Text "’"

src/Data/Generics/Product/Fields.hs+18−11

@@ -47,6 +47,7 @@ import Data.Kind (Constraint, Type)

4747import GHC.Generics

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

4949import Data.Generics.Internal.Profunctor.Lens as P

50+import Data.Generics.Internal.Errors

5051

5152-- $setup

5253-- == /Running example:/

@@ -152,23 +153,25 @@ instance

152153 ( Generic s

153154 , ErrorUnless field s (CollectField field (Rep s))

154155 , GLens' (HasTotalFieldPSym field) (Rep s) a

156+ , Defined (Rep s)

157+ (NoGeneric s '[ 'Text "arising from a generic lens focusing on the "

158+ ':<>: QuoteType field ':<>: 'Text " field of type " ':<>: QuoteType a

159+ , 'Text "in " ':<>: QuoteType s])

160+ (() :: Constraint)

155161 ) => HasField' field s a where

156− field' f s = VL.ravel (repLens . glens @(HasTotalFieldPSym field)) f s

162+ field' f s = field0 @field f s

157163

158164class (~~) (a :: k) (b :: k) | a -> b, b -> a

159165instance (a ~ b) => (~~) a b

160166

161167instance -- see Note [Changing type parameters]

162− ( Generic s

163− , Generic t

164− , ErrorUnless field s (CollectField field (Rep s))

165− , HasTotalFieldP field (Rep s) ~~ 'Just a

168+ ( HasTotalFieldP field (Rep s) ~~ 'Just a

166169 , HasTotalFieldP field (Rep t) ~~ 'Just b

167170 , HasTotalFieldP field (Rep (Indexed s)) ~~ 'Just a'

168171 , HasTotalFieldP field (Rep (Indexed t)) ~~ 'Just b'

169172 , t ~~ Infer s a' b

170173 , s ~~ Infer t b' a

171− , GLens (HasTotalFieldPSym field) (Rep s) (Rep t) a b

174+ , HasField0 field s t a b

172175 ) => HasField field s t a b where

173176 field f s = field0 @field f s

174177

@@ -177,14 +180,11 @@ instance {-# OVERLAPPING #-} HasField f (Void1 a) (Void1 b) a b where

177180 field = undefined

178181

179182instance

180− ( Generic s

181− , Generic t

182− , ErrorUnless field s (CollectField field (Rep s))

183− , HasTotalFieldP field (Rep s) ~~ 'Just a

183+ ( HasTotalFieldP field (Rep s) ~~ 'Just a

184184 , HasTotalFieldP field (Rep t) ~~ 'Just b

185185 , UnifyHead s t

186186 , UnifyHead t s

187− , GLens (HasTotalFieldPSym field) (Rep s) (Rep t) a b

187+ , HasField0 field s t a b

188188 ) => HasField_ field s t a b where

189189 field_ f s = field0 @field f s

190190

@@ -195,8 +195,15 @@ instance

195195 ( Generic s

196196 , Generic t

197197 , GLens (HasTotalFieldPSym field) (Rep s) (Rep t) a b

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

199+ , Defined (Rep s)

200+ (NoGeneric s '[ 'Text "arising from a generic lens focusing on the "

201+ ':<>: QuoteType field ':<>: 'Text " field of type " ':<>: QuoteType a

202+ , 'Text "in " ':<>: QuoteType s])

203+ (() :: Constraint)

198204 ) => HasField0 field s t a b where

199205 field0 = VL.ravel (repLens . glens @(HasTotalFieldPSym field))

206+ {-# INLINE field0 #-}

200207

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

202209 ErrorUnless field s ('TypeStat _ _ '[])

src/Data/Generics/Product/Param.hs+9−2

@@ -16,12 +16,12 @@

1616-- |

1717-- Module : Data.Generics.Product.Param

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

2019-- License : BSD3

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

2121-- Stability : experimental

2222-- Portability : non-portable

2323--

24−-- Derive traversal over type parameters

24+-- Derive traversals over type parameters

2525--

2626--------------------------------------------------------------------------------

2727

@@ -39,6 +39,7 @@ import GHC.Generics

3939import Data.Kind

4040import Data.Generics.Internal.VL.Iso

4141import Data.Generics.Internal.GenericN

42+import Data.Generics.Internal.Errors

4243

4344class HasParam (p :: Nat) s t a b | p t a -> s, p s b -> t, p s -> a, p t -> b where

4445 param :: Applicative g => (a -> g b) -> s -> g t

@@ -47,6 +48,12 @@ instance

4748 ( GenericN s

4849 , GenericN t

4950 -- TODO: merge the old 'Changing' code with 'GenericN'

51+ , Defined (Rep s)

52+ (NoGeneric s

53+ '[ 'Text "arising from a generic traversal of the type parameter at position " ':<>: QuoteType n

54+ , 'Text "of type " ':<>: QuoteType a ':<>: 'Text " in " ':<>: QuoteType s

55+ ])

56+ (() :: Constraint)

5057 , s ~ Infer t (P n b 'PTag) a

5158 , t ~ Infer s (P n a 'PTag) b

5259 , Error ((ArgCount s) <=? n) n (ArgCount s) s

src/Data/Generics/Product/Positions.hs+23−8

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

4747import Data.Generics.Internal.Families

4848import Data.Generics.Product.Internal.Positions

4949import Data.Generics.Product.Internal.GLens

50+import Data.Generics.Internal.Errors

5051

5152import Data.Kind (Constraint, Type)

5253import Data.Type.Bool (type (&&))

@@ -114,9 +115,15 @@ class HasPosition' (i :: Nat) s a | s i -> a where

114115class HasPosition0 (i :: Nat) s t a b where

115116 position0 :: VL.Lens s t a b

116117

118+-- |

119+-- >>> getPosition @2 human

120+-- 50

117121getPosition :: forall i s a. HasPosition' i s a => s -> a

118122getPosition s = s ^. position' @i

119123

124+-- |

125+-- >>> setPosition @2 60 human

126+-- Human {name = "Tunyasz", age = 60, address = "London"}

120127setPosition :: forall i s a. HasPosition' i s a => a -> s -> s

121128setPosition = VL.set (position' @i)

122129

@@ -126,6 +133,12 @@ instance

126133 , cs ~ CRep s

127134 , Coercible (Rep s) cs

128135 , GLens' (HasTotalPositionPSym i) cs a

136+ , Defined (Rep s)

137+ (NoGeneric s '[ 'Text "arising from a generic lens focusing on the field at"

138+ , 'Text "position " ':<>: QuoteType i ':<>: 'Text " of type " ':<>: QuoteType a

139+ ':<>: 'Text " in " ':<>: QuoteType s

140+ ])

141+ (() :: Constraint)

129142 ) => HasPosition' i s a where

130143 position' f s = VL.ravel (repLens . coerced @cs @cs . glens @(HasTotalPositionPSym i)) f s

131144 {-# INLINE position' #-}

@@ -136,10 +149,7 @@ class (~~) (a :: k) (b :: k) | a -> b, b -> a

136149instance (a ~ b) => (~~) a b

137150

138151instance -- see Note [Changing type parameters]

139− ( Generic s

140− , Generic t

141− , ErrorUnless i s (0 <? i && i <=? Size (Rep s))

142− , GLens (HasTotalPositionPSym i) (CRep s) (CRep t) a b

152+ ( ErrorUnless i s (0 <? i && i <=? Size (Rep s))

143153 , HasTotalPositionP i (CRep s) ~~ 'Just a

144154 , HasTotalPositionP i (CRep t) ~~ 'Just b

145155 , HasTotalPositionP i (CRep (Indexed s)) ~~ 'Just a'

@@ -148,6 +158,7 @@ instance -- see Note [Changing type parameters]

148158 , s ~~ Infer t b' a

149159 , Coercible (CRep s) (Rep s)

150160 , Coercible (CRep t) (Rep t)

161+ , HasPosition0 i s t a b

151162 ) => HasPosition i s t a b where

152163

153164 position = position0 @i

@@ -166,14 +177,12 @@ instance {-# OVERLAPPING #-} HasPosition f (Void1 a) (Void1 b) a b where

166177 position = undefined

167178

168179instance

169− ( Generic s

170− , Generic t

171− , ErrorUnless i s (0 <? i && i <=? Size (Rep s))

172− , GLens (HasTotalPositionPSym i) (CRep s) (CRep t) a b

180+ ( ErrorUnless i s (0 <? i && i <=? Size (Rep s))

173181 , UnifyHead s t

174182 , UnifyHead t s

175183 , Coercible (CRep s) (Rep s)

176184 , Coercible (CRep t) (Rep t)

185+ , HasPosition0 i s t a b

177186 ) => HasPosition_ i s t a b where

178187

179188 position_ = position0 @i

@@ -188,6 +197,12 @@ instance

188197 , GLens (HasTotalPositionPSym i) (CRep s) (CRep t) a b

189198 , Coercible (CRep s) (Rep s)

190199 , Coercible (CRep t) (Rep t)

200+ , Defined (Rep s)

201+ (NoGeneric s '[ 'Text "arising from a generic lens focusing on the field at"

202+ , 'Text "position " ':<>: QuoteType i ':<>: 'Text " of type " ':<>: QuoteType a

203+ ':<>: 'Text " in " ':<>: QuoteType s

204+ ])

205+ (() :: Constraint)

191206 ) => HasPosition0 i s t a b where

192207 position0 = VL.ravel (repLens . coerced @(CRep s) @(CRep t) . glens @(HasTotalPositionPSym i))

193208 {-# INLINE position0 #-}

src/Data/Generics/Product/Subtype.hs+11

@@ -41,6 +41,7 @@ import GHC.Generics (Generic (Rep, to, from) )

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

4242import Data.Kind (Type, Constraint)

4343import Data.Generics.Internal.Profunctor.Lens hiding (set)

44+import Data.Generics.Internal.Errors

4445

4546-- $setup

4647-- == /Running example:/

@@ -114,6 +115,16 @@ instance

114115 , GSmash (Rep a) (Rep b)

115116 , GUpcast (Rep a) (Rep b)

116117 , ErrorUnless b a (CollectFieldsOrdered (Rep b) \\ CollectFieldsOrdered (Rep a))

118+ , Defined (Rep a)

119+ (NoGeneric a '[ 'Text "arising from a generic lens focusing on " ':<>: QuoteType b

120+ , 'Text "as a supertype of " ':<>: QuoteType a

121+ ])

122+ (() :: Constraint)

123+ , Defined (Rep b)

124+ (NoGeneric b '[ 'Text "arising from a generic lens focusing on " ':<>: QuoteType b

125+ , 'Text "as a supertype of " ':<>: QuoteType a

126+ ])

127+ (() :: Constraint)

117128 ) => Subtype b a where

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

119130 upcast = to . gupcast . from

src/Data/Generics/Product/Typed.hs+4

@@ -40,6 +40,7 @@ import Data.Kind (Constraint, Type)

4040import GHC.Generics (Generic (Rep))

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

4242import Data.Generics.Internal.Profunctor.Lens

43+import Data.Generics.Internal.Errors

4344

4445-- $setup

4546-- == /Running example:/

@@ -111,6 +112,9 @@ class HasType a s where

111112instance

112113 ( Generic s

113114 , ErrorUnlessOne a s (CollectTotalType a (Rep s))

115+ , Defined (Rep s)

116+ (NoGeneric s '[ 'Text "arising from a generic lens focusing on a field of type " ':<>: QuoteType a])

117+ (() :: Constraint)

114118 , GLens (HasTotalTypePSym a) (Rep s) (Rep s) a a

115119 ) => HasType a s where

116120

src/Data/Generics/Product/Types.hs+32−4

@@ -50,7 +50,9 @@ import Data.Int (Int8, Int16, Int32, Int64)

5050import Data.Word (Word, Word8, Word16, Word32, Word64)

5151

5252import GHC.Generics

53+import GHC.TypeLits

5354import Data.Generics.Internal.VL.Traversal

55+import Data.Generics.Internal.Errors

5456

5557-- $setup

5658-- == /Running example:/

@@ -131,7 +133,9 @@ instance {-# OVERLAPPING #-} HasTypesUsing ch s Void where

131133-- >>> myTree = WithWeight (Fork (Leaf (Opaque "foo")) (Leaf (Opaque "bar"))) False

132134-- >>> over (types @String) (++ "!") myTree

133135-- ...

134−-- ... No instance for (HasTypesOpt

136+-- ... | No instance for ‘Generic Opaque’

137+-- ... | arising from a generic traversal.

138+-- ... | Either derive the instance, or define a custom traversal using ‘HasTypesCustom’

135139-- ...

136140--

137141-- In these cases, we can define a custom traversal strategy to override the

@@ -204,6 +208,13 @@ class HasTypesCustom (ch :: Type) s a where

204208instance {-# OVERLAPPABLE #-}

205209 ( GHasTypes ch (Rep s) a

206210 , Generic s

211+ -- if there's no Generic instance here, it means we got through the

212+ -- Children check by a user-defined custom strategy.

213+ -- Therefore, we can ignore the missing Generic instance, and

214+ -- instead report a missing HasTypesCustom instance

215+ , Defined (Rep s)

216+ (PrettyError '[ 'Text "No instance " ':<>: QuoteType (HasTypesCustom ch s a)])

217+ (() :: Constraint)

207218 ) => HasTypesCustom ch s a where

208219 typesCustom f s = to <$> gtypes_ @ch f (from s)

209220 --{-# INLINE types' #-}

@@ -230,7 +241,13 @@ type family ChildrenDefault (a :: Type) :: [Type] where

230241 ChildrenDefault Word16 = '[]

231242 ChildrenDefault Word32 = '[]

232243 ChildrenDefault Word64 = '[]

233− ChildrenDefault a = ChildrenGeneric (Rep a) '[]

244+ ChildrenDefault a

245+ = Defined (Rep a)

246+ (NoGeneric a

247+ '[ 'Text "arising from a generic traversal."

248+ , 'Text "Either derive the instance, or define a custom traversal using " ':<>: QuoteType HasTypesCustom

249+ ])

250+ (ChildrenGeneric (Rep a) '[])

234251

235252type family ChildrenGeneric (f :: k -> Type) (cs :: [Type]) :: [Type] where

236253 ChildrenGeneric (M1 _ _ f) cs = ChildrenGeneric f cs

@@ -303,7 +320,16 @@ instance GHasTypes ch V1 a where

303320 {-# INLINE gtypes_ #-}

304321

305322type Interesting (ch :: Type) (a :: Type) (t :: Type)

306− = IsNothing (Interesting' ch a '[t] (Children ch t))

323+ = Defined_list (Children ch t) (NoChildren ch t)

324+ (IsNothing (Interesting' ch a '[t] (Children ch t)))

325+

326+type family NoChildren (ch :: Type) (a :: Type) :: Constraint where

327+ NoChildren ch a = PrettyError

328+ '[ 'Text "No type family instance for " ':<>: QuoteType (Children ch a)

329+ , 'Text "arising from a traversal over " ':<>: QuoteType a

330+ , 'Text "with custom strategy " ':<>: QuoteType ch

331+ ]

332+

307333

308334type family Interesting' (ch :: Type) (a :: Type) (seen :: [Type]) (ts :: [Type]) :: Maybe [Type] where

309335 Interesting' ch _ seen '[] = 'Just seen

@@ -317,7 +343,9 @@ type family InterestingUnless

317343 Maybe [Type] where

318344 InterestingUnless ch a seen a _ = 'Nothing

319345 InterestingUnless ch a seen t 'True = 'Just seen

320− InterestingUnless ch a seen t 'False = Interesting' ch a (t ': seen) (Children ch t)

346+ InterestingUnless ch a seen t 'False

347+ = Defined_list (Children ch t) (NoChildren ch t)

348+ (Interesting' ch a (t ': seen) (Children ch t))

321349

322350-- Short circuit

323351type family InterestingOr

src/Data/Generics/Sum/Constructors.hs+16−7

@@ -45,6 +45,7 @@ import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))

4545import Data.Generics.Internal.VL.Prism

4646import Data.Generics.Internal.Profunctor.Iso

4747import Data.Generics.Internal.Profunctor.Prism (prismPRavel)

48+import Data.Generics.Internal.Errors

4849

4950-- $setup

5051-- == /Running example:/

@@ -70,7 +71,7 @@ import Data.Generics.Internal.Profunctor.Prism (prismPRavel)

7071-- , age :: Age

7172-- , fieldA :: a

7273-- }

73−-- deriving (Generic, Show)

74+-- deriving Show

7475-- type Name = String

7576-- type Age = Int

7677-- dog, cat, duck :: Animal Int

@@ -128,20 +129,24 @@ instance

128129 ( Generic s

129130 , ErrorUnless ctor s (HasCtorP ctor (Rep s))

130131 , GAsConstructor' ctor (Rep s) a

132+ , Defined (Rep s)

133+ (NoGeneric s '[ 'Text "arising from a generic prism focusing on the "

134+ ':<>: QuoteType ctor ':<>: 'Text " constructor of type " ':<>: QuoteType a

135+ , 'Text "in " ':<>: QuoteType s])

136+ (() :: Constraint)

131137 ) => AsConstructor' ctor s a where

132138 _Ctor' eta = prismRavel (prismPRavel (repIso . _GCtor @ctor)) eta

133139 {-# INLINE[2] _Ctor' #-}

134140

135141instance

136− ( Generic s

137− , Generic t

138− , ErrorUnless ctor s (HasCtorP ctor (Rep s))

142+ ( ErrorUnless ctor s (HasCtorP ctor (Rep s))

139143 , GAsConstructor' ctor (Rep s) a -- TODO: add a test similar to #62 for prisms

140144 , GAsConstructor' ctor (Rep (Indexed s)) a'

141145 , GAsConstructor ctor (Rep s) (Rep t) a b

142146 , t ~ Infer s a' b

143147 , GAsConstructor' ctor (Rep (Indexed t)) b'

144148 , s ~ Infer t b' a

149+ , AsConstructor0 ctor s t a b

145150 ) => AsConstructor ctor s t a b where

146151

147152 _Ctor = _Ctor0 @ctor

@@ -152,15 +157,14 @@ instance {-# OVERLAPPING #-} AsConstructor ctor (Void1 a) (Void1 b) a b where

152157 _Ctor = undefined

153158

154159instance

155− ( Generic s

156− , Generic t

157− , ErrorUnless ctor s (HasCtorP ctor (Rep s))

160+ ( ErrorUnless ctor s (HasCtorP ctor (Rep s))

158161 , GAsConstructor' ctor (Rep s) a -- TODO: add a test similar to #62 for prisms

159162 , GAsConstructor' ctor (Rep (Indexed s)) a'

160163 , GAsConstructor ctor (Rep s) (Rep t) a b

161164 , GAsConstructor' ctor (Rep (Indexed t)) b'

162165 , UnifyHead s t

163166 , UnifyHead t s

167+ , AsConstructor0 ctor s t a b

164168 ) => AsConstructor_ ctor s t a b where

165169

166170 _Ctor_ = _Ctor0 @ctor

@@ -173,6 +177,11 @@ instance

173177 ( Generic s

174178 , Generic t

175179 , GAsConstructor ctor (Rep s) (Rep t) a b

180+ , Defined (Rep s)

181+ (NoGeneric s '[ 'Text "arising from a generic prism focusing on the "

182+ ':<>: QuoteType ctor ':<>: 'Text " constructor of type " ':<>: QuoteType a

183+ , 'Text "in " ':<>: QuoteType s])

184+ (() :: Constraint)

176185 ) => AsConstructor0 ctor s t a b where

177186 _Ctor0 = prismRavel (prismPRavel (repIso . _GCtor @ctor))

178187 {-# INLINE[2] _Ctor0 #-}

src/Data/Generics/Sum/Typed.hs+4

@@ -34,6 +34,7 @@ import Data.Kind

3434import GHC.Generics

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

3636import Data.Generics.Sum.Internal.Typed

37+import Data.Generics.Internal.Errors

3738

3839import Data.Generics.Internal.Families

3940import Data.Generics.Internal.Void

@@ -109,6 +110,9 @@ instance

109110 , as ~ TupleToList a

110111 , ListTuple a as

111112 , GAsType (Rep s) as

113+ , Defined (Rep s)

114+ (NoGeneric s '[ 'Text "arising from a generic prism focusing on a constructor of type " ':<>: QuoteType a])

115+ (() :: Constraint)

112116 ) => AsType a s where

113117

114118 _Typed eta = prismRavel (prismPRavel (repIso . _GTyped @_ @as . tupled)) eta