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