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