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