Perform a validity check on assoc type defaults.
[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 #-}
7
8 module TcValidity (
9 Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType,
10 expectedKindInCtxt,
11 checkValidTheta, checkValidFamPats,
12 checkValidInstance, validDerivPred,
13 checkInstTermination,
14 ClsInfo, checkValidCoAxiom, checkValidCoAxBranch,
15 checkValidTyFamEqn,
16 checkConsistentFamInst,
17 arityErr, badATErr
18 ) where
19
20 #include "HsVersions.h"
21
22 -- friends:
23 import TcUnify ( tcSubType_NC )
24 import TcSimplify ( simplifyAmbiguityCheck )
25 import TypeRep
26 import TcType
27 import TcMType
28 import TysWiredIn ( coercibleClass, eqTyCon )
29 import PrelNames
30 import Type
31 import Unify( tcMatchTyX )
32 import Kind
33 import CoAxiom
34 import Class
35 import TyCon
36
37 -- others:
38 import HsSyn -- HsType
39 import TcRnMonad -- TcType, amongst others
40 import FunDeps
41 import FamInstEnv ( isDominatedBy, injectiveBranches,
42 InjectivityCheckResult(..) )
43 import FamInst ( makeInjectivityErrors )
44 import Name
45 import VarEnv
46 import VarSet
47 import ErrUtils
48 import DynFlags
49 import Util
50 import ListSetOps
51 import SrcLoc
52 import Outputable
53 import FastString
54
55 import Control.Monad
56 import Data.Maybe
57 import Data.List ( (\\) )
58
59 {-
60 ************************************************************************
61 * *
62 Checking for ambiguity
63 * *
64 ************************************************************************
65
66 Note [The ambiguity check for type signatures]
67 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
68 checkAmbiguity is a check on *user-supplied type signatures*. It is
69 *purely* there to report functions that cannot possibly be called. So for
70 example we want to reject:
71 f :: C a => Int
72 The idea is there can be no legal calls to 'f' because every call will
73 give rise to an ambiguous constraint. We could soundly omit the
74 ambiguity check on type signatures entirely, at the expense of
75 delaying ambiguity errors to call sites. Indeed, the flag
76 -XAllowAmbiguousTypes switches off the ambiguity check.
77
78 What about things like this:
79 class D a b | a -> b where ..
80 h :: D Int b => Int
81 The Int may well fix 'b' at the call site, so that signature should
82 not be rejected. Moreover, using *visible* fundeps is too
83 conservative. Consider
84 class X a b where ...
85 class D a b | a -> b where ...
86 instance D a b => X [a] b where...
87 h :: X a b => a -> a
88 Here h's type looks ambiguous in 'b', but here's a legal call:
89 ...(h [True])...
90 That gives rise to a (X [Bool] beta) constraint, and using the
91 instance means we need (D Bool beta) and that fixes 'beta' via D's
92 fundep!
93
94 Behind all these special cases there is a simple guiding principle.
95 Consider
96
97 f :: <type>
98 f = ...blah...
99
100 g :: <type>
101 g = f
102
103 You would think that the definition of g would surely typecheck!
104 After all f has exactly the same type, and g=f. But in fact f's type
105 is instantiated and the instantiated constraints are solved against
106 the originals, so in the case an ambiguous type it won't work.
107 Consider our earlier example f :: C a => Int. Then in g's definition,
108 we'll instantiate to (C alpha) and try to deduce (C alpha) from (C a),
109 and fail.
110
111 So in fact we use this as our *definition* of ambiguity. We use a
112 very similar test for *inferred* types, to ensure that they are
113 unambiguous. See Note [Impedence matching] in TcBinds.
114
115 This test is very conveniently implemented by calling
116 tcSubType <type> <type>
117 This neatly takes account of the functional dependecy stuff above,
118 and implicit parameter (see Note [Implicit parameters and ambiguity]).
119 And this is what checkAmbiguity does.
120
121 What about this, though?
122 g :: C [a] => Int
123 Is every call to 'g' ambiguous? After all, we might have
124 intance C [a] where ...
125 at the call site. So maybe that type is ok! Indeed even f's
126 quintessentially ambiguous type might, just possibly be callable:
127 with -XFlexibleInstances we could have
128 instance C a where ...
129 and now a call could be legal after all! Well, we'll reject this
130 unless the instance is available *here*.
131
132 Note [When to call checkAmbiguity]
133 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
134 We call checkAmbiguity
135 (a) on user-specified type signatures
136 (b) in checkValidType
137
138 Conncerning (b), you might wonder about nested foralls. What about
139 f :: forall b. (forall a. Eq a => b) -> b
140 The nested forall is ambiguous. Originally we called checkAmbiguity
141 in the forall case of check_type, but that had two bad consequences:
142 * We got two error messages about (Eq b) in a nested forall like this:
143 g :: forall a. Eq a => forall b. Eq b => a -> a
144 * If we try to check for ambiguity of an nested forall like
145 (forall a. Eq a => b), the implication constraint doesn't bind
146 all the skolems, which results in "No skolem info" in error
147 messages (see Trac #10432).
148
149 To avoid this, we call checkAmbiguity once, at the top, in checkValidType.
150 (I'm still a bit worried about unbound skolems when the type mentions
151 in-scope type variables.)
152
153 In fact, because of the co/contra-variance implemented in tcSubType,
154 this *does* catch function f above. too.
155
156 Concerning (a) the ambiguity check is only used for *user* types, not
157 for types coming from inteface files. The latter can legitimately
158 have ambiguous types. Example
159
160 class S a where s :: a -> (Int,Int)
161 instance S Char where s _ = (1,1)
162 f:: S a => [a] -> Int -> (Int,Int)
163 f (_::[a]) x = (a*x,b)
164 where (a,b) = s (undefined::a)
165
166 Here the worker for f gets the type
167 fw :: forall a. S a => Int -> (# Int, Int #)
168
169
170 Note [Implicit parameters and ambiguity]
171 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
172 Only a *class* predicate can give rise to ambiguity
173 An *implicit parameter* cannot. For example:
174 foo :: (?x :: [a]) => Int
175 foo = length ?x
176 is fine. The call site will supply a particular 'x'
177
178 Furthermore, the type variables fixed by an implicit parameter
179 propagate to the others. E.g.
180 foo :: (Show a, ?x::[a]) => Int
181 foo = show (?x++?x)
182 The type of foo looks ambiguous. But it isn't, because at a call site
183 we might have
184 let ?x = 5::Int in foo
185 and all is well. In effect, implicit parameters are, well, parameters,
186 so we can take their type variables into account as part of the
187 "tau-tvs" stuff. This is done in the function 'FunDeps.grow'.
188 -}
189
190 checkAmbiguity :: UserTypeCtxt -> Type -> TcM ()
191 checkAmbiguity ctxt ty
192 | GhciCtxt <- ctxt -- Allow ambiguous types in GHCi's :kind command
193 = return () -- E.g. type family T a :: * -- T :: forall k. k -> *
194 -- Then :k T should work in GHCi, not complain that
195 -- (T k) is ambiguous!
196
197 | InfSigCtxt {} <- ctxt -- See Note [Validity of inferred types] in TcBinds
198 = return ()
199
200 | otherwise
201 = do { traceTc "Ambiguity check for" (ppr ty)
202 ; let free_tkvs = varSetElemsKvsFirst (closeOverKinds (tyVarsOfType ty))
203 ; (subst, _tvs) <- tcInstSkolTyVars free_tkvs
204 ; let ty' = substTy subst ty
205 -- The type might have free TyVars, esp when the ambiguity check
206 -- happens during a call to checkValidType,
207 -- so we skolemise them as TcTyVars.
208 -- Tiresome; but the type inference engine expects TcTyVars
209 -- NB: The free tyvar might be (a::k), so k is also free
210 -- and we must skolemise it as well. Hence closeOverKinds.
211 -- (Trac #9222)
212
213 -- Solve the constraints eagerly because an ambiguous type
214 -- can cause a cascade of further errors. Since the free
215 -- tyvars are skolemised, we can safely use tcSimplifyTop
216 ; (_wrap, wanted) <- addErrCtxtM (mk_msg ty') $
217 captureConstraints $
218 tcSubType_NC ctxt ty' ty'
219 ; simplifyAmbiguityCheck ty wanted
220
221 ; traceTc "Done ambiguity check for" (ppr ty) }
222 where
223 mk_msg ty tidy_env
224 = do { allow_ambiguous <- xoptM Opt_AllowAmbiguousTypes
225 ; (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env ty
226 ; return (tidy_env', mk_msg tidy_ty $$ ppWhen (not allow_ambiguous) ambig_msg) }
227 where
228 mk_msg ty = pprSigCtxt ctxt (ptext (sLit "the ambiguity check for")) (ppr ty)
229 ambig_msg = ptext (sLit "To defer the ambiguity check to use sites, enable AllowAmbiguousTypes")
230
231 {-
232 ************************************************************************
233 * *
234 Checking validity of a user-defined type
235 * *
236 ************************************************************************
237
238 When dealing with a user-written type, we first translate it from an HsType
239 to a Type, performing kind checking, and then check various things that should
240 be true about it. We don't want to perform these checks at the same time
241 as the initial translation because (a) they are unnecessary for interface-file
242 types and (b) when checking a mutually recursive group of type and class decls,
243 we can't "look" at the tycons/classes yet. Also, the checks are rather
244 diverse, and used to really mess up the other code.
245
246 One thing we check for is 'rank'.
247
248 Rank 0: monotypes (no foralls)
249 Rank 1: foralls at the front only, Rank 0 inside
250 Rank 2: foralls at the front, Rank 1 on left of fn arrow,
251
252 basic ::= tyvar | T basic ... basic
253
254 r2 ::= forall tvs. cxt => r2a
255 r2a ::= r1 -> r2a | basic
256 r1 ::= forall tvs. cxt => r0
257 r0 ::= r0 -> r0 | basic
258
259 Another thing is to check that type synonyms are saturated.
260 This might not necessarily show up in kind checking.
261 type A i = i
262 data T k = MkT (k Int)
263 f :: T A -- BAD!
264 -}
265
266 checkValidType :: UserTypeCtxt -> Type -> TcM ()
267 -- Checks that the type is valid for the given context
268 -- Not used for instance decls; checkValidInstance instead
269 checkValidType ctxt ty
270 = do { traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (typeKind ty))
271 ; rankn_flag <- xoptM Opt_RankNTypes
272 ; let gen_rank :: Rank -> Rank
273 gen_rank r | rankn_flag = ArbitraryRank
274 | otherwise = r
275
276 rank1 = gen_rank r1
277 rank0 = gen_rank r0
278
279 r0 = rankZeroMonoType
280 r1 = LimitedRank True r0
281
282 rank
283 = case ctxt of
284 DefaultDeclCtxt-> MustBeMonoType
285 ResSigCtxt -> MustBeMonoType
286 PatSigCtxt -> rank0
287 RuleSigCtxt _ -> rank1
288 TySynCtxt _ -> rank0
289
290 ExprSigCtxt -> rank1
291 FunSigCtxt {} -> rank1
292 InfSigCtxt _ -> ArbitraryRank -- Inferred type
293 ConArgCtxt _ -> rank1 -- We are given the type of the entire
294 -- constructor, hence rank 1
295
296 ForSigCtxt _ -> rank1
297 SpecInstCtxt -> rank1
298 ThBrackCtxt -> rank1
299 GhciCtxt -> ArbitraryRank
300 _ -> panic "checkValidType"
301 -- Can't happen; not used for *user* sigs
302
303 -- Check the internal validity of the type itself
304 ; check_type ctxt rank ty
305
306 -- Check that the thing has kind Type, and is lifted if necessary.
307 -- Do this *after* check_type, because we can't usefully take
308 -- the kind of an ill-formed type such as (a~Int)
309 ; check_kind ctxt ty
310
311 -- Check for ambiguous types. See Note [When to call checkAmbiguity]
312 -- NB: this will happen even for monotypes, but that should be cheap;
313 -- and there may be nested foralls for the subtype test to examine
314 ; checkAmbiguity ctxt ty
315
316 ; traceTc "checkValidType done" (ppr ty <+> text "::" <+> ppr (typeKind ty)) }
317
318 checkValidMonoType :: Type -> TcM ()
319 checkValidMonoType ty = check_mono_type SigmaCtxt MustBeMonoType ty
320
321
322 check_kind :: UserTypeCtxt -> TcType -> TcM ()
323 -- Check that the type's kind is acceptable for the context
324 check_kind ctxt ty
325 | TySynCtxt {} <- ctxt
326 , returnsConstraintKind actual_kind
327 = do { ck <- xoptM Opt_ConstraintKinds
328 ; if ck
329 then when (isConstraintKind actual_kind)
330 (do { dflags <- getDynFlags
331 ; check_pred_ty dflags ctxt ty })
332 else addErrTc (constraintSynErr actual_kind) }
333
334 | Just k <- expectedKindInCtxt ctxt
335 = checkTc (tcIsSubKind actual_kind k) (kindErr actual_kind)
336
337 | otherwise
338 = return () -- Any kind will do
339 where
340 actual_kind = typeKind ty
341
342 -- Depending on the context, we might accept any kind (for instance, in a TH
343 -- splice), or only certain kinds (like in type signatures).
344 expectedKindInCtxt :: UserTypeCtxt -> Maybe Kind
345 expectedKindInCtxt (TySynCtxt _) = Nothing -- Any kind will do
346 expectedKindInCtxt ThBrackCtxt = Nothing
347 expectedKindInCtxt GhciCtxt = Nothing
348 expectedKindInCtxt (ForSigCtxt _) = Just liftedTypeKind
349 expectedKindInCtxt InstDeclCtxt = Just constraintKind
350 expectedKindInCtxt SpecInstCtxt = Just constraintKind
351 expectedKindInCtxt _ = Just openTypeKind
352
353 {-
354 Note [Higher rank types]
355 ~~~~~~~~~~~~~~~~~~~~~~~~
356 Technically
357 Int -> forall a. a->a
358 is still a rank-1 type, but it's not Haskell 98 (Trac #5957). So the
359 validity checker allow a forall after an arrow only if we allow it
360 before -- that is, with Rank2Types or RankNTypes
361 -}
362
363 data Rank = ArbitraryRank -- Any rank ok
364
365 | LimitedRank -- Note [Higher rank types]
366 Bool -- Forall ok at top
367 Rank -- Use for function arguments
368
369 | MonoType SDoc -- Monotype, with a suggestion of how it could be a polytype
370
371 | MustBeMonoType -- Monotype regardless of flags
372
373 rankZeroMonoType, tyConArgMonoType, synArgMonoType :: Rank
374 rankZeroMonoType = MonoType (ptext (sLit "Perhaps you intended to use RankNTypes or Rank2Types"))
375 tyConArgMonoType = MonoType (ptext (sLit "GHC doesn't yet support impredicative polymorphism"))
376 synArgMonoType = MonoType (ptext (sLit "Perhaps you intended to use LiberalTypeSynonyms"))
377
378 funArgResRank :: Rank -> (Rank, Rank) -- Function argument and result
379 funArgResRank (LimitedRank _ arg_rank) = (arg_rank, LimitedRank (forAllAllowed arg_rank) arg_rank)
380 funArgResRank other_rank = (other_rank, other_rank)
381
382 forAllAllowed :: Rank -> Bool
383 forAllAllowed ArbitraryRank = True
384 forAllAllowed (LimitedRank forall_ok _) = forall_ok
385 forAllAllowed _ = False
386
387 ----------------------------------------
388 check_mono_type :: UserTypeCtxt -> Rank
389 -> KindOrType -> TcM () -- No foralls anywhere
390 -- No unlifted types of any kind
391 check_mono_type ctxt rank ty
392 | isKind ty = return () -- IA0_NOTE: Do we need to check kinds?
393 | otherwise
394 = do { check_type ctxt rank ty
395 ; checkTc (not (isUnLiftedType ty)) (unliftedArgErr ty) }
396
397 check_type :: UserTypeCtxt -> Rank -> Type -> TcM ()
398 -- The args say what the *type context* requires, independent
399 -- of *flag* settings. You test the flag settings at usage sites.
400 --
401 -- Rank is allowed rank for function args
402 -- Rank 0 means no for-alls anywhere
403
404 check_type ctxt rank ty
405 | not (null tvs && null theta)
406 = do { checkTc (forAllAllowed rank) (forAllTyErr rank ty)
407 -- Reject e.g. (Maybe (?x::Int => Int)),
408 -- with a decent error message
409
410 ; check_valid_theta SigmaCtxt theta
411 -- Allow type T = ?x::Int => Int -> Int
412 -- but not type T = ?x::Int
413
414 ; check_type ctxt rank tau } -- Allow foralls to right of arrow
415 where
416 (tvs, theta, tau) = tcSplitSigmaTy ty
417
418 check_type _ _ (TyVarTy _) = return ()
419
420 check_type ctxt rank (FunTy arg_ty res_ty)
421 = do { check_type ctxt arg_rank arg_ty
422 ; check_type ctxt res_rank res_ty }
423 where
424 (arg_rank, res_rank) = funArgResRank rank
425
426 check_type ctxt rank (AppTy ty1 ty2)
427 = do { check_arg_type ctxt rank ty1
428 ; check_arg_type ctxt rank ty2 }
429
430 check_type ctxt rank ty@(TyConApp tc tys)
431 | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc
432 = check_syn_tc_app ctxt rank ty tc tys
433 | isUnboxedTupleTyCon tc = check_ubx_tuple ctxt ty tys
434 | otherwise = mapM_ (check_arg_type ctxt rank) tys
435
436 check_type _ _ (LitTy {}) = return ()
437
438 check_type _ _ ty = pprPanic "check_type" (ppr ty)
439
440 ----------------------------------------
441 check_syn_tc_app :: UserTypeCtxt -> Rank -> KindOrType
442 -> TyCon -> [KindOrType] -> TcM ()
443 -- Used for type synonyms and type synonym families,
444 -- which must be saturated,
445 -- but not data families, which need not be saturated
446 check_syn_tc_app ctxt rank ty tc tys
447 | tc_arity <= length tys -- Saturated
448 -- Check that the synonym has enough args
449 -- This applies equally to open and closed synonyms
450 -- It's OK to have an *over-applied* type synonym
451 -- data Tree a b = ...
452 -- type Foo a = Tree [a]
453 -- f :: Foo a b -> ...
454 = do { -- See Note [Liberal type synonyms]
455 ; liberal <- xoptM Opt_LiberalTypeSynonyms
456 ; if not liberal || isTypeFamilyTyCon tc then
457 -- For H98 and synonym families, do check the type args
458 mapM_ check_arg tys
459
460 else -- In the liberal case (only for closed syns), expand then check
461 case tcView ty of
462 Just ty' -> check_type ctxt rank ty'
463 Nothing -> pprPanic "check_tau_type" (ppr ty) }
464
465 | GhciCtxt <- ctxt -- Accept under-saturated type synonyms in
466 -- GHCi :kind commands; see Trac #7586
467 = mapM_ check_arg tys
468
469 | otherwise
470 = failWithTc (tyConArityErr tc tys)
471 where
472 tc_arity = tyConArity tc
473 check_arg | isTypeFamilyTyCon tc = check_arg_type ctxt rank
474 | otherwise = check_mono_type ctxt synArgMonoType
475
476 ----------------------------------------
477 check_ubx_tuple :: UserTypeCtxt -> KindOrType
478 -> [KindOrType] -> TcM ()
479 check_ubx_tuple ctxt ty tys
480 = do { ub_tuples_allowed <- xoptM Opt_UnboxedTuples
481 ; checkTc ub_tuples_allowed (ubxArgTyErr ty)
482
483 ; impred <- xoptM Opt_ImpredicativeTypes
484 ; let rank' = if impred then ArbitraryRank else tyConArgMonoType
485 -- c.f. check_arg_type
486 -- However, args are allowed to be unlifted, or
487 -- more unboxed tuples, so can't use check_arg_ty
488 ; mapM_ (check_type ctxt rank') tys }
489
490 ----------------------------------------
491 check_arg_type :: UserTypeCtxt -> Rank -> KindOrType -> TcM ()
492 -- The sort of type that can instantiate a type variable,
493 -- or be the argument of a type constructor.
494 -- Not an unboxed tuple, but now *can* be a forall (since impredicativity)
495 -- Other unboxed types are very occasionally allowed as type
496 -- arguments depending on the kind of the type constructor
497 --
498 -- For example, we want to reject things like:
499 --
500 -- instance Ord a => Ord (forall s. T s a)
501 -- and
502 -- g :: T s (forall b.b)
503 --
504 -- NB: unboxed tuples can have polymorphic or unboxed args.
505 -- This happens in the workers for functions returning
506 -- product types with polymorphic components.
507 -- But not in user code.
508 -- Anyway, they are dealt with by a special case in check_tau_type
509
510 check_arg_type ctxt rank ty
511 | isKind ty = return () -- IA0_NOTE: Do we need to check a kind?
512 | otherwise
513 = do { impred <- xoptM Opt_ImpredicativeTypes
514 ; let rank' = case rank of -- Predictive => must be monotype
515 MustBeMonoType -> MustBeMonoType -- Monotype, regardless
516 _other | impred -> ArbitraryRank
517 | otherwise -> tyConArgMonoType
518 -- Make sure that MustBeMonoType is propagated,
519 -- so that we don't suggest -XImpredicativeTypes in
520 -- (Ord (forall a.a)) => a -> a
521 -- and so that if it Must be a monotype, we check that it is!
522
523 ; check_type ctxt rank' ty
524 ; checkTc (not (isUnLiftedType ty)) (unliftedArgErr ty) }
525 -- NB the isUnLiftedType test also checks for
526 -- T State#
527 -- where there is an illegal partial application of State# (which has
528 -- kind * -> #); see Note [The kind invariant] in TypeRep
529
530 ----------------------------------------
531 forAllTyErr :: Rank -> Type -> SDoc
532 forAllTyErr rank ty
533 = vcat [ hang (ptext (sLit "Illegal polymorphic or qualified type:")) 2 (ppr ty)
534 , suggestion ]
535 where
536 suggestion = case rank of
537 LimitedRank {} -> ptext (sLit "Perhaps you intended to use RankNTypes or Rank2Types")
538 MonoType d -> d
539 _ -> Outputable.empty -- Polytype is always illegal
540
541 unliftedArgErr, ubxArgTyErr :: Type -> SDoc
542 unliftedArgErr ty = sep [ptext (sLit "Illegal unlifted type:"), ppr ty]
543 ubxArgTyErr ty = sep [ptext (sLit "Illegal unboxed tuple type as function argument:"), ppr ty]
544
545 kindErr :: Kind -> SDoc
546 kindErr kind = sep [ptext (sLit "Expecting an ordinary type, but found a type of kind"), ppr kind]
547
548 {-
549 Note [Liberal type synonyms]
550 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
551 If -XLiberalTypeSynonyms is on, expand closed type synonyms *before*
552 doing validity checking. This allows us to instantiate a synonym defn
553 with a for-all type, or with a partially-applied type synonym.
554 e.g. type T a b = a
555 type S m = m ()
556 f :: S (T Int)
557 Here, T is partially applied, so it's illegal in H98. But if you
558 expand S first, then T we get just
559 f :: Int
560 which is fine.
561
562 IMPORTANT: suppose T is a type synonym. Then we must do validity
563 checking on an appliation (T ty1 ty2)
564
565 *either* before expansion (i.e. check ty1, ty2)
566 *or* after expansion (i.e. expand T ty1 ty2, and then check)
567 BUT NOT BOTH
568
569 If we do both, we get exponential behaviour!!
570
571 data TIACons1 i r c = c i ::: r c
572 type TIACons2 t x = TIACons1 t (TIACons1 t x)
573 type TIACons3 t x = TIACons2 t (TIACons1 t x)
574 type TIACons4 t x = TIACons2 t (TIACons2 t x)
575 type TIACons7 t x = TIACons4 t (TIACons3 t x)
576
577
578 ************************************************************************
579 * *
580 \subsection{Checking a theta or source type}
581 * *
582 ************************************************************************
583
584 Note [Implicit parameters in instance decls]
585 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
586 Implicit parameters _only_ allowed in type signatures; not in instance
587 decls, superclasses etc. The reason for not allowing implicit params in
588 instances is a bit subtle. If we allowed
589 instance (?x::Int, Eq a) => Foo [a] where ...
590 then when we saw
591 (e :: (?x::Int) => t)
592 it would be unclear how to discharge all the potential uses of the ?x
593 in e. For example, a constraint Foo [Int] might come out of e, and
594 applying the instance decl would show up two uses of ?x. Trac #8912.
595 -}
596
597 checkValidTheta :: UserTypeCtxt -> ThetaType -> TcM ()
598 checkValidTheta ctxt theta
599 = addErrCtxt (checkThetaCtxt ctxt theta) (check_valid_theta ctxt theta)
600
601 -------------------------
602 check_valid_theta :: UserTypeCtxt -> [PredType] -> TcM ()
603 check_valid_theta _ []
604 = return ()
605 check_valid_theta ctxt theta
606 = do { dflags <- getDynFlags
607 ; warnTc (wopt Opt_WarnDuplicateConstraints dflags &&
608 notNull dups) (dupPredWarn dups)
609 ; traceTc "check_valid_theta" (ppr theta)
610 ; mapM_ (check_pred_ty dflags ctxt) theta }
611 where
612 (_,dups) = removeDups cmpPred theta
613
614 -------------------------
615 check_pred_ty :: DynFlags -> UserTypeCtxt -> PredType -> TcM ()
616 -- Check the validity of a predicate in a signature
617 -- Do not look through any type synonyms; any constraint kinded
618 -- type synonyms have been checked at their definition site
619 -- C.f. Trac #9838
620
621 check_pred_ty dflags ctxt pred
622 = do { checkValidMonoType pred
623 ; check_pred_help False dflags ctxt pred }
624
625 check_pred_help :: Bool -- True <=> under a type synonym
626 -> DynFlags -> UserTypeCtxt
627 -> PredType -> TcM ()
628 check_pred_help under_syn dflags ctxt pred
629 | Just pred' <- coreView pred -- Switch on under_syn when going under a
630 -- synonym (Trac #9838, yuk)
631 = check_pred_help True dflags ctxt pred'
632 | otherwise
633 = case splitTyConApp_maybe pred of
634 Just (tc, tys)
635 | isTupleTyCon tc
636 -> check_tuple_pred under_syn dflags ctxt pred tys
637 | Just cls <- tyConClass_maybe tc
638 -> check_class_pred dflags ctxt pred cls tys -- Includes Coercible
639 | tc `hasKey` eqTyConKey
640 -> check_eq_pred dflags pred tys
641 _ -> check_irred_pred under_syn dflags ctxt pred
642
643 check_eq_pred :: DynFlags -> PredType -> [TcType] -> TcM ()
644 check_eq_pred dflags pred tys
645 = -- Equational constraints are valid in all contexts if type
646 -- families are permitted
647 do { checkTc (length tys == 3)
648 (tyConArityErr eqTyCon tys)
649 ; checkTc (xopt Opt_TypeFamilies dflags || xopt Opt_GADTs dflags)
650 (eqPredTyErr pred) }
651
652 check_tuple_pred :: Bool -> DynFlags -> UserTypeCtxt -> PredType -> [PredType] -> TcM ()
653 check_tuple_pred under_syn dflags ctxt pred ts
654 = do { -- See Note [ConstraintKinds in predicates]
655 checkTc (under_syn || xopt Opt_ConstraintKinds dflags)
656 (predTupleErr pred)
657 ; mapM_ (check_pred_help under_syn dflags ctxt) ts }
658 -- This case will not normally be executed because without
659 -- -XConstraintKinds tuple types are only kind-checked as *
660
661 check_irred_pred :: Bool -> DynFlags -> UserTypeCtxt -> PredType -> TcM ()
662 check_irred_pred under_syn dflags ctxt pred
663 -- The predicate looks like (X t1 t2) or (x t1 t2) :: Constraint
664 -- where X is a type function
665 = do { -- If it looks like (x t1 t2), require ConstraintKinds
666 -- see Note [ConstraintKinds in predicates]
667 -- But (X t1 t2) is always ok because we just require ConstraintKinds
668 -- at the definition site (Trac #9838)
669 failIfTc (not under_syn && not (xopt Opt_ConstraintKinds dflags)
670 && hasTyVarHead pred)
671 (predIrredErr pred)
672
673 -- Make sure it is OK to have an irred pred in this context
674 -- See Note [Irreducible predicates in superclasses]
675 ; failIfTc (is_superclass ctxt
676 && not (xopt Opt_UndecidableInstances dflags)
677 && has_tyfun_head pred)
678 (predSuperClassErr pred) }
679 where
680 is_superclass ctxt = case ctxt of { ClassSCCtxt _ -> True; _ -> False }
681 has_tyfun_head ty
682 = case tcSplitTyConApp_maybe ty of
683 Just (tc, _) -> isTypeFamilyTyCon tc
684 Nothing -> False
685
686 {- Note [ConstraintKinds in predicates]
687 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
688 Don't check for -XConstraintKinds under a type synonym, because that
689 was done at the type synonym definition site; see Trac #9838
690 e.g. module A where
691 type C a = (Eq a, Ix a) -- Needs -XConstraintKinds
692 module B where
693 import A
694 f :: C a => a -> a -- Does *not* need -XConstraintKinds
695
696 Note [Irreducible predicates in superclasses]
697 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
698 Allowing type-family calls in class superclasses is somewhat dangerous
699 because we can write:
700
701 type family Fooish x :: * -> Constraint
702 type instance Fooish () = Foo
703 class Fooish () a => Foo a where
704
705 This will cause the constraint simplifier to loop because every time we canonicalise a
706 (Foo a) class constraint we add a (Fooish () a) constraint which will be immediately
707 solved to add+canonicalise another (Foo a) constraint. -}
708
709 -------------------------
710 check_class_pred :: DynFlags -> UserTypeCtxt -> PredType -> Class -> [TcType] -> TcM ()
711 check_class_pred dflags ctxt pred cls tys
712 | isIPClass cls
713 = do { check_arity
714 ; checkTc (okIPCtxt ctxt) (badIPPred pred) }
715
716 | otherwise
717 = do { check_arity
718 ; checkTc arg_tys_ok (predTyVarErr pred) }
719 where
720 check_arity = checkTc (classArity cls == length tys)
721 (tyConArityErr (classTyCon cls) tys)
722 flexible_contexts = xopt Opt_FlexibleContexts dflags
723 undecidable_ok = xopt Opt_UndecidableInstances dflags
724
725 arg_tys_ok = case ctxt of
726 SpecInstCtxt -> True -- {-# SPECIALISE instance Eq (T Int) #-} is fine
727 InstDeclCtxt -> checkValidClsArgs (flexible_contexts || undecidable_ok) tys
728 -- Further checks on head and theta
729 -- in checkInstTermination
730 _ -> checkValidClsArgs flexible_contexts tys
731
732 -------------------------
733 okIPCtxt :: UserTypeCtxt -> Bool
734 -- See Note [Implicit parameters in instance decls]
735 okIPCtxt (FunSigCtxt {}) = True
736 okIPCtxt (InfSigCtxt {}) = True
737 okIPCtxt ExprSigCtxt = True
738 okIPCtxt PatSigCtxt = True
739 okIPCtxt ResSigCtxt = True
740 okIPCtxt GenSigCtxt = True
741 okIPCtxt (ConArgCtxt {}) = True
742 okIPCtxt (ForSigCtxt {}) = True -- ??
743 okIPCtxt ThBrackCtxt = True
744 okIPCtxt GhciCtxt = True
745 okIPCtxt SigmaCtxt = True
746 okIPCtxt (DataTyCtxt {}) = True
747 okIPCtxt (PatSynCtxt {}) = True
748
749 okIPCtxt (ClassSCCtxt {}) = False
750 okIPCtxt (InstDeclCtxt {}) = False
751 okIPCtxt (SpecInstCtxt {}) = False
752 okIPCtxt (TySynCtxt {}) = False
753 okIPCtxt (RuleSigCtxt {}) = False
754 okIPCtxt DefaultDeclCtxt = False
755
756 badIPPred :: PredType -> SDoc
757 badIPPred pred = ptext (sLit "Illegal implicit parameter") <+> quotes (ppr pred)
758
759 {-
760 Note [Kind polymorphic type classes]
761 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
762 MultiParam check:
763
764 class C f where... -- C :: forall k. k -> Constraint
765 instance C Maybe where...
766
767 The dictionary gets type [C * Maybe] even if it's not a MultiParam
768 type class.
769
770 Flexibility check:
771
772 class C f where... -- C :: forall k. k -> Constraint
773 data D a = D a
774 instance C D where
775
776 The dictionary gets type [C * (D *)]. IA0_TODO it should be
777 generalized actually.
778 -}
779
780 checkThetaCtxt :: UserTypeCtxt -> ThetaType -> SDoc
781 checkThetaCtxt ctxt theta
782 = vcat [ptext (sLit "In the context:") <+> pprTheta theta,
783 ptext (sLit "While checking") <+> pprUserTypeCtxt ctxt ]
784
785 eqPredTyErr, predTyVarErr, predTupleErr, predIrredErr, predSuperClassErr :: PredType -> SDoc
786 eqPredTyErr pred = vcat [ ptext (sLit "Illegal equational constraint") <+> pprType pred
787 , parens (ptext (sLit "Use GADTs or TypeFamilies to permit this")) ]
788 predTyVarErr pred = vcat [ hang (ptext (sLit "Non type-variable argument"))
789 2 (ptext (sLit "in the constraint:") <+> pprType pred)
790 , parens (ptext (sLit "Use FlexibleContexts to permit this")) ]
791 predTupleErr pred = hang (ptext (sLit "Illegal tuple constraint:") <+> pprType pred)
792 2 (parens constraintKindsMsg)
793 predIrredErr pred = hang (ptext (sLit "Illegal constraint:") <+> pprType pred)
794 2 (parens constraintKindsMsg)
795 predSuperClassErr pred
796 = hang (ptext (sLit "Illegal constraint") <+> quotes (pprType pred)
797 <+> ptext (sLit "in a superclass context"))
798 2 (parens undecidableMsg)
799
800 constraintSynErr :: Type -> SDoc
801 constraintSynErr kind = hang (ptext (sLit "Illegal constraint synonym of kind:") <+> quotes (ppr kind))
802 2 (parens constraintKindsMsg)
803
804 dupPredWarn :: [[PredType]] -> SDoc
805 dupPredWarn dups = ptext (sLit "Duplicate constraint(s):") <+> pprWithCommas pprType (map head dups)
806
807 tyConArityErr :: TyCon -> [TcType] -> SDoc
808 -- For type-constructor arity errors, be careful to report
809 -- the number of /type/ arguments required and supplied,
810 -- ignoring the /kind/ arguments, which the user does not see.
811 -- (e.g. Trac #10516)
812 tyConArityErr tc tks
813 = arityErr (tyConFlavour tc) (tyConName tc)
814 tc_type_arity tc_type_args
815 where
816 tvs = tyConTyVars tc
817
818 kbs :: [Bool] -- True for a Type arg, false for a Kind arg
819 kbs = map isTypeVar tvs
820
821 -- tc_type_arity = number of *type* args expected
822 -- tc_type_args = number of *type* args encountered
823 tc_type_arity = count id kbs
824 tc_type_args = count (id . fst) (kbs `zip` tks)
825
826 arityErr :: Outputable a => String -> a -> Int -> Int -> SDoc
827 arityErr what name n m
828 = hsep [ ptext (sLit "The") <+> text what, quotes (ppr name), ptext (sLit "should have"),
829 n_arguments <> comma, text "but has been given",
830 if m==0 then text "none" else int m]
831 where
832 n_arguments | n == 0 = ptext (sLit "no arguments")
833 | n == 1 = ptext (sLit "1 argument")
834 | True = hsep [int n, ptext (sLit "arguments")]
835
836 {-
837 ************************************************************************
838 * *
839 \subsection{Checking for a decent instance head type}
840 * *
841 ************************************************************************
842
843 @checkValidInstHead@ checks the type {\em and} its syntactic constraints:
844 it must normally look like: @instance Foo (Tycon a b c ...) ...@
845
846 The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
847 flag is on, or (2)~the instance is imported (they must have been
848 compiled elsewhere). In these cases, we let them go through anyway.
849
850 We can also have instances for functions: @instance Foo (a -> b) ...@.
851 -}
852
853 checkValidInstHead :: UserTypeCtxt -> Class -> [Type] -> TcM ()
854 checkValidInstHead ctxt clas cls_args
855 = do { dflags <- getDynFlags
856
857 ; checkTc (clas `notElem` abstractClasses)
858 (instTypeErr clas cls_args abstract_class_msg)
859
860 -- Check language restrictions;
861 -- but not for SPECIALISE isntance pragmas
862 ; let ty_args = dropWhile isKind cls_args
863 ; unless spec_inst_prag $
864 do { checkTc (xopt Opt_TypeSynonymInstances dflags ||
865 all tcInstHeadTyNotSynonym ty_args)
866 (instTypeErr clas cls_args head_type_synonym_msg)
867 ; checkTc (xopt Opt_FlexibleInstances dflags ||
868 all tcInstHeadTyAppAllTyVars ty_args)
869 (instTypeErr clas cls_args head_type_args_tyvars_msg)
870 ; checkTc (xopt Opt_MultiParamTypeClasses dflags ||
871 length ty_args == 1 || -- Only count type arguments
872 (xopt Opt_NullaryTypeClasses dflags &&
873 null ty_args))
874 (instTypeErr clas cls_args head_one_type_msg) }
875
876 -- May not contain type family applications
877 ; mapM_ checkTyFamFreeness ty_args
878
879 ; mapM_ checkValidMonoType ty_args
880 -- For now, I only allow tau-types (not polytypes) in
881 -- the head of an instance decl.
882 -- E.g. instance C (forall a. a->a) is rejected
883 -- One could imagine generalising that, but I'm not sure
884 -- what all the consequences might be
885 }
886
887 where
888 spec_inst_prag = case ctxt of { SpecInstCtxt -> True; _ -> False }
889
890 head_type_synonym_msg = parens (
891 text "All instance types must be of the form (T t1 ... tn)" $$
892 text "where T is not a synonym." $$
893 text "Use TypeSynonymInstances if you want to disable this.")
894
895 head_type_args_tyvars_msg = parens (vcat [
896 text "All instance types must be of the form (T a1 ... an)",
897 text "where a1 ... an are *distinct type variables*,",
898 text "and each type variable appears at most once in the instance head.",
899 text "Use FlexibleInstances if you want to disable this."])
900
901 head_one_type_msg = parens (
902 text "Only one type can be given in an instance head." $$
903 text "Use MultiParamTypeClasses if you want to allow more, or zero.")
904
905 abstract_class_msg =
906 text "The class is abstract, manual instances are not permitted."
907
908 abstractClasses :: [ Class ]
909 abstractClasses = [ coercibleClass ] -- See Note [Coercible Instances]
910
911 instTypeErr :: Class -> [Type] -> SDoc -> SDoc
912 instTypeErr cls tys msg
913 = hang (hang (ptext (sLit "Illegal instance declaration for"))
914 2 (quotes (pprClassPred cls tys)))
915 2 msg
916
917 {- Note [Valid 'deriving' predicate]
918 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
919 validDerivPred checks for OK 'deriving' context. See Note [Exotic
920 derived instance contexts] in TcDeriv. However the predicate is
921 here because it uses sizeTypes, fvTypes.
922
923 It checks for three things
924
925 * No repeated variables (hasNoDups fvs)
926
927 * No type constructors. This is done by comparing
928 sizeTypes tys == length (fvTypes tys)
929 sizeTypes counts variables and constructors; fvTypes returns variables.
930 So if they are the same, there must be no constructors. But there
931 might be applications thus (f (g x)).
932
933 * Also check for a bizarre corner case, when the derived instance decl
934 would look like
935 instance C a b => D (T a) where ...
936 Note that 'b' isn't a parameter of T. This gives rise to all sorts of
937 problems; in particular, it's hard to compare solutions for equality
938 when finding the fixpoint, and that means the inferContext loop does
939 not converge. See Trac #5287.
940 -}
941
942 validDerivPred :: TyVarSet -> PredType -> Bool
943 -- See Note [Valid 'deriving' predicate]
944 validDerivPred tv_set pred
945 = case classifyPredType pred of
946 ClassPred _ tys -> check_tys tys
947 EqPred {} -> False -- reject equality constraints
948 _ -> True -- Non-class predicates are ok
949 where
950 check_tys tys = hasNoDups fvs
951 && sizeTypes tys == fromIntegral (length fvs)
952 && all (`elemVarSet` tv_set) fvs
953 where
954 fvs = fvTypes tys
955
956 {-
957 ************************************************************************
958 * *
959 \subsection{Checking instance for termination}
960 * *
961 ************************************************************************
962 -}
963
964 checkValidInstance :: UserTypeCtxt -> LHsType Name -> Type
965 -> TcM ([TyVar], ThetaType, Class, [Type])
966 checkValidInstance ctxt hs_type ty
967 | Just (clas,inst_tys) <- getClassPredTys_maybe tau
968 , inst_tys `lengthIs` classArity clas
969 = do { setSrcSpan head_loc (checkValidInstHead ctxt clas inst_tys)
970 ; checkValidTheta ctxt theta
971
972 -- The Termination and Coverate Conditions
973 -- Check that instance inference will terminate (if we care)
974 -- For Haskell 98 this will already have been done by checkValidTheta,
975 -- but as we may be using other extensions we need to check.
976 --
977 -- Note that the Termination Condition is *more conservative* than
978 -- the checkAmbiguity test we do on other type signatures
979 -- e.g. Bar a => Bar Int is ambiguous, but it also fails
980 -- the termination condition, because 'a' appears more often
981 -- in the constraint than in the head
982 ; undecidable_ok <- xoptM Opt_UndecidableInstances
983 ; if undecidable_ok
984 then checkAmbiguity ctxt ty
985 else checkInstTermination inst_tys theta
986
987 ; case (checkInstCoverage undecidable_ok clas theta inst_tys) of
988 IsValid -> return () -- Check succeeded
989 NotValid msg -> addErrTc (instTypeErr clas inst_tys msg)
990
991 ; return (tvs, theta, clas, inst_tys) }
992
993 | otherwise
994 = failWithTc (ptext (sLit "Malformed instance head:") <+> ppr tau)
995 where
996 (tvs, theta, tau) = tcSplitSigmaTy ty
997
998 -- The location of the "head" of the instance
999 head_loc = case hs_type of
1000 L _ (HsForAllTy _ _ _ _ (L loc _)) -> loc
1001 L loc _ -> loc
1002
1003 {-
1004 Note [Paterson conditions]
1005 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1006 Termination test: the so-called "Paterson conditions" (see Section 5 of
1007 "Understanding functional dependencies via Constraint Handling Rules,
1008 JFP Jan 2007).
1009
1010 We check that each assertion in the context satisfies:
1011 (1) no variable has more occurrences in the assertion than in the head, and
1012 (2) the assertion has fewer constructors and variables (taken together
1013 and counting repetitions) than the head.
1014 This is only needed with -fglasgow-exts, as Haskell 98 restrictions
1015 (which have already been checked) guarantee termination.
1016
1017 The underlying idea is that
1018
1019 for any ground substitution, each assertion in the
1020 context has fewer type constructors than the head.
1021 -}
1022
1023 checkInstTermination :: [TcType] -> ThetaType -> TcM ()
1024 -- See Note [Paterson conditions]
1025 checkInstTermination tys theta
1026 = check_preds theta
1027 where
1028 head_fvs = fvTypes tys
1029 head_size = sizeTypes tys
1030
1031 check_preds :: [PredType] -> TcM ()
1032 check_preds preds = mapM_ check preds
1033
1034 check :: PredType -> TcM ()
1035 check pred
1036 = case classifyPredType pred of
1037 EqPred {} -> return () -- See Trac #4200.
1038 IrredPred {} -> check2 pred (sizeType pred)
1039 ClassPred cls tys
1040 | isIPClass cls
1041 -> return () -- You can't get to class predicates from implicit params
1042
1043 | isCTupleClass cls -- Look inside tuple predicates; Trac #8359
1044 -> check_preds tys
1045
1046 | otherwise
1047 -> check2 pred (sizeTypes tys) -- Other ClassPreds
1048
1049 check2 pred pred_size
1050 | not (null bad_tvs) = addErrTc (noMoreMsg bad_tvs what)
1051 | pred_size >= head_size = addErrTc (smallerMsg what)
1052 | otherwise = return ()
1053 where
1054 what = ptext (sLit "constraint") <+> quotes (ppr pred)
1055 bad_tvs = fvType pred \\ head_fvs
1056
1057 smallerMsg :: SDoc -> SDoc
1058 smallerMsg what
1059 = vcat [ hang (ptext (sLit "The") <+> what)
1060 2 (ptext (sLit "is no smaller than the instance head"))
1061 , parens undecidableMsg ]
1062
1063 noMoreMsg :: [TcTyVar] -> SDoc -> SDoc
1064 noMoreMsg tvs what
1065 = vcat [ hang (ptext (sLit "Variable") <> plural tvs <+> quotes (pprWithCommas ppr tvs)
1066 <+> occurs <+> ptext (sLit "more often"))
1067 2 (sep [ ptext (sLit "in the") <+> what
1068 , ptext (sLit "than in the instance head") ])
1069 , parens undecidableMsg ]
1070 where
1071 occurs = if isSingleton tvs then ptext (sLit "occurs")
1072 else ptext (sLit "occur")
1073
1074 undecidableMsg, constraintKindsMsg :: SDoc
1075 undecidableMsg = ptext (sLit "Use UndecidableInstances to permit this")
1076 constraintKindsMsg = ptext (sLit "Use ConstraintKinds to permit this")
1077
1078 {-
1079 Note [Associated type instances]
1080 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1081 We allow this:
1082 class C a where
1083 type T x a
1084 instance C Int where
1085 type T (S y) Int = y
1086 type T Z Int = Char
1087
1088 Note that
1089 a) The variable 'x' is not bound by the class decl
1090 b) 'x' is instantiated to a non-type-variable in the instance
1091 c) There are several type instance decls for T in the instance
1092
1093 All this is fine. Of course, you can't give any *more* instances
1094 for (T ty Int) elsewhere, because it's an *associated* type.
1095
1096 Note [Checking consistent instantiation]
1097 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1098 class C a b where
1099 type T a x b
1100
1101 instance C [p] Int
1102 type T [p] y Int = (p,y,y) -- Induces the family instance TyCon
1103 -- type TR p y = (p,y,y)
1104
1105 So we
1106 * Form the mini-envt from the class type variables a,b
1107 to the instance decl types [p],Int: [a->[p], b->Int]
1108
1109 * Look at the tyvars a,x,b of the type family constructor T
1110 (it shares tyvars with the class C)
1111
1112 * Apply the mini-evnt to them, and check that the result is
1113 consistent with the instance types [p] y Int
1114
1115 We do *not* assume (at this point) the the bound variables of
1116 the associated type instance decl are the same as for the parent
1117 instance decl. So, for example,
1118
1119 instance C [p] Int
1120 type T [q] y Int = ...
1121
1122 would work equally well. Reason: making the *kind* variables line
1123 up is much harder. Example (Trac #7282):
1124 class Foo (xs :: [k]) where
1125 type Bar xs :: *
1126
1127 instance Foo '[] where
1128 type Bar '[] = Int
1129 Here the instance decl really looks like
1130 instance Foo k ('[] k) where
1131 type Bar k ('[] k) = Int
1132 but the k's are not scoped, and hence won't match Uniques.
1133
1134 So instead we just match structure, with tcMatchTyX, and check
1135 that distinct type variables match 1-1 with distinct type variables.
1136
1137 HOWEVER, we *still* make the instance type variables scope over the
1138 type instances, to pick up non-obvious kinds. Eg
1139 class Foo (a :: k) where
1140 type F a
1141 instance Foo (b :: k -> k) where
1142 type F b = Int
1143 Here the instance is kind-indexed and really looks like
1144 type F (k->k) (b::k->k) = Int
1145 But if the 'b' didn't scope, we would make F's instance too
1146 poly-kinded.
1147 -}
1148
1149 -- | Extra information needed when type-checking associated types. The 'Class' is
1150 -- the enclosing class, and the @VarEnv Type@ maps class variables to their
1151 -- instance types.
1152 type ClsInfo = (Class, VarEnv Type)
1153
1154 checkConsistentFamInst
1155 :: Maybe ClsInfo
1156 -> TyCon -- ^ Family tycon
1157 -> [TyVar] -- ^ Type variables of the family instance
1158 -> [Type] -- ^ Type patterns from instance
1159 -> TcM ()
1160 -- See Note [Checking consistent instantiation]
1161
1162 checkConsistentFamInst Nothing _ _ _ = return ()
1163 checkConsistentFamInst (Just (clas, mini_env)) fam_tc at_tvs at_tys
1164 = do { -- Check that the associated type indeed comes from this class
1165 checkTc (Just clas == tyConAssoc_maybe fam_tc)
1166 (badATErr (className clas) (tyConName fam_tc))
1167
1168 -- See Note [Checking consistent instantiation] in TcTyClsDecls
1169 -- Check right to left, so that we spot type variable
1170 -- inconsistencies before (more confusing) kind variables
1171 ; discardResult $ foldrM check_arg emptyTvSubst $
1172 tyConTyVars fam_tc `zip` at_tys }
1173 where
1174 at_tv_set = mkVarSet at_tvs
1175
1176 check_arg :: (TyVar, Type) -> TvSubst -> TcM TvSubst
1177 check_arg (fam_tc_tv, at_ty) subst
1178 | Just inst_ty <- lookupVarEnv mini_env fam_tc_tv
1179 = case tcMatchTyX at_tv_set subst at_ty inst_ty of
1180 Just subst | all_distinct subst -> return subst
1181 _ -> failWithTc $ wrongATArgErr at_ty inst_ty
1182 -- No need to instantiate here, because the axiom
1183 -- uses the same type variables as the assocated class
1184 | otherwise
1185 = return subst -- Allow non-type-variable instantiation
1186 -- See Note [Associated type instances]
1187
1188 all_distinct :: TvSubst -> Bool
1189 -- True if all the variables mapped the substitution
1190 -- map to *distinct* type *variables*
1191 all_distinct subst = go [] at_tvs
1192 where
1193 go _ [] = True
1194 go acc (tv:tvs) = case lookupTyVar subst tv of
1195 Nothing -> go acc tvs
1196 Just ty | Just tv' <- tcGetTyVar_maybe ty
1197 , tv' `notElem` acc
1198 -> go (tv' : acc) tvs
1199 _other -> False
1200
1201 badATErr :: Name -> Name -> SDoc
1202 badATErr clas op
1203 = hsep [ptext (sLit "Class"), quotes (ppr clas),
1204 ptext (sLit "does not have an associated type"), quotes (ppr op)]
1205
1206 wrongATArgErr :: Type -> Type -> SDoc
1207 wrongATArgErr ty instTy =
1208 sep [ ptext (sLit "Type indexes must match class instance head")
1209 , ptext (sLit "Found") <+> quotes (ppr ty)
1210 <+> ptext (sLit "but expected") <+> quotes (ppr instTy)
1211 ]
1212
1213 {-
1214 ************************************************************************
1215 * *
1216 Checking type instance well-formedness and termination
1217 * *
1218 ************************************************************************
1219 -}
1220
1221 checkValidCoAxiom :: CoAxiom Branched -> TcM ()
1222 checkValidCoAxiom (CoAxiom { co_ax_tc = fam_tc, co_ax_branches = branches })
1223 = do { _ <- brListMapM (checkValidCoAxBranch Nothing fam_tc) branches
1224 ; brListFoldlM_ check_branch_compat [] branches }
1225 where
1226 injectivity = familyTyConInjectivityInfo fam_tc
1227
1228 check_branch_compat :: [CoAxBranch] -- previous branches in reverse order
1229 -> CoAxBranch -- current branch
1230 -> TcM [CoAxBranch]-- current branch : previous branches
1231 -- Check for
1232 -- (a) this banch is dominated by previous ones
1233 -- (b) failure of injectivity
1234 check_branch_compat prev_branches cur_branch
1235 | cur_branch `isDominatedBy` prev_branches
1236 = do { addWarnAt (coAxBranchSpan cur_branch) $
1237 inaccessibleCoAxBranch fam_tc cur_branch
1238 ; return prev_branches }
1239 | otherwise
1240 = do { check_injectivity prev_branches cur_branch
1241 ; return (cur_branch : prev_branches) }
1242
1243 -- Injectivity check: check whether a new (CoAxBranch) can extend
1244 -- already checked equations without violating injectivity
1245 -- annotation supplied by the user.
1246 -- See Note [Verifying injectivity annotation] in FamInstEnv
1247 check_injectivity prev_branches cur_branch
1248 | Injective inj <- injectivity
1249 = do { let conflicts =
1250 fst $ foldl (gather_conflicts inj prev_branches cur_branch)
1251 ([], 0) prev_branches
1252 ; mapM_ (\(err, span) -> setSrcSpan span $ addErr err)
1253 (makeInjectivityErrors fam_tc cur_branch inj conflicts) }
1254 | otherwise
1255 = return ()
1256
1257 gather_conflicts inj prev_branches cur_branch (acc, n) branch
1258 -- n is 0-based index of branch in prev_branches
1259 = case injectiveBranches inj cur_branch branch of
1260 InjectivityUnified ax1 ax2
1261 | ax1 `isDominatedBy` (replace_br prev_branches n ax2)
1262 -> (acc, n + 1)
1263 | otherwise
1264 -> (branch : acc, n + 1)
1265 InjectivityAccepted -> (acc, n + 1)
1266
1267 -- Replace n-th element in the list. Assumes 0-based indexing.
1268 replace_br :: [CoAxBranch] -> Int -> CoAxBranch -> [CoAxBranch]
1269 replace_br brs n br = take n brs ++ [br] ++ drop (n+1) brs
1270
1271
1272 -- Check that a "type instance" is well-formed (which includes decidability
1273 -- unless -XUndecidableInstances is given).
1274 --
1275 checkValidCoAxBranch :: Maybe ClsInfo
1276 -> TyCon -> CoAxBranch -> TcM ()
1277 checkValidCoAxBranch mb_clsinfo fam_tc
1278 (CoAxBranch { cab_tvs = tvs, cab_lhs = typats
1279 , cab_rhs = rhs, cab_loc = loc })
1280 = checkValidTyFamEqn mb_clsinfo fam_tc tvs typats rhs loc
1281
1282 -- | Do validity checks on a type family equation, including consistency
1283 -- with any enclosing class instance head, termination, and lack of
1284 -- polytypes.
1285 checkValidTyFamEqn :: Maybe ClsInfo
1286 -> TyCon -- ^ of the type family
1287 -> [TyVar] -- ^ bound tyvars in the equation
1288 -> [Type] -- ^ type patterns
1289 -> Type -- ^ rhs
1290 -> SrcSpan
1291 -> TcM ()
1292 checkValidTyFamEqn mb_clsinfo fam_tc tvs typats rhs loc
1293 = setSrcSpan loc $
1294 do { checkValidFamPats fam_tc tvs typats
1295
1296 -- The argument patterns, and RHS, are all boxed tau types
1297 -- E.g Reject type family F (a :: k1) :: k2
1298 -- type instance F (forall a. a->a) = ...
1299 -- type instance F Int# = ...
1300 -- type instance F Int = forall a. a->a
1301 -- type instance F Int = Int#
1302 -- See Trac #9357
1303 ; mapM_ checkValidMonoType typats
1304 ; checkValidMonoType rhs
1305
1306 -- We have a decidable instance unless otherwise permitted
1307 ; undecidable_ok <- xoptM Opt_UndecidableInstances
1308 ; unless undecidable_ok $
1309 mapM_ addErrTc (checkFamInstRhs typats (tcTyFamInsts rhs))
1310
1311 -- Check that type patterns match the class instance head
1312 ; checkConsistentFamInst mb_clsinfo fam_tc tvs typats }
1313
1314 -- Make sure that each type family application is
1315 -- (1) strictly smaller than the lhs,
1316 -- (2) mentions no type variable more often than the lhs, and
1317 -- (3) does not contain any further type family instances.
1318 --
1319 checkFamInstRhs :: [Type] -- lhs
1320 -> [(TyCon, [Type])] -- type family instances
1321 -> [MsgDoc]
1322 checkFamInstRhs lhsTys famInsts
1323 = mapMaybe check famInsts
1324 where
1325 size = sizeTypes lhsTys
1326 fvs = fvTypes lhsTys
1327 check (tc, tys)
1328 | not (all isTyFamFree tys) = Just (nestedMsg what)
1329 | not (null bad_tvs) = Just (noMoreMsg bad_tvs what)
1330 | size <= sizeTypes tys = Just (smallerMsg what)
1331 | otherwise = Nothing
1332 where
1333 what = ptext (sLit "type family application") <+> quotes (pprType (TyConApp tc tys))
1334 bad_tvs = fvTypes tys \\ fvs
1335
1336 checkValidFamPats :: TyCon -> [TyVar] -> [Type] -> TcM ()
1337 -- Patterns in a 'type instance' or 'data instance' decl should
1338 -- a) contain no type family applications
1339 -- (vanilla synonyms are fine, though)
1340 -- b) properly bind all their free type variables
1341 -- e.g. we disallow (Trac #7536)
1342 -- type T a = Int
1343 -- type instance F (T a) = a
1344 -- c) Have the right number of patterns
1345 checkValidFamPats fam_tc tvs ty_pats
1346 = ASSERT2( length ty_pats == tyConArity fam_tc
1347 , ppr ty_pats $$ ppr fam_tc $$ ppr (tyConArity fam_tc) )
1348 -- A family instance must have exactly the same number of type
1349 -- parameters as the family declaration. You can't write
1350 -- type family F a :: * -> *
1351 -- type instance F Int y = y
1352 -- because then the type (F Int) would be like (\y.y)
1353 -- But this is checked at the time the axiom is created
1354 do { mapM_ checkTyFamFreeness ty_pats
1355 ; let unbound_tvs = filterOut (`elemVarSet` exactTyVarsOfTypes ty_pats) tvs
1356 ; checkTc (null unbound_tvs) (famPatErr fam_tc unbound_tvs ty_pats) }
1357
1358 -- Ensure that no type family instances occur in a type.
1359 checkTyFamFreeness :: Type -> TcM ()
1360 checkTyFamFreeness ty
1361 = checkTc (isTyFamFree ty) $
1362 tyFamInstIllegalErr ty
1363
1364 -- Check that a type does not contain any type family applications.
1365 --
1366 isTyFamFree :: Type -> Bool
1367 isTyFamFree = null . tcTyFamInsts
1368
1369 -- Error messages
1370
1371 inaccessibleCoAxBranch :: TyCon -> CoAxBranch -> SDoc
1372 inaccessibleCoAxBranch fam_tc (CoAxBranch { cab_tvs = tvs
1373 , cab_lhs = lhs
1374 , cab_rhs = rhs })
1375 = ptext (sLit "Type family instance equation is overlapped:") $$
1376 hang (pprUserForAll tvs)
1377 2 (hang (pprTypeApp fam_tc lhs) 2 (equals <+> (ppr rhs)))
1378
1379 tyFamInstIllegalErr :: Type -> SDoc
1380 tyFamInstIllegalErr ty
1381 = hang (ptext (sLit "Illegal type synonym family application in instance") <>
1382 colon) 2 $
1383 ppr ty
1384
1385 nestedMsg :: SDoc -> SDoc
1386 nestedMsg what
1387 = sep [ ptext (sLit "Illegal nested") <+> what
1388 , parens undecidableMsg ]
1389
1390 famPatErr :: TyCon -> [TyVar] -> [Type] -> SDoc
1391 famPatErr fam_tc tvs pats
1392 = hang (ptext (sLit "Family instance purports to bind type variable") <> plural tvs
1393 <+> pprQuotedList tvs)
1394 2 (hang (ptext (sLit "but the real LHS (expanding synonyms) is:"))
1395 2 (pprTypeApp fam_tc (map expandTypeSynonyms pats) <+> ptext (sLit "= ...")))
1396
1397 {-
1398 ************************************************************************
1399 * *
1400 \subsection{Auxiliary functions}
1401 * *
1402 ************************************************************************
1403 -}
1404
1405 -- Free variables of a type, retaining repetitions, and expanding synonyms
1406 -- Ignore kinds altogether: rightly or wrongly, we only check for
1407 -- excessive occurrences of *type* variables.
1408 -- e.g. type instance Demote {T k} a = T (Demote {k} (Any {k}))
1409 --
1410 -- c.f. sizeType, which is often called side by side with fvType
1411 fvType, fv_type :: Type -> [TyVar]
1412 fvType ty | isKind ty = []
1413 | otherwise = fv_type ty
1414
1415 fv_type ty | Just exp_ty <- tcView ty = fv_type exp_ty
1416 fv_type (TyVarTy tv) = [tv]
1417 fv_type (TyConApp _ tys) = fvTypes tys
1418 fv_type (LitTy {}) = []
1419 fv_type (FunTy arg res) = fv_type arg ++ fv_type res
1420 fv_type (AppTy fun arg) = fv_type fun ++ fv_type arg
1421 fv_type (ForAllTy tyvar ty) = filter (/= tyvar) (fv_type ty)
1422
1423 fvTypes :: [Type] -> [TyVar]
1424 fvTypes tys = concat (map fvType tys)