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