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