Yet more error message improvement
[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     env0 = cec_tidy ctxt
285     report_one (EqPred ty1 ty2) 
286       = getWantedEqExtra emptyTvSubst env0 orig ty1 ty2 $ \ env1 extra ->
287         let ctxt' = ctxt { cec_tidy = env1
288                          , cec_extra = cec_extra ctxt $$ extra }
289         in reportEqErr ctxt' ty1 ty2 
290     report_one pred 
291       = pprPanic "reportEqErrs" (ppr pred)    
292
293 reportEqErr :: ReportErrCtxt -> TcType -> TcType -> TcM ()
294 reportEqErr ctxt ty1 ty2
295   | Just tv1 <- tcGetTyVar_maybe ty1 = reportTyVarEqErr ctxt tv1 ty2
296   | Just tv2 <- tcGetTyVar_maybe ty2 = reportTyVarEqErr ctxt tv2 ty1
297   | otherwise   -- Neither side is a type variable
298                 -- Since the unsolved constraint is canonical, 
299                 -- it must therefore be of form (F tys ~ ty)
300   = addErrorReport ctxt (msg $$ mkTyFunInfoMsg ty1 ty2)
301   where
302     msg = case getUserGivens ctxt of
303             Just givens -> couldNotDeduce givens [EqPred ty1 ty2]
304             Nothing     -> misMatchMsg ty1 ty2
305
306 reportTyVarEqErr :: ReportErrCtxt -> TcTyVar -> TcType -> TcM ()
307 reportTyVarEqErr ctxt tv1 ty2
308   | not is_meta1
309   , Just tv2 <- tcGetTyVar_maybe ty2
310   , isMetaTyVar tv2
311   = -- sk ~ alpha: swap
312     reportTyVarEqErr ctxt tv2 ty1
313
314   | not is_meta1
315   = -- sk ~ ty, where ty isn't a meta-tyvar: mis-match
316     addErrTcM (misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2)
317
318   -- So tv is a meta tyvar, and presumably it is
319   -- an *untouchable* meta tyvar, else it'd have been unified
320   | not (k2 `isSubKind` k1)      -- Kind error
321   = addErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2)
322
323   -- Check for skolem escape
324   | (implic:_) <- cec_encl ctxt   -- Get the innermost context
325   , let esc_skols = varSetElems (tyVarsOfType ty2 `intersectVarSet` ic_skols implic)
326         implic_loc = ic_loc implic
327   , not (null esc_skols)
328   = setCtLoc implic_loc $       -- Override the error message location from the
329                                 -- place the equality arose to the implication site
330     do { (env1, env_sigs) <- findGlobals ctxt (unitVarSet tv1)
331        ; let msg = misMatchMsg ty1 ty2
332              esc_doc | isSingleton esc_skols 
333                      = ptext (sLit "because this skolem type variable would escape:")
334                      | otherwise
335                      = ptext (sLit "because these skolem type variables would escape:")
336              extra1 = vcat [ nest 2 $ esc_doc <+> pprQuotedList esc_skols
337                            , sep [ (if isSingleton esc_skols 
338                                       then ptext (sLit "This skolem is")
339                                       else ptext (sLit "These skolems are"))
340                                    <+> ptext (sLit "bound by")
341                                  , nest 2 $ pprSkolInfo (ctLocOrigin implic_loc) ] ]
342        ; addErrTcM (env1, msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) }
343
344   -- Nastiest case: attempt to unify an untouchable variable
345   | (implic:_) <- cec_encl ctxt   -- Get the innermost context
346   , let implic_loc = ic_loc implic
347         given      = ic_given implic
348   = setCtLoc (ic_loc implic) $
349     do { let (env1, msg) = misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2
350              extra = vcat [ ptext (sLit "because") <+> ppr tv1 <+> ptext (sLit "is untouchable")
351                           , ptext (sLit "inside the constraints") <+> pprEvVarTheta given 
352                           , nest 2 (ptext (sLit "bound at")
353                              <+> pprSkolInfo (ctLocOrigin implic_loc)) ]
354        ; addErrTcM (env1, msg $$ extra) }
355
356   | otherwise      -- I'm not sure how this can happen!
357   = addErrTcM (misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2)
358   where         
359     is_meta1 = isMetaTyVar tv1
360     k1       = tyVarKind tv1
361     k2       = typeKind ty2
362     ty1      = mkTyVarTy tv1
363
364 mkTyFunInfoMsg :: TcType -> TcType -> SDoc
365 -- See Note [Non-injective type functions]
366 mkTyFunInfoMsg ty1 ty2
367   | Just (tc1,_) <- tcSplitTyConApp_maybe ty1
368   , Just (tc2,_) <- tcSplitTyConApp_maybe ty2
369   , tc1 == tc2, isSynFamilyTyCon tc1
370   = ptext (sLit "NB:") <+> quotes (ppr tc1) 
371     <+> ptext (sLit "is a type function") <> (pp_inj tc1)
372   | otherwise = empty
373   where       
374     pp_inj tc | isInjectiveTyCon tc = empty
375               | otherwise = ptext (sLit (", and may not be injective"))
376
377 misMatchMsgWithExtras :: TidyEnv -> TcType -> TcType -> (TidyEnv, SDoc)
378 -- This version is used by TcSimplify too, which doesn't track the
379 -- expected/acutal thing, so we just have ty1 ty2 here
380 -- NB: The types are already tidied
381 misMatchMsgWithExtras env ty1 ty2
382   = (env2, sep [ misMatchMsg ty1 ty2, nest 2 (extra1 $$ extra2) ])
383   where
384     (env1, extra1) = typeExtraInfoMsg env ty1
385     (env2, extra2) = typeExtraInfoMsg env1 ty2
386
387 misMatchMsg :: TcType -> TcType -> SDoc    -- Types are already tidy
388 misMatchMsg ty1 ty2 = sep [ ptext (sLit "Couldn't match type") <+> quotes (ppr ty1)
389                           , nest 15 $ ptext (sLit "with") <+> quotes (ppr ty2)]
390
391 kindErrorMsg :: TcType -> TcType -> SDoc   -- Types are already tidy
392 kindErrorMsg ty1 ty2
393   = vcat [ ptext (sLit "Kind incompatibility when matching types:")
394          , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1
395                         , ppr ty2 <+> dcolon <+> ppr k2 ]) ]
396   where
397     k1 = typeKind ty1
398     k2 = typeKind ty2
399
400 typeExtraInfoMsg :: TidyEnv -> Type -> (TidyEnv, SDoc)
401 -- Shows a bit of extra info about skolem constants
402 typeExtraInfoMsg env ty 
403   | Just tv <- tcGetTyVar_maybe ty
404   , isTcTyVar tv
405   , isSkolemTyVar tv || isSigTyVar tv
406   , not (isUnk tv)
407   , let (env1, tv1) = tidySkolemTyVar env tv
408   = (env1, pprSkolTvBinding tv1)
409   where
410 typeExtraInfoMsg env _ty = (env, empty)         -- Normal case
411
412 --------------------
413 unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc)
414 unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env
415   = do  { act_ty' <- zonkTcType act_ty
416         ; exp_ty' <- zonkTcType exp_ty
417         ; let (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
418               (env2, act_ty'') = tidyOpenType env1     act_ty'
419         ; return (env2, mkExpectedActualMsg act_ty'' exp_ty'') }
420
421 mkExpectedActualMsg :: Type -> Type -> SDoc
422 mkExpectedActualMsg act_ty exp_ty
423   = vcat [ text "Expected type" <> colon <+> ppr exp_ty
424          , text "  Actual type" <> colon <+> ppr act_ty ]
425 \end{code}
426
427 Note [Non-injective type functions]
428 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
429 It's very confusing to get a message like
430      Couldn't match expected type `Depend s'
431             against inferred type `Depend s1'
432 so mkTyFunInfoMsg adds:
433        NB: `Depend' is type function, and hence may not be injective
434
435 Warn of loopy local equalities that were dropped.
436
437
438 %************************************************************************
439 %*                                                                      *
440                  Type-class errors
441 %*                                                                      *
442 %************************************************************************
443
444 \begin{code}
445 reportDictErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()     
446 reportDictErrs ctxt wanteds orig
447   = do { inst_envs <- tcGetInstEnvs
448        ; let (others, overlaps) = partitionWith (check_overlap inst_envs) wanteds
449        ; unless (null others) $
450          addErrorReport ctxt (mk_no_inst_err others) 
451        ; mapM_ (addErrorReport ctxt) overlaps }
452   where
453     check_overlap :: (InstEnv,InstEnv) -> PredType -> Either PredType SDoc
454         -- Right msg  => overlap message
455         -- Left  inst => no instance
456     check_overlap inst_envs pred@(ClassP clas tys)
457         = case lookupInstEnv inst_envs clas tys of
458                 ([], _) -> Left pred            -- No match
459                 -- The case of exactly one match and no unifiers means a
460                 -- successful lookup.  That can't happen here, because dicts
461                 -- only end up here if they didn't match in Inst.lookupInst
462                 ([_],[])
463                  | debugIsOn -> pprPanic "check_overlap" (ppr pred)
464                 res -> Right (mk_overlap_msg pred res)
465     check_overlap _ _ = panic "check_overlap"
466
467     mk_overlap_msg pred (matches, unifiers)
468       = ASSERT( not (null matches) )
469         vcat [  addArising orig (ptext (sLit "Overlapping instances for") 
470                                 <+> pprPred pred)
471              ,  sep [ptext (sLit "Matching instances") <> colon,
472                      nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
473              ,  if not (isSingleton matches)
474                 then    -- Two or more matches
475                      empty
476                 else    -- One match, plus some unifiers
477                 ASSERT( not (null unifiers) )
478                 parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
479                                  quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
480                               ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
481                               ptext (sLit "when compiling the other instance declarations")])]
482       where
483         ispecs = [ispec | (ispec, _) <- matches]
484
485     mk_no_inst_err :: [PredType] -> SDoc
486     mk_no_inst_err wanteds
487       | Just givens <- getUserGivens ctxt
488       = vcat [ addArising orig $ couldNotDeduce givens wanteds
489              , show_fixes (fix1 : fixes2) ]
490
491       | otherwise       -- Top level 
492       = vcat [ addArising orig $
493                ptext (sLit "No instance") <> plural wanteds
494                     <+> ptext (sLit "for") <+> pprTheta wanteds
495              , show_fixes fixes2 ]
496
497       where
498         fix1 = sep [ ptext (sLit "add") <+> pprTheta wanteds 
499                           <+> ptext (sLit "to the context of")
500                    , nest 2 $ pprErrCtxtLoc ctxt ]
501
502         fixes2 | null instance_dicts = []
503                | otherwise           = [sep [ptext (sLit "add an instance declaration for"),
504                                         pprTheta instance_dicts]]
505         instance_dicts = filterOut isTyVarClassPred wanteds
506                 -- Insts for which it is worth suggesting an adding an 
507                 -- instance declaration.  Exclude tyvar dicts.
508
509         show_fixes :: [SDoc] -> SDoc
510         show_fixes []     = empty
511         show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"), 
512                                  nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
513
514 reportAmbigErrs :: ReportErrCtxt -> TcTyVarSet -> [WantedEvVar] -> TcM ()
515 reportAmbigErrs ctxt skols ambigs 
516 -- Divide into groups that share a common set of ambiguous tyvars
517   = mapM_ report (equivClasses cmp ambigs_w_tvs)
518   where
519     ambigs_w_tvs = [ (d, varSetElems (tyVarsOfWantedEvVar d `minusVarSet` skols))
520                    | d <- ambigs ]
521     cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2
522
523     report :: [(WantedEvVar, [TcTyVar])] -> TcM ()
524     report pairs
525        = setCtLoc loc $
526          do { let main_msg = sep [ text "Ambiguous type variable" <> plural tvs
527                                    <+> pprQuotedList tvs
528                                    <+> text "in the constraint" <> plural pairs <> colon
529                                  , nest 2 pp_wanteds ]
530              ; (tidy_env, mono_msg) <- mkMonomorphismMsg ctxt tvs
531             ; addErrTcM (tidy_env, main_msg $$ mono_msg) }
532        where
533          (_, tvs) : _ = pairs
534          (loc, pp_wanteds) = pprWithArising (map fst pairs)
535
536 mkMonomorphismMsg :: ReportErrCtxt -> [TcTyVar] -> TcM (TidyEnv, SDoc)
537 -- There's an error with these Insts; if they have free type variables
538 -- it's probably caused by the monomorphism restriction. 
539 -- Try to identify the offending variable
540 -- ASSUMPTION: the Insts are fully zonked
541 mkMonomorphismMsg ctxt inst_tvs
542   = do  { dflags <- getDOpts
543         ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
544         ; return (tidy_env, mk_msg dflags docs) }
545   where
546     mk_msg _ _ | any isRuntimeUnk inst_tvs
547         =  vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+>
548                    (pprWithCommas ppr inst_tvs),
549                 ptext (sLit "Use :print or :force to determine these types")]
550     mk_msg _ []   = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)")
551                         -- This happens in things like
552                         --      f x = show (read "foo")
553                         -- where monomorphism doesn't play any role
554     mk_msg dflags docs 
555         = vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"),
556                 nest 2 (vcat docs),
557                 monomorphism_fix dflags]
558
559 monomorphism_fix :: DynFlags -> SDoc
560 monomorphism_fix dflags
561   = ptext (sLit "Probable fix:") <+> vcat
562         [ptext (sLit "give these definition(s) an explicit type signature"),
563          if dopt Opt_MonomorphismRestriction dflags
564            then ptext (sLit "or use -XNoMonomorphismRestriction")
565            else empty]  -- Only suggest adding "-XNoMonomorphismRestriction"
566                         -- if it is not already set!
567
568
569 -----------------------
570 -- findGlobals looks at the value environment and finds values whose
571 -- types mention any of the offending type variables.  It has to be
572 -- careful to zonk the Id's type first, so it has to be in the monad.
573 -- We must be careful to pass it a zonked type variable, too.
574
575 mkEnvSigMsg :: SDoc -> [SDoc] -> SDoc
576 mkEnvSigMsg what env_sigs
577  | null env_sigs = empty
578  | otherwise = vcat [ ptext (sLit "The following variables have types that mention") <+> what
579                     , nest 2 (vcat env_sigs) ]
580
581 findGlobals :: ReportErrCtxt
582             -> TcTyVarSet
583             -> TcM (TidyEnv, [SDoc])
584
585 findGlobals ctxt tvs 
586   = do { lcl_ty_env <- case cec_encl ctxt of 
587                         []    -> getLclTypeEnv
588                         (i:_) -> return (ic_env i)
589        ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) }
590   where
591     go tidy_env acc [] = return (tidy_env, acc)
592     go tidy_env acc (thing : things) = do
593         (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing
594         case maybe_doc of
595           Just d  -> go tidy_env1 (d:acc) things
596           Nothing -> go tidy_env1 acc     things
597
598     ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
599
600 -----------------------
601 find_thing :: TidyEnv -> (TcType -> Bool)
602            -> TcTyThing -> TcM (TidyEnv, Maybe SDoc)
603 find_thing tidy_env ignore_it (ATcId { tct_id = id })
604   = do { id_ty <- zonkTcType  (idType id)
605        ; if ignore_it id_ty then
606            return (tidy_env, Nothing)
607          else do 
608        { let (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
609              msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty
610                        , nest 2 (parens (ptext (sLit "bound at") <+>
611                                    ppr (getSrcLoc id)))]
612        ; return (tidy_env', Just msg) } }
613
614 find_thing tidy_env ignore_it (ATyVar tv ty)
615   = do { tv_ty <- zonkTcType ty
616        ; if ignore_it tv_ty then
617             return (tidy_env, Nothing)
618          else do
619        { let -- The name tv is scoped, so we don't need to tidy it
620             (tidy_env1, tidy_ty) = tidyOpenType  tidy_env tv_ty
621             msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff
622                       , nest 2 bound_at]
623
624             eq_stuff | Just tv' <- tcGetTyVar_maybe tv_ty 
625                      , getOccName tv == getOccName tv' = empty
626                      | otherwise = equals <+> ppr tidy_ty
627                 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
628             bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv)
629  
630        ; return (tidy_env1, Just msg) } }
631
632 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
633
634 warnDefaulting :: [WantedEvVar] -> Type -> TcM ()
635 warnDefaulting wanteds default_ty
636   = do { warn_default <- doptM Opt_WarnTypeDefaults
637        ; setCtLoc loc $ warnTc warn_default warn_msg }
638   where
639         -- Tidy them first
640     warn_msg  = vcat [ ptext (sLit "Defaulting the following constraint(s) to type") <+>
641                                 quotes (ppr default_ty),
642                       nest 2 ppr_wanteds ]
643     (loc, ppr_wanteds) = pprWithArising wanteds
644 \end{code}
645
646 %************************************************************************
647 %*                                                                      *
648                  Error from the canonicaliser
649 %*                                                                      *
650 %************************************************************************
651
652 \begin{code}
653 kindErrorTcS :: CtFlavor -> TcType -> TcType -> TcS ()
654 -- If there's a kind error, we don't want to blindly say "kind error"
655 -- We might, say, be unifying a skolem 'a' with a type 'Int', 
656 -- in which case that's the error to report.  So we set things
657 -- up to call reportEqErr, which does the business properly
658 kindErrorTcS fl ty1 ty2
659   = wrapEqErrTcS fl ty1 ty2 $ \ env0 extra -> 
660     do { let (env1, ty1') = tidyOpenType env0 ty1
661              (env2, ty2') = tidyOpenType env1 ty2
662              ctxt = CEC { cec_encl = []
663                         , cec_extra = extra
664                         , cec_tidy = env2 }
665        ; reportEqErr ctxt ty1' ty2' }
666
667 misMatchErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a
668 misMatchErrorTcS fl ty1 ty2
669   = wrapEqErrTcS fl ty1 ty2 $ \ env0 extra -> 
670     do { let (env1, ty1') = tidyOpenType env0 ty1
671              (env2, ty2') = tidyOpenType env1 ty2
672              (env3, msg)  = misMatchMsgWithExtras env2 ty1' ty2'
673        ; failWithTcM (env3, inaccessible_msg $$ msg $$ extra) }
674   where
675     inaccessible_msg 
676       = case fl of 
677           Given loc -> hang (ptext (sLit "Inaccessible code in"))
678                           2 (mk_what loc)
679           _         -> empty
680     mk_what loc 
681       = case ctLocOrigin loc of
682           PatSkol dc mc -> sep [ ptext (sLit "a pattern with constructor") 
683                                    <+> quotes (ppr dc) <> comma
684                                , ptext (sLit "in") <+> pprMatchContext mc ]
685           other_skol -> pprSkolInfo other_skol
686
687 occursCheckErrorTcS :: CtFlavor -> TcTyVar -> TcType -> TcS a
688 occursCheckErrorTcS fl tv ty
689   = wrapEqErrTcS fl (mkTyVarTy tv) ty $ \ env0 extra2 -> 
690     do  { let (env1, tv') = tidyOpenTyVar env0 tv
691               (env2, ty') = tidyOpenType env1 ty
692               extra1 = sep [ppr tv', char '=', ppr ty']
693         ; failWithTcM (env2, hang msg 2 (extra1 $$ extra2)) }
694   where
695     msg = text $ "Occurs check: cannot construct the infinite type:"
696
697 solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a
698 solverDepthErrorTcS depth stack
699   | null stack      -- Shouldn't happen unless you say -fcontext-stack=0
700   = wrapErrTcS $ failWith msg
701   | otherwise
702   = wrapErrTcS $ 
703     setCtFlavorLoc (cc_flavor top_item) $
704     do { env0 <- tcInitTidyEnv
705        ; let ev_vars  = map cc_id stack
706              env1     = tidyFreeTyVars env0 free_tvs
707              free_tvs = foldr (unionVarSet . tyVarsOfEvVar) emptyVarSet ev_vars
708              extra    = pprEvVars (map (tidyEvVar env1) ev_vars)
709        ; failWithTcM (env1, hang msg 2 extra) }
710   where
711     top_item = head stack
712     msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
713                , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
714
715 flattenForAllErrorTcS :: CtFlavor -> TcType -> Bag CanonicalCt -> TcS a
716 flattenForAllErrorTcS fl ty _bad_eqs
717   = wrapErrTcS        $ 
718     setCtFlavorLoc fl $ 
719     do { env0 <- tcInitTidyEnv
720        ; let (env1, ty') = tidyOpenType env0 ty 
721              msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:")
722                        , ppr ty' ]
723        ; failWithTcM (env1, msg) }
724 \end{code}
725
726 %************************************************************************
727 %*                                                                      *
728                  Setting the context
729 %*                                                                      *
730 %************************************************************************
731
732 \begin{code}
733 setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
734 setCtFlavorLoc (Wanted  loc) thing = setCtLoc loc thing
735 setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing
736 setCtFlavorLoc (Given   loc) thing = setCtLoc loc thing
737
738 wrapEqErrTcS :: CtFlavor -> TcType -> TcType
739              -> (TidyEnv -> SDoc -> TcM a)
740              -> TcS a
741 wrapEqErrTcS fl ty1 ty2 thing_inside
742   = do { ty_binds_var <- getTcSTyBinds
743        ; wrapErrTcS $ setCtFlavorLoc fl $ 
744     do { env0 <- tcInitTidyEnv 
745        ; ty_binds_bag <- readTcRef ty_binds_var
746        ; let subst = mkOpenTvSubst (mkVarEnv (bagToList ty_binds_bag))
747        ; case fl of
748            Wanted  loc -> getWantedEqExtra subst env0 (ctLocOrigin loc) ty1 ty2 thing_inside
749            Derived loc -> getWantedEqExtra subst env0 (ctLocOrigin loc) ty1 ty2 thing_inside
750            Given {}    -> thing_inside env0 empty  -- We could print more info, but it
751                                                    -- seems to be coming out already
752        } }  
753
754 getWantedEqExtra :: TvSubst -> TidyEnv -> CtOrigin -> TcType -> TcType
755                  -> (TidyEnv -> SDoc -> TcM a)
756                  -> TcM a
757 getWantedEqExtra subst env0 (TypeEqOrigin item) ty1 ty2 thing_inside
758   -- If the types in the error message are the same 
759   -- as the types we are unifying (remember to zonk the latter)
760   -- don't add the extra expected/actual message
761   --
762   -- The complication is that the types in the TypeEqOrigin must
763   --   (a) be zonked
764   --   (b) have any TcS-monad pending equalities applied to them 
765   --            (hence the passed-in substitution)
766   = do { act0 <- zonkTcType (uo_actual item)
767        ; exp0 <- zonkTcType (uo_expected item)
768        ; let act1 = substTy subst act0
769              exp1 = substTy subst exp0
770              (env1, exp2) = tidyOpenType env0 exp1
771              (env2, act2) = tidyOpenType env1 act1
772        ; if (act1 `tcEqType` ty1 && exp1 `tcEqType` ty2)
773          || (exp1 `tcEqType` ty1 && act1 `tcEqType` ty2)
774          then   
775             thing_inside env0 empty
776          else 
777             thing_inside env2 (mkExpectedActualMsg act2 exp2) }
778
779 getWantedEqExtra _ env0 orig _ _ thing_inside
780   = thing_inside env0 (pprArising orig)
781 \end{code}