Fix #13972 by producing tidier errors
[ghc.git] / compiler / typecheck / TcValidity.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 -}
5
6 {-# LANGUAGE CPP, TupleSections, ViewPatterns #-}
7
8 module TcValidity (
9 Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType,
10 ContextKind(..), expectedKindInCtxt,
11 checkValidTheta, checkValidFamPats,
12 checkValidInstance, validDerivPred,
13 checkInstTermination, checkTySynRhs,
14 ClsInstInfo, checkValidCoAxiom, checkValidCoAxBranch,
15 checkValidTyFamEqn,
16 arityErr, badATErr,
17 checkValidTelescope, checkZonkValidTelescope, checkValidInferredKinds,
18 allDistinctTyVars
19 ) where
20
21 #include "HsVersions.h"
22
23 import Maybes
24
25 -- friends:
26 import TcUnify ( tcSubType_NC )
27 import TcSimplify ( simplifyAmbiguityCheck )
28 import TyCoRep
29 import TcType hiding ( sizeType, sizeTypes )
30 import TcMType
31 import PrelNames
32 import Type
33 import Coercion
34 import Kind
35 import CoAxiom
36 import Class
37 import TyCon
38
39 -- others:
40 import HsSyn -- HsType
41 import TcRnMonad -- TcType, amongst others
42 import TcEnv ( tcGetInstEnvs )
43 import FunDeps
44 import InstEnv ( InstMatch, lookupInstEnv )
45 import FamInstEnv ( isDominatedBy, injectiveBranches,
46 InjectivityCheckResult(..) )
47 import FamInst ( makeInjectivityErrors )
48 import Name
49 import VarEnv
50 import VarSet
51 import UniqSet
52 import Var ( TyVarBndr(..), mkTyVar )
53 import ErrUtils
54 import DynFlags
55 import Util
56 import ListSetOps
57 import SrcLoc
58 import Outputable
59 import Module
60 import Unique ( mkAlphaTyVarUnique )
61 import qualified GHC.LanguageExtensions as LangExt
62
63 import Control.Monad
64 import Data.List ( (\\) )
65 import qualified Data.List.NonEmpty as NE
66
67 {-
68 ************************************************************************
69 * *
70 Checking for ambiguity
71 * *
72 ************************************************************************
73
74 Note [The ambiguity check for type signatures]
75 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
76 checkAmbiguity is a check on *user-supplied type signatures*. It is
77 *purely* there to report functions that cannot possibly be called. So for
78 example we want to reject:
79 f :: C a => Int
80 The idea is there can be no legal calls to 'f' because every call will
81 give rise to an ambiguous constraint. We could soundly omit the
82 ambiguity check on type signatures entirely, at the expense of
83 delaying ambiguity errors to call sites. Indeed, the flag
84 -XAllowAmbiguousTypes switches off the ambiguity check.
85
86 What about things like this:
87 class D a b | a -> b where ..
88 h :: D Int b => Int
89 The Int may well fix 'b' at the call site, so that signature should
90 not be rejected. Moreover, using *visible* fundeps is too
91 conservative. Consider
92 class X a b where ...
93 class D a b | a -> b where ...
94 instance D a b => X [a] b where...
95 h :: X a b => a -> a
96 Here h's type looks ambiguous in 'b', but here's a legal call:
97 ...(h [True])...
98 That gives rise to a (X [Bool] beta) constraint, and using the
99 instance means we need (D Bool beta) and that fixes 'beta' via D's
100 fundep!
101
102 Behind all these special cases there is a simple guiding principle.
103 Consider
104
105 f :: <type>
106 f = ...blah...
107
108 g :: <type>
109 g = f
110
111 You would think that the definition of g would surely typecheck!
112 After all f has exactly the same type, and g=f. But in fact f's type
113 is instantiated and the instantiated constraints are solved against
114 the originals, so in the case an ambiguous type it won't work.
115 Consider our earlier example f :: C a => Int. Then in g's definition,
116 we'll instantiate to (C alpha) and try to deduce (C alpha) from (C a),
117 and fail.
118
119 So in fact we use this as our *definition* of ambiguity. We use a
120 very similar test for *inferred* types, to ensure that they are
121 unambiguous. See Note [Impedance matching] in TcBinds.
122
123 This test is very conveniently implemented by calling
124 tcSubType <type> <type>
125 This neatly takes account of the functional dependecy stuff above,
126 and implicit parameter (see Note [Implicit parameters and ambiguity]).
127 And this is what checkAmbiguity does.
128
129 What about this, though?
130 g :: C [a] => Int
131 Is every call to 'g' ambiguous? After all, we might have
132 instance C [a] where ...
133 at the call site. So maybe that type is ok! Indeed even f's
134 quintessentially ambiguous type might, just possibly be callable:
135 with -XFlexibleInstances we could have
136 instance C a where ...
137 and now a call could be legal after all! Well, we'll reject this
138 unless the instance is available *here*.
139
140 Note [When to call checkAmbiguity]
141 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
142 We call checkAmbiguity
143 (a) on user-specified type signatures
144 (b) in checkValidType
145
146 Conncerning (b), you might wonder about nested foralls. What about
147 f :: forall b. (forall a. Eq a => b) -> b
148 The nested forall is ambiguous. Originally we called checkAmbiguity
149 in the forall case of check_type, but that had two bad consequences:
150 * We got two error messages about (Eq b) in a nested forall like this:
151 g :: forall a. Eq a => forall b. Eq b => a -> a
152 * If we try to check for ambiguity of an nested forall like
153 (forall a. Eq a => b), the implication constraint doesn't bind
154 all the skolems, which results in "No skolem info" in error
155 messages (see Trac #10432).
156
157 To avoid this, we call checkAmbiguity once, at the top, in checkValidType.
158 (I'm still a bit worried about unbound skolems when the type mentions
159 in-scope type variables.)
160
161 In fact, because of the co/contra-variance implemented in tcSubType,
162 this *does* catch function f above. too.
163
164 Concerning (a) the ambiguity check is only used for *user* types, not
165 for types coming from inteface files. The latter can legitimately
166 have ambiguous types. Example
167
168 class S a where s :: a -> (Int,Int)
169 instance S Char where s _ = (1,1)
170 f:: S a => [a] -> Int -> (Int,Int)
171 f (_::[a]) x = (a*x,b)
172 where (a,b) = s (undefined::a)
173
174 Here the worker for f gets the type
175 fw :: forall a. S a => Int -> (# Int, Int #)
176
177
178 Note [Implicit parameters and ambiguity]
179 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
180 Only a *class* predicate can give rise to ambiguity
181 An *implicit parameter* cannot. For example:
182 foo :: (?x :: [a]) => Int
183 foo = length ?x
184 is fine. The call site will supply a particular 'x'
185
186 Furthermore, the type variables fixed by an implicit parameter
187 propagate to the others. E.g.
188 foo :: (Show a, ?x::[a]) => Int
189 foo = show (?x++?x)
190 The type of foo looks ambiguous. But it isn't, because at a call site
191 we might have
192 let ?x = 5::Int in foo
193 and all is well. In effect, implicit parameters are, well, parameters,
194 so we can take their type variables into account as part of the
195 "tau-tvs" stuff. This is done in the function 'FunDeps.grow'.
196 -}
197
198 checkAmbiguity :: UserTypeCtxt -> Type -> TcM ()
199 checkAmbiguity ctxt ty
200 | wantAmbiguityCheck ctxt
201 = do { traceTc "Ambiguity check for" (ppr ty)
202 -- Solve the constraints eagerly because an ambiguous type
203 -- can cause a cascade of further errors. Since the free
204 -- tyvars are skolemised, we can safely use tcSimplifyTop
205 ; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes
206 ; (_wrap, wanted) <- addErrCtxt (mk_msg allow_ambiguous) $
207 captureConstraints $
208 tcSubType_NC ctxt ty ty
209 ; simplifyAmbiguityCheck ty wanted
210
211 ; traceTc "Done ambiguity check for" (ppr ty) }
212
213 | otherwise
214 = return ()
215 where
216 mk_msg allow_ambiguous
217 = vcat [ text "In the ambiguity check for" <+> what
218 , ppUnless allow_ambiguous ambig_msg ]
219 ambig_msg = text "To defer the ambiguity check to use sites, enable AllowAmbiguousTypes"
220 what | Just n <- isSigMaybe ctxt = quotes (ppr n)
221 | otherwise = pprUserTypeCtxt ctxt
222
223 wantAmbiguityCheck :: UserTypeCtxt -> Bool
224 wantAmbiguityCheck ctxt
225 = case ctxt of -- See Note [When we don't check for ambiguity]
226 GhciCtxt -> False
227 TySynCtxt {} -> False
228 _ -> True
229
230 checkUserTypeError :: Type -> TcM ()
231 -- Check to see if the type signature mentions "TypeError blah"
232 -- anywhere in it, and fail if so.
233 --
234 -- Very unsatisfactorily (Trac #11144) we need to tidy the type
235 -- because it may have come from an /inferred/ signature, not a
236 -- user-supplied one. This is really only a half-baked fix;
237 -- the other errors in checkValidType don't do tidying, and so
238 -- may give bad error messages when given an inferred type.
239 checkUserTypeError = check
240 where
241 check ty
242 | Just msg <- userTypeError_maybe ty = fail_with msg
243 | Just (_,ts) <- splitTyConApp_maybe ty = mapM_ check ts
244 | Just (t1,t2) <- splitAppTy_maybe ty = check t1 >> check t2
245 | Just (_,t1) <- splitForAllTy_maybe ty = check t1
246 | otherwise = return ()
247
248 fail_with msg = do { env0 <- tcInitTidyEnv
249 ; let (env1, tidy_msg) = tidyOpenType env0 msg
250 ; failWithTcM (env1, pprUserTypeErrorTy tidy_msg) }
251
252
253 {- Note [When we don't check for ambiguity]
254 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
255 In a few places we do not want to check a user-specified type for ambiguity
256
257 * GhciCtxt: Allow ambiguous types in GHCi's :kind command
258 E.g. type family T a :: * -- T :: forall k. k -> *
259 Then :k T should work in GHCi, not complain that
260 (T k) is ambiguous!
261
262 * TySynCtxt: type T a b = C a b => blah
263 It may be that when we /use/ T, we'll give an 'a' or 'b' that somehow
264 cure the ambiguity. So we defer the ambiguity check to the use site.
265
266 There is also an implementation reason (Trac #11608). In the RHS of
267 a type synonym we don't (currently) instantiate 'a' and 'b' with
268 TcTyVars before calling checkValidType, so we get asertion failures
269 from doing an ambiguity check on a type with TyVars in it. Fixing this
270 would not be hard, but let's wait till there's a reason.
271
272
273 ************************************************************************
274 * *
275 Checking validity of a user-defined type
276 * *
277 ************************************************************************
278
279 When dealing with a user-written type, we first translate it from an HsType
280 to a Type, performing kind checking, and then check various things that should
281 be true about it. We don't want to perform these checks at the same time
282 as the initial translation because (a) they are unnecessary for interface-file
283 types and (b) when checking a mutually recursive group of type and class decls,
284 we can't "look" at the tycons/classes yet. Also, the checks are rather
285 diverse, and used to really mess up the other code.
286
287 One thing we check for is 'rank'.
288
289 Rank 0: monotypes (no foralls)
290 Rank 1: foralls at the front only, Rank 0 inside
291 Rank 2: foralls at the front, Rank 1 on left of fn arrow,
292
293 basic ::= tyvar | T basic ... basic
294
295 r2 ::= forall tvs. cxt => r2a
296 r2a ::= r1 -> r2a | basic
297 r1 ::= forall tvs. cxt => r0
298 r0 ::= r0 -> r0 | basic
299
300 Another thing is to check that type synonyms are saturated.
301 This might not necessarily show up in kind checking.
302 type A i = i
303 data T k = MkT (k Int)
304 f :: T A -- BAD!
305 -}
306
307 checkValidType :: UserTypeCtxt -> Type -> TcM ()
308 -- Checks that a user-written type is valid for the given context
309 -- Assumes argument is fully zonked
310 -- Not used for instance decls; checkValidInstance instead
311 checkValidType ctxt ty
312 = do { traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (typeKind ty))
313 ; rankn_flag <- xoptM LangExt.RankNTypes
314 ; impred_flag <- xoptM LangExt.ImpredicativeTypes
315 ; let gen_rank :: Rank -> Rank
316 gen_rank r | rankn_flag = ArbitraryRank
317 | otherwise = r
318
319 rank1 = gen_rank r1
320 rank0 = gen_rank r0
321
322 r0 = rankZeroMonoType
323 r1 = LimitedRank True r0
324
325 rank
326 = case ctxt of
327 DefaultDeclCtxt-> MustBeMonoType
328 ResSigCtxt -> MustBeMonoType
329 PatSigCtxt -> rank0
330 RuleSigCtxt _ -> rank1
331 TySynCtxt _ -> rank0
332
333 ExprSigCtxt -> rank1
334 TypeAppCtxt | impred_flag -> ArbitraryRank
335 | otherwise -> tyConArgMonoType
336 -- Normally, ImpredicativeTypes is handled in check_arg_type,
337 -- but visible type applications don't go through there.
338 -- So we do this check here.
339
340 FunSigCtxt {} -> rank1
341 InfSigCtxt _ -> ArbitraryRank -- Inferred type
342 ConArgCtxt _ -> rank1 -- We are given the type of the entire
343 -- constructor, hence rank 1
344 PatSynCtxt _ -> rank1
345
346 ForSigCtxt _ -> rank1
347 SpecInstCtxt -> rank1
348 ThBrackCtxt -> rank1
349 GhciCtxt -> ArbitraryRank
350 _ -> panic "checkValidType"
351 -- Can't happen; not used for *user* sigs
352
353 ; env <- tcInitOpenTidyEnv (tyCoVarsOfTypeList ty)
354
355 -- Check the internal validity of the type itself
356 ; check_type env ctxt rank ty
357
358 ; checkUserTypeError ty
359
360 -- Check for ambiguous types. See Note [When to call checkAmbiguity]
361 -- NB: this will happen even for monotypes, but that should be cheap;
362 -- and there may be nested foralls for the subtype test to examine
363 ; checkAmbiguity ctxt ty
364
365 ; traceTc "checkValidType done" (ppr ty <+> text "::" <+> ppr (typeKind ty)) }
366
367 checkValidMonoType :: Type -> TcM ()
368 -- Assumes argument is fully zonked
369 checkValidMonoType ty
370 = do { env <- tcInitOpenTidyEnv (tyCoVarsOfTypeList ty)
371 ; check_type env SigmaCtxt MustBeMonoType ty }
372
373 checkTySynRhs :: UserTypeCtxt -> TcType -> TcM ()
374 checkTySynRhs ctxt ty
375 | returnsConstraintKind actual_kind
376 = do { ck <- xoptM LangExt.ConstraintKinds
377 ; if ck
378 then when (isConstraintKind actual_kind)
379 (do { dflags <- getDynFlags
380 ; check_pred_ty emptyTidyEnv dflags ctxt ty })
381 else addErrTcM (constraintSynErr emptyTidyEnv actual_kind) }
382
383 | otherwise
384 = return ()
385 where
386 actual_kind = typeKind ty
387
388 -- | The kind expected in a certain context.
389 data ContextKind = TheKind Kind -- ^ a specific kind
390 | AnythingKind -- ^ any kind will do
391 | OpenKind -- ^ something of the form @TYPE _@
392
393 -- Depending on the context, we might accept any kind (for instance, in a TH
394 -- splice), or only certain kinds (like in type signatures).
395 expectedKindInCtxt :: UserTypeCtxt -> ContextKind
396 expectedKindInCtxt (TySynCtxt _) = AnythingKind
397 expectedKindInCtxt ThBrackCtxt = AnythingKind
398 expectedKindInCtxt GhciCtxt = AnythingKind
399 -- The types in a 'default' decl can have varying kinds
400 -- See Note [Extended defaults]" in TcEnv
401 expectedKindInCtxt DefaultDeclCtxt = AnythingKind
402 expectedKindInCtxt TypeAppCtxt = AnythingKind
403 expectedKindInCtxt (ForSigCtxt _) = TheKind liftedTypeKind
404 expectedKindInCtxt InstDeclCtxt = TheKind constraintKind
405 expectedKindInCtxt SpecInstCtxt = TheKind constraintKind
406 expectedKindInCtxt _ = OpenKind
407
408 {-
409 Note [Higher rank types]
410 ~~~~~~~~~~~~~~~~~~~~~~~~
411 Technically
412 Int -> forall a. a->a
413 is still a rank-1 type, but it's not Haskell 98 (Trac #5957). So the
414 validity checker allow a forall after an arrow only if we allow it
415 before -- that is, with Rank2Types or RankNTypes
416 -}
417
418 data Rank = ArbitraryRank -- Any rank ok
419
420 | LimitedRank -- Note [Higher rank types]
421 Bool -- Forall ok at top
422 Rank -- Use for function arguments
423
424 | MonoType SDoc -- Monotype, with a suggestion of how it could be a polytype
425
426 | MustBeMonoType -- Monotype regardless of flags
427
428
429 rankZeroMonoType, tyConArgMonoType, synArgMonoType, constraintMonoType :: Rank
430 rankZeroMonoType = MonoType (text "Perhaps you intended to use RankNTypes or Rank2Types")
431 tyConArgMonoType = MonoType (text "GHC doesn't yet support impredicative polymorphism")
432 synArgMonoType = MonoType (text "Perhaps you intended to use LiberalTypeSynonyms")
433 constraintMonoType = MonoType (text "A constraint must be a monotype")
434
435 funArgResRank :: Rank -> (Rank, Rank) -- Function argument and result
436 funArgResRank (LimitedRank _ arg_rank) = (arg_rank, LimitedRank (forAllAllowed arg_rank) arg_rank)
437 funArgResRank other_rank = (other_rank, other_rank)
438
439 forAllAllowed :: Rank -> Bool
440 forAllAllowed ArbitraryRank = True
441 forAllAllowed (LimitedRank forall_ok _) = forall_ok
442 forAllAllowed _ = False
443
444 ----------------------------------------
445 check_type :: TidyEnv -> UserTypeCtxt -> Rank -> Type -> TcM ()
446 -- The args say what the *type context* requires, independent
447 -- of *flag* settings. You test the flag settings at usage sites.
448 --
449 -- Rank is allowed rank for function args
450 -- Rank 0 means no for-alls anywhere
451
452 check_type env ctxt rank ty
453 | not (null tvs && null theta)
454 = do { traceTc "check_type" (ppr ty $$ ppr (forAllAllowed rank))
455 ; checkTcM (forAllAllowed rank) (forAllTyErr env rank ty)
456 -- Reject e.g. (Maybe (?x::Int => Int)),
457 -- with a decent error message
458
459 ; check_valid_theta env' SigmaCtxt theta
460 -- Allow type T = ?x::Int => Int -> Int
461 -- but not type T = ?x::Int
462
463 ; check_type env' ctxt rank tau -- Allow foralls to right of arrow
464 ; checkTcM (not (any (`elemVarSet` tyCoVarsOfType phi_kind) tvs))
465 (forAllEscapeErr env' ty tau_kind)
466 }
467 where
468 (tvs, theta, tau) = tcSplitSigmaTy ty
469 tau_kind = typeKind tau
470 (env', _) = tidyTyCoVarBndrs env tvs
471
472 phi_kind | null theta = tau_kind
473 | otherwise = liftedTypeKind
474 -- If there are any constraints, the kind is *. (#11405)
475
476 check_type _ _ _ (TyVarTy _) = return ()
477
478 check_type env ctxt rank (FunTy arg_ty res_ty)
479 = do { check_type env ctxt arg_rank arg_ty
480 ; check_type env ctxt res_rank res_ty }
481 where
482 (arg_rank, res_rank) = funArgResRank rank
483
484 check_type env ctxt rank (AppTy ty1 ty2)
485 = do { check_arg_type env ctxt rank ty1
486 ; check_arg_type env ctxt rank ty2 }
487
488 check_type env ctxt rank ty@(TyConApp tc tys)
489 | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc
490 = check_syn_tc_app env ctxt rank ty tc tys
491 | isUnboxedTupleTyCon tc = check_ubx_tuple env ctxt ty tys
492 | otherwise = mapM_ (check_arg_type env ctxt rank) tys
493
494 check_type _ _ _ (LitTy {}) = return ()
495
496 check_type env ctxt rank (CastTy ty _) = check_type env ctxt rank ty
497
498 check_type _ _ _ ty = pprPanic "check_type" (ppr ty)
499
500 ----------------------------------------
501 check_syn_tc_app :: TidyEnv -> UserTypeCtxt -> Rank -> KindOrType
502 -> TyCon -> [KindOrType] -> TcM ()
503 -- Used for type synonyms and type synonym families,
504 -- which must be saturated,
505 -- but not data families, which need not be saturated
506 check_syn_tc_app env ctxt rank ty tc tys
507 | tys `lengthAtLeast` tc_arity -- Saturated
508 -- Check that the synonym has enough args
509 -- This applies equally to open and closed synonyms
510 -- It's OK to have an *over-applied* type synonym
511 -- data Tree a b = ...
512 -- type Foo a = Tree [a]
513 -- f :: Foo a b -> ...
514 = do { -- See Note [Liberal type synonyms]
515 ; liberal <- xoptM LangExt.LiberalTypeSynonyms
516 ; if not liberal || isTypeFamilyTyCon tc then
517 -- For H98 and synonym families, do check the type args
518 mapM_ check_arg tys
519
520 else -- In the liberal case (only for closed syns), expand then check
521 case tcView ty of
522 Just ty' -> check_type env ctxt rank ty'
523 Nothing -> pprPanic "check_tau_type" (ppr ty) }
524
525 | GhciCtxt <- ctxt -- Accept under-saturated type synonyms in
526 -- GHCi :kind commands; see Trac #7586
527 = mapM_ check_arg tys
528
529 | otherwise
530 = failWithTc (tyConArityErr tc tys)
531 where
532 tc_arity = tyConArity tc
533 check_arg | isTypeFamilyTyCon tc = check_arg_type env ctxt rank
534 | otherwise = check_type env ctxt synArgMonoType
535
536 ----------------------------------------
537 check_ubx_tuple :: TidyEnv -> UserTypeCtxt -> KindOrType
538 -> [KindOrType] -> TcM ()
539 check_ubx_tuple env ctxt ty tys
540 = do { ub_tuples_allowed <- xoptM LangExt.UnboxedTuples
541 ; checkTcM ub_tuples_allowed (ubxArgTyErr env ty)
542
543 ; impred <- xoptM LangExt.ImpredicativeTypes
544 ; let rank' = if impred then ArbitraryRank else tyConArgMonoType
545 -- c.f. check_arg_type
546 -- However, args are allowed to be unlifted, or
547 -- more unboxed tuples, so can't use check_arg_ty
548 ; mapM_ (check_type env ctxt rank') tys }
549
550 ----------------------------------------
551 check_arg_type :: TidyEnv -> UserTypeCtxt -> Rank -> KindOrType -> TcM ()
552 -- The sort of type that can instantiate a type variable,
553 -- or be the argument of a type constructor.
554 -- Not an unboxed tuple, but now *can* be a forall (since impredicativity)
555 -- Other unboxed types are very occasionally allowed as type
556 -- arguments depending on the kind of the type constructor
557 --
558 -- For example, we want to reject things like:
559 --
560 -- instance Ord a => Ord (forall s. T s a)
561 -- and
562 -- g :: T s (forall b.b)
563 --
564 -- NB: unboxed tuples can have polymorphic or unboxed args.
565 -- This happens in the workers for functions returning
566 -- product types with polymorphic components.
567 -- But not in user code.
568 -- Anyway, they are dealt with by a special case in check_tau_type
569
570 check_arg_type _ _ _ (CoercionTy {}) = return ()
571
572 check_arg_type env ctxt rank ty
573 = do { impred <- xoptM LangExt.ImpredicativeTypes
574 ; let rank' = case rank of -- Predictive => must be monotype
575 MustBeMonoType -> MustBeMonoType -- Monotype, regardless
576 _other | impred -> ArbitraryRank
577 | otherwise -> tyConArgMonoType
578 -- Make sure that MustBeMonoType is propagated,
579 -- so that we don't suggest -XImpredicativeTypes in
580 -- (Ord (forall a.a)) => a -> a
581 -- and so that if it Must be a monotype, we check that it is!
582
583 ; check_type env ctxt rank' ty }
584
585 ----------------------------------------
586 forAllTyErr :: TidyEnv -> Rank -> Type -> (TidyEnv, SDoc)
587 forAllTyErr env rank ty
588 = ( env
589 , vcat [ hang herald 2 (ppr_tidy env ty)
590 , suggestion ] )
591 where
592 (tvs, _theta, _tau) = tcSplitSigmaTy ty
593 herald | null tvs = text "Illegal qualified type:"
594 | otherwise = text "Illegal polymorphic type:"
595 suggestion = case rank of
596 LimitedRank {} -> text "Perhaps you intended to use RankNTypes or Rank2Types"
597 MonoType d -> d
598 _ -> Outputable.empty -- Polytype is always illegal
599
600 forAllEscapeErr :: TidyEnv -> Type -> Kind -> (TidyEnv, SDoc)
601 forAllEscapeErr env ty tau_kind
602 = ( env
603 , hang (vcat [ text "Quantified type's kind mentions quantified type variable"
604 , text "(skolem escape)" ])
605 2 (vcat [ text " type:" <+> ppr_tidy env ty
606 , text "of kind:" <+> ppr_tidy env tau_kind ]) )
607
608 ubxArgTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc)
609 ubxArgTyErr env ty = (env, sep [text "Illegal unboxed tuple type as function argument:", ppr_tidy env ty])
610
611 {-
612 Note [Liberal type synonyms]
613 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
614 If -XLiberalTypeSynonyms is on, expand closed type synonyms *before*
615 doing validity checking. This allows us to instantiate a synonym defn
616 with a for-all type, or with a partially-applied type synonym.
617 e.g. type T a b = a
618 type S m = m ()
619 f :: S (T Int)
620 Here, T is partially applied, so it's illegal in H98. But if you
621 expand S first, then T we get just
622 f :: Int
623 which is fine.
624
625 IMPORTANT: suppose T is a type synonym. Then we must do validity
626 checking on an appliation (T ty1 ty2)
627
628 *either* before expansion (i.e. check ty1, ty2)
629 *or* after expansion (i.e. expand T ty1 ty2, and then check)
630 BUT NOT BOTH
631
632 If we do both, we get exponential behaviour!!
633
634 data TIACons1 i r c = c i ::: r c
635 type TIACons2 t x = TIACons1 t (TIACons1 t x)
636 type TIACons3 t x = TIACons2 t (TIACons1 t x)
637 type TIACons4 t x = TIACons2 t (TIACons2 t x)
638 type TIACons7 t x = TIACons4 t (TIACons3 t x)
639
640
641 ************************************************************************
642 * *
643 \subsection{Checking a theta or source type}
644 * *
645 ************************************************************************
646
647 Note [Implicit parameters in instance decls]
648 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
649 Implicit parameters _only_ allowed in type signatures; not in instance
650 decls, superclasses etc. The reason for not allowing implicit params in
651 instances is a bit subtle. If we allowed
652 instance (?x::Int, Eq a) => Foo [a] where ...
653 then when we saw
654 (e :: (?x::Int) => t)
655 it would be unclear how to discharge all the potential uses of the ?x
656 in e. For example, a constraint Foo [Int] might come out of e, and
657 applying the instance decl would show up two uses of ?x. Trac #8912.
658 -}
659
660 checkValidTheta :: UserTypeCtxt -> ThetaType -> TcM ()
661 -- Assumes argument is fully zonked
662 checkValidTheta ctxt theta
663 = do { env <- tcInitOpenTidyEnv (tyCoVarsOfTypesList theta)
664 ; addErrCtxtM (checkThetaCtxt ctxt theta) $
665 check_valid_theta env ctxt theta }
666
667 -------------------------
668 check_valid_theta :: TidyEnv -> UserTypeCtxt -> [PredType] -> TcM ()
669 check_valid_theta _ _ []
670 = return ()
671 check_valid_theta env ctxt theta
672 = do { dflags <- getDynFlags
673 ; warnTcM (Reason Opt_WarnDuplicateConstraints)
674 (wopt Opt_WarnDuplicateConstraints dflags && notNull dups)
675 (dupPredWarn env dups)
676 ; traceTc "check_valid_theta" (ppr theta)
677 ; mapM_ (check_pred_ty env dflags ctxt) theta }
678 where
679 (_,dups) = removeDups nonDetCmpType theta
680 -- It's OK to use nonDetCmpType because dups only appears in the
681 -- warning
682
683 -------------------------
684 {- Note [Validity checking for constraints]
685 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
686 We look through constraint synonyms so that we can see the underlying
687 constraint(s). For example
688 type Foo = ?x::Int
689 instance Foo => C T
690 We should reject the instance because it has an implicit parameter in
691 the context.
692
693 But we record, in 'under_syn', whether we have looked under a synonym
694 to avoid requiring language extensions at the use site. Main example
695 (Trac #9838):
696
697 {-# LANGUAGE ConstraintKinds #-}
698 module A where
699 type EqShow a = (Eq a, Show a)
700
701 module B where
702 import A
703 foo :: EqShow a => a -> String
704
705 We don't want to require ConstraintKinds in module B.
706 -}
707
708 check_pred_ty :: TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> TcM ()
709 -- Check the validity of a predicate in a signature
710 -- See Note [Validity checking for constraints]
711 check_pred_ty env dflags ctxt pred
712 = do { check_type env SigmaCtxt constraintMonoType pred
713 ; check_pred_help False env dflags ctxt pred }
714
715 check_pred_help :: Bool -- True <=> under a type synonym
716 -> TidyEnv
717 -> DynFlags -> UserTypeCtxt
718 -> PredType -> TcM ()
719 check_pred_help under_syn env dflags ctxt pred
720 | Just pred' <- tcView pred -- Switch on under_syn when going under a
721 -- synonym (Trac #9838, yuk)
722 = check_pred_help True env dflags ctxt pred'
723 | otherwise
724 = case splitTyConApp_maybe pred of
725 Just (tc, tys)
726 | isTupleTyCon tc
727 -> check_tuple_pred under_syn env dflags ctxt pred tys
728 -- NB: this equality check must come first, because (~) is a class,
729 -- too.
730 | tc `hasKey` heqTyConKey ||
731 tc `hasKey` eqTyConKey ||
732 tc `hasKey` eqPrimTyConKey
733 -> check_eq_pred env dflags pred tc tys
734 | Just cls <- tyConClass_maybe tc
735 -> check_class_pred env dflags ctxt pred cls tys -- Includes Coercible
736 _ -> check_irred_pred under_syn env dflags ctxt pred
737
738 check_eq_pred :: TidyEnv -> DynFlags -> PredType -> TyCon -> [TcType] -> TcM ()
739 check_eq_pred env dflags pred tc tys
740 = -- Equational constraints are valid in all contexts if type
741 -- families are permitted
742 do { checkTc (tys `lengthIs` tyConArity tc) (tyConArityErr tc tys)
743 ; checkTcM (xopt LangExt.TypeFamilies dflags
744 || xopt LangExt.GADTs dflags)
745 (eqPredTyErr env pred) }
746
747 check_tuple_pred :: Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> [PredType] -> TcM ()
748 check_tuple_pred under_syn env dflags ctxt pred ts
749 = do { -- See Note [ConstraintKinds in predicates]
750 checkTcM (under_syn || xopt LangExt.ConstraintKinds dflags)
751 (predTupleErr env pred)
752 ; mapM_ (check_pred_help under_syn env dflags ctxt) ts }
753 -- This case will not normally be executed because without
754 -- -XConstraintKinds tuple types are only kind-checked as *
755
756 check_irred_pred :: Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> TcM ()
757 check_irred_pred under_syn env dflags ctxt pred
758 -- The predicate looks like (X t1 t2) or (x t1 t2) :: Constraint
759 -- where X is a type function
760 = do { -- If it looks like (x t1 t2), require ConstraintKinds
761 -- see Note [ConstraintKinds in predicates]
762 -- But (X t1 t2) is always ok because we just require ConstraintKinds
763 -- at the definition site (Trac #9838)
764 failIfTcM (not under_syn && not (xopt LangExt.ConstraintKinds dflags)
765 && hasTyVarHead pred)
766 (predIrredErr env pred)
767
768 -- Make sure it is OK to have an irred pred in this context
769 -- See Note [Irreducible predicates in superclasses]
770 ; failIfTcM (is_superclass ctxt
771 && not (xopt LangExt.UndecidableInstances dflags)
772 && has_tyfun_head pred)
773 (predSuperClassErr env pred) }
774 where
775 is_superclass ctxt = case ctxt of { ClassSCCtxt _ -> True; _ -> False }
776 has_tyfun_head ty
777 = case tcSplitTyConApp_maybe ty of
778 Just (tc, _) -> isTypeFamilyTyCon tc
779 Nothing -> False
780
781 {- Note [ConstraintKinds in predicates]
782 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
783 Don't check for -XConstraintKinds under a type synonym, because that
784 was done at the type synonym definition site; see Trac #9838
785 e.g. module A where
786 type C a = (Eq a, Ix a) -- Needs -XConstraintKinds
787 module B where
788 import A
789 f :: C a => a -> a -- Does *not* need -XConstraintKinds
790
791 Note [Irreducible predicates in superclasses]
792 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
793 Allowing type-family calls in class superclasses is somewhat dangerous
794 because we can write:
795
796 type family Fooish x :: * -> Constraint
797 type instance Fooish () = Foo
798 class Fooish () a => Foo a where
799
800 This will cause the constraint simplifier to loop because every time we canonicalise a
801 (Foo a) class constraint we add a (Fooish () a) constraint which will be immediately
802 solved to add+canonicalise another (Foo a) constraint. -}
803
804 -------------------------
805 check_class_pred :: TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> Class -> [TcType] -> TcM ()
806 check_class_pred env dflags ctxt pred cls tys
807 | isIPClass cls
808 = do { check_arity
809 ; checkTcM (okIPCtxt ctxt) (badIPPred env pred) }
810
811 | otherwise
812 = do { check_arity
813 ; warn_simp <- woptM Opt_WarnSimplifiableClassConstraints
814 ; when warn_simp check_simplifiable_class_constraint
815 ; checkTcM arg_tys_ok (predTyVarErr env pred) }
816 where
817 check_arity = checkTc (tys `lengthIs` classArity cls)
818 (tyConArityErr (classTyCon cls) tys)
819
820 -- Check the arguments of a class constraint
821 flexible_contexts = xopt LangExt.FlexibleContexts dflags
822 undecidable_ok = xopt LangExt.UndecidableInstances dflags
823 arg_tys_ok = case ctxt of
824 SpecInstCtxt -> True -- {-# SPECIALISE instance Eq (T Int) #-} is fine
825 InstDeclCtxt -> checkValidClsArgs (flexible_contexts || undecidable_ok) cls tys
826 -- Further checks on head and theta
827 -- in checkInstTermination
828 _ -> checkValidClsArgs flexible_contexts cls tys
829
830 -- See Note [Simplifiable given constraints]
831 check_simplifiable_class_constraint
832 | xopt LangExt.MonoLocalBinds dflags
833 = return ()
834 | DataTyCtxt {} <- ctxt -- Don't do this check for the "stupid theta"
835 = return () -- of a data type declaration
836 | otherwise
837 = do { envs <- tcGetInstEnvs
838 ; case lookupInstEnv False envs cls tys of
839 ([m], [], _) -> addWarnTc (Reason Opt_WarnSimplifiableClassConstraints)
840 (simplifiable_constraint_warn m)
841 _ -> return () }
842
843 simplifiable_constraint_warn :: InstMatch -> SDoc
844 simplifiable_constraint_warn (match, _)
845 = vcat [ hang (text "The constraint" <+> quotes (ppr (tidyType env pred)))
846 2 (text "matches an instance declaration")
847 , ppr match
848 , hang (text "This makes type inference for inner bindings fragile;")
849 2 (text "either use MonoLocalBinds, or simplify it using the instance") ]
850
851 {- Note [Simplifiable given constraints]
852 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
853 A type signature like
854 f :: Eq [(a,b)] => a -> b
855 is very fragile, for reasons described at length in TcInteract
856 Note [Instance and Given overlap]. As that Note discusses, for the
857 most part the clever stuff in TcInteract means that we don't use a
858 top-level instance if a local Given might fire, so there is no
859 fragility. But if we /infer/ the type of a local let-binding, things
860 can go wrong (Trac #11948 is an example, discussed in the Note).
861
862 So this warning is switched on only if we have NoMonoLocalBinds; in
863 that case the warning discourages users from writing simplifiable
864 class constraints.
865
866 The warning only fires if the constraint in the signature
867 matches the top-level instances in only one way, and with no
868 unifiers -- that is, under the same circumstances that
869 TcInteract.matchInstEnv fires an interaction with the top
870 level instances. For example (Trac #13526), consider
871
872 instance {-# OVERLAPPABLE #-} Eq (T a) where ...
873 instance Eq (T Char) where ..
874 f :: Eq (T a) => ...
875
876 We don't want to complain about this, even though the context
877 (Eq (T a)) matches an instance, because the user may be
878 deliberately deferring the choice so that the Eq (T Char)
879 has a chance to fire when 'f' is called. And the fragility
880 only matters when there's a risk that the instance might
881 fire instead of the local 'given'; and there is no such
882 risk in this case. Just use the same rules as for instance
883 firing!
884 -}
885
886 -------------------------
887 okIPCtxt :: UserTypeCtxt -> Bool
888 -- See Note [Implicit parameters in instance decls]
889 okIPCtxt (FunSigCtxt {}) = True
890 okIPCtxt (InfSigCtxt {}) = True
891 okIPCtxt ExprSigCtxt = True
892 okIPCtxt TypeAppCtxt = True
893 okIPCtxt PatSigCtxt = True
894 okIPCtxt ResSigCtxt = True
895 okIPCtxt GenSigCtxt = True
896 okIPCtxt (ConArgCtxt {}) = True
897 okIPCtxt (ForSigCtxt {}) = True -- ??
898 okIPCtxt ThBrackCtxt = True
899 okIPCtxt GhciCtxt = True
900 okIPCtxt SigmaCtxt = True
901 okIPCtxt (DataTyCtxt {}) = True
902 okIPCtxt (PatSynCtxt {}) = True
903 okIPCtxt (TySynCtxt {}) = True -- e.g. type Blah = ?x::Int
904 -- Trac #11466
905
906 okIPCtxt (ClassSCCtxt {}) = False
907 okIPCtxt (InstDeclCtxt {}) = False
908 okIPCtxt (SpecInstCtxt {}) = False
909 okIPCtxt (RuleSigCtxt {}) = False
910 okIPCtxt DefaultDeclCtxt = False
911
912 {-
913 Note [Kind polymorphic type classes]
914 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
915 MultiParam check:
916
917 class C f where... -- C :: forall k. k -> Constraint
918 instance C Maybe where...
919
920 The dictionary gets type [C * Maybe] even if it's not a MultiParam
921 type class.
922
923 Flexibility check:
924
925 class C f where... -- C :: forall k. k -> Constraint
926 data D a = D a
927 instance C D where
928
929 The dictionary gets type [C * (D *)]. IA0_TODO it should be
930 generalized actually.
931 -}
932
933 checkThetaCtxt :: UserTypeCtxt -> ThetaType -> TidyEnv -> TcM (TidyEnv, SDoc)
934 checkThetaCtxt ctxt theta env
935 = return ( env
936 , vcat [ text "In the context:" <+> pprTheta (tidyTypes env theta)
937 , text "While checking" <+> pprUserTypeCtxt ctxt ] )
938
939 eqPredTyErr, predTupleErr, predIrredErr, predSuperClassErr :: TidyEnv -> PredType -> (TidyEnv, SDoc)
940 eqPredTyErr env pred
941 = ( env
942 , text "Illegal equational constraint" <+> ppr_tidy env pred $$
943 parens (text "Use GADTs or TypeFamilies to permit this") )
944 predTupleErr env pred
945 = ( env
946 , hang (text "Illegal tuple constraint:" <+> ppr_tidy env pred)
947 2 (parens constraintKindsMsg) )
948 predIrredErr env pred
949 = ( env
950 , hang (text "Illegal constraint:" <+> ppr_tidy env pred)
951 2 (parens constraintKindsMsg) )
952 predSuperClassErr env pred
953 = ( env
954 , hang (text "Illegal constraint" <+> quotes (ppr_tidy env pred)
955 <+> text "in a superclass context")
956 2 (parens undecidableMsg) )
957
958 predTyVarErr :: TidyEnv -> PredType -> (TidyEnv, SDoc)
959 predTyVarErr env pred
960 = (env
961 , vcat [ hang (text "Non type-variable argument")
962 2 (text "in the constraint:" <+> ppr_tidy env pred)
963 , parens (text "Use FlexibleContexts to permit this") ])
964
965 badIPPred :: TidyEnv -> PredType -> (TidyEnv, SDoc)
966 badIPPred env pred
967 = ( env
968 , text "Illegal implicit parameter" <+> quotes (ppr_tidy env pred) )
969
970 constraintSynErr :: TidyEnv -> Type -> (TidyEnv, SDoc)
971 constraintSynErr env kind
972 = ( env
973 , hang (text "Illegal constraint synonym of kind:" <+> quotes (ppr_tidy env kind))
974 2 (parens constraintKindsMsg) )
975
976 dupPredWarn :: TidyEnv -> [NE.NonEmpty PredType] -> (TidyEnv, SDoc)
977 dupPredWarn env dups
978 = ( env
979 , text "Duplicate constraint" <> plural primaryDups <> text ":"
980 <+> pprWithCommas (ppr_tidy env) primaryDups )
981 where
982 primaryDups = map NE.head dups
983
984 tyConArityErr :: TyCon -> [TcType] -> SDoc
985 -- For type-constructor arity errors, be careful to report
986 -- the number of /visible/ arguments required and supplied,
987 -- ignoring the /invisible/ arguments, which the user does not see.
988 -- (e.g. Trac #10516)
989 tyConArityErr tc tks
990 = arityErr (ppr (tyConFlavour tc)) (tyConName tc)
991 tc_type_arity tc_type_args
992 where
993 vis_tks = filterOutInvisibleTypes tc tks
994
995 -- tc_type_arity = number of *type* args expected
996 -- tc_type_args = number of *type* args encountered
997 tc_type_arity = count isVisibleTyConBinder (tyConBinders tc)
998 tc_type_args = length vis_tks
999
1000 arityErr :: Outputable a => SDoc -> a -> Int -> Int -> SDoc
1001 arityErr what name n m
1002 = hsep [ text "The" <+> what, quotes (ppr name), text "should have",
1003 n_arguments <> comma, text "but has been given",
1004 if m==0 then text "none" else int m]
1005 where
1006 n_arguments | n == 0 = text "no arguments"
1007 | n == 1 = text "1 argument"
1008 | True = hsep [int n, text "arguments"]
1009
1010 {-
1011 ************************************************************************
1012 * *
1013 \subsection{Checking for a decent instance head type}
1014 * *
1015 ************************************************************************
1016
1017 @checkValidInstHead@ checks the type {\em and} its syntactic constraints:
1018 it must normally look like: @instance Foo (Tycon a b c ...) ...@
1019
1020 The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
1021 flag is on, or (2)~the instance is imported (they must have been
1022 compiled elsewhere). In these cases, we let them go through anyway.
1023
1024 We can also have instances for functions: @instance Foo (a -> b) ...@.
1025 -}
1026
1027 checkValidInstHead :: UserTypeCtxt -> Class -> [Type] -> TcM ()
1028 checkValidInstHead ctxt clas cls_args
1029 = do { dflags <- getDynFlags
1030
1031 ; mod <- getModule
1032 ; checkTc (getUnique clas `notElem` abstractClassKeys ||
1033 nameModule (getName clas) == mod)
1034 (instTypeErr clas cls_args abstract_class_msg)
1035
1036 ; when (clas `hasKey` hasFieldClassNameKey) $
1037 checkHasFieldInst clas cls_args
1038
1039 -- Check language restrictions;
1040 -- but not for SPECIALISE instance pragmas
1041 ; let ty_args = filterOutInvisibleTypes (classTyCon clas) cls_args
1042 ; unless spec_inst_prag $
1043 do { checkTc (xopt LangExt.TypeSynonymInstances dflags ||
1044 all tcInstHeadTyNotSynonym ty_args)
1045 (instTypeErr clas cls_args head_type_synonym_msg)
1046 ; checkTc (xopt LangExt.FlexibleInstances dflags ||
1047 all tcInstHeadTyAppAllTyVars ty_args)
1048 (instTypeErr clas cls_args head_type_args_tyvars_msg)
1049 ; checkTc (xopt LangExt.MultiParamTypeClasses dflags ||
1050 lengthIs ty_args 1 || -- Only count type arguments
1051 (xopt LangExt.NullaryTypeClasses dflags &&
1052 null ty_args))
1053 (instTypeErr clas cls_args head_one_type_msg) }
1054
1055 ; mapM_ checkValidTypePat ty_args }
1056 where
1057 spec_inst_prag = case ctxt of { SpecInstCtxt -> True; _ -> False }
1058
1059 head_type_synonym_msg = parens (
1060 text "All instance types must be of the form (T t1 ... tn)" $$
1061 text "where T is not a synonym." $$
1062 text "Use TypeSynonymInstances if you want to disable this.")
1063
1064 head_type_args_tyvars_msg = parens (vcat [
1065 text "All instance types must be of the form (T a1 ... an)",
1066 text "where a1 ... an are *distinct type variables*,",
1067 text "and each type variable appears at most once in the instance head.",
1068 text "Use FlexibleInstances if you want to disable this."])
1069
1070 head_one_type_msg = parens (
1071 text "Only one type can be given in an instance head." $$
1072 text "Use MultiParamTypeClasses if you want to allow more, or zero.")
1073
1074 abstract_class_msg =
1075 text "Manual instances of this class are not permitted."
1076
1077 tcInstHeadTyNotSynonym :: Type -> Bool
1078 -- Used in Haskell-98 mode, for the argument types of an instance head
1079 -- These must not be type synonyms, but everywhere else type synonyms
1080 -- are transparent, so we need a special function here
1081 tcInstHeadTyNotSynonym ty
1082 = case ty of -- Do not use splitTyConApp,
1083 -- because that expands synonyms!
1084 TyConApp tc _ -> not (isTypeSynonymTyCon tc)
1085 _ -> True
1086
1087 tcInstHeadTyAppAllTyVars :: Type -> Bool
1088 -- Used in Haskell-98 mode, for the argument types of an instance head
1089 -- These must be a constructor applied to type variable arguments.
1090 -- But we allow kind instantiations.
1091 tcInstHeadTyAppAllTyVars ty
1092 | Just (tc, tys) <- tcSplitTyConApp_maybe (dropCasts ty)
1093 = ok (filterOutInvisibleTypes tc tys) -- avoid kinds
1094
1095 | otherwise
1096 = False
1097 where
1098 -- Check that all the types are type variables,
1099 -- and that each is distinct
1100 ok tys = equalLength tvs tys && hasNoDups tvs
1101 where
1102 tvs = mapMaybe tcGetTyVar_maybe tys
1103
1104 dropCasts :: Type -> Type
1105 -- See Note [Casts during validity checking]
1106 -- This function can turn a well-kinded type into an ill-kinded
1107 -- one, so I've kept it local to this module
1108 -- To consider: drop only UnivCo(HoleProv) casts
1109 dropCasts (CastTy ty _) = dropCasts ty
1110 dropCasts (AppTy t1 t2) = mkAppTy (dropCasts t1) (dropCasts t2)
1111 dropCasts (FunTy t1 t2) = mkFunTy (dropCasts t1) (dropCasts t2)
1112 dropCasts (TyConApp tc tys) = mkTyConApp tc (map dropCasts tys)
1113 dropCasts (ForAllTy b ty) = ForAllTy (dropCastsB b) (dropCasts ty)
1114 dropCasts ty = ty -- LitTy, TyVarTy, CoercionTy
1115
1116 dropCastsB :: TyVarBinder -> TyVarBinder
1117 dropCastsB b = b -- Don't bother in the kind of a forall
1118
1119 abstractClassKeys :: [Unique]
1120 abstractClassKeys = [ heqTyConKey
1121 , eqTyConKey
1122 , coercibleTyConKey
1123 ] -- See Note [Equality class instances]
1124
1125 instTypeErr :: Class -> [Type] -> SDoc -> SDoc
1126 instTypeErr cls tys msg
1127 = hang (hang (text "Illegal instance declaration for")
1128 2 (quotes (pprClassPred cls tys)))
1129 2 msg
1130
1131 -- | See Note [Validity checking of HasField instances]
1132 checkHasFieldInst :: Class -> [Type] -> TcM ()
1133 checkHasFieldInst cls tys@[_k_ty, x_ty, r_ty, _a_ty] =
1134 case splitTyConApp_maybe r_ty of
1135 Nothing -> whoops (text "Record data type must be specified")
1136 Just (tc, _)
1137 | isFamilyTyCon tc
1138 -> whoops (text "Record data type may not be a data family")
1139 | otherwise -> case isStrLitTy x_ty of
1140 Just lbl
1141 | isJust (lookupTyConFieldLabel lbl tc)
1142 -> whoops (ppr tc <+> text "already has a field"
1143 <+> quotes (ppr lbl))
1144 | otherwise -> return ()
1145 Nothing
1146 | null (tyConFieldLabels tc) -> return ()
1147 | otherwise -> whoops (ppr tc <+> text "has fields")
1148 where
1149 whoops = addErrTc . instTypeErr cls tys
1150 checkHasFieldInst _ tys = pprPanic "checkHasFieldInst" (ppr tys)
1151
1152 {- Note [Casts during validity checking]
1153 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1154 Consider the (bogus)
1155 instance Eq Char#
1156 We elaborate to 'Eq (Char# |> UnivCo(hole))' where the hole is an
1157 insoluble equality constraint for * ~ #. We'll report the insoluble
1158 constraint separately, but we don't want to *also* complain that Eq is
1159 not applied to a type constructor. So we look gaily look through
1160 CastTys here.
1161
1162 Another example: Eq (Either a). Then we actually get a cast in
1163 the middle:
1164 Eq ((Either |> g) a)
1165
1166
1167 Note [Validity checking of HasField instances]
1168 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1169 The HasField class has magic constraint solving behaviour (see Note
1170 [HasField instances] in TcInteract). However, we permit users to
1171 declare their own instances, provided they do not clash with the
1172 built-in behaviour. In particular, we forbid:
1173
1174 1. `HasField _ r _` where r is a variable
1175
1176 2. `HasField _ (T ...) _` if T is a data family
1177 (because it might have fields introduced later)
1178
1179 3. `HasField x (T ...) _` where x is a variable,
1180 if T has any fields at all
1181
1182 4. `HasField "foo" (T ...) _` if T has a "foo" field
1183
1184 The usual functional dependency checks also apply.
1185
1186
1187 Note [Valid 'deriving' predicate]
1188 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1189 validDerivPred checks for OK 'deriving' context. See Note [Exotic
1190 derived instance contexts] in TcDeriv. However the predicate is
1191 here because it uses sizeTypes, fvTypes.
1192
1193 It checks for three things
1194
1195 * No repeated variables (hasNoDups fvs)
1196
1197 * No type constructors. This is done by comparing
1198 sizeTypes tys == length (fvTypes tys)
1199 sizeTypes counts variables and constructors; fvTypes returns variables.
1200 So if they are the same, there must be no constructors. But there
1201 might be applications thus (f (g x)).
1202
1203 Note that tys only includes the visible arguments of the class type
1204 constructor. Including the non-visible arguments can cause the following,
1205 perfectly valid instance to be rejected:
1206 class Category (cat :: k -> k -> *) where ...
1207 newtype T (c :: * -> * -> *) a b = MkT (c a b)
1208 instance Category c => Category (T c) where ...
1209 since the first argument to Category is a non-visible *, which sizeTypes
1210 would count as a constructor! See Trac #11833.
1211
1212 * Also check for a bizarre corner case, when the derived instance decl
1213 would look like
1214 instance C a b => D (T a) where ...
1215 Note that 'b' isn't a parameter of T. This gives rise to all sorts of
1216 problems; in particular, it's hard to compare solutions for equality
1217 when finding the fixpoint, and that means the inferContext loop does
1218 not converge. See Trac #5287.
1219
1220 Note [Equality class instances]
1221 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1222 We can't have users writing instances for the equality classes. But we
1223 still need to be able to write instances for them ourselves. So we allow
1224 instances only in the defining module.
1225
1226 -}
1227
1228 validDerivPred :: TyVarSet -> PredType -> Bool
1229 -- See Note [Valid 'deriving' predicate]
1230 validDerivPred tv_set pred
1231 = case classifyPredType pred of
1232 ClassPred cls tys -> cls `hasKey` typeableClassKey
1233 -- Typeable constraints are bigger than they appear due
1234 -- to kind polymorphism, but that's OK
1235 || check_tys cls tys
1236 EqPred {} -> False -- reject equality constraints
1237 _ -> True -- Non-class predicates are ok
1238 where
1239 check_tys cls tys
1240 = hasNoDups fvs
1241 -- use sizePred to ignore implicit args
1242 && lengthIs fvs (sizePred pred)
1243 && all (`elemVarSet` tv_set) fvs
1244 where tys' = filterOutInvisibleTypes (classTyCon cls) tys
1245 fvs = fvTypes tys'
1246
1247 {-
1248 ************************************************************************
1249 * *
1250 \subsection{Checking instance for termination}
1251 * *
1252 ************************************************************************
1253 -}
1254
1255 {- Note [Instances and constraint synonyms]
1256 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1257 Currently, we don't allow instances for constraint synonyms at all.
1258 Consider these (Trac #13267):
1259 type C1 a = Show (a -> Bool)
1260 instance C1 Int where -- I1
1261 show _ = "ur"
1262
1263 This elicits "show is not a (visible) method of class C1", which isn't
1264 a great message. But it comes from the renamer, so it's hard to improve.
1265
1266 This needs a bit more care:
1267 type C2 a = (Show a, Show Int)
1268 instance C2 Int -- I2
1269
1270 If we use (splitTyConApp_maybe tau) in checkValidInstance to decompose
1271 the instance head, we'll expand the synonym on fly, and it'll look like
1272 instance (%,%) (Show Int, Show Int)
1273 and we /really/ don't want that. So we carefully do /not/ expand
1274 synonyms, by matching on TyConApp directly.
1275 -}
1276
1277 checkValidInstance :: UserTypeCtxt -> LHsSigType GhcRn -> Type
1278 -> TcM ([TyVar], ThetaType, Class, [Type])
1279 checkValidInstance ctxt hs_type ty
1280 | not is_tc_app
1281 = failWithTc (text "Instance head is not headed by a class")
1282
1283 | isNothing mb_cls
1284 = failWithTc (vcat [ text "Illegal instance for a" <+> ppr (tyConFlavour tc)
1285 , text "A class instance must be for a class" ])
1286
1287 | not arity_ok
1288 = failWithTc (text "Arity mis-match in instance head")
1289
1290 | otherwise
1291 = do { setSrcSpan head_loc (checkValidInstHead ctxt clas inst_tys)
1292 ; traceTc "checkValidInstance {" (ppr ty)
1293 ; checkValidTheta ctxt theta
1294
1295 -- The Termination and Coverate Conditions
1296 -- Check that instance inference will terminate (if we care)
1297 -- For Haskell 98 this will already have been done by checkValidTheta,
1298 -- but as we may be using other extensions we need to check.
1299 --
1300 -- Note that the Termination Condition is *more conservative* than
1301 -- the checkAmbiguity test we do on other type signatures
1302 -- e.g. Bar a => Bar Int is ambiguous, but it also fails
1303 -- the termination condition, because 'a' appears more often
1304 -- in the constraint than in the head
1305 ; undecidable_ok <- xoptM LangExt.UndecidableInstances
1306 ; if undecidable_ok
1307 then checkAmbiguity ctxt ty
1308 else checkInstTermination inst_tys theta
1309
1310 ; traceTc "cvi 2" (ppr ty)
1311
1312 ; case (checkInstCoverage undecidable_ok clas theta inst_tys) of
1313 IsValid -> return () -- Check succeeded
1314 NotValid msg -> addErrTc (instTypeErr clas inst_tys msg)
1315
1316 ; traceTc "End checkValidInstance }" empty
1317
1318 ; return (tvs, theta, clas, inst_tys) }
1319 where
1320 (tvs, theta, tau) = tcSplitSigmaTy ty
1321 is_tc_app = case tau of { TyConApp {} -> True; _ -> False }
1322 TyConApp tc inst_tys = tau -- See Note [Instances and constraint synonyms]
1323 mb_cls = tyConClass_maybe tc
1324 Just clas = mb_cls
1325 arity_ok = inst_tys `lengthIs` classArity clas
1326
1327 -- The location of the "head" of the instance
1328 head_loc = getLoc (getLHsInstDeclHead hs_type)
1329
1330 {-
1331 Note [Paterson conditions]
1332 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1333 Termination test: the so-called "Paterson conditions" (see Section 5 of
1334 "Understanding functional dependencies via Constraint Handling Rules,
1335 JFP Jan 2007).
1336
1337 We check that each assertion in the context satisfies:
1338 (1) no variable has more occurrences in the assertion than in the head, and
1339 (2) the assertion has fewer constructors and variables (taken together
1340 and counting repetitions) than the head.
1341 This is only needed with -fglasgow-exts, as Haskell 98 restrictions
1342 (which have already been checked) guarantee termination.
1343
1344 The underlying idea is that
1345
1346 for any ground substitution, each assertion in the
1347 context has fewer type constructors than the head.
1348 -}
1349
1350 checkInstTermination :: [TcType] -> ThetaType -> TcM ()
1351 -- See Note [Paterson conditions]
1352 checkInstTermination tys theta
1353 = check_preds theta
1354 where
1355 head_fvs = fvTypes tys
1356 head_size = sizeTypes tys
1357
1358 check_preds :: [PredType] -> TcM ()
1359 check_preds preds = mapM_ check preds
1360
1361 check :: PredType -> TcM ()
1362 check pred
1363 = case classifyPredType pred of
1364 EqPred {} -> return () -- See Trac #4200.
1365 IrredPred {} -> check2 pred (sizeType pred)
1366 ClassPred cls tys
1367 | isTerminatingClass cls
1368 -> return ()
1369
1370 | isCTupleClass cls -- Look inside tuple predicates; Trac #8359
1371 -> check_preds tys
1372
1373 | otherwise
1374 -> check2 pred (sizeTypes $ filterOutInvisibleTypes (classTyCon cls) tys)
1375 -- Other ClassPreds
1376
1377 check2 pred pred_size
1378 | not (null bad_tvs) = addErrTc (noMoreMsg bad_tvs what)
1379 | pred_size >= head_size = addErrTc (smallerMsg what)
1380 | otherwise = return ()
1381 where
1382 what = text "constraint" <+> quotes (ppr pred)
1383 bad_tvs = fvType pred \\ head_fvs
1384
1385 smallerMsg :: SDoc -> SDoc
1386 smallerMsg what
1387 = vcat [ hang (text "The" <+> what)
1388 2 (text "is no smaller than the instance head")
1389 , parens undecidableMsg ]
1390
1391 noMoreMsg :: [TcTyVar] -> SDoc -> SDoc
1392 noMoreMsg tvs what
1393 = vcat [ hang (text "Variable" <> plural tvs <+> quotes (pprWithCommas ppr tvs)
1394 <+> occurs <+> text "more often")
1395 2 (sep [ text "in the" <+> what
1396 , text "than in the instance head" ])
1397 , parens undecidableMsg ]
1398 where
1399 occurs = if isSingleton tvs then text "occurs"
1400 else text "occur"
1401
1402 undecidableMsg, constraintKindsMsg :: SDoc
1403 undecidableMsg = text "Use UndecidableInstances to permit this"
1404 constraintKindsMsg = text "Use ConstraintKinds to permit this"
1405
1406 {-
1407 Note [Associated type instances]
1408 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1409 We allow this:
1410 class C a where
1411 type T x a
1412 instance C Int where
1413 type T (S y) Int = y
1414 type T Z Int = Char
1415
1416 Note that
1417 a) The variable 'x' is not bound by the class decl
1418 b) 'x' is instantiated to a non-type-variable in the instance
1419 c) There are several type instance decls for T in the instance
1420
1421 All this is fine. Of course, you can't give any *more* instances
1422 for (T ty Int) elsewhere, because it's an *associated* type.
1423
1424 Note [Checking consistent instantiation]
1425 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1426 See Trac #11450 for background discussion on this check.
1427
1428 class C a b where
1429 type T a x b
1430
1431 With this class decl, if we have an instance decl
1432 instance C ty1 ty2 where ...
1433 then the type instance must look like
1434 type T ty1 v ty2 = ...
1435 with exactly 'ty1' for 'a', 'ty2' for 'b', and some type 'v' for 'x'.
1436 For example:
1437
1438 instance C [p] Int
1439 type T [p] y Int = (p,y,y)
1440
1441 Note that
1442
1443 * We used to allow completely different bound variables in the
1444 associated type instance; e.g.
1445 instance C [p] Int
1446 type T [q] y Int = ...
1447 But from GHC 8.2 onwards, we don't. It's much simpler this way.
1448 See Trac #11450.
1449
1450 * When the class variable isn't used on the RHS of the type instance,
1451 it's tempting to allow wildcards, thus
1452 instance C [p] Int
1453 type T [_] y Int = (y,y)
1454 But it's awkward to do the test, and it doesn't work if the
1455 variable is repeated:
1456 instance C (p,p) Int
1457 type T (_,_) y Int = (y,y)
1458 Even though 'p' is not used on the RHS, we still need to use 'p'
1459 on the LHS to establish the repeated pattern. So to keep it simple
1460 we just require equality.
1461
1462 * For variables in associated type families that are not bound by the class
1463 itself, we do _not_ check if they are over-specific. In other words,
1464 it's perfectly acceptable to have an instance like this:
1465
1466 instance C [p] Int where
1467 type T [p] (Maybe x) Int = x
1468
1469 While the first and third arguments to T are required to be exactly [p] and
1470 Int, respectively, since they are bound by C, the second argument is allowed
1471 to be more specific than just a type variable. Furthermore, it is permissible
1472 to define multiple equations for T that differ only in the non-class-bound
1473 argument:
1474
1475 instance C [p] Int where
1476 type T [p] (Maybe x) Int = x
1477 type T [p] (Either x y) Int = x -> y
1478
1479 We once considered requiring that non-class-bound variables in associated
1480 type family instances be instantiated with distinct type variables. However,
1481 that requirement proved too restrictive in practice, as there were examples
1482 of extremely simple associated type family instances that this check would
1483 reject, and fixing them required tiresome boilerplate in the form of
1484 auxiliary type families. For instance, you would have to define the above
1485 example as:
1486
1487 instance C [p] Int where
1488 type T [p] x Int = CAux x
1489
1490 type family CAux x where
1491 CAux (Maybe x) = x
1492 CAux (Either x y) = x -> y
1493
1494 We decided that this restriction wasn't buying us much, so we opted not
1495 to pursue that design (see also GHC Trac #13398).
1496
1497 Implementation
1498 * Form the mini-envt from the class type variables a,b
1499 to the instance decl types [p],Int: [a->[p], b->Int]
1500
1501 * Look at the tyvars a,x,b of the type family constructor T
1502 (it shares tyvars with the class C)
1503
1504 * Apply the mini-evnt to them, and check that the result is
1505 consistent with the instance types [p] y Int. (where y can be any type, as
1506 it is not scoped over the class type variables.
1507
1508 We make all the instance type variables scope over the
1509 type instances, of course, which picks up non-obvious kinds. Eg
1510 class Foo (a :: k) where
1511 type F a
1512 instance Foo (b :: k -> k) where
1513 type F b = Int
1514 Here the instance is kind-indexed and really looks like
1515 type F (k->k) (b::k->k) = Int
1516 But if the 'b' didn't scope, we would make F's instance too
1517 poly-kinded.
1518 -}
1519
1520 -- | Extra information about the parent instance declaration, needed
1521 -- when type-checking associated types. The 'Class' is the enclosing
1522 -- class, the [TyVar] are the type variable of the instance decl,
1523 -- and and the @VarEnv Type@ maps class variables to their instance
1524 -- types.
1525 type ClsInstInfo = (Class, [TyVar], VarEnv Type)
1526
1527 type AssocInstArgShape = (Maybe Type, Type)
1528 -- AssocInstArgShape is used only for associated family instances
1529 -- (mb_exp, actual)
1530 -- mb_exp = Just ty => this arg corresponds to a class variable
1531 -- = Nothing => it doesn't correspond to a class variable
1532 -- e.g. class C b where
1533 -- type F a b c
1534 -- instance C [x] where
1535 -- type F p [x] q
1536 -- We get [AssocInstArgShape] = [ (Nothing, p)
1537 -- , (Just [x], [x])
1538 -- , (Nothing, q)]
1539
1540 checkConsistentFamInst
1541 :: Maybe ClsInstInfo
1542 -> TyCon -- ^ Family tycon
1543 -> [Type] -- ^ Type patterns from instance
1544 -> SDoc -- ^ pretty-printed user-written instance head
1545 -> TcM ()
1546 -- See Note [Checking consistent instantiation]
1547
1548 checkConsistentFamInst Nothing _ _ _ = return ()
1549 checkConsistentFamInst (Just (clas, inst_tvs, mini_env)) fam_tc at_tys pp_hs_pats
1550 = do { -- Check that the associated type indeed comes from this class
1551 checkTc (Just clas == tyConAssoc_maybe fam_tc)
1552 (badATErr (className clas) (tyConName fam_tc))
1553
1554 -- Check type args first (more comprehensible)
1555 ; checkTc (all check_arg type_shapes) pp_wrong_at_arg
1556
1557 -- And now kind args
1558 ; checkTcM (all check_arg kind_shapes)
1559 (tidy_env2, pp_wrong_at_arg $$ ppSuggestExplicitKinds)
1560
1561 ; traceTc "cfi" (vcat [ ppr inst_tvs
1562 , ppr arg_shapes
1563 , ppr mini_env ]) }
1564 where
1565 arg_shapes :: [AssocInstArgShape]
1566 arg_shapes = [ (lookupVarEnv mini_env fam_tc_tv, at_ty)
1567 | (fam_tc_tv, at_ty) <- tyConTyVars fam_tc `zip` at_tys ]
1568
1569 (kind_shapes, type_shapes) = partitionInvisibles fam_tc snd arg_shapes
1570
1571 check_arg :: AssocInstArgShape -> Bool
1572 check_arg (Just exp_ty, at_ty) = exp_ty `tcEqType` at_ty
1573 check_arg (Nothing, _ ) = True -- Arg position does not correspond
1574 -- to a class variable
1575
1576 pp_wrong_at_arg
1577 = vcat [ text "Type indexes must match class instance head"
1578 , pp_exp_act ]
1579
1580 pp_exp_act
1581 = vcat [ text "Expected:" <+> ppr (mkTyConApp fam_tc expected_args)
1582 , text " Actual:" <+> pp_hs_pats
1583 , sdocWithDynFlags $ \dflags ->
1584 ppWhen (has_poly_args dflags) $
1585 vcat [ text "where the `<tv>' arguments are type variables,"
1586 , text "distinct from each other and from the instance variables" ] ]
1587
1588 -- We need to tidy, since it's possible that expected_args will contain
1589 -- inferred kind variables with names identical to those in at_tys. If we
1590 -- don't, we'll end up with horrible messages like this one (#13972):
1591 --
1592 -- Expected: T (a -> Either a b)
1593 -- Actual: T (a -> Either a b)
1594 (tidy_env1, _) = tidyOpenTypes emptyTidyEnv at_tys
1595 (tidy_env2, expected_args)
1596 = tidyOpenTypes tidy_env1 [ exp_ty `orElse` mk_tv at_ty
1597 | (exp_ty, at_ty) <- arg_shapes ]
1598 mk_tv at_ty = mkTyVarTy (mkTyVar tv_name (typeKind at_ty))
1599 tv_name = mkInternalName (mkAlphaTyVarUnique 1) (mkTyVarOcc "<tv>") noSrcSpan
1600
1601 has_poly_args dflags = any (isNothing . fst) shapes
1602 where
1603 shapes | gopt Opt_PrintExplicitKinds dflags = arg_shapes
1604 | otherwise = type_shapes
1605
1606 badATErr :: Name -> Name -> SDoc
1607 badATErr clas op
1608 = hsep [text "Class", quotes (ppr clas),
1609 text "does not have an associated type", quotes (ppr op)]
1610
1611
1612 {-
1613 ************************************************************************
1614 * *
1615 Checking type instance well-formedness and termination
1616 * *
1617 ************************************************************************
1618 -}
1619
1620 checkValidCoAxiom :: CoAxiom Branched -> TcM ()
1621 checkValidCoAxiom ax@(CoAxiom { co_ax_tc = fam_tc, co_ax_branches = branches })
1622 = do { mapM_ (checkValidCoAxBranch Nothing fam_tc) branch_list
1623 ; foldlM_ check_branch_compat [] branch_list }
1624 where
1625 branch_list = fromBranches branches
1626 injectivity = tyConInjectivityInfo fam_tc
1627
1628 check_branch_compat :: [CoAxBranch] -- previous branches in reverse order
1629 -> CoAxBranch -- current branch
1630 -> TcM [CoAxBranch]-- current branch : previous branches
1631 -- Check for
1632 -- (a) this branch is dominated by previous ones
1633 -- (b) failure of injectivity
1634 check_branch_compat prev_branches cur_branch
1635 | cur_branch `isDominatedBy` prev_branches
1636 = do { addWarnAt NoReason (coAxBranchSpan cur_branch) $
1637 inaccessibleCoAxBranch ax cur_branch
1638 ; return prev_branches }
1639 | otherwise
1640 = do { check_injectivity prev_branches cur_branch
1641 ; return (cur_branch : prev_branches) }
1642
1643 -- Injectivity check: check whether a new (CoAxBranch) can extend
1644 -- already checked equations without violating injectivity
1645 -- annotation supplied by the user.
1646 -- See Note [Verifying injectivity annotation] in FamInstEnv
1647 check_injectivity prev_branches cur_branch
1648 | Injective inj <- injectivity
1649 = do { let conflicts =
1650 fst $ foldl (gather_conflicts inj prev_branches cur_branch)
1651 ([], 0) prev_branches
1652 ; mapM_ (\(err, span) -> setSrcSpan span $ addErr err)
1653 (makeInjectivityErrors ax cur_branch inj conflicts) }
1654 | otherwise
1655 = return ()
1656
1657 gather_conflicts inj prev_branches cur_branch (acc, n) branch
1658 -- n is 0-based index of branch in prev_branches
1659 = case injectiveBranches inj cur_branch branch of
1660 InjectivityUnified ax1 ax2
1661 | ax1 `isDominatedBy` (replace_br prev_branches n ax2)
1662 -> (acc, n + 1)
1663 | otherwise
1664 -> (branch : acc, n + 1)
1665 InjectivityAccepted -> (acc, n + 1)
1666
1667 -- Replace n-th element in the list. Assumes 0-based indexing.
1668 replace_br :: [CoAxBranch] -> Int -> CoAxBranch -> [CoAxBranch]
1669 replace_br brs n br = take n brs ++ [br] ++ drop (n+1) brs
1670
1671
1672 -- Check that a "type instance" is well-formed (which includes decidability
1673 -- unless -XUndecidableInstances is given).
1674 --
1675 checkValidCoAxBranch :: Maybe ClsInstInfo
1676 -> TyCon -> CoAxBranch -> TcM ()
1677 checkValidCoAxBranch mb_clsinfo fam_tc
1678 (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs
1679 , cab_lhs = typats
1680 , cab_rhs = rhs, cab_loc = loc })
1681 = checkValidTyFamEqn mb_clsinfo fam_tc tvs cvs typats rhs pp_lhs loc
1682 where
1683 pp_lhs = ppr (mkTyConApp fam_tc typats)
1684
1685 -- | Do validity checks on a type family equation, including consistency
1686 -- with any enclosing class instance head, termination, and lack of
1687 -- polytypes.
1688 checkValidTyFamEqn :: Maybe ClsInstInfo
1689 -> TyCon -- ^ of the type family
1690 -> [TyVar] -- ^ bound tyvars in the equation
1691 -> [CoVar] -- ^ bound covars in the equation
1692 -> [Type] -- ^ type patterns
1693 -> Type -- ^ rhs
1694 -> SDoc -- ^ user-written LHS
1695 -> SrcSpan
1696 -> TcM ()
1697 checkValidTyFamEqn mb_clsinfo fam_tc tvs cvs typats rhs pp_lhs loc
1698 = setSrcSpan loc $
1699 do { checkValidFamPats mb_clsinfo fam_tc tvs cvs typats [] pp_lhs
1700
1701 -- The argument patterns, and RHS, are all boxed tau types
1702 -- E.g Reject type family F (a :: k1) :: k2
1703 -- type instance F (forall a. a->a) = ...
1704 -- type instance F Int# = ...
1705 -- type instance F Int = forall a. a->a
1706 -- type instance F Int = Int#
1707 -- See Trac #9357
1708 ; checkValidMonoType rhs
1709
1710 -- We have a decidable instance unless otherwise permitted
1711 ; undecidable_ok <- xoptM LangExt.UndecidableInstances
1712 ; unless undecidable_ok $
1713 mapM_ addErrTc (checkFamInstRhs typats (tcTyFamInsts rhs)) }
1714
1715 -- Make sure that each type family application is
1716 -- (1) strictly smaller than the lhs,
1717 -- (2) mentions no type variable more often than the lhs, and
1718 -- (3) does not contain any further type family instances.
1719 --
1720 checkFamInstRhs :: [Type] -- lhs
1721 -> [(TyCon, [Type])] -- type family instances
1722 -> [MsgDoc]
1723 checkFamInstRhs lhsTys famInsts
1724 = mapMaybe check famInsts
1725 where
1726 size = sizeTypes lhsTys
1727 fvs = fvTypes lhsTys
1728 check (tc, tys)
1729 | not (all isTyFamFree tys) = Just (nestedMsg what)
1730 | not (null bad_tvs) = Just (noMoreMsg bad_tvs what)
1731 | size <= sizeTypes tys = Just (smallerMsg what)
1732 | otherwise = Nothing
1733 where
1734 what = text "type family application" <+> quotes (pprType (TyConApp tc tys))
1735 bad_tvs = fvTypes tys \\ fvs
1736
1737 checkValidFamPats :: Maybe ClsInstInfo -> TyCon -> [TyVar] -> [CoVar]
1738 -> [Type] -- ^ patterns the user wrote
1739 -> [Type] -- ^ "extra" patterns from a data instance kind sig
1740 -> SDoc -- ^ pretty-printed user-written instance head
1741 -> TcM ()
1742 -- Patterns in a 'type instance' or 'data instance' decl should
1743 -- a) contain no type family applications
1744 -- (vanilla synonyms are fine, though)
1745 -- b) properly bind all their free type variables
1746 -- e.g. we disallow (Trac #7536)
1747 -- type T a = Int
1748 -- type instance F (T a) = a
1749 -- c) For associated types, are consistently instantiated
1750 checkValidFamPats mb_clsinfo fam_tc tvs cvs user_ty_pats extra_ty_pats pp_hs_pats
1751 = do { mapM_ checkValidTypePat user_ty_pats
1752
1753 ; let unbound_tcvs = filterOut (`elemVarSet` exactTyCoVarsOfTypes user_ty_pats)
1754 (tvs ++ cvs)
1755 ; checkTc (null unbound_tcvs) (famPatErr fam_tc unbound_tcvs user_ty_pats)
1756
1757 -- Check that type patterns match the class instance head
1758 ; checkConsistentFamInst mb_clsinfo fam_tc (user_ty_pats `chkAppend` extra_ty_pats) pp_hs_pats }
1759
1760 checkValidTypePat :: Type -> TcM ()
1761 -- Used for type patterns in class instances,
1762 -- and in type/data family instances
1763 checkValidTypePat pat_ty
1764 = do { -- Check that pat_ty is a monotype
1765 checkValidMonoType pat_ty
1766 -- One could imagine generalising to allow
1767 -- instance C (forall a. a->a)
1768 -- but we don't know what all the consequences might be
1769
1770 -- Ensure that no type family instances occur a type pattern
1771 ; checkTc (isTyFamFree pat_ty) $
1772 tyFamInstIllegalErr pat_ty }
1773
1774 isTyFamFree :: Type -> Bool
1775 -- ^ Check that a type does not contain any type family applications.
1776 isTyFamFree = null . tcTyFamInsts
1777
1778 -- Error messages
1779
1780 inaccessibleCoAxBranch :: CoAxiom br -> CoAxBranch -> SDoc
1781 inaccessibleCoAxBranch fi_ax cur_branch
1782 = text "Type family instance equation is overlapped:" $$
1783 nest 2 (pprCoAxBranch fi_ax cur_branch)
1784
1785 tyFamInstIllegalErr :: Type -> SDoc
1786 tyFamInstIllegalErr ty
1787 = hang (text "Illegal type synonym family application in instance" <>
1788 colon) 2 $
1789 ppr ty
1790
1791 nestedMsg :: SDoc -> SDoc
1792 nestedMsg what
1793 = sep [ text "Illegal nested" <+> what
1794 , parens undecidableMsg ]
1795
1796 famPatErr :: TyCon -> [TyVar] -> [Type] -> SDoc
1797 famPatErr fam_tc tvs pats
1798 = hang (text "Family instance purports to bind type variable" <> plural tvs
1799 <+> pprQuotedList tvs)
1800 2 (hang (text "but the real LHS (expanding synonyms) is:")
1801 2 (pprTypeApp fam_tc (map expandTypeSynonyms pats) <+>
1802 text "= ..."))
1803
1804 {-
1805 ************************************************************************
1806 * *
1807 Telescope checking
1808 * *
1809 ************************************************************************
1810
1811 Note [Bad telescopes]
1812 ~~~~~~~~~~~~~~~~~~~~~
1813 Now that we can mix type and kind variables, there are an awful lot of
1814 ways to shoot yourself in the foot. Here are some.
1815
1816 data SameKind :: k -> k -> * -- just to force unification
1817
1818 1. data T1 a k (b :: k) (x :: SameKind a b)
1819
1820 The problem here is that we discover that a and b should have the same
1821 kind. But this kind mentions k, which is bound *after* a.
1822 (Testcase: dependent/should_fail/BadTelescope)
1823
1824 2. data T2 a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d)
1825
1826 Note that b is not bound. Yet its kind mentions a. Because we have
1827 a nice rule that all implicitly bound variables come before others,
1828 this is bogus. (We could probably figure out to put b between a and c.
1829 But I think this is doing users a disservice, in the long run.)
1830 (Testcase: dependent/should_fail/BadTelescope4)
1831
1832 3. t3 :: forall a. (forall k (b :: k). SameKind a b) -> ()
1833
1834 This is a straightforward skolem escape. Note that a and b need to have
1835 the same kind.
1836 (Testcase: polykinds/T11142)
1837
1838 How do we deal with all of this? For TyCons, we have checkValidTyConTyVars.
1839 That function looks to see if any of the tyConTyVars are repeated, but
1840 it's really a telescope check. It works because all tycons are kind-generalized.
1841 If there is a bad telescope, the kind-generalization will end up generalizing
1842 over a variable bound later in the telescope.
1843
1844 For non-tycons, we do scope checking when we bring tyvars into scope,
1845 in tcImplicitTKBndrs and tcExplicitTKBndrs. Note that we also have to
1846 sort implicit binders into a well-scoped order whenever we have implicit
1847 binders to worry about. This is done in quantifyTyVars and in
1848 tcImplicitTKBndrs.
1849 -}
1850
1851 -- | Check a list of binders to see if they make a valid telescope.
1852 -- The key property we're checking for is scoping. For example:
1853 -- > data SameKind :: k -> k -> *
1854 -- > data X a k (b :: k) (c :: SameKind a b)
1855 -- Kind inference says that a's kind should be k. But that's impossible,
1856 -- because k isn't in scope when a is bound. This check has to come before
1857 -- general validity checking, because once we kind-generalise, this sort
1858 -- of problem is harder to spot (as we'll generalise over the unbound
1859 -- k in a's type.) See also Note [Bad telescopes].
1860 checkValidTelescope :: SDoc -- the original user-written telescope
1861 -> [TyVar] -- explicit vars (not necessarily zonked)
1862 -> SDoc -- note to put at bottom of message
1863 -> TcM ()
1864 checkValidTelescope hs_tvs orig_tvs extra
1865 = discardResult $ checkZonkValidTelescope hs_tvs orig_tvs extra
1866
1867 -- | Like 'checkZonkValidTelescope', but returns the zonked tyvars
1868 checkZonkValidTelescope :: SDoc
1869 -> [TyVar]
1870 -> SDoc
1871 -> TcM [TyVar]
1872 checkZonkValidTelescope hs_tvs orig_tvs extra
1873 = do { orig_tvs <- mapM zonkTyCoVarKind orig_tvs
1874 ; let (_, sorted_tidied_tvs) = tidyTyCoVarBndrs emptyTidyEnv $
1875 toposortTyVars orig_tvs
1876 ; unless (go [] emptyVarSet orig_tvs) $
1877 addErr $
1878 vcat [ hang (text "These kind and type variables:" <+> hs_tvs $$
1879 text "are out of dependency order. Perhaps try this ordering:")
1880 2 (sep (map pprTyVar sorted_tidied_tvs))
1881 , extra ]
1882 ; return orig_tvs }
1883
1884 where
1885 go :: [TyVar] -- misplaced variables
1886 -> TyVarSet -> [TyVar] -> Bool
1887 go errs in_scope [] = null (filter (`elemVarSet` in_scope) errs)
1888 -- report an error only when the variable in the kind is brought
1889 -- into scope later in the telescope. Otherwise, we'll just quantify
1890 -- over it in kindGeneralize, as we should.
1891
1892 go errs in_scope (tv:tvs)
1893 = let bad_tvs = filterOut (`elemVarSet` in_scope) $
1894 tyCoVarsOfTypeList (tyVarKind tv)
1895 in go (bad_tvs ++ errs) (in_scope `extendVarSet` tv) tvs
1896
1897 -- | After inferring kinds of type variables, check to make sure that the
1898 -- inferred kinds any of the type variables bound in a smaller scope.
1899 -- This is a skolem escape check. See also Note [Bad telescopes].
1900 checkValidInferredKinds :: [TyVar] -- ^ vars to check (zonked)
1901 -> TyVarSet -- ^ vars out of scope
1902 -> SDoc -- ^ suffix to error message
1903 -> TcM ()
1904 checkValidInferredKinds orig_kvs out_of_scope extra
1905 = do { let bad_pairs = [ (tv, kv)
1906 | kv <- orig_kvs
1907 , Just tv <- map (lookupVarSet out_of_scope)
1908 (tyCoVarsOfTypeList (tyVarKind kv)) ]
1909 report (tidyTyVarOcc env -> tv, tidyTyVarOcc env -> kv)
1910 = addErr $
1911 text "The kind of variable" <+>
1912 quotes (ppr kv) <> text ", namely" <+>
1913 quotes (ppr (tyVarKind kv)) <> comma $$
1914 text "depends on variable" <+>
1915 quotes (ppr tv) <+> text "from an inner scope" $$
1916 text "Perhaps bind" <+> quotes (ppr kv) <+>
1917 text "sometime after binding" <+>
1918 quotes (ppr tv) $$
1919 extra
1920 ; mapM_ report bad_pairs }
1921
1922 where
1923 (env1, _) = tidyTyCoVarBndrs emptyTidyEnv orig_kvs
1924 (env, _) = tidyTyCoVarBndrs env1 (nonDetEltsUniqSet out_of_scope)
1925 -- It's OK to use nonDetEltsUniqSet here because it's only used for
1926 -- generating the error message
1927
1928 {-
1929 ************************************************************************
1930 * *
1931 \subsection{Auxiliary functions}
1932 * *
1933 ************************************************************************
1934 -}
1935
1936 -- Free variables of a type, retaining repetitions, and expanding synonyms
1937 fvType :: Type -> [TyCoVar]
1938 fvType ty | Just exp_ty <- tcView ty = fvType exp_ty
1939 fvType (TyVarTy tv) = [tv]
1940 fvType (TyConApp _ tys) = fvTypes tys
1941 fvType (LitTy {}) = []
1942 fvType (AppTy fun arg) = fvType fun ++ fvType arg
1943 fvType (FunTy arg res) = fvType arg ++ fvType res
1944 fvType (ForAllTy (TvBndr tv _) ty)
1945 = fvType (tyVarKind tv) ++
1946 filter (/= tv) (fvType ty)
1947 fvType (CastTy ty co) = fvType ty ++ fvCo co
1948 fvType (CoercionTy co) = fvCo co
1949
1950 fvTypes :: [Type] -> [TyVar]
1951 fvTypes tys = concat (map fvType tys)
1952
1953 fvCo :: Coercion -> [TyCoVar]
1954 fvCo (Refl _ ty) = fvType ty
1955 fvCo (TyConAppCo _ _ args) = concatMap fvCo args
1956 fvCo (AppCo co arg) = fvCo co ++ fvCo arg
1957 fvCo (ForAllCo tv h co) = filter (/= tv) (fvCo co) ++ fvCo h
1958 fvCo (FunCo _ co1 co2) = fvCo co1 ++ fvCo co2
1959 fvCo (CoVarCo v) = [v]
1960 fvCo (AxiomInstCo _ _ args) = concatMap fvCo args
1961 fvCo (UnivCo p _ t1 t2) = fvProv p ++ fvType t1 ++ fvType t2
1962 fvCo (SymCo co) = fvCo co
1963 fvCo (TransCo co1 co2) = fvCo co1 ++ fvCo co2
1964 fvCo (NthCo _ co) = fvCo co
1965 fvCo (LRCo _ co) = fvCo co
1966 fvCo (InstCo co arg) = fvCo co ++ fvCo arg
1967 fvCo (CoherenceCo co1 co2) = fvCo co1 ++ fvCo co2
1968 fvCo (KindCo co) = fvCo co
1969 fvCo (SubCo co) = fvCo co
1970 fvCo (AxiomRuleCo _ cs) = concatMap fvCo cs
1971
1972 fvProv :: UnivCoProvenance -> [TyCoVar]
1973 fvProv UnsafeCoerceProv = []
1974 fvProv (PhantomProv co) = fvCo co
1975 fvProv (ProofIrrelProv co) = fvCo co
1976 fvProv (PluginProv _) = []
1977 fvProv (HoleProv h) = pprPanic "fvProv falls into a hole" (ppr h)
1978
1979 sizeType :: Type -> Int
1980 -- Size of a type: the number of variables and constructors
1981 sizeType ty | Just exp_ty <- tcView ty = sizeType exp_ty
1982 sizeType (TyVarTy {}) = 1
1983 sizeType (TyConApp _ tys) = sizeTypes tys + 1
1984 sizeType (LitTy {}) = 1
1985 sizeType (AppTy fun arg) = sizeType fun + sizeType arg
1986 sizeType (FunTy arg res) = sizeType arg + sizeType res + 1
1987 sizeType (ForAllTy _ ty) = sizeType ty
1988 sizeType (CastTy ty _) = sizeType ty
1989 sizeType (CoercionTy _) = 1
1990
1991 sizeTypes :: [Type] -> Int
1992 sizeTypes = sum . map sizeType
1993
1994 -- Size of a predicate
1995 --
1996 -- We are considering whether class constraints terminate.
1997 -- Equality constraints and constraints for the implicit
1998 -- parameter class always terminate so it is safe to say "size 0".
1999 -- (Implicit parameter constraints always terminate because
2000 -- there are no instances for them---they are only solved by
2001 -- "local instances" in expressions).
2002 -- See Trac #4200.
2003 sizePred :: PredType -> Int
2004 sizePred ty = goClass ty
2005 where
2006 goClass p = go (classifyPredType p)
2007
2008 go (ClassPred cls tys')
2009 | isTerminatingClass cls = 0
2010 | otherwise = sizeTypes (filterOutInvisibleTypes (classTyCon cls) tys')
2011 go (EqPred {}) = 0
2012 go (IrredPred ty) = sizeType ty
2013
2014 -- | When this says "True", ignore this class constraint during
2015 -- a termination check
2016 isTerminatingClass :: Class -> Bool
2017 isTerminatingClass cls
2018 = isIPClass cls
2019 || cls `hasKey` typeableClassKey
2020 || cls `hasKey` coercibleTyConKey
2021 || cls `hasKey` eqTyConKey
2022 || cls `hasKey` heqTyConKey
2023
2024 -- | Tidy before printing a type
2025 ppr_tidy :: TidyEnv -> Type -> SDoc
2026 ppr_tidy env ty = pprType (tidyType env ty)
2027
2028 allDistinctTyVars :: TyVarSet -> [KindOrType] -> Bool
2029 -- (allDistinctTyVars tvs tys) returns True if tys are
2030 -- a) all tyvars
2031 -- b) all distinct
2032 -- c) disjoint from tvs
2033 allDistinctTyVars _ [] = True
2034 allDistinctTyVars tkvs (ty : tys)
2035 = case getTyVar_maybe ty of
2036 Nothing -> False
2037 Just tv | tv `elemVarSet` tkvs -> False
2038 | otherwise -> allDistinctTyVars (tkvs `extendVarSet` tv) tys