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