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