11 #include "HsVersions.h"
18 import Type( isTyVarTy )
32 import ListSetOps( equivClasses )
37 import StaticFlags( opt_PprStyle_Debug )
38 import Data.List( partition )
39 import Control.Monad( when, unless )
42 %************************************************************************
44 \section{Errors and contexts}
46 %************************************************************************
48 ToDo: for these error messages, should we note the location as coming
49 from the insts, or just whatever seems to be around in the monad just
53 reportUnsolved :: WantedConstraints -> TcM ()
58 = do { -- Zonk to un-flatten any flatten-skols
59 ; wanted <- zonkWC wanted
61 ; env0 <- tcInitTidyEnv
62 ; let tidy_env = tidyFreeTyVars env0 free_tvs
63 free_tvs = tyVarsOfWC wanted
64 err_ctxt = CEC { cec_encl = []
65 , cec_insol = insolubleWC wanted
67 , cec_tidy = tidy_env }
68 tidy_wanted = tidyWC tidy_env wanted
70 ; traceTc "reportUnsolved" (ppr tidy_wanted)
72 ; reportTidyWanteds err_ctxt tidy_wanted }
74 --------------------------------------------
76 --------------------------------------------
79 = CEC { cec_encl :: [Implication] -- Enclosing implications
82 , cec_extra :: SDoc -- Add this to each error message
83 , cec_insol :: Bool -- True <=> we are reporting insoluble errors only
84 -- Main effect: don't say "Cannot deduce..."
85 -- when reporting equality errors; see misMatchOrCND
88 reportTidyImplic :: ReportErrCtxt -> Implication -> TcM ()
89 reportTidyImplic ctxt implic
90 | BracketSkol <- ctLocOrigin (ic_loc implic)
91 , not insoluble -- For Template Haskell brackets report only
92 = return () -- definite errors. The whole thing will be re-checked
93 -- later when we plug it in, and meanwhile there may
94 -- certainly be un-satisfied constraints
97 = reportTidyWanteds ctxt' (ic_wanted implic)
99 insoluble = ic_insol implic
100 ctxt' = ctxt { cec_encl = implic : cec_encl ctxt
101 , cec_insol = insoluble }
103 reportTidyWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
104 reportTidyWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = implics })
105 | cec_insol ctxt -- If there are any insolubles, report only them
106 -- because they are unconditionally wrong
107 -- Moreover, if any of the insolubles are givens, stop right there
108 -- ignoring nested errors, because the code is inaccessible
109 = do { let (given, other) = partitionBag (isGiven . evVarX) insols
110 insol_implics = filterBag ic_insol implics
111 ; if isEmptyBag given
112 then do { mapBagM_ (reportInsoluble ctxt) other
113 ; mapBagM_ (reportTidyImplic ctxt) insol_implics }
114 else mapBagM_ (reportInsoluble ctxt) given }
116 | otherwise -- No insoluble ones
117 = ASSERT( isEmptyBag insols )
118 do { let (ambigs, non_ambigs) = partition is_ambiguous (bagToList flats)
119 (tv_eqs, others) = partition is_tv_eq non_ambigs
121 ; groupErrs (reportEqErrs ctxt) tv_eqs
122 ; when (null tv_eqs) $ groupErrs (reportFlat ctxt) others
123 ; mapBagM_ (reportTidyImplic ctxt) implics
125 -- Only report ambiguity if no other errors (at all) happened
126 -- See Note [Avoiding spurious errors] in TcSimplify
127 ; ifErrsM (return ()) $ reportAmbigErrs ctxt skols ambigs }
129 skols = foldr (unionVarSet . ic_skols) emptyVarSet (cec_encl ctxt)
131 -- Report equalities of form (a~ty) first. They are usually
132 -- skolem-equalities, and they cause confusing knock-on
133 -- effects in other errors; see test T4093b.
134 is_tv_eq c | EqPred ty1 ty2 <- evVarOfPred c
135 = tcIsTyVarTy ty1 || tcIsTyVarTy ty2
138 -- Treat it as "ambiguous" if
139 -- (a) it is a class constraint
140 -- (b) it constrains only type variables
141 -- (else we'd prefer to report it as "no instance for...")
142 -- (c) it mentions type variables that are not skolems
143 is_ambiguous d = isTyVarClassPred pred
144 && not (tyVarsOfPred pred `subVarSet` skols)
148 reportInsoluble :: ReportErrCtxt -> FlavoredEvVar -> TcM ()
149 reportInsoluble ctxt (EvVarX ev flav)
150 | EqPred ty1 ty2 <- evVarPred ev
151 = setCtFlavorLoc flav $
152 do { let ctxt2 = ctxt { cec_extra = cec_extra ctxt $$ inaccessible_msg }
153 ; reportEqErr ctxt2 ty1 ty2 }
155 = pprPanic "reportInsoluble" (pprEvVarWithType ev)
157 inaccessible_msg | Given loc <- flav
158 = hang (ptext (sLit "Inaccessible code in"))
159 2 (ppr (ctLocOrigin loc))
162 reportFlat :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
163 -- The [PredType] are already tidied
164 reportFlat ctxt flats origin
165 = do { unless (null dicts) $ reportDictErrs ctxt dicts origin
166 ; unless (null eqs) $ reportEqErrs ctxt eqs origin
167 ; unless (null ips) $ reportIPErrs ctxt ips origin
168 ; ASSERT( null others ) return () }
170 (dicts, non_dicts) = partition isClassPred flats
171 (eqs, non_eqs) = partition isEqPred non_dicts
172 (ips, others) = partition isIPPred non_eqs
174 --------------------------------------------
176 --------------------------------------------
178 groupErrs :: ([PredType] -> CtOrigin -> TcM ()) -- Deal with one group
179 -> [WantedEvVar] -- Unsolved wanteds
181 -- Group together insts with the same origin
182 -- We want to report them together in error messages
186 groupErrs report_err (wanted : wanteds)
187 = do { setCtLoc the_loc $
188 report_err the_vars (ctLocOrigin the_loc)
189 ; groupErrs report_err others }
191 the_loc = evVarX wanted
192 the_key = mk_key the_loc
193 the_vars = map evVarOfPred (wanted:friends)
194 (friends, others) = partition is_friend wanteds
195 is_friend friend = mk_key (evVarX friend) `same_key` the_key
197 mk_key :: WantedLoc -> (SrcSpan, CtOrigin)
198 mk_key loc = (ctLocSpan loc, ctLocOrigin loc)
200 same_key (s1, o1) (s2, o2) = s1==s2 && o1 `same_orig` o2
201 same_orig (OccurrenceOf n1) (OccurrenceOf n2) = n1==n2
202 same_orig ScOrigin ScOrigin = True
203 same_orig DerivOrigin DerivOrigin = True
204 same_orig DefaultOrigin DefaultOrigin = True
205 same_orig _ _ = False
208 -- Add the "arising from..." part to a message about bunch of dicts
209 addArising :: CtOrigin -> SDoc -> SDoc
210 addArising orig msg = msg $$ nest 2 (pprArising orig)
212 pprWithArising :: [WantedEvVar] -> (WantedLoc, SDoc)
213 -- Print something like
214 -- (Eq a) arising from a use of x at y
215 -- (Show a) arising from a use of p at q
216 -- Also return a location for the error message
218 = panic "pprWithArising"
219 pprWithArising [EvVarX ev loc]
220 = (loc, pprEvVarTheta [ev] <+> pprArising (ctLocOrigin loc))
221 pprWithArising ev_vars
222 = (first_loc, vcat (map ppr_one ev_vars))
224 first_loc = evVarX (head ev_vars)
225 ppr_one (EvVarX v loc)
226 = parens (pprPred (evVarPred v)) <+> pprArisingAt loc
228 addErrorReport :: ReportErrCtxt -> SDoc -> TcM ()
229 addErrorReport ctxt msg = addErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt)
231 pprErrCtxtLoc :: ReportErrCtxt -> SDoc
233 = case map (ctLocOrigin . ic_loc) (cec_encl ctxt) of
234 [] -> ptext (sLit "the top level") -- Should not happen
235 (orig:origs) -> ppr_skol orig $$
236 vcat [ ptext (sLit "or") <+> ppr_skol orig | orig <- origs ]
238 ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc)
239 ppr_skol skol_info = ppr skol_info
241 getUserGivens :: ReportErrCtxt -> [([EvVar], GivenLoc)]
242 -- One item for each enclosing implication
243 getUserGivens (CEC {cec_encl = ctxt})
245 [ (givens', loc) | Implic {ic_given = givens, ic_loc = loc} <- ctxt
246 , let givens' = get_user_givens givens
247 , not (null givens') ]
249 get_user_givens givens | opt_PprStyle_Debug = givens
250 | otherwise = filterOut isSilentEvVar givens
251 -- In user mode, don't show the "silent" givens, used for
252 -- the "self" dictionary and silent superclass arguments for dfuns
257 %************************************************************************
259 Implicit parameter errors
261 %************************************************************************
264 reportIPErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
265 reportIPErrs ctxt ips orig
266 = addErrorReport ctxt msg
268 givens = getUserGivens ctxt
271 sep [ ptext (sLit "Unbound implicit parameter") <> plural ips
272 , nest 2 (pprTheta ips) ]
274 = couldNotDeduce givens (ips, orig)
278 %************************************************************************
282 %************************************************************************
285 reportEqErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
286 -- The [PredType] are already tidied
287 reportEqErrs ctxt eqs orig
288 = do { orig' <- zonkTidyOrigin ctxt orig
289 ; mapM_ (report_one orig') eqs }
291 report_one orig (EqPred ty1 ty2)
292 = do { let extra = getWantedEqExtra orig ty1 ty2
293 ctxt' = ctxt { cec_extra = extra $$ cec_extra ctxt }
294 ; reportEqErr ctxt' ty1 ty2 }
296 = pprPanic "reportEqErrs" (ppr pred)
298 getWantedEqExtra :: CtOrigin -> TcType -> TcType -> SDoc
299 getWantedEqExtra (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp }))
301 -- If the types in the error message are the same as the types we are unifying,
302 -- don't add the extra expected/actual message
303 | act `tcEqType` ty1 && exp `tcEqType` ty2 = empty
304 | exp `tcEqType` ty1 && act `tcEqType` ty2 = empty
305 | otherwise = mkExpectedActualMsg act exp
307 getWantedEqExtra orig _ _ = pprArising orig
309 reportEqErr :: ReportErrCtxt -> TcType -> TcType -> TcM ()
310 -- ty1 and ty2 are already tidied
311 reportEqErr ctxt ty1 ty2
312 | Just tv1 <- tcGetTyVar_maybe ty1 = reportTyVarEqErr ctxt tv1 ty2
313 | Just tv2 <- tcGetTyVar_maybe ty2 = reportTyVarEqErr ctxt tv2 ty1
315 | otherwise -- Neither side is a type variable
316 -- Since the unsolved constraint is canonical,
317 -- it must therefore be of form (F tys ~ ty)
318 = addErrorReport ctxt (misMatchOrCND ctxt ty1 ty2 $$ mkTyFunInfoMsg ty1 ty2)
321 reportTyVarEqErr :: ReportErrCtxt -> TcTyVar -> TcType -> TcM ()
322 -- tv1 and ty2 are already tidied
323 reportTyVarEqErr ctxt tv1 ty2
324 | isSkolemTyVar tv1 -- ty2 won't be a meta-tyvar, or else the thing would
325 -- be oriented the other way round; see TcCanonical.reOrient
326 || isSigTyVar tv1 && not (isTyVarTy ty2)
327 = addErrorReport (addExtraInfo ctxt ty1 ty2)
328 (misMatchOrCND ctxt ty1 ty2)
330 -- So tv is a meta tyvar, and presumably it is
331 -- an *untouchable* meta tyvar, else it'd have been unified
332 | not (k2 `isSubKind` k1) -- Kind error
333 = addErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2)
336 | tv1 `elemVarSet` tyVarsOfType ty2
337 = let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:") 2
338 (sep [ppr ty1, char '=', ppr ty2])
339 in addErrorReport ctxt occCheckMsg
341 -- Check for skolem escape
342 | (implic:_) <- cec_encl ctxt -- Get the innermost context
343 , let esc_skols = varSetElems (tyVarsOfType ty2 `intersectVarSet` ic_skols implic)
344 implic_loc = ic_loc implic
345 , not (null esc_skols)
346 = setCtLoc implic_loc $ -- Override the error message location from the
347 -- place the equality arose to the implication site
348 do { (env1, env_sigs) <- findGlobals ctxt (unitVarSet tv1)
349 ; let msg = misMatchMsg ty1 ty2
350 esc_doc = sep [ ptext (sLit "because type variable") <> plural esc_skols
351 <+> pprQuotedList esc_skols
352 , ptext (sLit "would escape") <+>
353 if isSingleton esc_skols then ptext (sLit "its scope")
354 else ptext (sLit "their scope") ]
355 extra1 = vcat [ nest 2 $ esc_doc
356 , sep [ (if isSingleton esc_skols
357 then ptext (sLit "This (rigid, skolem) type variable is")
358 else ptext (sLit "These (rigid, skolem) type variables are"))
359 <+> ptext (sLit "bound by")
360 , nest 2 $ ppr (ctLocOrigin implic_loc) ] ]
361 ; addErrTcM (env1, msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) }
363 -- Nastiest case: attempt to unify an untouchable variable
364 | (implic:_) <- cec_encl ctxt -- Get the innermost context
365 , let implic_loc = ic_loc implic
366 given = ic_given implic
367 = setCtLoc (ic_loc implic) $
368 do { let msg = misMatchMsg ty1 ty2
369 extra = quotes (ppr tv1)
370 <+> sep [ ptext (sLit "is untouchable")
371 , ptext (sLit "inside the constraints") <+> pprEvVarTheta given
372 , ptext (sLit "bound at") <+> ppr (ctLocOrigin implic_loc)]
373 ; addErrorReport (addExtraInfo ctxt ty1 ty2) (msg $$ nest 2 extra) }
376 = pprTrace "reportTyVarEqErr" (ppr tv1 $$ ppr ty2 $$ ppr (cec_encl ctxt)) $
378 -- I don't think this should happen, and if it does I want to know
379 -- Trac #5130 happened because an actual type error was not
380 -- reported at all! So not reporting is pretty dangerous.
382 -- OLD, OUT OF DATE COMMENT
383 -- This can happen, by a recursive decomposition of frozen
384 -- occurs check constraints
385 -- Example: alpha ~ T Int alpha has frozen.
386 -- Then alpha gets unified to T beta gamma
387 -- So now we have T beta gamma ~ T Int (T beta gamma)
388 -- Decompose to (beta ~ Int, gamma ~ T beta gamma)
389 -- The (gamma ~ T beta gamma) is the occurs check, but
390 -- the (beta ~ Int) isn't an error at all. So return ()
396 mkTyFunInfoMsg :: TcType -> TcType -> SDoc
397 -- See Note [Non-injective type functions]
398 mkTyFunInfoMsg ty1 ty2
399 | Just (tc1,_) <- tcSplitTyConApp_maybe ty1
400 , Just (tc2,_) <- tcSplitTyConApp_maybe ty2
401 , tc1 == tc2, isSynFamilyTyCon tc1
402 = ptext (sLit "NB:") <+> quotes (ppr tc1)
403 <+> ptext (sLit "is a type function") <> (pp_inj tc1)
406 pp_inj tc | isInjectiveTyCon tc = empty
407 | otherwise = ptext (sLit (", and may not be injective"))
409 misMatchOrCND :: ReportErrCtxt -> TcType -> TcType -> SDoc
410 misMatchOrCND ctxt ty1 ty2
411 | cec_insol ctxt = misMatchMsg ty1 ty2 -- If the equality is unconditionally
412 -- insoluble, don't report the context
413 | null givens = misMatchMsg ty1 ty2
414 | otherwise = couldNotDeduce givens ([EqPred ty1 ty2], orig)
416 givens = getUserGivens ctxt
417 orig = TypeEqOrigin (UnifyOrigin ty1 ty2)
419 couldNotDeduce :: [([EvVar], GivenLoc)] -> (ThetaType, CtOrigin) -> SDoc
420 couldNotDeduce givens (wanteds, orig)
421 = vcat [ hang (ptext (sLit "Could not deduce") <+> pprTheta wanteds)
428 (g:gs) -> ppr_given (ptext (sLit "from the context")) g
429 : map (ppr_given (ptext (sLit "or from"))) gs
431 ppr_given herald (gs,loc)
432 = hang (herald <+> pprEvVarTheta gs)
433 2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin loc)
434 , ptext (sLit "at") <+> ppr (ctLocSpan loc)])
436 addExtraInfo :: ReportErrCtxt -> TcType -> TcType -> ReportErrCtxt
437 -- Add on extra info about the types themselves
438 -- NB: The types themselves are already tidied
439 addExtraInfo ctxt ty1 ty2
440 = ctxt { cec_extra = nest 2 (extra1 $$ extra2) $$ cec_extra ctxt }
442 extra1 = typeExtraInfoMsg (cec_encl ctxt) ty1
443 extra2 = typeExtraInfoMsg (cec_encl ctxt) ty2
445 misMatchMsg :: TcType -> TcType -> SDoc -- Types are already tidy
446 misMatchMsg ty1 ty2 = sep [ ptext (sLit "Couldn't match type") <+> quotes (ppr ty1)
447 , nest 15 $ ptext (sLit "with") <+> quotes (ppr ty2)]
449 kindErrorMsg :: TcType -> TcType -> SDoc -- Types are already tidy
451 = vcat [ ptext (sLit "Kind incompatibility when matching types:")
452 , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1
453 , ppr ty2 <+> dcolon <+> ppr k2 ]) ]
458 typeExtraInfoMsg :: [Implication] -> Type -> SDoc
459 -- Shows a bit of extra info about skolem constants
460 typeExtraInfoMsg implics ty
461 | Just tv <- tcGetTyVar_maybe ty
464 = pprSkolTvBinding implics tv
466 typeExtraInfoMsg _ _ = empty -- Normal case
469 unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc)
470 unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env
471 = do { (env1, act_ty') <- zonkTidyTcType tidy_env act_ty
472 ; (env2, exp_ty') <- zonkTidyTcType env1 exp_ty
473 ; return (env2, mkExpectedActualMsg act_ty' exp_ty') }
475 mkExpectedActualMsg :: Type -> Type -> SDoc
476 mkExpectedActualMsg act_ty exp_ty
477 = vcat [ text "Expected type" <> colon <+> ppr exp_ty
478 , text " Actual type" <> colon <+> ppr act_ty ]
481 Note [Non-injective type functions]
482 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
483 It's very confusing to get a message like
484 Couldn't match expected type `Depend s'
485 against inferred type `Depend s1'
486 so mkTyFunInfoMsg adds:
487 NB: `Depend' is type function, and hence may not be injective
489 Warn of loopy local equalities that were dropped.
492 %************************************************************************
496 %************************************************************************
499 reportDictErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
500 reportDictErrs ctxt wanteds orig
501 = do { inst_envs <- tcGetInstEnvs
502 ; non_overlaps <- mapMaybeM (reportOverlap ctxt inst_envs orig) wanteds
503 ; unless (null non_overlaps) $
504 addErrorReport ctxt (mk_no_inst_err non_overlaps) }
506 mk_no_inst_err :: [PredType] -> SDoc
507 mk_no_inst_err wanteds
508 | null givens -- Top level
509 = vcat [ addArising orig $
510 ptext (sLit "No instance") <> plural min_wanteds
511 <+> ptext (sLit "for") <+> pprTheta min_wanteds
512 , show_fixes (fixes2 ++ fixes3) ]
515 = vcat [ couldNotDeduce givens (min_wanteds, orig)
516 , show_fixes (fix1 : (fixes2 ++ fixes3)) ]
518 givens = getUserGivens ctxt
519 min_wanteds = mkMinimalBySCs wanteds
520 fix1 = sep [ ptext (sLit "add") <+> pprTheta min_wanteds
521 <+> ptext (sLit "to the context of")
522 , nest 2 $ pprErrCtxtLoc ctxt ]
524 fixes2 = case instance_dicts of
526 [_] -> [sep [ptext (sLit "add an instance declaration for"),
527 pprTheta instance_dicts]]
528 _ -> [sep [ptext (sLit "add instance declarations for"),
529 pprTheta instance_dicts]]
530 fixes3 = case orig of
531 DerivOrigin -> [drv_fix]
534 instance_dicts = filterOut isTyVarClassPred min_wanteds
535 -- Insts for which it is worth suggesting an adding an
536 -- instance declaration. Exclude tyvar dicts.
538 drv_fix = vcat [ptext (sLit "use a standalone 'deriving instance' declaration,"),
539 nest 2 $ ptext (sLit "so you can specify the instance context yourself")]
541 show_fixes :: [SDoc] -> SDoc
542 show_fixes [] = empty
543 show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"),
544 nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
546 reportOverlap :: ReportErrCtxt -> (InstEnv,InstEnv) -> CtOrigin
547 -> PredType -> TcM (Maybe PredType)
548 -- Report an overlap error if this class constraint results
549 -- from an overlap (returning Nothing), otherwise return (Just pred)
550 reportOverlap ctxt inst_envs orig pred@(ClassP clas tys)
551 = do { tys_flat <- mapM quickFlattenTy tys
552 -- Note [Flattening in error message generation]
554 ; case lookupInstEnv inst_envs clas tys_flat of
555 ([], _) -> return (Just pred) -- No match
556 -- The case of exactly one match and no unifiers means a
557 -- successful lookup. That can't happen here, because dicts
558 -- only end up here if they didn't match in Inst.lookupInst
560 | debugIsOn -> pprPanic "check_overlap" (ppr pred)
561 res -> do { addErrorReport ctxt (mk_overlap_msg res)
564 mk_overlap_msg (matches, unifiers)
565 = ASSERT( not (null matches) )
566 vcat [ addArising orig (ptext (sLit "Overlapping instances for")
568 , sep [ptext (sLit "Matching instances") <> colon,
569 nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
570 , if not (isSingleton matches)
571 then -- Two or more matches
573 else -- One match, plus some unifiers
574 ASSERT( not (null unifiers) )
575 parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
576 quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
577 ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
578 ptext (sLit "when compiling the other instance declarations")])]
580 ispecs = [ispec | (ispec, _) <- matches]
582 reportOverlap _ _ _ _ = panic "reportOverlap" -- Not a ClassP
584 ----------------------
585 quickFlattenTy :: TcType -> TcM TcType
586 -- See Note [Flattening in error message generation]
587 quickFlattenTy ty | Just ty' <- tcView ty = quickFlattenTy ty'
588 quickFlattenTy ty@(TyVarTy {}) = return ty
589 quickFlattenTy ty@(ForAllTy {}) = return ty -- See
590 quickFlattenTy ty@(PredTy {}) = return ty -- Note [Quick-flatten polytypes]
591 -- Don't flatten because of the danger or removing a bound variable
592 quickFlattenTy (AppTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
593 ; fy2 <- quickFlattenTy ty2
594 ; return (AppTy fy1 fy2) }
595 quickFlattenTy (FunTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
596 ; fy2 <- quickFlattenTy ty2
597 ; return (FunTy fy1 fy2) }
598 quickFlattenTy (TyConApp tc tys)
599 | not (isSynFamilyTyCon tc)
600 = do { fys <- mapM quickFlattenTy tys
601 ; return (TyConApp tc fys) }
603 = do { let (funtys,resttys) = splitAt (tyConArity tc) tys
604 -- Ignore the arguments of the type family funtys
605 ; v <- newMetaTyVar TauTv (typeKind (TyConApp tc funtys))
606 ; flat_resttys <- mapM quickFlattenTy resttys
607 ; return (foldl AppTy (mkTyVarTy v) flat_resttys) }
610 Note [Flattening in error message generation]
611 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
612 Consider (C (Maybe (F x))), where F is a type function, and we have
614 C (Maybe Int) and C (Maybe a)
615 Since (F x) might turn into Int, this is an overlap situation, and
616 indeed (because of flattening) the main solver will have refrained
617 from solving. But by the time we get to error message generation, we've
618 un-flattened the constraint. So we must *re*-flatten it before looking
619 up in the instance environment, lest we only report one matching
620 instance when in fact there are two.
622 Re-flattening is pretty easy, because we don't need to keep track of
623 evidence. We don't re-use the code in TcCanonical because that's in
624 the TcS monad, and we are in TcM here.
626 Note [Quick-flatten polytypes]
627 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
628 If we see C (Ix a => blah) or C (forall a. blah) we simply refrain from
629 flattening any further. After all, there can be no instance declarations
630 that match such things. And flattening under a for-all is problematic
631 anyway; consider C (forall a. F a)
634 reportAmbigErrs :: ReportErrCtxt -> TcTyVarSet -> [WantedEvVar] -> TcM ()
635 reportAmbigErrs ctxt skols ambigs
636 -- Divide into groups that share a common set of ambiguous tyvars
637 = mapM_ report (equivClasses cmp ambigs_w_tvs)
639 ambigs_w_tvs = [ (d, varSetElems (tyVarsOfEvVarX d `minusVarSet` skols))
641 cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2
643 report :: [(WantedEvVar, [TcTyVar])] -> TcM ()
646 do { let main_msg = sep [ text "Ambiguous type variable" <> plural tvs
647 <+> pprQuotedList tvs
648 <+> text "in the constraint" <> plural pairs <> colon
649 , nest 2 pp_wanteds ]
650 ; (tidy_env, mono_msg) <- mkMonomorphismMsg ctxt tvs
651 ; addErrTcM (tidy_env, main_msg $$ mono_msg) }
654 (loc, pp_wanteds) = pprWithArising (map fst pairs)
656 mkMonomorphismMsg :: ReportErrCtxt -> [TcTyVar] -> TcM (TidyEnv, SDoc)
657 -- There's an error with these Insts; if they have free type variables
658 -- it's probably caused by the monomorphism restriction.
659 -- Try to identify the offending variable
660 -- ASSUMPTION: the Insts are fully zonked
661 mkMonomorphismMsg ctxt inst_tvs
662 = do { dflags <- getDOpts
663 ; traceTc "Mono" (vcat (map (pprSkolTvBinding (cec_encl ctxt)) inst_tvs))
664 ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
665 ; return (tidy_env, mk_msg dflags docs) }
667 mk_msg _ _ | any isRuntimeUnkSkol inst_tvs -- See Note [Runtime skolems]
668 = vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+>
669 (pprWithCommas ppr inst_tvs),
670 ptext (sLit "Use :print or :force to determine these types")]
671 mk_msg _ [] = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)")
672 -- This happens in things like
673 -- f x = show (read "foo")
674 -- where monomorphism doesn't play any role
676 = vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"),
678 monomorphism_fix dflags]
680 monomorphism_fix :: DynFlags -> SDoc
681 monomorphism_fix dflags
682 = ptext (sLit "Probable fix:") <+> vcat
683 [ptext (sLit "give these definition(s) an explicit type signature"),
684 if xopt Opt_MonomorphismRestriction dflags
685 then ptext (sLit "or use -XNoMonomorphismRestriction")
686 else empty] -- Only suggest adding "-XNoMonomorphismRestriction"
687 -- if it is not already set!
690 pprSkolTvBinding :: [Implication] -> TcTyVar -> SDoc
691 -- Print info about the binding of a skolem tyvar,
692 -- or nothing if we don't have anything useful to say
693 pprSkolTvBinding implics tv
694 | isTcTyVar tv = quotes (ppr tv) <+> ppr_details (tcTyVarDetails tv)
695 | otherwise = quotes (ppr tv) <+> ppr_skol (getSkolemInfo implics tv)
697 ppr_details (SkolemTv {}) = ppr_skol (getSkolemInfo implics tv)
698 ppr_details (FlatSkol {}) = ptext (sLit "is a flattening type variable")
699 ppr_details (RuntimeUnk {}) = ptext (sLit "is an interactive-debugger skolem")
700 ppr_details (MetaTv (SigTv n) _) = ptext (sLit "is bound by the type signature for")
702 ppr_details (MetaTv _ _) = ptext (sLit "is a meta type variable")
705 ppr_skol UnkSkol = ptext (sLit "is an unknown type variable") -- Unhelpful
706 ppr_skol RuntimeUnkSkol = ptext (sLit "is an unknown runtime type")
707 ppr_skol info = sep [ptext (sLit "is a rigid type variable bound by"),
709 ptext (sLit "at") <+> ppr (getSrcLoc tv)]]
711 getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo
713 = WARN( True, ptext (sLit "No skolem info:") <+> ppr tv )
715 getSkolemInfo (implic:implics) tv
716 | tv `elemVarSet` ic_skols implic = ctLocOrigin (ic_loc implic)
717 | otherwise = getSkolemInfo implics tv
719 -----------------------
720 -- findGlobals looks at the value environment and finds values whose
721 -- types mention any of the offending type variables. It has to be
722 -- careful to zonk the Id's type first, so it has to be in the monad.
723 -- We must be careful to pass it a zonked type variable, too.
725 mkEnvSigMsg :: SDoc -> [SDoc] -> SDoc
726 mkEnvSigMsg what env_sigs
727 | null env_sigs = empty
728 | otherwise = vcat [ ptext (sLit "The following variables have types that mention") <+> what
729 , nest 2 (vcat env_sigs) ]
731 findGlobals :: ReportErrCtxt
733 -> TcM (TidyEnv, [SDoc])
736 = do { lcl_ty_env <- case cec_encl ctxt of
738 (i:_) -> return (ic_env i)
739 ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) }
741 go tidy_env acc [] = return (tidy_env, acc)
742 go tidy_env acc (thing : things) = do
743 (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing
745 Just d -> go tidy_env1 (d:acc) things
746 Nothing -> go tidy_env1 acc things
748 ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
750 -----------------------
751 find_thing :: TidyEnv -> (TcType -> Bool)
752 -> TcTyThing -> TcM (TidyEnv, Maybe SDoc)
753 find_thing tidy_env ignore_it (ATcId { tct_id = id })
754 = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id)
755 ; if ignore_it tidy_ty then
756 return (tidy_env, Nothing)
758 { let msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty
759 , nest 2 (parens (ptext (sLit "bound at") <+>
760 ppr (getSrcLoc id)))]
761 ; return (tidy_env', Just msg) } }
763 find_thing tidy_env ignore_it (ATyVar tv ty)
764 = do { (tidy_env1, tidy_ty) <- zonkTidyTcType tidy_env ty
765 ; if ignore_it tidy_ty then
766 return (tidy_env, Nothing)
768 { let -- The name tv is scoped, so we don't need to tidy it
769 msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff
772 eq_stuff | Just tv' <- tcGetTyVar_maybe tidy_ty
773 , getOccName tv == getOccName tv' = empty
774 | otherwise = equals <+> ppr tidy_ty
775 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
776 bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv)
778 ; return (tidy_env1, Just msg) } }
780 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
782 warnDefaulting :: [FlavoredEvVar] -> Type -> TcM ()
783 warnDefaulting wanteds default_ty
784 = do { warn_default <- doptM Opt_WarnTypeDefaults
785 ; env0 <- tcInitTidyEnv
786 ; let wanted_bag = listToBag wanteds
787 tidy_env = tidyFreeTyVars env0 $
788 tyVarsOfEvVarXs wanted_bag
789 tidy_wanteds = mapBag (tidyFlavoredEvVar tidy_env) wanted_bag
790 (loc, ppr_wanteds) = pprWithArising (map get_wev (bagToList tidy_wanteds))
791 warn_msg = hang (ptext (sLit "Defaulting the following constraint(s) to type")
792 <+> quotes (ppr default_ty))
794 ; setCtLoc loc $ warnTc warn_default warn_msg }
796 get_wev (EvVarX ev (Wanted loc)) = EvVarX ev loc -- Yuk
797 get_wev ev = pprPanic "warnDefaulting" (ppr ev)
800 Note [Runtime skolems]
801 ~~~~~~~~~~~~~~~~~~~~~~
802 We want to give a reasonably helpful error message for ambiguity
803 arising from *runtime* skolems in the debugger. These
804 are created by in RtClosureInspect.zonkRTTIType.
806 %************************************************************************
808 Error from the canonicaliser
809 These ones are called *during* constraint simplification
811 %************************************************************************
814 solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a
815 solverDepthErrorTcS depth stack
816 | null stack -- Shouldn't happen unless you say -fcontext-stack=0
817 = wrapErrTcS $ failWith msg
820 setCtFlavorLoc (cc_flavor top_item) $
821 do { ev_vars <- mapM (zonkEvVar . cc_id) stack
822 ; env0 <- tcInitTidyEnv
823 ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfEvVars ev_vars)
824 tidy_ev_vars = map (tidyEvVar tidy_env) ev_vars
825 ; failWithTcM (tidy_env, hang msg 2 (pprEvVars tidy_ev_vars)) }
827 top_item = head stack
828 msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
829 , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
831 flattenForAllErrorTcS :: CtFlavor -> TcType -> Bag CanonicalCt -> TcS a
832 flattenForAllErrorTcS fl ty _bad_eqs
835 do { env0 <- tcInitTidyEnv
836 ; let (env1, ty') = tidyOpenType env0 ty
837 msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:")
839 ; failWithTcM (env1, msg) }
842 %************************************************************************
846 %************************************************************************
849 setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
850 setCtFlavorLoc (Wanted loc) thing = setCtLoc loc thing
851 setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing
852 setCtFlavorLoc (Given loc) thing = setCtLoc loc thing
855 %************************************************************************
859 %************************************************************************
862 zonkTidyTcType :: TidyEnv -> TcType -> TcM (TidyEnv, TcType)
863 zonkTidyTcType env ty = do { ty' <- zonkTcType ty
864 ; return (tidyOpenType env ty') }
866 zonkTidyOrigin :: ReportErrCtxt -> CtOrigin -> TcM CtOrigin
867 zonkTidyOrigin ctxt (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp }))
868 = do { (env1, act') <- zonkTidyTcType (cec_tidy ctxt) act
869 ; (_env2, exp') <- zonkTidyTcType env1 exp
870 ; return (TypeEqOrigin (UnifyOrigin { uo_actual = act', uo_expected = exp' })) }
871 -- Drop the returned env on the floor; we may conceivably thereby get
872 -- inconsistent naming between uses of this function
873 zonkTidyOrigin _ orig = return orig