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