More error message wibbles
[ghc.git] / compiler / typecheck / TcErrors.lhs
1 \begin{code}
2 module TcErrors( 
3        reportUnsolved, reportUnsolvedImplication, reportUnsolvedDeriv,
4        reportUnsolvedWantedEvVars, warnDefaulting, 
5        unifyCtxt, typeExtraInfoMsg, 
6        kindErrorTcS, misMatchErrorTcS, flattenForAllErrorTcS,
7        occursCheckErrorTcS, solverDepthErrorTcS
8   ) where
9
10 #include "HsVersions.h"
11
12 import TcRnMonad
13 import TcMType
14 import TcSMonad
15 import TcType
16 import Inst
17 import InstEnv
18
19 import TyCon
20 import Name
21 import NameEnv
22 import Id       ( idType )
23 import HsExpr   ( pprMatchContext )
24 import Var
25 import VarSet
26 import VarEnv
27 import SrcLoc
28 import Bag
29 import ListSetOps( equivClasses )
30 import Util
31 import Unique
32 import FastString
33 import Outputable
34 import DynFlags
35 import StaticFlags( opt_PprStyle_Debug )
36 import Data.List( partition )
37 import Control.Monad( unless )
38 \end{code}
39
40 %************************************************************************
41 %*                                                                      *
42 \section{Errors and contexts}
43 %*                                                                      *
44 %************************************************************************
45
46 ToDo: for these error messages, should we note the location as coming
47 from the insts, or just whatever seems to be around in the monad just
48 now?
49
50 \begin{code}
51 reportUnsolved :: (CanonicalCts, Bag Implication) -> TcM ()
52 reportUnsolved (unsolved_flats, unsolved_implics)
53   | isEmptyBag unsolved
54   = return ()
55   | otherwise
56   = do { env0 <- tcInitTidyEnv
57        ; let tidy_env      = tidyFreeTyVars env0 (tyVarsOfWanteds unsolved)
58              tidy_unsolved = tidyWanteds tidy_env unsolved
59              err_ctxt = CEC { cec_encl = [] 
60                             , cec_extra = empty
61                             , cec_tidy = tidy_env } 
62        ; traceTc "reportUnsolved" (ppr unsolved)
63        ; reportTidyWanteds err_ctxt tidy_unsolved }
64   where
65     unsolved = mkWantedConstraints unsolved_flats unsolved_implics
66
67 reportUnsolvedWantedEvVars :: Bag WantedEvVar -> TcM ()
68 reportUnsolvedWantedEvVars wanteds
69   | isEmptyBag wanteds 
70   = return ()
71   | otherwise
72   = do { env0 <- tcInitTidyEnv
73        ; let tidy_env      = tidyFreeTyVars env0 (tyVarsOfWantedEvVars wanteds)
74              tidy_unsolved = tidyWantedEvVars tidy_env wanteds
75              err_ctxt = CEC { cec_encl  = [] 
76                             , cec_extra = empty
77                             , cec_tidy  = tidy_env } 
78        ; groupErrs (reportFlat err_ctxt) (bagToList tidy_unsolved) }
79
80 reportUnsolvedDeriv :: [PredType] -> WantedLoc -> TcM ()
81 reportUnsolvedDeriv unsolved loc
82   | null unsolved
83   = return ()
84   | otherwise
85   = setCtLoc loc $
86     do { env0 <- tcInitTidyEnv
87        ; let tidy_env      = tidyFreeTyVars env0 (tyVarsOfTheta unsolved)
88              tidy_unsolved = map (tidyPred tidy_env) unsolved
89              err_ctxt = CEC { cec_encl  = [] 
90                             , cec_extra = alt_fix
91                             , cec_tidy  = tidy_env } 
92        ; reportFlat err_ctxt tidy_unsolved (ctLocOrigin loc) }
93   where
94     alt_fix = vcat [ptext (sLit "Alternatively, use a standalone 'deriving instance' declaration,"),
95                     nest 2 $ ptext (sLit "so you can specify the instance context yourself")]
96
97 reportUnsolvedImplication :: Implication -> TcM ()
98 reportUnsolvedImplication implic
99   = do { env0 <- tcInitTidyEnv
100        ; let tidy_env    = tidyFreeTyVars env0 (tyVarsOfImplication implic)
101              tidy_implic = tidyImplication tidy_env implic
102              new_tidy_env = foldNameEnv add tidy_env (ic_env implic)
103              err_ctxt = CEC { cec_encl = [tidy_implic]
104                             , cec_extra = empty
105                             , cec_tidy = new_tidy_env } 
106        ; reportTidyWanteds err_ctxt (ic_wanted tidy_implic) }
107   where
108     -- Extend the tidy env with a mapping from tyvars to the
109     -- names the user originally used.  At the moment we do this
110     -- from the type env, but it might be better to record the
111     -- scoped type variable in the Implication.  Urgh.
112     add (ATyVar name ty) (occ_env, var_env)
113        | Just tv <- tcGetTyVar_maybe ty
114        , not (getUnique name `elemVarEnvByKey` var_env)
115        = case tidyOccName occ_env (nameOccName name) of
116             (occ_env', occ') ->  (occ_env', extendVarEnv var_env tv tv')
117                 where
118                   tv'   = setTyVarName tv name'
119                   name' = tidyNameOcc name occ'
120     add _ tidy_env = tidy_env      
121
122 data ReportErrCtxt 
123     = CEC { cec_encl :: [Implication]  -- Enclosing implications
124                                        --   (innermost first)
125           , cec_tidy :: TidyEnv
126           , cec_extra :: SDoc          -- Add this to each error message
127       }
128
129 reportTidyImplic :: ReportErrCtxt -> Implication -> TcM ()
130 reportTidyImplic ctxt implic
131   = reportTidyWanteds ctxt' (ic_wanted implic)
132   where
133     ctxt' = ctxt { cec_encl = implic : cec_encl ctxt }
134   
135 reportTidyWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
136 reportTidyWanteds ctxt unsolved
137   = do { let (flats, implics) = splitWanteds unsolved
138              (ambigs, others) = partition is_ambiguous (bagToList flats)
139        ; groupErrs (reportFlat ctxt) others
140        ; mapBagM_ (reportTidyImplic ctxt) implics
141        ; ifErrsM (return ()) $
142            -- Only report ambiguity if no other errors happened
143            -- See Note [Avoiding spurious errors]
144          reportAmbigErrs ctxt skols ambigs }
145   where
146     skols = foldr (unionVarSet . ic_skols) emptyVarSet (cec_encl ctxt)
147  
148         -- Treat it as "ambiguous" if 
149         --   (a) it is a class constraint
150         --   (b) it constrains only type variables
151         --       (else we'd prefer to report it as "no instance for...")
152         --   (c) it mentions type variables that are not skolems
153     is_ambiguous d = isTyVarClassPred pred
154                   && not (tyVarsOfPred pred `subVarSet` skols)
155                   where   
156                      pred = wantedEvVarPred d
157
158 reportFlat :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
159 reportFlat ctxt flats origin
160   = do { unless (null dicts) $ reportDictErrs ctxt dicts origin
161        ; unless (null eqs)   $ reportEqErrs   ctxt eqs   origin
162        ; unless (null ips)   $ reportIPErrs   ctxt ips   origin
163        ; ASSERT( null others ) return () }
164   where
165     (dicts, non_dicts) = partition isClassPred flats
166     (eqs, non_eqs)     = partition isEqPred    non_dicts
167     (ips, others)      = partition isIPPred    non_eqs
168
169 --------------------------------------------
170 --      Support code 
171 --------------------------------------------
172
173 groupErrs :: ([PredType] -> CtOrigin -> TcM ()) -- Deal with one group
174           -> [WantedEvVar]                      -- Unsolved wanteds
175           -> TcM ()
176 -- Group together insts with the same origin
177 -- We want to report them together in error messages
178
179 groupErrs _ [] 
180   = return ()
181 groupErrs report_err (wanted : wanteds)
182   = do  { setCtLoc the_loc $ 
183           report_err the_vars (ctLocOrigin the_loc)
184         ; groupErrs report_err others }
185   where
186    the_loc           = wantedEvVarLoc wanted
187    the_key           = mk_key the_loc
188    the_vars          = map wantedEvVarPred (wanted:friends)
189    (friends, others) = partition is_friend wanteds
190    is_friend friend  = mk_key (wantedEvVarLoc friend) == the_key
191
192    mk_key :: WantedLoc -> (SrcSpan, String)
193    mk_key loc = (ctLocSpan loc, showSDoc (ppr (ctLocOrigin loc)))
194         -- It may seem crude to compare the error messages,
195         -- but it makes sure that we combine just what the user sees,
196         -- and it avoids need equality on InstLocs.
197
198 -- Add the "arising from..." part to a message about bunch of dicts
199 addArising :: CtOrigin -> SDoc -> SDoc
200 addArising orig msg = msg $$ nest 2 (pprArising orig)
201
202 pprWithArising :: [WantedEvVar] -> (WantedLoc, SDoc)
203 -- Print something like
204 --    (Eq a) arising from a use of x at y
205 --    (Show a) arising froma use of p at q
206 -- Also return a location for the erroe message
207 pprWithArising [] 
208   = panic "pprWithArising"
209 pprWithArising [WantedEvVar ev loc] 
210   = (loc, pprEvVarTheta [ev] <+> pprArising (ctLocOrigin loc))
211 pprWithArising ev_vars
212   = (first_loc, vcat (map ppr_one ev_vars))
213   where
214     first_loc = wantedEvVarLoc (head ev_vars)
215     ppr_one (WantedEvVar v loc) 
216        = parens (pprPred (evVarPred v)) <+> pprArisingAt loc
217
218 addErrorReport :: ReportErrCtxt -> SDoc -> TcM ()
219 addErrorReport ctxt msg = addErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt)
220
221 pprErrCtxtLoc :: ReportErrCtxt -> SDoc
222 pprErrCtxtLoc ctxt 
223   = case map (ctLocOrigin . ic_loc) (cec_encl ctxt) of
224        []           -> ptext (sLit "the top level")     -- Should not happen
225        (orig:origs) -> ppr_skol orig $$ 
226                        vcat [ ptext (sLit "or") <+> ppr_skol orig | orig <- origs ]
227   where
228     ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc)
229     ppr_skol skol_info      = pprSkolInfo skol_info
230
231 couldNotDeduce :: [EvVar] -> [PredType] -> SDoc
232 couldNotDeduce givens wanteds
233   = sep [ ptext (sLit "Could not deduce") <+> pprTheta wanteds
234         , nest 2 $ ptext (sLit "from the context") 
235                      <+> pprEvVarTheta givens]
236
237 getUserGivens :: ReportErrCtxt -> Maybe [EvVar]
238 -- Just gs => Say "could not deduce ... from gs"
239 -- Nothing => No interesting givens, say something else
240 getUserGivens (CEC {cec_encl = ctxt})
241   | null user_givens = Nothing
242   | otherwise        = Just user_givens
243   where 
244     givens = foldl (\gs ic -> ic_given ic ++ gs) [] ctxt
245     user_givens | opt_PprStyle_Debug = givens
246                 | otherwise          = filterOut isSelfDict givens
247        -- In user mode, don't show the "self-dict" given
248        -- which is only added to do co-inductive solving
249        -- Rather an awkward hack, but there we are
250        -- This is the only use of isSelfDict, so it's not in an inner loop
251 \end{code}
252
253
254 %************************************************************************
255 %*                                                                      *
256                 Implicit parameter errors
257 %*                                                                      *
258 %************************************************************************
259
260 \begin{code}
261 reportIPErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
262 reportIPErrs ctxt ips orig
263   = addErrorReport ctxt $ addArising orig msg
264   where
265     msg | Just givens <- getUserGivens ctxt
266         = couldNotDeduce givens ips
267         | otherwise
268         = sep [ ptext (sLit "Unbound implicit parameter") <> plural ips
269               , nest 2 (pprTheta ips) ] 
270 \end{code}
271
272
273 %************************************************************************
274 %*                                                                      *
275                 Equality errors
276 %*                                                                      *
277 %************************************************************************
278
279 \begin{code}
280 reportEqErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
281 reportEqErrs ctxt eqs orig
282   = mapM_ report_one eqs 
283   where
284     report_one (EqPred ty1 ty2) 
285       = do { (env1, extra) <- getWantedEqExtra (cec_tidy ctxt) orig ty1 ty2
286            ; let ctxt' = ctxt { cec_tidy = env1
287                               , cec_extra = cec_extra ctxt $$ extra }
288            ; reportEqErr ctxt' ty1 ty2 }
289     report_one pred 
290       = pprPanic "reportEqErrs" (ppr pred)    
291
292 reportEqErr :: ReportErrCtxt -> TcType -> TcType -> TcM ()
293 reportEqErr ctxt ty1 ty2
294   | Just tv1 <- tcGetTyVar_maybe ty1 = reportTyVarEqErr ctxt tv1 ty2
295   | Just tv2 <- tcGetTyVar_maybe ty2 = reportTyVarEqErr ctxt tv2 ty1
296   | otherwise   -- Neither side is a type variable
297                 -- Since the unsolved constraint is canonical, 
298                 -- it must therefore be of form (F tys ~ ty)
299   = addErrorReport ctxt (msg $$ mkTyFunInfoMsg ty1 ty2)
300   where
301     msg = case getUserGivens ctxt of
302             Just givens -> couldNotDeduce givens [EqPred ty1 ty2]
303             Nothing     -> misMatchMsg ty1 ty2
304
305 reportTyVarEqErr :: ReportErrCtxt -> TcTyVar -> TcType -> TcM ()
306 reportTyVarEqErr ctxt tv1 ty2
307   | not is_meta1
308   , Just tv2 <- tcGetTyVar_maybe ty2
309   , isMetaTyVar tv2
310   = -- sk ~ alpha: swap
311     reportTyVarEqErr ctxt tv2 ty1
312
313   | not is_meta1
314   = -- sk ~ ty, where ty isn't a meta-tyvar: mis-match
315     addErrTcM (misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2)
316
317   -- So tv is a meta tyvar, and presumably it is
318   -- an *untouchable* meta tyvar, else it'd have been unified
319   | not (k2 `isSubKind` k1)      -- Kind error
320   = addErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2)
321
322   -- Check for skolem escape
323   | (implic:_) <- cec_encl ctxt   -- Get the innermost context
324   , let esc_skols = varSetElems (tyVarsOfType ty2 `intersectVarSet` ic_skols implic)
325         implic_loc = ic_loc implic
326   , not (null esc_skols)
327   = setCtLoc implic_loc $       -- Override the error message location from the
328                                 -- place the equality arose to the implication site
329     do { (env1, env_sigs) <- findGlobals ctxt (unitVarSet tv1)
330        ; let msg = misMatchMsg ty1 ty2
331              esc_doc | isSingleton esc_skols 
332                      = ptext (sLit "because this skolem type variable would escape:")
333                      | otherwise
334                      = ptext (sLit "because these skolem type variables would escape:")
335              extra1 = vcat [ nest 2 $ esc_doc <+> pprQuotedList esc_skols
336                            , sep [ (if isSingleton esc_skols 
337                                       then ptext (sLit "This skolem is")
338                                       else ptext (sLit "These skolems are"))
339                                    <+> ptext (sLit "bound by")
340                                  , nest 2 $ pprSkolInfo (ctLocOrigin implic_loc) ] ]
341        ; addErrTcM (env1, msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) }
342
343   -- Nastiest case: attempt to unify an untouchable variable
344   | (implic:_) <- cec_encl ctxt   -- Get the innermost context
345   , let implic_loc = ic_loc implic
346         given      = ic_given implic
347   = setCtLoc (ic_loc implic) $
348     do { let (env1, msg) = misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2
349              extra = vcat [ ptext (sLit "because") <+> ppr tv1 <+> ptext (sLit "is untouchable")
350                           , ptext (sLit "inside the constraints") <+> pprEvVarTheta given 
351                           , nest 2 (ptext (sLit "bound at")
352                              <+> pprSkolInfo (ctLocOrigin implic_loc)) ]
353        ; addErrTcM (env1, msg $$ extra) }
354
355   | otherwise      -- I'm not sure how this can happen!
356   = addErrTcM (misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2)
357   where         
358     is_meta1 = isMetaTyVar tv1
359     k1       = tyVarKind tv1
360     k2       = typeKind ty2
361     ty1      = mkTyVarTy tv1
362
363 mkTyFunInfoMsg :: TcType -> TcType -> SDoc
364 -- See Note [Non-injective type functions]
365 mkTyFunInfoMsg ty1 ty2
366   | Just (tc1,_) <- tcSplitTyConApp_maybe ty1
367   , Just (tc2,_) <- tcSplitTyConApp_maybe ty2
368   , tc1 == tc2, isSynFamilyTyCon tc1
369   = ptext (sLit "NB:") <+> quotes (ppr tc1) 
370     <+> ptext (sLit "is a type function") <> (pp_inj tc1)
371   | otherwise = empty
372   where       
373     pp_inj tc | isInjectiveTyCon tc = empty
374               | otherwise = ptext (sLit (", and may not be injective"))
375
376 misMatchMsgWithExtras :: TidyEnv -> TcType -> TcType -> (TidyEnv, SDoc)
377 -- This version is used by TcSimplify too, which doesn't track the
378 -- expected/acutal thing, so we just have ty1 ty2 here
379 -- NB: The types are already tidied
380 misMatchMsgWithExtras env ty1 ty2
381   = (env2, sep [ misMatchMsg ty1 ty2, nest 2 (extra1 $$ extra2) ])
382   where
383     (env1, extra1) = typeExtraInfoMsg env ty1
384     (env2, extra2) = typeExtraInfoMsg env1 ty2
385
386 misMatchMsg :: TcType -> TcType -> SDoc    -- Types are already tidy
387 misMatchMsg ty1 ty2 = sep [ ptext (sLit "Couldn't match type") <+> quotes (ppr ty1)
388                           , nest 15 $ ptext (sLit "with") <+> quotes (ppr ty2)]
389
390 kindErrorMsg :: TcType -> TcType -> SDoc   -- Types are already tidy
391 kindErrorMsg ty1 ty2
392   = vcat [ ptext (sLit "Kind incompatibility when matching types:")
393          , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1
394                         , ppr ty2 <+> dcolon <+> ppr k2 ]) ]
395   where
396     k1 = typeKind ty1
397     k2 = typeKind ty2
398
399 typeExtraInfoMsg :: TidyEnv -> Type -> (TidyEnv, SDoc)
400 -- Shows a bit of extra info about skolem constants
401 typeExtraInfoMsg env ty 
402   | Just tv <- tcGetTyVar_maybe ty
403   , isTcTyVar tv
404   , isSkolemTyVar tv || isSigTyVar tv
405   , not (isUnk tv)
406   , let (env1, tv1) = tidySkolemTyVar env tv
407   = (env1, pprSkolTvBinding tv1)
408   where
409 typeExtraInfoMsg env _ty = (env, empty)         -- Normal case
410
411 --------------------
412 unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc)
413 unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env
414   = do  { act_ty' <- zonkTcType act_ty
415         ; exp_ty' <- zonkTcType exp_ty
416         ; let (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
417               (env2, act_ty'') = tidyOpenType env1     act_ty'
418         ; return (env2, mkExpectedActualMsg act_ty'' exp_ty'') }
419
420 mkExpectedActualMsg :: Type -> Type -> SDoc
421 mkExpectedActualMsg act_ty exp_ty
422   = vcat [ text "Expected type" <> colon <+> ppr exp_ty
423          , text "  Actual type" <> colon <+> ppr act_ty ]
424 \end{code}
425
426 Note [Non-injective type functions]
427 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
428 It's very confusing to get a message like
429      Couldn't match expected type `Depend s'
430             against inferred type `Depend s1'
431 so mkTyFunInfoMsg adds:
432        NB: `Depend' is type function, and hence may not be injective
433
434 Warn of loopy local equalities that were dropped.
435
436
437 %************************************************************************
438 %*                                                                      *
439                  Type-class errors
440 %*                                                                      *
441 %************************************************************************
442
443 \begin{code}
444 reportDictErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()     
445 reportDictErrs ctxt wanteds orig
446   = do { inst_envs <- tcGetInstEnvs
447        ; let (others, overlaps) = partitionWith (check_overlap inst_envs) wanteds
448        ; unless (null others) $
449          addErrorReport ctxt (mk_no_inst_err others) 
450        ; mapM_ (addErrorReport ctxt) overlaps }
451   where
452     check_overlap :: (InstEnv,InstEnv) -> PredType -> Either PredType SDoc
453         -- Right msg  => overlap message
454         -- Left  inst => no instance
455     check_overlap inst_envs pred@(ClassP clas tys)
456         = case lookupInstEnv inst_envs clas tys of
457                 ([], _) -> Left pred            -- No match
458                 -- The case of exactly one match and no unifiers means a
459                 -- successful lookup.  That can't happen here, because dicts
460                 -- only end up here if they didn't match in Inst.lookupInst
461                 ([_],[])
462                  | debugIsOn -> pprPanic "check_overlap" (ppr pred)
463                 res -> Right (mk_overlap_msg pred res)
464     check_overlap _ _ = panic "check_overlap"
465
466     mk_overlap_msg pred (matches, unifiers)
467       = ASSERT( not (null matches) )
468         vcat [  addArising orig (ptext (sLit "Overlapping instances for") 
469                                 <+> pprPred pred)
470              ,  sep [ptext (sLit "Matching instances") <> colon,
471                      nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
472              ,  if not (isSingleton matches)
473                 then    -- Two or more matches
474                      empty
475                 else    -- One match, plus some unifiers
476                 ASSERT( not (null unifiers) )
477                 parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
478                                  quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
479                               ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
480                               ptext (sLit "when compiling the other instance declarations")])]
481       where
482         ispecs = [ispec | (ispec, _) <- matches]
483
484     mk_no_inst_err :: [PredType] -> SDoc
485     mk_no_inst_err wanteds
486       | Just givens <- getUserGivens ctxt
487       = vcat [ addArising orig $ couldNotDeduce givens wanteds
488              , show_fixes (fix1 : fixes2) ]
489
490       | otherwise       -- Top level 
491       = vcat [ addArising orig $
492                ptext (sLit "No instance") <> plural wanteds
493                     <+> ptext (sLit "for") <+> pprTheta wanteds
494              , show_fixes fixes2 ]
495
496       where
497         fix1 = sep [ ptext (sLit "add") <+> pprTheta wanteds 
498                           <+> ptext (sLit "to the context of")
499                    , nest 2 $ pprErrCtxtLoc ctxt ]
500
501         fixes2 | null instance_dicts = []
502                | otherwise           = [sep [ptext (sLit "add an instance declaration for"),
503                                         pprTheta instance_dicts]]
504         instance_dicts = filterOut isTyVarClassPred wanteds
505                 -- Insts for which it is worth suggesting an adding an 
506                 -- instance declaration.  Exclude tyvar dicts.
507
508         show_fixes :: [SDoc] -> SDoc
509         show_fixes []     = empty
510         show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"), 
511                                  nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
512
513 reportAmbigErrs :: ReportErrCtxt -> TcTyVarSet -> [WantedEvVar] -> TcM ()
514 reportAmbigErrs ctxt skols ambigs 
515 -- Divide into groups that share a common set of ambiguous tyvars
516   = mapM_ report (equivClasses cmp ambigs_w_tvs)
517   where
518     ambigs_w_tvs = [ (d, varSetElems (tyVarsOfWantedEvVar d `minusVarSet` skols))
519                    | d <- ambigs ]
520     cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2
521
522     report :: [(WantedEvVar, [TcTyVar])] -> TcM ()
523     report pairs
524        = setCtLoc loc $
525          do { let main_msg = sep [ text "Ambiguous type variable" <> plural tvs
526                                    <+> pprQuotedList tvs
527                                    <+> text "in the constraint" <> plural pairs <> colon
528                                  , nest 2 pp_wanteds ]
529              ; (tidy_env, mono_msg) <- mkMonomorphismMsg ctxt tvs
530             ; addErrTcM (tidy_env, main_msg $$ mono_msg) }
531        where
532          (_, tvs) : _ = pairs
533          (loc, pp_wanteds) = pprWithArising (map fst pairs)
534
535 mkMonomorphismMsg :: ReportErrCtxt -> [TcTyVar] -> TcM (TidyEnv, SDoc)
536 -- There's an error with these Insts; if they have free type variables
537 -- it's probably caused by the monomorphism restriction. 
538 -- Try to identify the offending variable
539 -- ASSUMPTION: the Insts are fully zonked
540 mkMonomorphismMsg ctxt inst_tvs
541   = do  { dflags <- getDOpts
542         ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
543         ; return (tidy_env, mk_msg dflags docs) }
544   where
545     mk_msg _ _ | any isRuntimeUnk inst_tvs
546         =  vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+>
547                    (pprWithCommas ppr inst_tvs),
548                 ptext (sLit "Use :print or :force to determine these types")]
549     mk_msg _ []   = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)")
550                         -- This happens in things like
551                         --      f x = show (read "foo")
552                         -- where monomorphism doesn't play any role
553     mk_msg dflags docs 
554         = vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"),
555                 nest 2 (vcat docs),
556                 monomorphism_fix dflags]
557
558 monomorphism_fix :: DynFlags -> SDoc
559 monomorphism_fix dflags
560   = ptext (sLit "Probable fix:") <+> vcat
561         [ptext (sLit "give these definition(s) an explicit type signature"),
562          if dopt Opt_MonomorphismRestriction dflags
563            then ptext (sLit "or use -XNoMonomorphismRestriction")
564            else empty]  -- Only suggest adding "-XNoMonomorphismRestriction"
565                         -- if it is not already set!
566
567
568 -----------------------
569 -- findGlobals looks at the value environment and finds values whose
570 -- types mention any of the offending type variables.  It has to be
571 -- careful to zonk the Id's type first, so it has to be in the monad.
572 -- We must be careful to pass it a zonked type variable, too.
573
574 mkEnvSigMsg :: SDoc -> [SDoc] -> SDoc
575 mkEnvSigMsg what env_sigs
576  | null env_sigs = empty
577  | otherwise = vcat [ ptext (sLit "The following variables have types that mention") <+> what
578                     , nest 2 (vcat env_sigs) ]
579
580 findGlobals :: ReportErrCtxt
581             -> TcTyVarSet
582             -> TcM (TidyEnv, [SDoc])
583
584 findGlobals ctxt tvs 
585   = do { lcl_ty_env <- case cec_encl ctxt of 
586                         []    -> getLclTypeEnv
587                         (i:_) -> return (ic_env i)
588        ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) }
589   where
590     go tidy_env acc [] = return (tidy_env, acc)
591     go tidy_env acc (thing : things) = do
592         (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing
593         case maybe_doc of
594           Just d  -> go tidy_env1 (d:acc) things
595           Nothing -> go tidy_env1 acc     things
596
597     ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
598
599 -----------------------
600 find_thing :: TidyEnv -> (TcType -> Bool)
601            -> TcTyThing -> TcM (TidyEnv, Maybe SDoc)
602 find_thing tidy_env ignore_it (ATcId { tct_id = id })
603   = do { id_ty <- zonkTcType  (idType id)
604        ; if ignore_it id_ty then
605            return (tidy_env, Nothing)
606          else do 
607        { let (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
608              msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty
609                        , nest 2 (parens (ptext (sLit "bound at") <+>
610                                    ppr (getSrcLoc id)))]
611        ; return (tidy_env', Just msg) } }
612
613 find_thing tidy_env ignore_it (ATyVar tv ty)
614   = do { tv_ty <- zonkTcType ty
615        ; if ignore_it tv_ty then
616             return (tidy_env, Nothing)
617          else do
618        { let -- The name tv is scoped, so we don't need to tidy it
619             (tidy_env1, tidy_ty) = tidyOpenType  tidy_env tv_ty
620             msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff
621                       , nest 2 bound_at]
622
623             eq_stuff | Just tv' <- tcGetTyVar_maybe tv_ty 
624                      , getOccName tv == getOccName tv' = empty
625                      | otherwise = equals <+> ppr tidy_ty
626                 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
627             bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv)
628  
629        ; return (tidy_env1, Just msg) } }
630
631 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
632
633 warnDefaulting :: [WantedEvVar] -> Type -> TcM ()
634 warnDefaulting wanteds default_ty
635   = do { warn_default <- doptM Opt_WarnTypeDefaults
636        ; setCtLoc loc $ warnTc warn_default warn_msg }
637   where
638         -- Tidy them first
639     warn_msg  = vcat [ ptext (sLit "Defaulting the following constraint(s) to type") <+>
640                                 quotes (ppr default_ty),
641                       nest 2 ppr_wanteds ]
642     (loc, ppr_wanteds) = pprWithArising wanteds
643 \end{code}
644
645 %************************************************************************
646 %*                                                                      *
647                  Error from the canonicaliser
648 %*                                                                      *
649 %************************************************************************
650
651 \begin{code}
652 kindErrorTcS :: CtFlavor -> TcType -> TcType -> TcS ()
653 -- If there's a kind error, we don't want to blindly say "kind error"
654 -- We might, say, be unifying a skolem 'a' with a type 'Int', 
655 -- in which case that's the error to report.  So we set things
656 -- up to call reportEqErr, which does the business properly
657 kindErrorTcS fl ty1 ty2
658   = wrapErrTcS        $ 
659     setCtFlavorLoc fl $ 
660     do { env0 <- tcInitTidyEnv
661        ; (env1, extra) <- getEqExtra env0 fl ty1 ty2
662        ; let (env2, ty1') = tidyOpenType env1 ty1
663              (env3, ty2') = tidyOpenType env2 ty2
664              ctxt = CEC { cec_encl = []
665                         , cec_extra = extra
666                         , cec_tidy = env3 }
667        ; reportEqErr ctxt ty1' ty2' }
668
669 misMatchErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a
670 misMatchErrorTcS fl ty1 ty2
671   = wrapErrTcS        $ 
672     setCtFlavorLoc fl $ 
673     do { env0 <- tcInitTidyEnv
674        ; let (env1, ty1') = tidyOpenType env0 ty1
675              (env2, ty2') = tidyOpenType env1 ty2
676              (env3, msg)  = misMatchMsgWithExtras env2 ty1' ty2'
677        ; (env4, extra) <- getEqExtra env3 fl ty1 ty2
678        ; failWithTcM (env4, inaccessible_msg $$ msg $$ extra) }
679   where
680     inaccessible_msg 
681       = case fl of 
682           Given loc -> hang (ptext (sLit "Inaccessible code in"))
683                           2 (mk_what loc)
684           _         -> empty
685     mk_what loc 
686       = case ctLocOrigin loc of
687           PatSkol dc mc -> sep [ ptext (sLit "a pattern with constructor") 
688                                    <+> quotes (ppr dc) <> comma
689                                , ptext (sLit "in") <+> pprMatchContext mc ]
690           other_skol -> pprSkolInfo other_skol
691
692 occursCheckErrorTcS :: CtFlavor -> TcTyVar -> TcType -> TcS a
693 occursCheckErrorTcS fl tv ty
694   = wrapErrTcS        $ 
695     setCtFlavorLoc fl $
696     do  { env0 <- tcInitTidyEnv
697         ; let (env1, tv') = tidyOpenTyVar env0 tv
698               (env2, ty') = tidyOpenType env1 ty
699               extra1 = sep [ppr tv', char '=', ppr ty']
700         ; (env3, extra2) <- getEqExtra env2 fl (mkTyVarTy tv) ty
701         ; failWithTcM (env3, hang msg 2 (extra1 $$ extra2)) }
702   where
703     msg = text $ "Occurs check: cannot construct the infinite type:"
704
705 solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a
706 solverDepthErrorTcS depth stack
707   | null stack      -- Shouldn't happen unless you say -fcontext-stack=0
708   = wrapErrTcS $ failWith msg
709   | otherwise
710   = wrapErrTcS $ 
711     setCtFlavorLoc (cc_flavor top_item) $
712     do { env0 <- tcInitTidyEnv
713        ; let ev_vars  = map cc_id stack
714              env1     = tidyFreeTyVars env0 free_tvs
715              free_tvs = foldr (unionVarSet . tyVarsOfEvVar) emptyVarSet ev_vars
716              extra    = pprEvVars (map (tidyEvVar env1) ev_vars)
717        ; failWithTcM (env1, hang msg 2 extra) }
718   where
719     top_item = head stack
720     msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
721                , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
722
723 flattenForAllErrorTcS :: CtFlavor -> TcType -> Bag CanonicalCt -> TcS a
724 flattenForAllErrorTcS fl ty _bad_eqs
725   = wrapErrTcS        $ 
726     setCtFlavorLoc fl $ 
727     do { env0 <- tcInitTidyEnv
728        ; let (env1, ty') = tidyOpenType env0 ty 
729              msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:")
730                        , ppr ty' ]
731        ; failWithTcM (env1, msg) }
732 \end{code}
733
734 %************************************************************************
735 %*                                                                      *
736                  Setting the context
737 %*                                                                      *
738 %************************************************************************
739
740 \begin{code}
741 setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
742 setCtFlavorLoc (Wanted  loc) thing = setCtLoc loc thing
743 setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing
744 setCtFlavorLoc (Given   loc) thing = setCtLoc loc thing
745
746 getEqExtra :: TidyEnv -> CtFlavor -> TcType -> TcType -> TcM (TidyEnv, SDoc)
747 getEqExtra env (Wanted  loc) ty1 ty2 = getWantedEqExtra env (ctLocOrigin loc) ty1 ty2
748 getEqExtra env (Derived loc) ty1 ty2 = getWantedEqExtra env (ctLocOrigin loc) ty1 ty2
749 getEqExtra env (Given   _)   _   _   = return (env, empty)
750   -- We could print more info, but it seems to be already coming out
751
752 getWantedEqExtra :: TidyEnv -> CtOrigin -> TcType -> TcType -> TcM (TidyEnv, SDoc)
753 getWantedEqExtra env0 (TypeEqOrigin item) ty1 ty2
754   -- If the types in the error message are the same 
755   -- as the types we are unifying (remember to zonk the latter)
756   -- don't add the extra expected/actual message
757   = do { act <- zonkTcType (uo_actual item)
758        ; exp <- zonkTcType (uo_expected item)
759        ; if (act `tcEqType` ty1 && exp `tcEqType` ty2)
760          || (exp `tcEqType` ty1 && act `tcEqType` ty2)
761          then   
762             return (env0, empty)
763          else do
764        { let (env1, exp') = tidyOpenType env0 exp
765              (env2, act') = tidyOpenType env1     act
766        ; return (env2, mkExpectedActualMsg act' exp') } }
767
768 getWantedEqExtra env0 orig _ _ 
769   = return (env0, pprArising orig)
770 \end{code}