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