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