Suppress knock-on typechecker errors
[ghc.git] / compiler / typecheck / TcErrors.lhs
1 \begin{code}
2 module TcErrors( 
3        reportUnsolved, 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 FastString
32 import Outputable
33 import DynFlags
34 import StaticFlags( opt_PprStyle_Debug )
35 import Data.List( partition )
36 import Control.Monad( when, unless )
37 \end{code}
38
39 %************************************************************************
40 %*                                                                      *
41 \section{Errors and contexts}
42 %*                                                                      *
43 %************************************************************************
44
45 ToDo: for these error messages, should we note the location as coming
46 from the insts, or just whatever seems to be around in the monad just
47 now?
48
49 \begin{code}
50 reportUnsolved :: (CanonicalCts, Bag Implication) -> TcM ()
51 reportUnsolved (unsolved_flats, unsolved_implics)
52   | isEmptyBag unsolved
53   = return ()
54   | otherwise
55   = do { unsolved <- mapBagM zonkWanted unsolved
56                      -- Zonk to un-flatten any flatten-skols
57        ; env0 <- tcInitTidyEnv
58        ; let tidy_env      = tidyFreeTyVars env0 (tyVarsOfWanteds unsolved)
59              tidy_unsolved = tidyWanteds tidy_env unsolved
60              err_ctxt = CEC { cec_encl = [] 
61                             , cec_extra = empty
62                             , cec_tidy = tidy_env } 
63        ; traceTc "reportUnsolved" (ppr unsolved)
64        ; reportTidyWanteds err_ctxt tidy_unsolved }
65   where
66     unsolved = mkWantedConstraints unsolved_flats unsolved_implics
67
68
69 reportUnsolvedWantedEvVars :: Bag WantedEvVar -> TcM ()
70 reportUnsolvedWantedEvVars wanteds
71   | isEmptyBag wanteds 
72   = return ()
73   | otherwise
74   = do { wanteds <- mapBagM zonkWantedEvVar wanteds
75        ; env0 <- tcInitTidyEnv
76        ; let tidy_env      = tidyFreeTyVars env0 (tyVarsOfWantedEvVars wanteds)
77              tidy_unsolved = tidyWantedEvVars tidy_env wanteds
78              err_ctxt = CEC { cec_encl  = [] 
79                             , cec_extra = empty
80                             , cec_tidy  = tidy_env } 
81        ; groupErrs (reportFlat err_ctxt) (bagToList tidy_unsolved) }
82
83 reportUnsolvedDeriv :: [PredType] -> WantedLoc -> TcM ()
84 reportUnsolvedDeriv unsolved loc
85   | null unsolved
86   = return ()
87   | otherwise
88   = setCtLoc loc $
89     do { unsolved <- zonkTcThetaType unsolved
90        ; env0 <- tcInitTidyEnv
91        ; let tidy_env      = tidyFreeTyVars env0 (tyVarsOfTheta unsolved)
92              tidy_unsolved = map (tidyPred tidy_env) unsolved
93              err_ctxt = CEC { cec_encl  = [] 
94                             , cec_extra = alt_fix
95                             , cec_tidy  = tidy_env } 
96        ; reportFlat err_ctxt tidy_unsolved (ctLocOrigin loc) }
97   where
98     alt_fix = vcat [ptext (sLit "Alternatively, use a standalone 'deriving instance' declaration,"),
99                     nest 2 $ ptext (sLit "so you can specify the instance context yourself")]
100
101 --------------------------------------------
102 --      Internal functions
103 --------------------------------------------
104
105 data ReportErrCtxt 
106     = CEC { cec_encl :: [Implication]  -- Enclosing implications
107                                        --   (innermost first)
108           , cec_tidy :: TidyEnv
109           , cec_extra :: SDoc          -- Add this to each error message
110       }
111
112 reportTidyImplic :: ReportErrCtxt -> Implication -> TcM ()
113 reportTidyImplic ctxt implic
114   = reportTidyWanteds ctxt' (ic_wanted implic)
115   where
116     ctxt' = ctxt { cec_encl = implic : cec_encl ctxt }
117   
118 reportTidyWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
119 reportTidyWanteds ctxt unsolved
120   = do { let (flats,  implics)    = splitWanteds unsolved
121              (ambigs, non_ambigs) = partition is_ambiguous (bagToList flats)
122              (tv_eqs, others)     = partition is_tv_eq non_ambigs
123
124        ; groupErrs (reportEqErrs ctxt) tv_eqs
125        ; when (null tv_eqs) $ groupErrs (reportFlat ctxt) others
126        ; when (null tv_eqs) $ mapBagM_ (reportTidyImplic ctxt) implics
127
128            -- Only report ambiguity if no other errors happened
129            -- See Note [Avoiding spurious errors]
130        ; when (isEmptyBag implics && null non_ambigs) $
131          reportAmbigErrs ctxt skols ambigs }
132   where
133     skols = foldr (unionVarSet . ic_skols) emptyVarSet (cec_encl ctxt)
134  
135         -- Report equalities of form (a~ty) first.  They are usually
136         -- skolem-equalities, and they cause confusing knock-on 
137         -- effects in other errors; see test T4093b.
138     is_tv_eq c | EqPred ty1 ty2 <- wantedEvVarPred c
139                = tcIsTyVarTy ty1 || tcIsTyVarTy ty2
140                | otherwise = False
141
142         -- Treat it as "ambiguous" if 
143         --   (a) it is a class constraint
144         --   (b) it constrains only type variables
145         --       (else we'd prefer to report it as "no instance for...")
146         --   (c) it mentions type variables that are not skolems
147     is_ambiguous d = isTyVarClassPred pred
148                   && not (tyVarsOfPred pred `subVarSet` skols)
149                   where   
150                      pred = wantedEvVarPred d
151
152 reportFlat :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
153 reportFlat ctxt flats origin
154   = do { unless (null dicts) $ reportDictErrs ctxt dicts origin
155        ; unless (null eqs)   $ reportEqErrs   ctxt eqs   origin
156        ; unless (null ips)   $ reportIPErrs   ctxt ips   origin
157        ; ASSERT( null others ) return () }
158   where
159     (dicts, non_dicts) = partition isClassPred flats
160     (eqs, non_eqs)     = partition isEqPred    non_dicts
161     (ips, others)      = partition isIPPred    non_eqs
162
163 --------------------------------------------
164 --      Support code 
165 --------------------------------------------
166
167 groupErrs :: ([PredType] -> CtOrigin -> TcM ()) -- Deal with one group
168           -> [WantedEvVar]                      -- Unsolved wanteds
169           -> TcM ()
170 -- Group together insts with the same origin
171 -- We want to report them together in error messages
172
173 groupErrs _ [] 
174   = return ()
175 groupErrs report_err (wanted : wanteds)
176   = do  { setCtLoc the_loc $ 
177           report_err the_vars (ctLocOrigin the_loc)
178         ; groupErrs report_err others }
179   where
180    the_loc           = wantedEvVarLoc wanted
181    the_key           = mk_key the_loc
182    the_vars          = map wantedEvVarPred (wanted:friends)
183    (friends, others) = partition is_friend wanteds
184    is_friend friend  = mk_key (wantedEvVarLoc friend) == the_key
185
186    mk_key :: WantedLoc -> (SrcSpan, String)
187    mk_key loc = (ctLocSpan loc, showSDoc (ppr (ctLocOrigin loc)))
188         -- It may seem crude to compare the error messages,
189         -- but it makes sure that we combine just what the user sees,
190         -- and it avoids need equality on InstLocs.
191
192 -- Add the "arising from..." part to a message about bunch of dicts
193 addArising :: CtOrigin -> SDoc -> SDoc
194 addArising orig msg = msg $$ nest 2 (pprArising orig)
195
196 pprWithArising :: [WantedEvVar] -> (WantedLoc, SDoc)
197 -- Print something like
198 --    (Eq a) arising from a use of x at y
199 --    (Show a) arising froma use of p at q
200 -- Also return a location for the erroe message
201 pprWithArising [] 
202   = panic "pprWithArising"
203 pprWithArising [WantedEvVar ev loc] 
204   = (loc, pprEvVarTheta [ev] <+> pprArising (ctLocOrigin loc))
205 pprWithArising ev_vars
206   = (first_loc, vcat (map ppr_one ev_vars))
207   where
208     first_loc = wantedEvVarLoc (head ev_vars)
209     ppr_one (WantedEvVar v loc) 
210        = parens (pprPred (evVarPred v)) <+> pprArisingAt loc
211
212 addErrorReport :: ReportErrCtxt -> SDoc -> TcM ()
213 addErrorReport ctxt msg = addErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt)
214
215 pprErrCtxtLoc :: ReportErrCtxt -> SDoc
216 pprErrCtxtLoc ctxt 
217   = case map (ctLocOrigin . ic_loc) (cec_encl ctxt) of
218        []           -> ptext (sLit "the top level")     -- Should not happen
219        (orig:origs) -> ppr_skol orig $$ 
220                        vcat [ ptext (sLit "or") <+> ppr_skol orig | orig <- origs ]
221   where
222     ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc)
223     ppr_skol skol_info      = pprSkolInfo skol_info
224
225 couldNotDeduce :: [EvVar] -> [PredType] -> SDoc
226 couldNotDeduce givens wanteds
227   = sep [ ptext (sLit "Could not deduce") <+> pprTheta wanteds
228         , nest 2 $ ptext (sLit "from the context") 
229                      <+> pprEvVarTheta givens]
230
231 getUserGivens :: ReportErrCtxt -> Maybe [EvVar]
232 -- Just gs => Say "could not deduce ... from gs"
233 -- Nothing => No interesting givens, say something else
234 getUserGivens (CEC {cec_encl = ctxt})
235   | null user_givens = Nothing
236   | otherwise        = Just user_givens
237   where 
238     givens = foldl (\gs ic -> ic_given ic ++ gs) [] ctxt
239     user_givens | opt_PprStyle_Debug = givens
240                 | otherwise          = filterOut isSelfDict givens
241        -- In user mode, don't show the "self-dict" given
242        -- which is only added to do co-inductive solving
243        -- Rather an awkward hack, but there we are
244        -- This is the only use of isSelfDict, so it's not in an inner loop
245 \end{code}
246
247
248 %************************************************************************
249 %*                                                                      *
250                 Implicit parameter errors
251 %*                                                                      *
252 %************************************************************************
253
254 \begin{code}
255 reportIPErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
256 reportIPErrs ctxt ips orig
257   = addErrorReport ctxt $ addArising orig msg
258   where
259     msg | Just givens <- getUserGivens ctxt
260         = couldNotDeduce givens ips
261         | otherwise
262         = sep [ ptext (sLit "Unbound implicit parameter") <> plural ips
263               , nest 2 (pprTheta ips) ] 
264 \end{code}
265
266
267 %************************************************************************
268 %*                                                                      *
269                 Equality errors
270 %*                                                                      *
271 %************************************************************************
272
273 \begin{code}
274 reportEqErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
275 reportEqErrs ctxt eqs orig
276   = mapM_ report_one eqs 
277   where
278     env0 = cec_tidy ctxt
279     report_one (EqPred ty1 ty2) 
280       = do { (env1, extra) <- getWantedEqExtra emptyTvSubst env0 orig ty1 ty2
281            ; let ctxt' = ctxt { cec_tidy = env1
282                                , cec_extra = cec_extra ctxt $$ extra }
283            ; reportEqErr ctxt' ty1 ty2 }
284     report_one pred 
285       = 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 xopt 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          These ones are called *during* constraint simplification
644 %*                                                                      *
645 %************************************************************************
646
647 \begin{code}
648 kindErrorTcS :: CtFlavor -> TcType -> TcType -> TcS ()
649 -- If there's a kind error, we don't want to blindly say "kind error"
650 -- We might, say, be unifying a skolem 'a' with a type 'Int', 
651 -- in which case that's the error to report.  So we set things
652 -- up to call reportEqErr, which does the business properly
653 kindErrorTcS fl ty1 ty2
654   = wrapEqErrTcS fl ty1 ty2 $ \ env0 ty1 ty2 extra -> 
655     do { let ctxt = CEC { cec_encl = []
656                         , cec_extra = extra
657                         , cec_tidy = env0 }
658        ; reportEqErr ctxt ty1 ty2 }
659
660 misMatchErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a
661 misMatchErrorTcS fl ty1 ty2
662   = wrapEqErrTcS fl ty1 ty2 $ \ env0 ty1 ty2 extra -> 
663     do { let (env1, msg)  = misMatchMsgWithExtras env0 ty1 ty2
664        ; failWithTcM (env1, inaccessible_msg $$ msg $$ extra) }
665   where
666     inaccessible_msg 
667       = case fl of 
668           Given loc -> hang (ptext (sLit "Inaccessible code in"))
669                           2 (mk_what loc)
670           _         -> empty
671     mk_what loc 
672       = case ctLocOrigin loc of
673           PatSkol dc mc -> sep [ ptext (sLit "a pattern with constructor") 
674                                    <+> quotes (ppr dc) <> comma
675                                , ptext (sLit "in") <+> pprMatchContext mc ]
676           other_skol -> pprSkolInfo other_skol
677
678 occursCheckErrorTcS :: CtFlavor -> TcTyVar -> TcType -> TcS a
679 occursCheckErrorTcS fl tv ty
680   = wrapEqErrTcS fl (mkTyVarTy tv) ty $ \ env0 ty1 ty2 extra2 -> 
681     do  { let extra1 = sep [ppr ty1, char '=', ppr ty2]
682         ; failWithTcM (env0, hang msg 2 (extra1 $$ extra2)) }
683   where
684     msg = text $ "Occurs check: cannot construct the infinite type:"
685
686 solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a
687 solverDepthErrorTcS depth stack
688   | null stack      -- Shouldn't happen unless you say -fcontext-stack=0
689   = wrapErrTcS $ failWith msg
690   | otherwise
691   = wrapErrTcS $ 
692     setCtFlavorLoc (cc_flavor top_item) $
693     do { env0 <- tcInitTidyEnv
694        ; let ev_vars  = map cc_id stack
695              env1     = tidyFreeTyVars env0 free_tvs
696              free_tvs = foldr (unionVarSet . tyVarsOfEvVar) emptyVarSet ev_vars
697              extra    = pprEvVars (map (tidyEvVar env1) ev_vars)
698        ; failWithTcM (env1, hang msg 2 extra) }
699   where
700     top_item = head stack
701     msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
702                , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
703
704 flattenForAllErrorTcS :: CtFlavor -> TcType -> Bag CanonicalCt -> TcS a
705 flattenForAllErrorTcS fl ty _bad_eqs
706   = wrapErrTcS        $ 
707     setCtFlavorLoc fl $ 
708     do { env0 <- tcInitTidyEnv
709        ; let (env1, ty') = tidyOpenType env0 ty 
710              msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:")
711                        , ppr ty' ]
712        ; failWithTcM (env1, msg) }
713 \end{code}
714
715 %************************************************************************
716 %*                                                                      *
717                  Setting the context
718 %*                                                                      *
719 %************************************************************************
720
721 \begin{code}
722 setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
723 setCtFlavorLoc (Wanted  loc) thing = setCtLoc loc thing
724 setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing
725 setCtFlavorLoc (Given   loc) thing = setCtLoc loc thing
726
727 wrapEqErrTcS :: CtFlavor -> TcType -> TcType
728              -> (TidyEnv -> TcType -> TcType -> SDoc -> TcM a)
729              -> TcS a
730 wrapEqErrTcS fl ty1 ty2 thing_inside
731   = do { ty_binds_var <- getTcSTyBinds
732        ; wrapErrTcS $ setCtFlavorLoc fl $ 
733     do {   -- Apply the current substitition
734            -- and zonk to get rid of flatten-skolems
735        ; ty_binds_map <- readTcRef ty_binds_var
736        ; let subst = mkOpenTvSubst (mapVarEnv snd ty_binds_map)
737        ; env0 <- tcInitTidyEnv 
738        ; (env1, ty1) <- zonkSubstTidy env0 subst ty1
739        ; (env2, ty2) <- zonkSubstTidy env1 subst ty2
740        ; let do_wanted loc = do { (env3, extra) <- getWantedEqExtra subst env2 
741                                                      (ctLocOrigin loc) ty1 ty2
742                                 ; thing_inside env3 ty1 ty2 extra } 
743        ; case fl of
744            Wanted  loc -> do_wanted loc
745            Derived loc -> do_wanted loc
746            Given {}    -> thing_inside env2 ty1 ty2 empty 
747                                  -- We could print more info, but it
748                                  -- seems to be coming out already
749        } }  
750   where
751
752 getWantedEqExtra :: TvSubst -> TidyEnv -> CtOrigin -> TcType -> TcType
753                  -> TcM (TidyEnv, SDoc)
754 getWantedEqExtra subst env0 (TypeEqOrigin item) ty1 ty2
755   -- If the types in the error message are the same 
756   -- as the types we are unifying (remember to zonk the latter)
757   -- don't add the extra expected/actual message
758   --
759   -- The complication is that the types in the TypeEqOrigin must
760   --   (a) be zonked
761   --   (b) have any TcS-monad pending equalities applied to them 
762   --            (hence the passed-in substitution)
763   = do { (env1, act) <- zonkSubstTidy env0 subst (uo_actual item)
764        ; (env2, exp) <- zonkSubstTidy env1 subst (uo_expected item)
765        ; if (act `tcEqType` ty1 && exp `tcEqType` ty2)
766          || (exp `tcEqType` ty1 && act `tcEqType` ty2)
767          then   
768             return (env0, empty)
769          else 
770             return (env2, mkExpectedActualMsg act exp) }
771
772 getWantedEqExtra _ env0 orig _ _ 
773   = return (env0, pprArising orig)
774
775 zonkSubstTidy :: TidyEnv -> TvSubst -> TcType -> TcM (TidyEnv, TcType)
776 -- In general, becore printing a type, we want to
777 --   a) Zonk it.  Even during constraint simplification this is
778 --      is important, to un-flatten the flatten skolems in a type
779 --   b) Substitute any solved unification variables.  This is
780 --      only important *during* solving, becuase after solving
781 --      the substitution is expressed in the mutable type variables
782 --      But during solving there may be constraint (F xi ~ ty)
783 --      where the substitution has not been applied to the RHS
784 zonkSubstTidy env subst ty
785   = do { ty' <- zonkTcTypeAndSubst subst ty
786        ; return (tidyOpenType env ty') }
787 \end{code}