Replace calls to `ptext . sLit` with `text`
[ghc.git] / compiler / typecheck / TcValidity.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 -}
5
6 {-# LANGUAGE CPP, TupleSections, ViewPatterns #-}
7
8 module TcValidity (
9 Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType,
10 ContextKind(..), expectedKindInCtxt,
11 checkValidTheta, checkValidFamPats,
12 checkValidInstance, validDerivPred,
13 checkInstTermination,
14 ClsInfo, checkValidCoAxiom, checkValidCoAxBranch,
15 checkValidTyFamEqn,
16 checkConsistentFamInst,
17 arityErr, badATErr,
18 checkValidTelescope, checkZonkValidTelescope, checkValidInferredKinds
19 ) where
20
21 #include "HsVersions.h"
22
23 -- friends:
24 import TcUnify ( tcSubType_NC )
25 import TcSimplify ( simplifyAmbiguityCheck )
26 import TyCoRep
27 import TcType hiding ( sizeType, sizeTypes )
28 import TcMType
29 import PrelNames
30 import Type
31 import Coercion
32 import Unify( tcMatchTyX )
33 import Kind
34 import CoAxiom
35 import Class
36 import TyCon
37
38 -- others:
39 import HsSyn -- HsType
40 import TcRnMonad -- TcType, amongst others
41 import FunDeps
42 import FamInstEnv ( isDominatedBy, injectiveBranches,
43 InjectivityCheckResult(..) )
44 import FamInst ( makeInjectivityErrors )
45 import Name
46 import VarEnv
47 import VarSet
48 import ErrUtils
49 import DynFlags
50 import Util
51 import ListSetOps
52 import SrcLoc
53 import Outputable
54 import BasicTypes
55 import Module
56 import qualified GHC.LanguageExtensions as LangExt
57
58 import Control.Monad
59 import Data.Maybe
60 import Data.List ( (\\) )
61
62 {-
63 ************************************************************************
64 * *
65 Checking for ambiguity
66 * *
67 ************************************************************************
68
69 Note [The ambiguity check for type signatures]
70 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
71 checkAmbiguity is a check on *user-supplied type signatures*. It is
72 *purely* there to report functions that cannot possibly be called. So for
73 example we want to reject:
74 f :: C a => Int
75 The idea is there can be no legal calls to 'f' because every call will
76 give rise to an ambiguous constraint. We could soundly omit the
77 ambiguity check on type signatures entirely, at the expense of
78 delaying ambiguity errors to call sites. Indeed, the flag
79 -XAllowAmbiguousTypes switches off the ambiguity check.
80
81 What about things like this:
82 class D a b | a -> b where ..
83 h :: D Int b => Int
84 The Int may well fix 'b' at the call site, so that signature should
85 not be rejected. Moreover, using *visible* fundeps is too
86 conservative. Consider
87 class X a b where ...
88 class D a b | a -> b where ...
89 instance D a b => X [a] b where...
90 h :: X a b => a -> a
91 Here h's type looks ambiguous in 'b', but here's a legal call:
92 ...(h [True])...
93 That gives rise to a (X [Bool] beta) constraint, and using the
94 instance means we need (D Bool beta) and that fixes 'beta' via D's
95 fundep!
96
97 Behind all these special cases there is a simple guiding principle.
98 Consider
99
100 f :: <type>
101 f = ...blah...
102
103 g :: <type>
104 g = f
105
106 You would think that the definition of g would surely typecheck!
107 After all f has exactly the same type, and g=f. But in fact f's type
108 is instantiated and the instantiated constraints are solved against
109 the originals, so in the case an ambiguous type it won't work.
110 Consider our earlier example f :: C a => Int. Then in g's definition,
111 we'll instantiate to (C alpha) and try to deduce (C alpha) from (C a),
112 and fail.
113
114 So in fact we use this as our *definition* of ambiguity. We use a
115 very similar test for *inferred* types, to ensure that they are
116 unambiguous. See Note [Impedence matching] in TcBinds.
117
118 This test is very conveniently implemented by calling
119 tcSubType <type> <type>
120 This neatly takes account of the functional dependecy stuff above,
121 and implicit parameter (see Note [Implicit parameters and ambiguity]).
122 And this is what checkAmbiguity does.
123
124 What about this, though?
125 g :: C [a] => Int
126 Is every call to 'g' ambiguous? After all, we might have
127 intance C [a] where ...
128 at the call site. So maybe that type is ok! Indeed even f's
129 quintessentially ambiguous type might, just possibly be callable:
130 with -XFlexibleInstances we could have
131 instance C a where ...
132 and now a call could be legal after all! Well, we'll reject this
133 unless the instance is available *here*.
134
135 Note [When to call checkAmbiguity]
136 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
137 We call checkAmbiguity
138 (a) on user-specified type signatures
139 (b) in checkValidType
140
141 Conncerning (b), you might wonder about nested foralls. What about
142 f :: forall b. (forall a. Eq a => b) -> b
143 The nested forall is ambiguous. Originally we called checkAmbiguity
144 in the forall case of check_type, but that had two bad consequences:
145 * We got two error messages about (Eq b) in a nested forall like this:
146 g :: forall a. Eq a => forall b. Eq b => a -> a
147 * If we try to check for ambiguity of an nested forall like
148 (forall a. Eq a => b), the implication constraint doesn't bind
149 all the skolems, which results in "No skolem info" in error
150 messages (see Trac #10432).
151
152 To avoid this, we call checkAmbiguity once, at the top, in checkValidType.
153 (I'm still a bit worried about unbound skolems when the type mentions
154 in-scope type variables.)
155
156 In fact, because of the co/contra-variance implemented in tcSubType,
157 this *does* catch function f above. too.
158
159 Concerning (a) the ambiguity check is only used for *user* types, not
160 for types coming from inteface files. The latter can legitimately
161 have ambiguous types. Example
162
163 class S a where s :: a -> (Int,Int)
164 instance S Char where s _ = (1,1)
165 f:: S a => [a] -> Int -> (Int,Int)
166 f (_::[a]) x = (a*x,b)
167 where (a,b) = s (undefined::a)
168
169 Here the worker for f gets the type
170 fw :: forall a. S a => Int -> (# Int, Int #)
171
172
173 Note [Implicit parameters and ambiguity]
174 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
175 Only a *class* predicate can give rise to ambiguity
176 An *implicit parameter* cannot. For example:
177 foo :: (?x :: [a]) => Int
178 foo = length ?x
179 is fine. The call site will supply a particular 'x'
180
181 Furthermore, the type variables fixed by an implicit parameter
182 propagate to the others. E.g.
183 foo :: (Show a, ?x::[a]) => Int
184 foo = show (?x++?x)
185 The type of foo looks ambiguous. But it isn't, because at a call site
186 we might have
187 let ?x = 5::Int in foo
188 and all is well. In effect, implicit parameters are, well, parameters,
189 so we can take their type variables into account as part of the
190 "tau-tvs" stuff. This is done in the function 'FunDeps.grow'.
191 -}
192
193 checkAmbiguity :: UserTypeCtxt -> Type -> TcM ()
194 checkAmbiguity ctxt ty
195 | wantAmbiguityCheck ctxt
196 = do { traceTc "Ambiguity check for" (ppr ty)
197 -- Solve the constraints eagerly because an ambiguous type
198 -- can cause a cascade of further errors. Since the free
199 -- tyvars are skolemised, we can safely use tcSimplifyTop
200 ; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes
201 ; (_wrap, wanted) <- addErrCtxt (mk_msg allow_ambiguous) $
202 captureConstraints $
203 tcSubType_NC ctxt ty ty
204 ; simplifyAmbiguityCheck ty wanted
205
206 ; traceTc "Done ambiguity check for" (ppr ty) }
207
208 | otherwise
209 = return ()
210 where
211 mk_msg allow_ambiguous
212 = vcat [ text "In the ambiguity check for" <+> what
213 , ppUnless allow_ambiguous ambig_msg ]
214 ambig_msg = text "To defer the ambiguity check to use sites, enable AllowAmbiguousTypes"
215 what | Just n <- isSigMaybe ctxt = quotes (ppr n)
216 | otherwise = pprUserTypeCtxt ctxt
217
218 wantAmbiguityCheck :: UserTypeCtxt -> Bool
219 wantAmbiguityCheck ctxt
220 = case ctxt of
221 GhciCtxt -> False -- Allow ambiguous types in GHCi's :kind command
222 -- E.g. type family T a :: * -- T :: forall k. k -> *
223 -- Then :k T should work in GHCi, not complain that
224 -- (T k) is ambiguous!
225 _ -> True
226
227
228 checkUserTypeError :: Type -> TcM ()
229 -- Check to see if the type signature mentions "TypeError blah"
230 -- anywhere in it, and fail if so.
231 --
232 -- Very unsatisfactorily (Trac #11144) we need to tidy the type
233 -- because it may have come from an /inferred/ signature, not a
234 -- user-supplied one. This is really only a half-baked fix;
235 -- the other errors in checkValidType don't do tidying, and so
236 -- may give bad error messages when given an inferred type.
237 checkUserTypeError = check
238 where
239 check ty
240 | Just msg <- userTypeError_maybe ty = fail_with msg
241 | Just (_,ts) <- splitTyConApp_maybe ty = mapM_ check ts
242 | Just (t1,t2) <- splitAppTy_maybe ty = check t1 >> check t2
243 | Just (_,t1) <- splitForAllTy_maybe ty = check t1
244 | otherwise = return ()
245
246 fail_with msg = do { env0 <- tcInitTidyEnv
247 ; let (env1, tidy_msg) = tidyOpenType env0 msg
248 ; failWithTcM (env1, pprUserTypeErrorTy tidy_msg) }
249
250
251 {-
252 ************************************************************************
253 * *
254 Checking validity of a user-defined type
255 * *
256 ************************************************************************
257
258 When dealing with a user-written type, we first translate it from an HsType
259 to a Type, performing kind checking, and then check various things that should
260 be true about it. We don't want to perform these checks at the same time
261 as the initial translation because (a) they are unnecessary for interface-file
262 types and (b) when checking a mutually recursive group of type and class decls,
263 we can't "look" at the tycons/classes yet. Also, the checks are rather
264 diverse, and used to really mess up the other code.
265
266 One thing we check for is 'rank'.
267
268 Rank 0: monotypes (no foralls)
269 Rank 1: foralls at the front only, Rank 0 inside
270 Rank 2: foralls at the front, Rank 1 on left of fn arrow,
271
272 basic ::= tyvar | T basic ... basic
273
274 r2 ::= forall tvs. cxt => r2a
275 r2a ::= r1 -> r2a | basic
276 r1 ::= forall tvs. cxt => r0
277 r0 ::= r0 -> r0 | basic
278
279 Another thing is to check that type synonyms are saturated.
280 This might not necessarily show up in kind checking.
281 type A i = i
282 data T k = MkT (k Int)
283 f :: T A -- BAD!
284 -}
285
286 checkValidType :: UserTypeCtxt -> Type -> TcM ()
287 -- Checks that a user-written type is valid for the given context
288 -- Assumes arguemt is fully zonked
289 -- Not used for instance decls; checkValidInstance instead
290 checkValidType ctxt ty
291 = do { traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (typeKind ty))
292 ; rankn_flag <- xoptM LangExt.RankNTypes
293 ; impred_flag <- xoptM LangExt.ImpredicativeTypes
294 ; let gen_rank :: Rank -> Rank
295 gen_rank r | rankn_flag = ArbitraryRank
296 | otherwise = r
297
298 rank1 = gen_rank r1
299 rank0 = gen_rank r0
300
301 r0 = rankZeroMonoType
302 r1 = LimitedRank True r0
303
304 rank
305 = case ctxt of
306 DefaultDeclCtxt-> MustBeMonoType
307 ResSigCtxt -> MustBeMonoType
308 PatSigCtxt -> rank0
309 RuleSigCtxt _ -> rank1
310 TySynCtxt _ -> rank0
311
312 ExprSigCtxt -> rank1
313 TypeAppCtxt | impred_flag -> ArbitraryRank
314 | otherwise -> tyConArgMonoType
315 -- Normally, ImpredicativeTypes is handled in check_arg_type,
316 -- but visible type applications don't go through there.
317 -- So we do this check here.
318
319 FunSigCtxt {} -> rank1
320 InfSigCtxt _ -> ArbitraryRank -- Inferred type
321 ConArgCtxt _ -> rank1 -- We are given the type of the entire
322 -- constructor, hence rank 1
323
324 ForSigCtxt _ -> rank1
325 SpecInstCtxt -> rank1
326 ThBrackCtxt -> rank1
327 GhciCtxt -> ArbitraryRank
328 _ -> panic "checkValidType"
329 -- Can't happen; not used for *user* sigs
330
331 ; env <- tcInitOpenTidyEnv (tyCoVarsOfType ty)
332
333 -- Check the internal validity of the type itself
334 ; check_type env ctxt rank ty
335
336 -- Check that the thing has kind Type, and is lifted if necessary.
337 -- Do this *after* check_type, because we can't usefully take
338 -- the kind of an ill-formed type such as (a~Int)
339 ; check_kind env ctxt ty
340
341 ; checkUserTypeError ty
342
343 -- Check for ambiguous types. See Note [When to call checkAmbiguity]
344 -- NB: this will happen even for monotypes, but that should be cheap;
345 -- and there may be nested foralls for the subtype test to examine
346 ; checkAmbiguity ctxt ty
347
348 ; traceTc "checkValidType done" (ppr ty <+> text "::" <+> ppr (typeKind ty)) }
349
350 checkValidMonoType :: Type -> TcM ()
351 -- Assumes arguemt is fully zonked
352 checkValidMonoType ty
353 = do { env <- tcInitOpenTidyEnv (tyCoVarsOfType ty)
354 ; check_type env SigmaCtxt MustBeMonoType ty }
355
356 check_kind :: TidyEnv -> UserTypeCtxt -> TcType -> TcM ()
357 -- Check that the type's kind is acceptable for the context
358 check_kind env ctxt ty
359 | TySynCtxt {} <- ctxt
360 , returnsConstraintKind actual_kind
361 = do { ck <- xoptM LangExt.ConstraintKinds
362 ; if ck
363 then when (isConstraintKind actual_kind)
364 (do { dflags <- getDynFlags
365 ; check_pred_ty env dflags ctxt ty })
366 else addErrTcM (constraintSynErr env actual_kind) }
367
368 | otherwise
369 = case expectedKindInCtxt ctxt of
370 TheKind k -> checkTcM (tcEqType actual_kind k) (kindErr env actual_kind)
371 OpenKind -> checkTcM (classifiesTypeWithValues actual_kind) (kindErr env actual_kind)
372 AnythingKind -> return ()
373 where
374 actual_kind = typeKind ty
375
376 -- | The kind expected in a certain context.
377 data ContextKind = TheKind Kind -- ^ a specific kind
378 | AnythingKind -- ^ any kind will do
379 | OpenKind -- ^ something of the form @TYPE _@
380
381 -- Depending on the context, we might accept any kind (for instance, in a TH
382 -- splice), or only certain kinds (like in type signatures).
383 expectedKindInCtxt :: UserTypeCtxt -> ContextKind
384 expectedKindInCtxt (TySynCtxt _) = AnythingKind
385 expectedKindInCtxt ThBrackCtxt = AnythingKind
386 expectedKindInCtxt GhciCtxt = AnythingKind
387 -- The types in a 'default' decl can have varying kinds
388 -- See Note [Extended defaults]" in TcEnv
389 expectedKindInCtxt DefaultDeclCtxt = AnythingKind
390 expectedKindInCtxt TypeAppCtxt = AnythingKind
391 expectedKindInCtxt (ForSigCtxt _) = TheKind liftedTypeKind
392 expectedKindInCtxt InstDeclCtxt = TheKind constraintKind
393 expectedKindInCtxt SpecInstCtxt = TheKind constraintKind
394 expectedKindInCtxt _ = OpenKind
395
396 {-
397 Note [Higher rank types]
398 ~~~~~~~~~~~~~~~~~~~~~~~~
399 Technically
400 Int -> forall a. a->a
401 is still a rank-1 type, but it's not Haskell 98 (Trac #5957). So the
402 validity checker allow a forall after an arrow only if we allow it
403 before -- that is, with Rank2Types or RankNTypes
404 -}
405
406 data Rank = ArbitraryRank -- Any rank ok
407
408 | LimitedRank -- Note [Higher rank types]
409 Bool -- Forall ok at top
410 Rank -- Use for function arguments
411
412 | MonoType SDoc -- Monotype, with a suggestion of how it could be a polytype
413
414 | MustBeMonoType -- Monotype regardless of flags
415
416 rankZeroMonoType, tyConArgMonoType, synArgMonoType :: Rank
417 rankZeroMonoType = MonoType (text "Perhaps you intended to use RankNTypes or Rank2Types")
418 tyConArgMonoType = MonoType (text "GHC doesn't yet support impredicative polymorphism")
419 synArgMonoType = MonoType (text "Perhaps you intended to use LiberalTypeSynonyms")
420
421 funArgResRank :: Rank -> (Rank, Rank) -- Function argument and result
422 funArgResRank (LimitedRank _ arg_rank) = (arg_rank, LimitedRank (forAllAllowed arg_rank) arg_rank)
423 funArgResRank other_rank = (other_rank, other_rank)
424
425 forAllAllowed :: Rank -> Bool
426 forAllAllowed ArbitraryRank = True
427 forAllAllowed (LimitedRank forall_ok _) = forall_ok
428 forAllAllowed _ = False
429
430 ----------------------------------------
431 -- | Fail with error message if the type is unlifted
432 check_lifted :: TidyEnv -> Type -> TcM ()
433 check_lifted env ty
434 = checkTcM (not (isUnLiftedType ty)) (unliftedArgErr env ty)
435
436 check_type :: TidyEnv -> UserTypeCtxt -> Rank -> Type -> TcM ()
437 -- The args say what the *type context* requires, independent
438 -- of *flag* settings. You test the flag settings at usage sites.
439 --
440 -- Rank is allowed rank for function args
441 -- Rank 0 means no for-alls anywhere
442
443 check_type env ctxt rank ty
444 | not (null tvs && null theta)
445 = do { checkTcM (forAllAllowed rank) (forAllTyErr env' rank ty)
446 -- Reject e.g. (Maybe (?x::Int => Int)),
447 -- with a decent error message
448
449 ; check_valid_theta env' SigmaCtxt theta
450 -- Allow type T = ?x::Int => Int -> Int
451 -- but not type T = ?x::Int
452
453 ; check_type env' ctxt rank tau -- Allow foralls to right of arrow
454 ; checkTcM (not (any (`elemVarSet` tyCoVarsOfType phi_kind) tvs))
455 (forAllEscapeErr env' ty tau_kind)
456 }
457 where
458 (tvs, theta, tau) = tcSplitSigmaTy ty
459 tau_kind = typeKind tau
460
461 phi_kind | null theta = tau_kind
462 | otherwise = liftedTypeKind
463 -- If there are any constraints, the kind is *. (#11405)
464
465 (env', _) = tidyTyCoVarBndrs env tvs
466
467 check_type _ _ _ (TyVarTy _) = return ()
468
469 check_type env ctxt rank (ForAllTy (Anon arg_ty) res_ty)
470 = do { check_type env ctxt arg_rank arg_ty
471 ; check_type env ctxt res_rank res_ty }
472 where
473 (arg_rank, res_rank) = funArgResRank rank
474
475 check_type env ctxt rank (AppTy ty1 ty2)
476 = do { check_arg_type env ctxt rank ty1
477 ; check_arg_type env ctxt rank ty2 }
478
479 check_type env ctxt rank ty@(TyConApp tc tys)
480 | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc
481 = check_syn_tc_app env ctxt rank ty tc tys
482 | isUnboxedTupleTyCon tc = check_ubx_tuple env ctxt ty tys
483 | otherwise = mapM_ (check_arg_type env ctxt rank) tys
484
485 check_type _ _ _ (LitTy {}) = return ()
486
487 check_type env ctxt rank (CastTy ty _) = check_type env ctxt rank ty
488
489 check_type _ _ _ ty = pprPanic "check_type" (ppr ty)
490
491 ----------------------------------------
492 check_syn_tc_app :: TidyEnv -> UserTypeCtxt -> Rank -> KindOrType
493 -> TyCon -> [KindOrType] -> TcM ()
494 -- Used for type synonyms and type synonym families,
495 -- which must be saturated,
496 -- but not data families, which need not be saturated
497 check_syn_tc_app env ctxt rank ty tc tys
498 | tc_arity <= length tys -- Saturated
499 -- Check that the synonym has enough args
500 -- This applies equally to open and closed synonyms
501 -- It's OK to have an *over-applied* type synonym
502 -- data Tree a b = ...
503 -- type Foo a = Tree [a]
504 -- f :: Foo a b -> ...
505 = do { -- See Note [Liberal type synonyms]
506 ; liberal <- xoptM LangExt.LiberalTypeSynonyms
507 ; if not liberal || isTypeFamilyTyCon tc then
508 -- For H98 and synonym families, do check the type args
509 mapM_ check_arg tys
510
511 else -- In the liberal case (only for closed syns), expand then check
512 case coreView ty of
513 Just ty' -> check_type env ctxt rank ty'
514 Nothing -> pprPanic "check_tau_type" (ppr ty) }
515
516 | GhciCtxt <- ctxt -- Accept under-saturated type synonyms in
517 -- GHCi :kind commands; see Trac #7586
518 = mapM_ check_arg tys
519
520 | otherwise
521 = failWithTc (tyConArityErr tc tys)
522 where
523 tc_arity = tyConArity tc
524 check_arg | isTypeFamilyTyCon tc = check_arg_type env ctxt rank
525 | otherwise = check_type env ctxt synArgMonoType
526
527 ----------------------------------------
528 check_ubx_tuple :: TidyEnv -> UserTypeCtxt -> KindOrType
529 -> [KindOrType] -> TcM ()
530 check_ubx_tuple env ctxt ty tys
531 = do { ub_tuples_allowed <- xoptM LangExt.UnboxedTuples
532 ; checkTcM ub_tuples_allowed (ubxArgTyErr env ty)
533
534 ; impred <- xoptM LangExt.ImpredicativeTypes
535 ; let rank' = if impred then ArbitraryRank else tyConArgMonoType
536 -- c.f. check_arg_type
537 -- However, args are allowed to be unlifted, or
538 -- more unboxed tuples, so can't use check_arg_ty
539 ; mapM_ (check_type env ctxt rank') tys }
540
541 ----------------------------------------
542 check_arg_type :: TidyEnv -> UserTypeCtxt -> Rank -> KindOrType -> TcM ()
543 -- The sort of type that can instantiate a type variable,
544 -- or be the argument of a type constructor.
545 -- Not an unboxed tuple, but now *can* be a forall (since impredicativity)
546 -- Other unboxed types are very occasionally allowed as type
547 -- arguments depending on the kind of the type constructor
548 --
549 -- For example, we want to reject things like:
550 --
551 -- instance Ord a => Ord (forall s. T s a)
552 -- and
553 -- g :: T s (forall b.b)
554 --
555 -- NB: unboxed tuples can have polymorphic or unboxed args.
556 -- This happens in the workers for functions returning
557 -- product types with polymorphic components.
558 -- But not in user code.
559 -- Anyway, they are dealt with by a special case in check_tau_type
560
561 check_arg_type _ _ _ (CoercionTy {}) = return ()
562
563 check_arg_type env ctxt rank ty
564 = do { impred <- xoptM LangExt.ImpredicativeTypes
565 ; let rank' = case rank of -- Predictive => must be monotype
566 MustBeMonoType -> MustBeMonoType -- Monotype, regardless
567 _other | impred -> ArbitraryRank
568 | otherwise -> tyConArgMonoType
569 -- Make sure that MustBeMonoType is propagated,
570 -- so that we don't suggest -XImpredicativeTypes in
571 -- (Ord (forall a.a)) => a -> a
572 -- and so that if it Must be a monotype, we check that it is!
573
574 ; check_type env ctxt rank' ty
575 ; check_lifted env ty }
576 -- NB the isUnLiftedType test also checks for
577 -- T State#
578 -- where there is an illegal partial application of State# (which has
579 -- kind * -> #); see Note [The kind invariant] in TyCoRep
580
581 ----------------------------------------
582 forAllTyErr :: TidyEnv -> Rank -> Type -> (TidyEnv, SDoc)
583 forAllTyErr env rank ty
584 = ( env
585 , vcat [ hang (text "Illegal polymorphic or qualified type:") 2 (ppr_tidy env ty)
586 , suggestion ] )
587 where
588 suggestion = case rank of
589 LimitedRank {} -> text "Perhaps you intended to use RankNTypes or Rank2Types"
590 MonoType d -> d
591 _ -> Outputable.empty -- Polytype is always illegal
592
593 forAllEscapeErr :: TidyEnv -> Type -> Kind -> (TidyEnv, SDoc)
594 forAllEscapeErr env ty tau_kind
595 = ( env
596 , hang (vcat [ text "Quantified type's kind mentions quantified type variable"
597 , text "(skolem escape)" ])
598 2 (vcat [ text " type:" <+> ppr_tidy env ty
599 , text "of kind:" <+> ppr_tidy env tau_kind ]) )
600
601 unliftedArgErr, ubxArgTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc)
602 unliftedArgErr env ty = (env, sep [text "Illegal unlifted type:", ppr_tidy env ty])
603 ubxArgTyErr env ty = (env, sep [text "Illegal unboxed tuple type as function argument:", ppr_tidy env ty])
604
605 kindErr :: TidyEnv -> Kind -> (TidyEnv, SDoc)
606 kindErr env kind = (env, sep [text "Expecting an ordinary type, but found a type of kind", ppr_tidy env kind])
607
608 {-
609 Note [Liberal type synonyms]
610 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
611 If -XLiberalTypeSynonyms is on, expand closed type synonyms *before*
612 doing validity checking. This allows us to instantiate a synonym defn
613 with a for-all type, or with a partially-applied type synonym.
614 e.g. type T a b = a
615 type S m = m ()
616 f :: S (T Int)
617 Here, T is partially applied, so it's illegal in H98. But if you
618 expand S first, then T we get just
619 f :: Int
620 which is fine.
621
622 IMPORTANT: suppose T is a type synonym. Then we must do validity
623 checking on an appliation (T ty1 ty2)
624
625 *either* before expansion (i.e. check ty1, ty2)
626 *or* after expansion (i.e. expand T ty1 ty2, and then check)
627 BUT NOT BOTH
628
629 If we do both, we get exponential behaviour!!
630
631 data TIACons1 i r c = c i ::: r c
632 type TIACons2 t x = TIACons1 t (TIACons1 t x)
633 type TIACons3 t x = TIACons2 t (TIACons1 t x)
634 type TIACons4 t x = TIACons2 t (TIACons2 t x)
635 type TIACons7 t x = TIACons4 t (TIACons3 t x)
636
637
638 ************************************************************************
639 * *
640 \subsection{Checking a theta or source type}
641 * *
642 ************************************************************************
643
644 Note [Implicit parameters in instance decls]
645 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
646 Implicit parameters _only_ allowed in type signatures; not in instance
647 decls, superclasses etc. The reason for not allowing implicit params in
648 instances is a bit subtle. If we allowed
649 instance (?x::Int, Eq a) => Foo [a] where ...
650 then when we saw
651 (e :: (?x::Int) => t)
652 it would be unclear how to discharge all the potential uses of the ?x
653 in e. For example, a constraint Foo [Int] might come out of e, and
654 applying the instance decl would show up two uses of ?x. Trac #8912.
655 -}
656
657 checkValidTheta :: UserTypeCtxt -> ThetaType -> TcM ()
658 -- Assumes arguemt is fully zonked
659 checkValidTheta ctxt theta
660 = do { env <- tcInitOpenTidyEnv (tyCoVarsOfTypes theta)
661 ; addErrCtxtM (checkThetaCtxt ctxt theta) $
662 check_valid_theta env ctxt theta }
663
664 -------------------------
665 check_valid_theta :: TidyEnv -> UserTypeCtxt -> [PredType] -> TcM ()
666 check_valid_theta _ _ []
667 = return ()
668 check_valid_theta env ctxt theta
669 = do { dflags <- getDynFlags
670 ; warnTcM (wopt Opt_WarnDuplicateConstraints dflags &&
671 notNull dups) (dupPredWarn env dups)
672 ; traceTc "check_valid_theta" (ppr theta)
673 ; mapM_ (check_pred_ty env dflags ctxt) theta }
674 where
675 (_,dups) = removeDups cmpType theta
676
677 -------------------------
678 check_pred_ty :: TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> TcM ()
679 -- Check the validity of a predicate in a signature
680 -- Do not look through any type synonyms; any constraint kinded
681 -- type synonyms have been checked at their definition site
682 -- C.f. Trac #9838
683
684 check_pred_ty env dflags ctxt pred
685 = do { check_type env SigmaCtxt MustBeMonoType pred
686 ; check_pred_help False env dflags ctxt pred }
687
688 check_pred_help :: Bool -- True <=> under a type synonym
689 -> TidyEnv
690 -> DynFlags -> UserTypeCtxt
691 -> PredType -> TcM ()
692 check_pred_help under_syn env dflags ctxt pred
693 | Just pred' <- coreView pred -- Switch on under_syn when going under a
694 -- synonym (Trac #9838, yuk)
695 = check_pred_help True env dflags ctxt pred'
696 | otherwise
697 = case splitTyConApp_maybe pred of
698 Just (tc, tys)
699 | isTupleTyCon tc
700 -> check_tuple_pred under_syn env dflags ctxt pred tys
701 -- NB: this equality check must come first, because (~) is a class,
702 -- too.
703 | tc `hasKey` heqTyConKey ||
704 tc `hasKey` eqTyConKey ||
705 tc `hasKey` eqPrimTyConKey
706 -> check_eq_pred env dflags pred tc tys
707 | Just cls <- tyConClass_maybe tc
708 -> check_class_pred env dflags ctxt pred cls tys -- Includes Coercible
709 _ -> check_irred_pred under_syn env dflags ctxt pred
710
711 check_eq_pred :: TidyEnv -> DynFlags -> PredType -> TyCon -> [TcType] -> TcM ()
712 check_eq_pred env dflags pred tc tys
713 = -- Equational constraints are valid in all contexts if type
714 -- families are permitted
715 do { checkTc (length tys == tyConArity tc) (tyConArityErr tc tys)
716 ; checkTcM (xopt LangExt.TypeFamilies dflags
717 || xopt LangExt.GADTs dflags)
718 (eqPredTyErr env pred) }
719
720 check_tuple_pred :: Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> [PredType] -> TcM ()
721 check_tuple_pred under_syn env dflags ctxt pred ts
722 = do { -- See Note [ConstraintKinds in predicates]
723 checkTcM (under_syn || xopt LangExt.ConstraintKinds dflags)
724 (predTupleErr env pred)
725 ; mapM_ (check_pred_help under_syn env dflags ctxt) ts }
726 -- This case will not normally be executed because without
727 -- -XConstraintKinds tuple types are only kind-checked as *
728
729 check_irred_pred :: Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> TcM ()
730 check_irred_pred under_syn env dflags ctxt pred
731 -- The predicate looks like (X t1 t2) or (x t1 t2) :: Constraint
732 -- where X is a type function
733 = do { -- If it looks like (x t1 t2), require ConstraintKinds
734 -- see Note [ConstraintKinds in predicates]
735 -- But (X t1 t2) is always ok because we just require ConstraintKinds
736 -- at the definition site (Trac #9838)
737 failIfTcM (not under_syn && not (xopt LangExt.ConstraintKinds dflags)
738 && hasTyVarHead pred)
739 (predIrredErr env pred)
740
741 -- Make sure it is OK to have an irred pred in this context
742 -- See Note [Irreducible predicates in superclasses]
743 ; failIfTcM (is_superclass ctxt
744 && not (xopt LangExt.UndecidableInstances dflags)
745 && has_tyfun_head pred)
746 (predSuperClassErr env pred) }
747 where
748 is_superclass ctxt = case ctxt of { ClassSCCtxt _ -> True; _ -> False }
749 has_tyfun_head ty
750 = case tcSplitTyConApp_maybe ty of
751 Just (tc, _) -> isTypeFamilyTyCon tc
752 Nothing -> False
753
754 {- Note [ConstraintKinds in predicates]
755 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
756 Don't check for -XConstraintKinds under a type synonym, because that
757 was done at the type synonym definition site; see Trac #9838
758 e.g. module A where
759 type C a = (Eq a, Ix a) -- Needs -XConstraintKinds
760 module B where
761 import A
762 f :: C a => a -> a -- Does *not* need -XConstraintKinds
763
764 Note [Irreducible predicates in superclasses]
765 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
766 Allowing type-family calls in class superclasses is somewhat dangerous
767 because we can write:
768
769 type family Fooish x :: * -> Constraint
770 type instance Fooish () = Foo
771 class Fooish () a => Foo a where
772
773 This will cause the constraint simplifier to loop because every time we canonicalise a
774 (Foo a) class constraint we add a (Fooish () a) constraint which will be immediately
775 solved to add+canonicalise another (Foo a) constraint. -}
776
777 -------------------------
778 check_class_pred :: TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> Class -> [TcType] -> TcM ()
779 check_class_pred env dflags ctxt pred cls tys
780 | isIPClass cls
781 = do { check_arity
782 ; checkTcM (okIPCtxt ctxt) (badIPPred env pred) }
783
784 | otherwise
785 = do { check_arity
786 ; checkTcM arg_tys_ok (env, predTyVarErr (tidyType env pred)) }
787 where
788 check_arity = checkTc (classArity cls == length tys)
789 (tyConArityErr (classTyCon cls) tys)
790 flexible_contexts = xopt LangExt.FlexibleContexts dflags
791 undecidable_ok = xopt LangExt.UndecidableInstances dflags
792
793 arg_tys_ok = case ctxt of
794 SpecInstCtxt -> True -- {-# SPECIALISE instance Eq (T Int) #-} is fine
795 InstDeclCtxt -> checkValidClsArgs (flexible_contexts || undecidable_ok) cls tys
796 -- Further checks on head and theta
797 -- in checkInstTermination
798 _ -> checkValidClsArgs flexible_contexts cls tys
799
800 -------------------------
801 okIPCtxt :: UserTypeCtxt -> Bool
802 -- See Note [Implicit parameters in instance decls]
803 okIPCtxt (FunSigCtxt {}) = True
804 okIPCtxt (InfSigCtxt {}) = True
805 okIPCtxt ExprSigCtxt = True
806 okIPCtxt TypeAppCtxt = True
807 okIPCtxt PatSigCtxt = True
808 okIPCtxt ResSigCtxt = True
809 okIPCtxt GenSigCtxt = True
810 okIPCtxt (ConArgCtxt {}) = True
811 okIPCtxt (ForSigCtxt {}) = True -- ??
812 okIPCtxt ThBrackCtxt = True
813 okIPCtxt GhciCtxt = True
814 okIPCtxt SigmaCtxt = True
815 okIPCtxt (DataTyCtxt {}) = True
816 okIPCtxt (PatSynCtxt {}) = True
817
818 okIPCtxt (ClassSCCtxt {}) = False
819 okIPCtxt (InstDeclCtxt {}) = False
820 okIPCtxt (SpecInstCtxt {}) = False
821 okIPCtxt (TySynCtxt {}) = False
822 okIPCtxt (RuleSigCtxt {}) = False
823 okIPCtxt DefaultDeclCtxt = False
824
825 badIPPred :: TidyEnv -> PredType -> (TidyEnv, SDoc)
826 badIPPred env pred
827 = ( env
828 , text "Illegal implicit parameter" <+> quotes (ppr_tidy env pred) )
829
830 {-
831 Note [Kind polymorphic type classes]
832 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
833 MultiParam check:
834
835 class C f where... -- C :: forall k. k -> Constraint
836 instance C Maybe where...
837
838 The dictionary gets type [C * Maybe] even if it's not a MultiParam
839 type class.
840
841 Flexibility check:
842
843 class C f where... -- C :: forall k. k -> Constraint
844 data D a = D a
845 instance C D where
846
847 The dictionary gets type [C * (D *)]. IA0_TODO it should be
848 generalized actually.
849 -}
850
851 checkThetaCtxt :: UserTypeCtxt -> ThetaType -> TidyEnv -> TcM (TidyEnv, SDoc)
852 checkThetaCtxt ctxt theta env
853 = return ( env
854 , vcat [ text "In the context:" <+> pprTheta (tidyTypes env theta)
855 , text "While checking" <+> pprUserTypeCtxt ctxt ] )
856
857 eqPredTyErr, predTupleErr, predIrredErr, predSuperClassErr :: TidyEnv -> PredType -> (TidyEnv, SDoc)
858 eqPredTyErr env pred
859 = ( env
860 , text "Illegal equational constraint" <+> ppr_tidy env pred $$
861 parens (text "Use GADTs or TypeFamilies to permit this") )
862 predTupleErr env pred
863 = ( env
864 , hang (text "Illegal tuple constraint:" <+> ppr_tidy env pred)
865 2 (parens constraintKindsMsg) )
866 predIrredErr env pred
867 = ( env
868 , hang (text "Illegal constraint:" <+> ppr_tidy env pred)
869 2 (parens constraintKindsMsg) )
870 predSuperClassErr env pred
871 = ( env
872 , hang (text "Illegal constraint" <+> quotes (ppr_tidy env pred)
873 <+> text "in a superclass context")
874 2 (parens undecidableMsg) )
875
876 predTyVarErr :: PredType -> SDoc -- type is already tidied!
877 predTyVarErr pred
878 = vcat [ hang (text "Non type-variable argument")
879 2 (text "in the constraint:" <+> ppr pred)
880 , parens (text "Use FlexibleContexts to permit this") ]
881
882 constraintSynErr :: TidyEnv -> Type -> (TidyEnv, SDoc)
883 constraintSynErr env kind
884 = ( env
885 , hang (text "Illegal constraint synonym of kind:" <+> quotes (ppr_tidy env kind))
886 2 (parens constraintKindsMsg) )
887
888 dupPredWarn :: TidyEnv -> [[PredType]] -> (TidyEnv, SDoc)
889 dupPredWarn env dups
890 = ( env
891 , text "Duplicate constraint" <> plural primaryDups <> text ":"
892 <+> pprWithCommas (ppr_tidy env) primaryDups )
893 where
894 primaryDups = map head dups
895
896 tyConArityErr :: TyCon -> [TcType] -> SDoc
897 -- For type-constructor arity errors, be careful to report
898 -- the number of /visible/ arguments required and supplied,
899 -- ignoring the /invisible/ arguments, which the user does not see.
900 -- (e.g. Trac #10516)
901 tyConArityErr tc tks
902 = arityErr (tyConFlavour tc) (tyConName tc)
903 tc_type_arity tc_type_args
904 where
905 vis_tks = filterOutInvisibleTypes tc tks
906
907 -- tc_type_arity = number of *type* args expected
908 -- tc_type_args = number of *type* args encountered
909 tc_type_arity = count isVisibleBinder $ fst $ splitPiTys (tyConKind tc)
910 tc_type_args = length vis_tks
911
912 arityErr :: Outputable a => String -> a -> Int -> Int -> SDoc
913 arityErr what name n m
914 = hsep [ text "The" <+> text what, quotes (ppr name), text "should have",
915 n_arguments <> comma, text "but has been given",
916 if m==0 then text "none" else int m]
917 where
918 n_arguments | n == 0 = text "no arguments"
919 | n == 1 = text "1 argument"
920 | True = hsep [int n, text "arguments"]
921
922 {-
923 ************************************************************************
924 * *
925 \subsection{Checking for a decent instance head type}
926 * *
927 ************************************************************************
928
929 @checkValidInstHead@ checks the type {\em and} its syntactic constraints:
930 it must normally look like: @instance Foo (Tycon a b c ...) ...@
931
932 The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
933 flag is on, or (2)~the instance is imported (they must have been
934 compiled elsewhere). In these cases, we let them go through anyway.
935
936 We can also have instances for functions: @instance Foo (a -> b) ...@.
937 -}
938
939 checkValidInstHead :: UserTypeCtxt -> Class -> [Type] -> TcM ()
940 checkValidInstHead ctxt clas cls_args
941 = do { dflags <- getDynFlags
942
943 ; mod <- getModule
944 ; checkTc (getUnique clas `notElem` abstractClassKeys ||
945 nameModule (getName clas) == mod)
946 (instTypeErr clas cls_args abstract_class_msg)
947
948 -- Check language restrictions;
949 -- but not for SPECIALISE isntance pragmas
950 ; let ty_args = filterOutInvisibleTypes (classTyCon clas) cls_args
951 ; unless spec_inst_prag $
952 do { checkTc (xopt LangExt.TypeSynonymInstances dflags ||
953 all tcInstHeadTyNotSynonym ty_args)
954 (instTypeErr clas cls_args head_type_synonym_msg)
955 ; checkTc (xopt LangExt.FlexibleInstances dflags ||
956 all tcInstHeadTyAppAllTyVars ty_args)
957 (instTypeErr clas cls_args head_type_args_tyvars_msg)
958 ; checkTc (xopt LangExt.MultiParamTypeClasses dflags ||
959 length ty_args == 1 || -- Only count type arguments
960 (xopt LangExt.NullaryTypeClasses dflags &&
961 null ty_args))
962 (instTypeErr clas cls_args head_one_type_msg) }
963
964 -- May not contain type family applications
965 ; mapM_ checkTyFamFreeness ty_args
966
967 ; mapM_ checkValidMonoType ty_args
968 -- For now, I only allow tau-types (not polytypes) in
969 -- the head of an instance decl.
970 -- E.g. instance C (forall a. a->a) is rejected
971 -- One could imagine generalising that, but I'm not sure
972 -- what all the consequences might be
973
974 -- We can't have unlifted type arguments.
975 -- check_arg_type is redundant with checkValidMonoType
976 ; env <- tcInitOpenTidyEnv (tyCoVarsOfTypes ty_args)
977 ; mapM_ (check_lifted env) ty_args
978 }
979
980 where
981 spec_inst_prag = case ctxt of { SpecInstCtxt -> True; _ -> False }
982
983 head_type_synonym_msg = parens (
984 text "All instance types must be of the form (T t1 ... tn)" $$
985 text "where T is not a synonym." $$
986 text "Use TypeSynonymInstances if you want to disable this.")
987
988 head_type_args_tyvars_msg = parens (vcat [
989 text "All instance types must be of the form (T a1 ... an)",
990 text "where a1 ... an are *distinct type variables*,",
991 text "and each type variable appears at most once in the instance head.",
992 text "Use FlexibleInstances if you want to disable this."])
993
994 head_one_type_msg = parens (
995 text "Only one type can be given in an instance head." $$
996 text "Use MultiParamTypeClasses if you want to allow more, or zero.")
997
998 abstract_class_msg =
999 text "Manual instances of this class are not permitted."
1000
1001 abstractClassKeys :: [Unique]
1002 abstractClassKeys = [ heqTyConKey
1003 , eqTyConKey
1004 , coercibleTyConKey
1005 ] -- See Note [Equality class instances]
1006
1007 instTypeErr :: Class -> [Type] -> SDoc -> SDoc
1008 instTypeErr cls tys msg
1009 = hang (hang (text "Illegal instance declaration for")
1010 2 (quotes (pprClassPred cls tys)))
1011 2 msg
1012
1013 {- Note [Valid 'deriving' predicate]
1014 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1015 validDerivPred checks for OK 'deriving' context. See Note [Exotic
1016 derived instance contexts] in TcDeriv. However the predicate is
1017 here because it uses sizeTypes, fvTypes.
1018
1019 It checks for three things
1020
1021 * No repeated variables (hasNoDups fvs)
1022
1023 * No type constructors. This is done by comparing
1024 sizeTypes tys == length (fvTypes tys)
1025 sizeTypes counts variables and constructors; fvTypes returns variables.
1026 So if they are the same, there must be no constructors. But there
1027 might be applications thus (f (g x)).
1028
1029 * Also check for a bizarre corner case, when the derived instance decl
1030 would look like
1031 instance C a b => D (T a) where ...
1032 Note that 'b' isn't a parameter of T. This gives rise to all sorts of
1033 problems; in particular, it's hard to compare solutions for equality
1034 when finding the fixpoint, and that means the inferContext loop does
1035 not converge. See Trac #5287.
1036
1037 Note [Equality class instances]
1038 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1039 We can't have users writing instances for the equality classes. But we
1040 still need to be able to write instances for them ourselves. So we allow
1041 instances only in the defining module.
1042
1043 -}
1044
1045 validDerivPred :: TyVarSet -> PredType -> Bool
1046 -- See Note [Valid 'deriving' predicate]
1047 validDerivPred tv_set pred
1048 = case classifyPredType pred of
1049 ClassPred cls _ -> cls `hasKey` typeableClassKey
1050 -- Typeable constraints are bigger than they appear due
1051 -- to kind polymorphism, but that's OK
1052 || check_tys
1053 EqPred {} -> False -- reject equality constraints
1054 _ -> True -- Non-class predicates are ok
1055 where
1056 check_tys = hasNoDups fvs
1057 -- use sizePred to ignore implicit args
1058 && sizePred pred == fromIntegral (length fvs)
1059 && all (`elemVarSet` tv_set) fvs
1060
1061 fvs = fvType pred
1062
1063 {-
1064 ************************************************************************
1065 * *
1066 \subsection{Checking instance for termination}
1067 * *
1068 ************************************************************************
1069 -}
1070
1071 checkValidInstance :: UserTypeCtxt -> LHsSigType Name -> Type
1072 -> TcM ([TyVar], ThetaType, Class, [Type])
1073 checkValidInstance ctxt hs_type ty
1074 | Just (clas,inst_tys) <- getClassPredTys_maybe tau
1075 , inst_tys `lengthIs` classArity clas
1076 = do { setSrcSpan head_loc (checkValidInstHead ctxt clas inst_tys)
1077 ; checkValidTheta ctxt theta
1078
1079 -- The Termination and Coverate Conditions
1080 -- Check that instance inference will terminate (if we care)
1081 -- For Haskell 98 this will already have been done by checkValidTheta,
1082 -- but as we may be using other extensions we need to check.
1083 --
1084 -- Note that the Termination Condition is *more conservative* than
1085 -- the checkAmbiguity test we do on other type signatures
1086 -- e.g. Bar a => Bar Int is ambiguous, but it also fails
1087 -- the termination condition, because 'a' appears more often
1088 -- in the constraint than in the head
1089 ; undecidable_ok <- xoptM LangExt.UndecidableInstances
1090 ; traceTc "cvi" (ppr undecidable_ok $$ ppr ty)
1091 ; if undecidable_ok
1092 then checkAmbiguity ctxt ty
1093 else checkInstTermination inst_tys theta
1094
1095 ; case (checkInstCoverage undecidable_ok clas theta inst_tys) of
1096 IsValid -> return () -- Check succeeded
1097 NotValid msg -> addErrTc (instTypeErr clas inst_tys msg)
1098
1099 ; return (tvs, theta, clas, inst_tys) }
1100
1101 | otherwise
1102 = failWithTc (text "Malformed instance head:" <+> ppr tau)
1103 where
1104 (tvs, theta, tau) = tcSplitSigmaTy ty
1105
1106 -- The location of the "head" of the instance
1107 head_loc = case splitLHsInstDeclTy hs_type of
1108 (_, _, L loc _) -> loc
1109
1110 {-
1111 Note [Paterson conditions]
1112 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1113 Termination test: the so-called "Paterson conditions" (see Section 5 of
1114 "Understanding functional dependencies via Constraint Handling Rules,
1115 JFP Jan 2007).
1116
1117 We check that each assertion in the context satisfies:
1118 (1) no variable has more occurrences in the assertion than in the head, and
1119 (2) the assertion has fewer constructors and variables (taken together
1120 and counting repetitions) than the head.
1121 This is only needed with -fglasgow-exts, as Haskell 98 restrictions
1122 (which have already been checked) guarantee termination.
1123
1124 The underlying idea is that
1125
1126 for any ground substitution, each assertion in the
1127 context has fewer type constructors than the head.
1128 -}
1129
1130 checkInstTermination :: [TcType] -> ThetaType -> TcM ()
1131 -- See Note [Paterson conditions]
1132 checkInstTermination tys theta
1133 = check_preds theta
1134 where
1135 head_fvs = fvTypes tys
1136 head_size = sizeTypes tys
1137
1138 check_preds :: [PredType] -> TcM ()
1139 check_preds preds = mapM_ check preds
1140
1141 check :: PredType -> TcM ()
1142 check pred
1143 = case classifyPredType pred of
1144 EqPred {} -> return () -- See Trac #4200.
1145 IrredPred {} -> check2 pred (sizeType pred)
1146 ClassPred cls tys
1147 | isTerminatingClass cls
1148 -> return ()
1149
1150 | isCTupleClass cls -- Look inside tuple predicates; Trac #8359
1151 -> check_preds tys
1152
1153 | otherwise
1154 -> check2 pred (sizeTypes $ filterOutInvisibleTypes (classTyCon cls) tys)
1155 -- Other ClassPreds
1156
1157 check2 pred pred_size
1158 | not (null bad_tvs) = addErrTc (noMoreMsg bad_tvs what)
1159 | pred_size >= head_size = addErrTc (smallerMsg what)
1160 | otherwise = return ()
1161 where
1162 what = text "constraint" <+> quotes (ppr pred)
1163 bad_tvs = fvType pred \\ head_fvs
1164
1165 smallerMsg :: SDoc -> SDoc
1166 smallerMsg what
1167 = vcat [ hang (text "The" <+> what)
1168 2 (text "is no smaller than the instance head")
1169 , parens undecidableMsg ]
1170
1171 noMoreMsg :: [TcTyVar] -> SDoc -> SDoc
1172 noMoreMsg tvs what
1173 = vcat [ hang (text "Variable" <> plural tvs <+> quotes (pprWithCommas ppr tvs)
1174 <+> occurs <+> text "more often")
1175 2 (sep [ text "in the" <+> what
1176 , text "than in the instance head" ])
1177 , parens undecidableMsg ]
1178 where
1179 occurs = if isSingleton tvs then text "occurs"
1180 else text "occur"
1181
1182 undecidableMsg, constraintKindsMsg :: SDoc
1183 undecidableMsg = text "Use UndecidableInstances to permit this"
1184 constraintKindsMsg = text "Use ConstraintKinds to permit this"
1185
1186 {-
1187 Note [Associated type instances]
1188 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1189 We allow this:
1190 class C a where
1191 type T x a
1192 instance C Int where
1193 type T (S y) Int = y
1194 type T Z Int = Char
1195
1196 Note that
1197 a) The variable 'x' is not bound by the class decl
1198 b) 'x' is instantiated to a non-type-variable in the instance
1199 c) There are several type instance decls for T in the instance
1200
1201 All this is fine. Of course, you can't give any *more* instances
1202 for (T ty Int) elsewhere, because it's an *associated* type.
1203
1204 Note [Checking consistent instantiation]
1205 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1206 class C a b where
1207 type T a x b
1208
1209 instance C [p] Int
1210 type T [p] y Int = (p,y,y) -- Induces the family instance TyCon
1211 -- type TR p y = (p,y,y)
1212
1213 So we
1214 * Form the mini-envt from the class type variables a,b
1215 to the instance decl types [p],Int: [a->[p], b->Int]
1216
1217 * Look at the tyvars a,x,b of the type family constructor T
1218 (it shares tyvars with the class C)
1219
1220 * Apply the mini-evnt to them, and check that the result is
1221 consistent with the instance types [p] y Int
1222
1223 We do *not* assume (at this point) the the bound variables of
1224 the associated type instance decl are the same as for the parent
1225 instance decl. So, for example,
1226
1227 instance C [p] Int
1228 type T [q] y Int = ...
1229
1230 would work equally well. Reason: making the *kind* variables line
1231 up is much harder. Example (Trac #7282):
1232 class Foo (xs :: [k]) where
1233 type Bar xs :: *
1234
1235 instance Foo '[] where
1236 type Bar '[] = Int
1237 Here the instance decl really looks like
1238 instance Foo k ('[] k) where
1239 type Bar k ('[] k) = Int
1240 but the k's are not scoped, and hence won't match Uniques.
1241
1242 So instead we just match structure, with tcMatchTyX, and check
1243 that distinct type variables match 1-1 with distinct type variables.
1244
1245 HOWEVER, we *still* make the instance type variables scope over the
1246 type instances, to pick up non-obvious kinds. Eg
1247 class Foo (a :: k) where
1248 type F a
1249 instance Foo (b :: k -> k) where
1250 type F b = Int
1251 Here the instance is kind-indexed and really looks like
1252 type F (k->k) (b::k->k) = Int
1253 But if the 'b' didn't scope, we would make F's instance too
1254 poly-kinded.
1255 -}
1256
1257 -- | Extra information needed when type-checking associated types. The 'Class' is
1258 -- the enclosing class, and the @VarEnv Type@ maps class variables to their
1259 -- instance types.
1260 type ClsInfo = (Class, VarEnv Type)
1261
1262 checkConsistentFamInst
1263 :: Maybe ClsInfo
1264 -> TyCon -- ^ Family tycon
1265 -> [TyVar] -- ^ Type variables of the family instance
1266 -> [Type] -- ^ Type patterns from instance
1267 -> TcM ()
1268 -- See Note [Checking consistent instantiation]
1269
1270 checkConsistentFamInst Nothing _ _ _ = return ()
1271 checkConsistentFamInst (Just (clas, mini_env)) fam_tc at_tvs at_tys
1272 = do { -- Check that the associated type indeed comes from this class
1273 checkTc (Just clas == tyConAssoc_maybe fam_tc)
1274 (badATErr (className clas) (tyConName fam_tc))
1275
1276 -- See Note [Checking consistent instantiation] in TcTyClsDecls
1277 -- Check right to left, so that we spot type variable
1278 -- inconsistencies before (more confusing) kind variables
1279 ; discardResult $ foldrM check_arg emptyTCvSubst $
1280 tyConTyVars fam_tc `zip` at_tys }
1281 where
1282 check_arg :: (TyVar, Type) -> TCvSubst -> TcM TCvSubst
1283 check_arg (fam_tc_tv, at_ty) subst
1284 | Just inst_ty <- lookupVarEnv mini_env fam_tc_tv
1285 = case tcMatchTyX subst at_ty inst_ty of
1286 Just subst | all_distinct subst -> return subst
1287 _ -> failWithTc $ wrongATArgErr at_ty inst_ty
1288 -- No need to instantiate here, because the axiom
1289 -- uses the same type variables as the assocated class
1290 | otherwise
1291 = return subst -- Allow non-type-variable instantiation
1292 -- See Note [Associated type instances]
1293
1294 all_distinct :: TCvSubst -> Bool
1295 -- True if all the variables mapped the substitution
1296 -- map to *distinct* type *variables*
1297 all_distinct subst = go [] at_tvs
1298 where
1299 go _ [] = True
1300 go acc (tv:tvs) = case lookupTyVar subst tv of
1301 Nothing -> go acc tvs
1302 Just ty | Just tv' <- tcGetTyVar_maybe ty
1303 , tv' `notElem` acc
1304 -> go (tv' : acc) tvs
1305 _other -> False
1306
1307 badATErr :: Name -> Name -> SDoc
1308 badATErr clas op
1309 = hsep [text "Class", quotes (ppr clas),
1310 text "does not have an associated type", quotes (ppr op)]
1311
1312 wrongATArgErr :: Type -> Type -> SDoc
1313 wrongATArgErr ty instTy =
1314 sep [ text "Type indexes must match class instance head"
1315 , text "Found" <+> quotes (ppr ty)
1316 <+> text "but expected" <+> quotes (ppr instTy)
1317 ]
1318
1319 {-
1320 ************************************************************************
1321 * *
1322 Checking type instance well-formedness and termination
1323 * *
1324 ************************************************************************
1325 -}
1326
1327 checkValidCoAxiom :: CoAxiom Branched -> TcM ()
1328 checkValidCoAxiom ax@(CoAxiom { co_ax_tc = fam_tc, co_ax_branches = branches })
1329 = do { mapM_ (checkValidCoAxBranch Nothing fam_tc) branch_list
1330 ; foldlM_ check_branch_compat [] branch_list }
1331 where
1332 branch_list = fromBranches branches
1333 injectivity = familyTyConInjectivityInfo fam_tc
1334
1335 check_branch_compat :: [CoAxBranch] -- previous branches in reverse order
1336 -> CoAxBranch -- current branch
1337 -> TcM [CoAxBranch]-- current branch : previous branches
1338 -- Check for
1339 -- (a) this branch is dominated by previous ones
1340 -- (b) failure of injectivity
1341 check_branch_compat prev_branches cur_branch
1342 | cur_branch `isDominatedBy` prev_branches
1343 = do { addWarnAt (coAxBranchSpan cur_branch) $
1344 inaccessibleCoAxBranch ax cur_branch
1345 ; return prev_branches }
1346 | otherwise
1347 = do { check_injectivity prev_branches cur_branch
1348 ; return (cur_branch : prev_branches) }
1349
1350 -- Injectivity check: check whether a new (CoAxBranch) can extend
1351 -- already checked equations without violating injectivity
1352 -- annotation supplied by the user.
1353 -- See Note [Verifying injectivity annotation] in FamInstEnv
1354 check_injectivity prev_branches cur_branch
1355 | Injective inj <- injectivity
1356 = do { let conflicts =
1357 fst $ foldl (gather_conflicts inj prev_branches cur_branch)
1358 ([], 0) prev_branches
1359 ; mapM_ (\(err, span) -> setSrcSpan span $ addErr err)
1360 (makeInjectivityErrors ax cur_branch inj conflicts) }
1361 | otherwise
1362 = return ()
1363
1364 gather_conflicts inj prev_branches cur_branch (acc, n) branch
1365 -- n is 0-based index of branch in prev_branches
1366 = case injectiveBranches inj cur_branch branch of
1367 InjectivityUnified ax1 ax2
1368 | ax1 `isDominatedBy` (replace_br prev_branches n ax2)
1369 -> (acc, n + 1)
1370 | otherwise
1371 -> (branch : acc, n + 1)
1372 InjectivityAccepted -> (acc, n + 1)
1373
1374 -- Replace n-th element in the list. Assumes 0-based indexing.
1375 replace_br :: [CoAxBranch] -> Int -> CoAxBranch -> [CoAxBranch]
1376 replace_br brs n br = take n brs ++ [br] ++ drop (n+1) brs
1377
1378
1379 -- Check that a "type instance" is well-formed (which includes decidability
1380 -- unless -XUndecidableInstances is given).
1381 --
1382 checkValidCoAxBranch :: Maybe ClsInfo
1383 -> TyCon -> CoAxBranch -> TcM ()
1384 checkValidCoAxBranch mb_clsinfo fam_tc
1385 (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs
1386 , cab_lhs = typats
1387 , cab_rhs = rhs, cab_loc = loc })
1388 = checkValidTyFamEqn mb_clsinfo fam_tc tvs cvs typats rhs loc
1389
1390 -- | Do validity checks on a type family equation, including consistency
1391 -- with any enclosing class instance head, termination, and lack of
1392 -- polytypes.
1393 checkValidTyFamEqn :: Maybe ClsInfo
1394 -> TyCon -- ^ of the type family
1395 -> [TyVar] -- ^ bound tyvars in the equation
1396 -> [CoVar] -- ^ bound covars in the equation
1397 -> [Type] -- ^ type patterns
1398 -> Type -- ^ rhs
1399 -> SrcSpan
1400 -> TcM ()
1401 checkValidTyFamEqn mb_clsinfo fam_tc tvs cvs typats rhs loc
1402 = setSrcSpan loc $
1403 do { checkValidFamPats fam_tc tvs cvs typats
1404
1405 -- The argument patterns, and RHS, are all boxed tau types
1406 -- E.g Reject type family F (a :: k1) :: k2
1407 -- type instance F (forall a. a->a) = ...
1408 -- type instance F Int# = ...
1409 -- type instance F Int = forall a. a->a
1410 -- type instance F Int = Int#
1411 -- See Trac #9357
1412 ; env <- tcInitOpenTidyEnv (tyCoVarsOfTypes (rhs : typats))
1413 ; mapM_ checkValidMonoType typats
1414 ; mapM_ (check_lifted env) typats
1415 ; checkValidMonoType rhs
1416 ; check_lifted env rhs
1417
1418 -- We have a decidable instance unless otherwise permitted
1419 ; undecidable_ok <- xoptM LangExt.UndecidableInstances
1420 ; unless undecidable_ok $
1421 mapM_ addErrTc (checkFamInstRhs typats (tcTyFamInsts rhs))
1422
1423 -- Check that type patterns match the class instance head
1424 ; checkConsistentFamInst mb_clsinfo fam_tc tvs typats }
1425
1426 -- Make sure that each type family application is
1427 -- (1) strictly smaller than the lhs,
1428 -- (2) mentions no type variable more often than the lhs, and
1429 -- (3) does not contain any further type family instances.
1430 --
1431 checkFamInstRhs :: [Type] -- lhs
1432 -> [(TyCon, [Type])] -- type family instances
1433 -> [MsgDoc]
1434 checkFamInstRhs lhsTys famInsts
1435 = mapMaybe check famInsts
1436 where
1437 size = sizeTypes lhsTys
1438 fvs = fvTypes lhsTys
1439 check (tc, tys)
1440 | not (all isTyFamFree tys) = Just (nestedMsg what)
1441 | not (null bad_tvs) = Just (noMoreMsg bad_tvs what)
1442 | size <= sizeTypes tys = Just (smallerMsg what)
1443 | otherwise = Nothing
1444 where
1445 what = text "type family application" <+> quotes (pprType (TyConApp tc tys))
1446 bad_tvs = fvTypes tys \\ fvs
1447
1448 checkValidFamPats :: TyCon -> [TyVar] -> [CoVar] -> [Type] -> TcM ()
1449 -- Patterns in a 'type instance' or 'data instance' decl should
1450 -- a) contain no type family applications
1451 -- (vanilla synonyms are fine, though)
1452 -- b) properly bind all their free type variables
1453 -- e.g. we disallow (Trac #7536)
1454 -- type T a = Int
1455 -- type instance F (T a) = a
1456 -- c) Have the right number of patterns
1457 checkValidFamPats fam_tc tvs cvs ty_pats
1458 = do { -- A family instance must have exactly the same number of type
1459 -- parameters as the family declaration. You can't write
1460 -- type family F a :: * -> *
1461 -- type instance F Int y = y
1462 -- because then the type (F Int) would be like (\y.y)
1463 checkTc (length ty_pats == fam_arity) $
1464 wrongNumberOfParmsErr (fam_arity - count isInvisibleBinder fam_bndrs)
1465 -- report only explicit arguments
1466
1467 ; mapM_ checkTyFamFreeness ty_pats
1468 ; let unbound_tcvs = filterOut (`elemVarSet` exactTyCoVarsOfTypes ty_pats) (tvs ++ cvs)
1469 ; checkTc (null unbound_tcvs) (famPatErr fam_tc unbound_tcvs ty_pats) }
1470 where fam_arity = tyConArity fam_tc
1471 fam_bndrs = take fam_arity $ fst $ splitPiTys (tyConKind fam_tc)
1472
1473 wrongNumberOfParmsErr :: Arity -> SDoc
1474 wrongNumberOfParmsErr exp_arity
1475 = text "Number of parameters must match family declaration; expected"
1476 <+> ppr exp_arity
1477
1478 -- Ensure that no type family instances occur in a type.
1479 checkTyFamFreeness :: Type -> TcM ()
1480 checkTyFamFreeness ty
1481 = checkTc (isTyFamFree ty) $
1482 tyFamInstIllegalErr ty
1483
1484 -- Check that a type does not contain any type family applications.
1485 --
1486 isTyFamFree :: Type -> Bool
1487 isTyFamFree = null . tcTyFamInsts
1488
1489 -- Error messages
1490
1491 inaccessibleCoAxBranch :: CoAxiom br -> CoAxBranch -> SDoc
1492 inaccessibleCoAxBranch fi_ax cur_branch
1493 = text "Type family instance equation is overlapped:" $$
1494 nest 2 (pprCoAxBranch fi_ax cur_branch)
1495
1496 tyFamInstIllegalErr :: Type -> SDoc
1497 tyFamInstIllegalErr ty
1498 = hang (text "Illegal type synonym family application in instance" <>
1499 colon) 2 $
1500 ppr ty
1501
1502 nestedMsg :: SDoc -> SDoc
1503 nestedMsg what
1504 = sep [ text "Illegal nested" <+> what
1505 , parens undecidableMsg ]
1506
1507 famPatErr :: TyCon -> [TyVar] -> [Type] -> SDoc
1508 famPatErr fam_tc tvs pats
1509 = hang (text "Family instance purports to bind type variable" <> plural tvs
1510 <+> pprQuotedList tvs)
1511 2 (hang (text "but the real LHS (expanding synonyms) is:")
1512 2 (pprTypeApp fam_tc (map expandTypeSynonyms pats) <+>
1513 text "= ..."))
1514
1515 {-
1516 ************************************************************************
1517 * *
1518 Telescope checking
1519 * *
1520 ************************************************************************
1521
1522 Note [Bad telescopes]
1523 ~~~~~~~~~~~~~~~~~~~~~
1524 Now that we can mix type and kind variables, there are an awful lot of
1525 ways to shoot yourself in the foot. Here are some.
1526
1527 data SameKind :: k -> k -> * -- just to force unification
1528
1529 1. data T1 a k (b :: k) (x :: SameKind a b)
1530
1531 The problem here is that we discover that a and b should have the same
1532 kind. But this kind mentions k, which is bound *after* a.
1533 (Testcase: dependent/should_fail/BadTelescope)
1534
1535 2. data T2 a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d)
1536
1537 Note that b is not bound. Yet its kind mentions a. Because we have
1538 a nice rule that all implicitly bound variables come before others,
1539 this is bogus. (We could probably figure out to put b between a and c.
1540 But I think this is doing users a disservice, in the long run.)
1541 (Testcase: dependent/should_fail/BadTelescope4)
1542
1543 3. t3 :: forall a. (forall k (b :: k). SameKind a b) -> ()
1544
1545 This is a straightforward skolem escape. Note that a and b need to have
1546 the same kind.
1547 (Testcase: polykinds/T11142)
1548
1549 How do we deal with all of this? For TyCons, we have checkValidTyConTyVars.
1550 That function looks to see if any of the tyConTyVars are repeated, but
1551 it's really a telescope check. It works because all tycons are kind-generalized.
1552 If there is a bad telescope, the kind-generalization will end up generalizing
1553 over a variable bound later in the telescope.
1554
1555 For non-tycons, we do scope checking when we bring tyvars into scope,
1556 in tcImplicitTKBndrs and tcHsTyVarBndrs. Note that we also have to
1557 sort implicit binders into a well-scoped order whenever we have implicit
1558 binders to worry about. This is done in quantifyTyVars and in
1559 tcImplicitTKBndrs.
1560 -}
1561
1562 -- | Check a list of binders to see if they make a valid telescope.
1563 -- The key property we're checking for is scoping. For example:
1564 -- > data SameKind :: k -> k -> *
1565 -- > data X a k (b :: k) (c :: SameKind a b)
1566 -- Kind inference says that a's kind should be k. But that's impossible,
1567 -- because k isn't in scope when a is bound. This check has to come before
1568 -- general validity checking, because once we kind-generalise, this sort
1569 -- of problem is harder to spot (as we'll generalise over the unbound
1570 -- k in a's type.) See also Note [Bad telescopes].
1571 checkValidTelescope :: SDoc -- the original user-written telescope
1572 -> [TyVar] -- explicit vars (not necessarily zonked)
1573 -> SDoc -- note to put at bottom of message
1574 -> TcM () -- returns zonked tyvars
1575 checkValidTelescope hs_tvs orig_tvs extra
1576 = discardResult $ checkZonkValidTelescope hs_tvs orig_tvs extra
1577
1578 -- | Like 'checkZonkValidTelescope', but returns the zonked tyvars
1579 checkZonkValidTelescope :: SDoc
1580 -> [TyVar]
1581 -> SDoc
1582 -> TcM [TyVar]
1583 checkZonkValidTelescope hs_tvs orig_tvs extra
1584 = do { orig_tvs <- mapM zonkTyCoVarKind orig_tvs
1585 ; let (_, sorted_tidied_tvs) = tidyTyCoVarBndrs emptyTidyEnv $
1586 toposortTyVars orig_tvs
1587 ; unless (go [] emptyVarSet orig_tvs) $
1588 addErr $
1589 vcat [ hang (text "These kind and type variables:" <+> hs_tvs $$
1590 text "are out of dependency order. Perhaps try this ordering:")
1591 2 (sep (map pprTvBndr sorted_tidied_tvs))
1592 , extra ]
1593 ; return orig_tvs }
1594
1595 where
1596 go :: [TyVar] -- misplaced variables
1597 -> TyVarSet -> [TyVar] -> Bool
1598 go errs in_scope [] = null (filter (`elemVarSet` in_scope) errs)
1599 -- report an error only when the variable in the kind is brought
1600 -- into scope later in the telescope. Otherwise, we'll just quantify
1601 -- over it in kindGeneralize, as we should.
1602
1603 go errs in_scope (tv:tvs)
1604 = let bad_tvs = tyCoVarsOfType (tyVarKind tv) `minusVarSet` in_scope in
1605 go (varSetElems bad_tvs ++ errs) (in_scope `extendVarSet` tv) tvs
1606
1607 -- | After inferring kinds of type variables, check to make sure that the
1608 -- inferred kinds any of the type variables bound in a smaller scope.
1609 -- This is a skolem escape check. See also Note [Bad telescopes].
1610 checkValidInferredKinds :: [TyVar] -- ^ vars to check (zonked)
1611 -> TyVarSet -- ^ vars out of scope
1612 -> SDoc -- ^ suffix to error message
1613 -> TcM ()
1614 checkValidInferredKinds orig_kvs out_of_scope extra
1615 = do { let bad_pairs = [ (tv, kv)
1616 | kv <- orig_kvs
1617 , Just tv <- map (lookupVarSet out_of_scope)
1618 (tyCoVarsOfTypeList (tyVarKind kv)) ]
1619 report (tidyTyVarOcc env -> tv, tidyTyVarOcc env -> kv)
1620 = addErr $
1621 text "The kind of variable" <+>
1622 quotes (ppr kv) <> text ", namely" <+>
1623 quotes (ppr (tyVarKind kv)) <> comma $$
1624 text "depends on variable" <+>
1625 quotes (ppr tv) <+> text "from an inner scope" $$
1626 text "Perhaps bind" <+> quotes (ppr kv) <+>
1627 text "sometime after binding" <+>
1628 quotes (ppr tv) $$
1629 extra
1630 ; mapM_ report bad_pairs }
1631
1632 where
1633 (env1, _) = tidyTyCoVarBndrs emptyTidyEnv orig_kvs
1634 (env, _) = tidyTyCoVarBndrs env1 (varSetElems out_of_scope)
1635
1636 {-
1637 ************************************************************************
1638 * *
1639 \subsection{Auxiliary functions}
1640 * *
1641 ************************************************************************
1642 -}
1643
1644 -- Free variables of a type, retaining repetitions, and expanding synonyms
1645 fvType :: Type -> [TyCoVar]
1646 fvType ty | Just exp_ty <- coreView ty = fvType exp_ty
1647 fvType (TyVarTy tv) = [tv]
1648 fvType (TyConApp _ tys) = fvTypes tys
1649 fvType (LitTy {}) = []
1650 fvType (AppTy fun arg) = fvType fun ++ fvType arg
1651 fvType (ForAllTy bndr ty)
1652 = fvType (binderType bndr) ++
1653 caseBinder bndr (\tv -> filter (/= tv)) (const id) (fvType ty)
1654 fvType (CastTy ty co) = fvType ty ++ fvCo co
1655 fvType (CoercionTy co) = fvCo co
1656
1657 fvTypes :: [Type] -> [TyVar]
1658 fvTypes tys = concat (map fvType tys)
1659
1660 fvCo :: Coercion -> [TyCoVar]
1661 fvCo (Refl _ ty) = fvType ty
1662 fvCo (TyConAppCo _ _ args) = concatMap fvCo args
1663 fvCo (AppCo co arg) = fvCo co ++ fvCo arg
1664 fvCo (ForAllCo tv h co) = filter (/= tv) (fvCo co) ++ fvCo h
1665 fvCo (CoVarCo v) = [v]
1666 fvCo (AxiomInstCo _ _ args) = concatMap fvCo args
1667 fvCo (UnivCo p _ t1 t2) = fvProv p ++ fvType t1 ++ fvType t2
1668 fvCo (SymCo co) = fvCo co
1669 fvCo (TransCo co1 co2) = fvCo co1 ++ fvCo co2
1670 fvCo (NthCo _ co) = fvCo co
1671 fvCo (LRCo _ co) = fvCo co
1672 fvCo (InstCo co arg) = fvCo co ++ fvCo arg
1673 fvCo (CoherenceCo co1 co2) = fvCo co1 ++ fvCo co2
1674 fvCo (KindCo co) = fvCo co
1675 fvCo (SubCo co) = fvCo co
1676 fvCo (AxiomRuleCo _ cs) = concatMap fvCo cs
1677
1678 fvProv :: UnivCoProvenance -> [TyCoVar]
1679 fvProv UnsafeCoerceProv = []
1680 fvProv (PhantomProv co) = fvCo co
1681 fvProv (ProofIrrelProv co) = fvCo co
1682 fvProv (PluginProv _) = []
1683 fvProv (HoleProv h) = pprPanic "fvProv falls into a hole" (ppr h)
1684
1685 sizeType :: Type -> Int
1686 -- Size of a type: the number of variables and constructors
1687 sizeType ty | Just exp_ty <- coreView ty = sizeType exp_ty
1688 sizeType (TyVarTy {}) = 1
1689 sizeType (TyConApp _ tys) = sizeTypes tys + 1
1690 sizeType (LitTy {}) = 1
1691 sizeType (AppTy fun arg) = sizeType fun + sizeType arg
1692 sizeType (ForAllTy (Anon arg) res)
1693 = sizeType arg + sizeType res + 1
1694 sizeType (ForAllTy (Named {}) ty)
1695 = sizeType ty
1696 sizeType (CastTy ty _) = sizeType ty
1697 sizeType (CoercionTy _) = 1
1698
1699 sizeTypes :: [Type] -> Int
1700 sizeTypes = sum . map sizeType
1701
1702 -- Size of a predicate
1703 --
1704 -- We are considering whether class constraints terminate.
1705 -- Equality constraints and constraints for the implicit
1706 -- parameter class always termiante so it is safe to say "size 0".
1707 -- (Implicit parameter constraints always terminate because
1708 -- there are no instances for them---they are only solved by
1709 -- "local instances" in expressions).
1710 -- See Trac #4200.
1711 sizePred :: PredType -> Int
1712 sizePred ty = goClass ty
1713 where
1714 goClass p = go (classifyPredType p)
1715
1716 go (ClassPred cls tys')
1717 | isTerminatingClass cls = 0
1718 | otherwise = sizeTypes tys'
1719 go (EqPred {}) = 0
1720 go (IrredPred ty) = sizeType ty
1721
1722 -- | When this says "True", ignore this class constraint during
1723 -- a termination check
1724 isTerminatingClass :: Class -> Bool
1725 isTerminatingClass cls
1726 = isIPClass cls
1727 || cls `hasKey` typeableClassKey
1728 || cls `hasKey` coercibleTyConKey
1729 || cls `hasKey` eqTyConKey
1730 || cls `hasKey` heqTyConKey
1731
1732 -- | Tidy before printing a type
1733 ppr_tidy :: TidyEnv -> Type -> SDoc
1734 ppr_tidy env ty = pprType (tidyType env ty)