TcErrors.lhs 34.5 KB
Newer Older
1 2
\begin{code}
module TcErrors( 
3 4 5
       reportUnsolved,
       warnDefaulting,
       unifyCtxt,
6 7 8

       flattenForAllErrorTcS,
       solverDepthErrorTcS
9 10 11 12 13 14 15 16
  ) where

#include "HsVersions.h"

import TcRnMonad
import TcMType
import TcSMonad
import TcType
17
import TypeRep
18
import Type( isTyVarTy )
19

20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38
import Inst
import InstEnv

import TyCon
import Name
import NameEnv
import Id	( idType )
import Var
import VarSet
import VarEnv
import SrcLoc
import Bag
import ListSetOps( equivClasses )
import Util
import FastString
import Outputable
import DynFlags
import StaticFlags( opt_PprStyle_Debug )
import Data.List( partition )
39
import Control.Monad( when, unless )
40 41 42 43 44 45 46 47 48 49 50 51 52
\end{code}

%************************************************************************
%*									*
\section{Errors and contexts}
%*									*
%************************************************************************

ToDo: for these error messages, should we note the location as coming
from the insts, or just whatever seems to be around in the monad just
now?

\begin{code}
53 54 55
reportUnsolved :: WantedConstraints -> TcM ()
reportUnsolved wanted
  | isEmptyWC wanted
56 57
  = return ()
  | otherwise
58 59
  = do {   -- Zonk to un-flatten any flatten-skols
       ; wanted  <- zonkWC wanted
60

61
       ; env0 <- tcInitTidyEnv
62 63 64 65
       ; let tidy_env = tidyFreeTyVars env0 free_tvs
             free_tvs = tyVarsOfWC wanted
             err_ctxt = CEC { cec_encl  = []
                            , cec_insol = insolubleWC wanted
66
                            , cec_extra = empty
67 68
                            , cec_tidy  = tidy_env }
             tidy_wanted = tidyWC tidy_env wanted
69

70
       ; traceTc "reportUnsolved" (ppr tidy_wanted)
71

72
       ; reportTidyWanteds err_ctxt tidy_wanted }
73

74 75 76
--------------------------------------------
--      Internal functions
--------------------------------------------
77 78 79 80

data ReportErrCtxt 
    = CEC { cec_encl :: [Implication]  -- Enclosing implications
                	       	       --   (innermost first)
81 82 83 84 85
          , cec_tidy  :: TidyEnv
          , cec_extra :: SDoc       -- Add this to each error message
          , cec_insol :: Bool       -- True <=> we are reporting insoluble errors only
                                    --      Main effect: don't say "Cannot deduce..."
                                    --      when reporting equality errors; see misMatchOrCND
86 87 88 89
      }

reportTidyImplic :: ReportErrCtxt -> Implication -> TcM ()
reportTidyImplic ctxt implic
90 91 92 93 94 95 96
  | BracketSkol <- ctLocOrigin (ic_loc implic)
  , not insoluble  -- For Template Haskell brackets report only
  = return ()      -- definite errors. The whole thing will be re-checked
                   -- later when we plug it in, and meanwhile there may
                   -- certainly be un-satisfied constraints

  | otherwise
97 98
  = reportTidyWanteds ctxt' (ic_wanted implic)
  where
99 100 101 102
    insoluble = ic_insol implic
    ctxt' = ctxt { cec_encl = implic : cec_encl ctxt
                 , cec_insol = insoluble }

103
reportTidyWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
104 105 106 107 108 109 110 111 112 113 114 115 116 117 118
reportTidyWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = implics })
  | cec_insol ctxt     -- If there are any insolubles, report only them
                       -- because they are unconditionally wrong
                       -- Moreover, if any of the insolubles are givens, stop right there
                       -- ignoring nested errors, because the code is inaccessible
  = do { let (given, other) = partitionBag (isGiven . evVarX) insols
             insol_implics  = filterBag ic_insol implics
       ; if isEmptyBag given
         then do { mapBagM_ (reportInsoluble ctxt) other
                 ; mapBagM_ (reportTidyImplic ctxt) insol_implics }
         else mapBagM_ (reportInsoluble ctxt) given }

  | otherwise          -- No insoluble ones
  = ASSERT( isEmptyBag insols )
    do { let (ambigs, non_ambigs) = partition is_ambiguous (bagToList flats)
119 120 121 122
       	     (tv_eqs, others)     = partition is_tv_eq non_ambigs

       ; groupErrs (reportEqErrs ctxt) tv_eqs
       ; when (null tv_eqs) $ groupErrs (reportFlat ctxt) others
123
       ; mapBagM_ (reportTidyImplic ctxt) implics
124

125 126 127
       	   -- Only report ambiguity if no other errors (at all) happened
	   -- See Note [Avoiding spurious errors] in TcSimplify
       ; ifErrsM (return ()) $ reportAmbigErrs ctxt skols ambigs }
128 129 130
  where
    skols = foldr (unionVarSet . ic_skols) emptyVarSet (cec_encl ctxt)
 
131 132 133
	-- Report equalities of form (a~ty) first.  They are usually
	-- skolem-equalities, and they cause confusing knock-on 
	-- effects in other errors; see test T4093b.
134
    is_tv_eq c | EqPred ty1 ty2 <- evVarOfPred c
135 136 137
               = tcIsTyVarTy ty1 || tcIsTyVarTy ty2
               | otherwise = False

138 139 140 141 142 143 144 145
	-- Treat it as "ambiguous" if 
	--   (a) it is a class constraint
        --   (b) it constrains only type variables
	--       (else we'd prefer to report it as "no instance for...")
        --   (c) it mentions type variables that are not skolems
    is_ambiguous d = isTyVarClassPred pred
                  && not (tyVarsOfPred pred `subVarSet` skols)
		  where   
146 147 148 149 150 151 152 153 154 155 156 157 158 159 160
                     pred = evVarOfPred d

reportInsoluble :: ReportErrCtxt -> FlavoredEvVar -> TcM ()
reportInsoluble ctxt (EvVarX ev flav)
  | EqPred ty1 ty2 <- evVarPred ev
  = setCtFlavorLoc flav $
    do { let ctxt2 = ctxt { cec_extra = cec_extra ctxt $$ inaccessible_msg }
       ; reportEqErr ctxt2 ty1 ty2 }
  | otherwise
  = pprPanic "reportInsoluble" (pprEvVarWithType ev)
  where
    inaccessible_msg | Given loc <- flav
                     = hang (ptext (sLit "Inaccessible code in"))
                          2 (ppr (ctLocOrigin loc))
                     | otherwise = empty
161

162
reportFlat :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
163
-- The [PredType] are already tidied
164 165
reportFlat ctxt flats origin
  = do { unless (null dicts) $ reportDictErrs ctxt dicts origin
166
       ; unless (null eqs)   $ reportEqErrs   ctxt eqs   origin
167
       ; unless (null ips)   $ reportIPErrs   ctxt ips   origin
168 169 170 171 172 173 174 175 176 177
       ; ASSERT( null others ) return () }
  where
    (dicts, non_dicts) = partition isClassPred flats
    (eqs, non_eqs)     = partition isEqPred    non_dicts
    (ips, others)      = partition isIPPred    non_eqs

--------------------------------------------
--      Support code 
--------------------------------------------

178 179
groupErrs :: ([PredType] -> CtOrigin -> TcM ()) -- Deal with one group
	  -> [WantedEvVar]	                -- Unsolved wanteds
180 181 182 183 184 185 186
          -> TcM ()
-- Group together insts with the same origin
-- We want to report them together in error messages

groupErrs _ [] 
  = return ()
groupErrs report_err (wanted : wanteds)
187
  = do  { setCtLoc the_loc $
188
          report_err the_vars (ctLocOrigin the_loc)
189 190
	; groupErrs report_err others }
  where
191
   the_loc           = evVarX wanted
192
   the_key	     = mk_key the_loc
193
   the_vars          = map evVarOfPred (wanted:friends)
194
   (friends, others) = partition is_friend wanteds
195 196 197 198 199 200 201 202 203 204 205
   is_friend friend  = mk_key (evVarX friend) `same_key` the_key

   mk_key :: WantedLoc -> (SrcSpan, CtOrigin)
   mk_key loc = (ctLocSpan loc, ctLocOrigin loc)

   same_key (s1, o1) (s2, o2) = s1==s2 && o1 `same_orig` o2
   same_orig (OccurrenceOf n1) (OccurrenceOf n2) = n1==n2
   same_orig ScOrigin          ScOrigin          = True
   same_orig DerivOrigin       DerivOrigin       = True
   same_orig DefaultOrigin     DefaultOrigin     = True
   same_orig _ _ = False
206 207 208


-- Add the "arising from..." part to a message about bunch of dicts
209 210
addArising :: CtOrigin -> SDoc -> SDoc
addArising orig msg = msg $$ nest 2 (pprArising orig)
211 212 213 214

pprWithArising :: [WantedEvVar] -> (WantedLoc, SDoc)
-- Print something like
--    (Eq a) arising from a use of x at y
215 216
--    (Show a) arising from a use of p at q
-- Also return a location for the error message
217 218
pprWithArising [] 
  = panic "pprWithArising"
219
pprWithArising [EvVarX ev loc]
220
  = (loc, pprEvVarTheta [ev] <+> pprArising (ctLocOrigin loc))
221 222 223
pprWithArising ev_vars
  = (first_loc, vcat (map ppr_one ev_vars))
  where
224 225
    first_loc = evVarX (head ev_vars)
    ppr_one (EvVarX v loc)
226 227 228 229 230 231 232 233 234 235 236 237 238
       = parens (pprPred (evVarPred v)) <+> pprArisingAt loc

addErrorReport :: ReportErrCtxt -> SDoc -> TcM ()
addErrorReport ctxt msg = addErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt)

pprErrCtxtLoc :: ReportErrCtxt -> SDoc
pprErrCtxtLoc ctxt 
  = case map (ctLocOrigin . ic_loc) (cec_encl ctxt) of
       []           -> ptext (sLit "the top level")	-- Should not happen
       (orig:origs) -> ppr_skol orig $$ 
                       vcat [ ptext (sLit "or") <+> ppr_skol orig | orig <- origs ]
  where
    ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc)
239
    ppr_skol skol_info      = ppr skol_info
240

241 242
getUserGivens :: ReportErrCtxt -> [([EvVar], GivenLoc)]
-- One item for each enclosing implication
243
getUserGivens (CEC {cec_encl = ctxt})
244 245 246 247 248 249 250
  = reverse $
    [ (givens', loc) | Implic {ic_given = givens, ic_loc = loc} <- ctxt
                     , let givens' = get_user_givens givens
                     , not (null givens') ]
  where
    get_user_givens givens | opt_PprStyle_Debug = givens
                           | otherwise          = filterOut isSilentEvVar givens
251 252
       -- In user mode, don't show the "silent" givens, used for
       -- the "self" dictionary and silent superclass arguments for dfuns
253

254 255 256 257 258 259 260 261 262 263
\end{code}


%************************************************************************
%*									*
                Implicit parameter errors
%*									*
%************************************************************************

\begin{code}
264 265
reportIPErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
reportIPErrs ctxt ips orig
266
  = addErrorReport ctxt msg
267
  where
268 269 270 271
    givens = getUserGivens ctxt
    msg | null givens
        = addArising orig $
          sep [ ptext (sLit "Unbound implicit parameter") <> plural ips
272
              , nest 2 (pprTheta ips) ] 
273 274
        | otherwise
        = couldNotDeduce givens (ips, orig)
275 276 277 278 279 280 281 282 283 284
\end{code}


%************************************************************************
%*									*
                Equality errors
%*									*
%************************************************************************

\begin{code}
285
reportEqErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
286
-- The [PredType] are already tidied
287
reportEqErrs ctxt eqs orig
288 289
  = do { orig' <- zonkTidyOrigin ctxt orig
       ; mapM_ (report_one orig') eqs }
290
  where
291 292 293
    report_one orig (EqPred ty1 ty2)
      = do { let extra = getWantedEqExtra orig ty1 ty2
                 ctxt' = ctxt { cec_extra = extra $$ cec_extra ctxt }
294
           ; reportEqErr ctxt' ty1 ty2 }
295
    report_one _ pred
296
      = pprPanic "reportEqErrs" (ppr pred)    
297

298 299 300 301 302 303 304 305 306 307 308
getWantedEqExtra ::  CtOrigin -> TcType -> TcType -> SDoc
getWantedEqExtra (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp }))
                 ty1 ty2
  -- If the types in the error message are the same as the types we are unifying,
  -- don't add the extra expected/actual message
  | act `tcEqType` ty1 && exp `tcEqType` ty2 = empty
  | exp `tcEqType` ty1 && act `tcEqType` ty2 = empty
  | otherwise                                = mkExpectedActualMsg act exp

getWantedEqExtra orig _ _ = pprArising orig

309
reportEqErr :: ReportErrCtxt -> TcType -> TcType -> TcM ()
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
310
-- ty1 and ty2 are already tidied
311 312 313
reportEqErr ctxt ty1 ty2
  | Just tv1 <- tcGetTyVar_maybe ty1 = reportTyVarEqErr ctxt tv1 ty2
  | Just tv2 <- tcGetTyVar_maybe ty2 = reportTyVarEqErr ctxt tv2 ty1
314

315 316 317
  | otherwise	-- Neither side is a type variable
    		-- Since the unsolved constraint is canonical, 
		-- it must therefore be of form (F tys ~ ty)
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
318
  = addErrorReport ctxt (misMatchOrCND ctxt ty1 ty2 $$ mkTyFunInfoMsg ty1 ty2)
319

320

321
reportTyVarEqErr :: ReportErrCtxt -> TcTyVar -> TcType -> TcM ()
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
322
-- tv1 and ty2 are already tidied
323
reportTyVarEqErr ctxt tv1 ty2
324 325 326 327
  |  isSkolemTyVar tv1 	  -- ty2 won't be a meta-tyvar, or else the thing would
     		   	  -- be oriented the other way round; see TcCanonical.reOrient
  || isSigTyVar tv1 && not (isTyVarTy ty2)
  = addErrorReport (addExtraInfo ctxt ty1 ty2)
328
                   (misMatchOrCND ctxt ty1 ty2)
329 330 331 332 333 334

  -- So tv is a meta tyvar, and presumably it is
  -- an *untouchable* meta tyvar, else it'd have been unified
  | not (k2 `isSubKind` k1)   	 -- Kind error
  = addErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2)

335 336 337 338 339 340
  -- Occurs check
  | tv1 `elemVarSet` tyVarsOfType ty2
  = let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:") 2
                           (sep [ppr ty1, char '=', ppr ty2])
    in addErrorReport ctxt occCheckMsg

341 342 343 344 345 346 347 348 349
  -- Check for skolem escape
  | (implic:_) <- cec_encl ctxt   -- Get the innermost context
  , let esc_skols = varSetElems (tyVarsOfType ty2 `intersectVarSet` ic_skols implic)
        implic_loc = ic_loc implic
  , not (null esc_skols)
  = setCtLoc implic_loc $	-- Override the error message location from the
    	     			-- place the equality arose to the implication site
    do { (env1, env_sigs) <- findGlobals ctxt (unitVarSet tv1)
       ; let msg = misMatchMsg ty1 ty2
350 351 352 353 354 355
             esc_doc = sep [ ptext (sLit "because type variable") <> plural esc_skols
                             <+> pprQuotedList esc_skols
                           , ptext (sLit "would escape") <+>
                             if isSingleton esc_skols then ptext (sLit "its scope")
                                                      else ptext (sLit "their scope") ]
             extra1 = vcat [ nest 2 $ esc_doc
356
                           , sep [ (if isSingleton esc_skols 
357 358
                                    then ptext (sLit "This (rigid, skolem) type variable is")
                                    else ptext (sLit "These (rigid, skolem) type variables are"))
359
                                   <+> ptext (sLit "bound by")
360
                                 , nest 2 $ ppr (ctLocOrigin implic_loc) ] ]
361 362 363 364 365 366 367
       ; addErrTcM (env1, msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) }

  -- Nastiest case: attempt to unify an untouchable variable
  | (implic:_) <- cec_encl ctxt   -- Get the innermost context
  , let implic_loc = ic_loc implic
        given      = ic_given implic
  = setCtLoc (ic_loc implic) $
368 369 370 371
    do { let msg = misMatchMsg ty1 ty2
             extra = quotes (ppr tv1)
                 <+> sep [ ptext (sLit "is untouchable")
                         , ptext (sLit "inside the constraints") <+> pprEvVarTheta given
372
                         , ptext (sLit "bound at") <+> ppr (ctLocOrigin implic_loc)]
373 374
       ; addErrorReport (addExtraInfo ctxt ty1 ty2) (msg $$ nest 2 extra) }

375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390
  | otherwise
  = pprTrace "reportTyVarEqErr" (ppr tv1 $$ ppr ty2 $$ ppr (cec_encl ctxt)) $
    return () 
    	-- I don't think this should happen, and if it does I want to know
	-- Trac #5130 happened because an actual type error was not
	-- reported at all!  So not reporting is pretty dangerous.
	-- 
	-- OLD, OUT OF DATE COMMENT
        -- This can happen, by a recursive decomposition of frozen
        -- occurs check constraints
        -- Example: alpha ~ T Int alpha has frozen.
        --          Then alpha gets unified to T beta gamma
        -- So now we have  T beta gamma ~ T Int (T beta gamma)
        -- Decompose to (beta ~ Int, gamma ~ T beta gamma)
        -- The (gamma ~ T beta gamma) is the occurs check, but
        -- the (beta ~ Int) isn't an error at all.  So return ()
391
  where         
392 393 394
    k1 	= tyVarKind tv1
    k2 	= typeKind ty2
    ty1 = mkTyVarTy tv1
395 396 397 398 399 400 401 402 403 404 405 406 407 408

mkTyFunInfoMsg :: TcType -> TcType -> SDoc
-- See Note [Non-injective type functions]
mkTyFunInfoMsg ty1 ty2
  | Just (tc1,_) <- tcSplitTyConApp_maybe ty1
  , Just (tc2,_) <- tcSplitTyConApp_maybe ty2
  , tc1 == tc2, isSynFamilyTyCon tc1
  = ptext (sLit "NB:") <+> quotes (ppr tc1) 
    <+> ptext (sLit "is a type function") <> (pp_inj tc1)
  | otherwise = empty
  where       
    pp_inj tc | isInjectiveTyCon tc = empty
              | otherwise = ptext (sLit (", and may not be injective"))

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
409 410
misMatchOrCND :: ReportErrCtxt -> TcType -> TcType -> SDoc
misMatchOrCND ctxt ty1 ty2
411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429
  | cec_insol ctxt = misMatchMsg ty1 ty2    -- If the equality is unconditionally
                                            -- insoluble, don't report the context
  | null givens    = misMatchMsg ty1 ty2
  | otherwise      = couldNotDeduce givens ([EqPred ty1 ty2], orig)
  where
    givens = getUserGivens ctxt
    orig   = TypeEqOrigin (UnifyOrigin ty1 ty2)

couldNotDeduce :: [([EvVar], GivenLoc)] -> (ThetaType, CtOrigin) -> SDoc
couldNotDeduce givens (wanteds, orig)
  = vcat [ hang (ptext (sLit "Could not deduce") <+> pprTheta wanteds)
              2 (pprArising orig)
         , vcat pp_givens ]
  where
    pp_givens
      = case givens of
         []     -> []
         (g:gs) ->      ppr_given (ptext (sLit "from the context")) g
                 : map (ppr_given (ptext (sLit "or from"))) gs
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
430

431 432 433 434
    ppr_given herald (gs,loc)
      = hang (herald <+> pprEvVarTheta gs)
           2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin loc)
                  , ptext (sLit "at") <+> ppr (ctLocSpan loc)])
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
435

436 437 438 439
addExtraInfo :: ReportErrCtxt -> TcType -> TcType -> ReportErrCtxt
-- Add on extra info about the types themselves
-- NB: The types themselves are already tidied
addExtraInfo ctxt ty1 ty2
440
  = ctxt { cec_extra = nest 2 (extra1 $$ extra2) $$ cec_extra ctxt }
441
  where
442 443
    extra1 = typeExtraInfoMsg (cec_encl ctxt) ty1
    extra2 = typeExtraInfoMsg (cec_encl ctxt) ty2
444 445 446 447 448 449 450 451 452 453 454 455 456 457

misMatchMsg :: TcType -> TcType -> SDoc	   -- Types are already tidy
misMatchMsg ty1 ty2 = sep [ ptext (sLit "Couldn't match type") <+> quotes (ppr ty1)
	                  , nest 15 $ ptext (sLit "with") <+> quotes (ppr ty2)]

kindErrorMsg :: TcType -> TcType -> SDoc   -- Types are already tidy
kindErrorMsg ty1 ty2
  = vcat [ ptext (sLit "Kind incompatibility when matching types:")
         , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1
                        , ppr ty2 <+> dcolon <+> ppr k2 ]) ]
  where
    k1 = typeKind ty1
    k2 = typeKind ty2

458
typeExtraInfoMsg :: [Implication] -> Type -> SDoc
459
-- Shows a bit of extra info about skolem constants
460
typeExtraInfoMsg implics ty
461
  | Just tv <- tcGetTyVar_maybe ty
Simon Peyton Jones's avatar
Simon Peyton Jones committed
462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477
  , isTcTyVar tv, isSkolemTyVar tv
  , let pp_tv = quotes (ppr tv)
 = case tcTyVarDetails tv of
    SkolemTv {}   -> pp_tv <+> ppr_skol (getSkolemInfo implics tv) (getSrcLoc tv)
    FlatSkol {}   -> pp_tv <+> ptext (sLit "is a flattening type variable")
    RuntimeUnk {} -> pp_tv <+> ptext (sLit "is an interactive-debugger skolem")
    MetaTv {}     -> empty

 | otherwise             -- Normal case
 = empty

 where
   ppr_skol UnkSkol _   = ptext (sLit "is an unknown type variable")  -- Unhelpful
   ppr_skol info    loc = sep [ptext (sLit "is a rigid type variable bound by"),
                               sep [ppr info, ptext (sLit "at") <+> ppr loc]]
 
478 479 480
--------------------
unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc)
unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env
481 482 483
  = do  { (env1, act_ty') <- zonkTidyTcType tidy_env act_ty
        ; (env2, exp_ty') <- zonkTidyTcType env1 exp_ty
        ; return (env2, mkExpectedActualMsg act_ty' exp_ty') }
484 485 486 487 488

mkExpectedActualMsg :: Type -> Type -> SDoc
mkExpectedActualMsg act_ty exp_ty
  = vcat [ text "Expected type" <> colon <+> ppr exp_ty
         , text "  Actual type" <> colon <+> ppr act_ty ]
489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508
\end{code}

Note [Non-injective type functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's very confusing to get a message like
     Couldn't match expected type `Depend s'
            against inferred type `Depend s1'
so mkTyFunInfoMsg adds:
       NB: `Depend' is type function, and hence may not be injective

Warn of loopy local equalities that were dropped.


%************************************************************************
%*									*
                 Type-class errors
%*									*
%************************************************************************

\begin{code}
509 510
reportDictErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()	
reportDictErrs ctxt wanteds orig
511
  = do { inst_envs <- tcGetInstEnvs
512 513 514
       ; non_overlaps <- mapMaybeM (reportOverlap ctxt inst_envs orig) wanteds
       ; unless (null non_overlaps) $
         addErrorReport ctxt (mk_no_inst_err non_overlaps) }
515 516 517
  where
    mk_no_inst_err :: [PredType] -> SDoc
    mk_no_inst_err wanteds
518
      | null givens     -- Top level
519
      = vcat [ addArising orig $
520 521 522
               ptext (sLit "No instance") <> plural min_wanteds
                    <+> ptext (sLit "for") <+> pprTheta min_wanteds
             , show_fixes (fixes2 ++ fixes3) ]
523

524 525 526
      | otherwise
      = vcat [ couldNotDeduce givens (min_wanteds, orig)
             , show_fixes (fix1 : (fixes2 ++ fixes3)) ]
527
      where
528 529 530
        givens = getUserGivens ctxt
        min_wanteds = mkMinimalBySCs wanteds
        fix1 = sep [ ptext (sLit "add") <+> pprTheta min_wanteds
531 532 533
                          <+> ptext (sLit "to the context of")
	           , nest 2 $ pprErrCtxtLoc ctxt ]

534 535 536 537 538 539
        fixes2 = case instance_dicts of
                   []  -> []
                   [_] -> [sep [ptext (sLit "add an instance declaration for"),
                                pprTheta instance_dicts]]
                   _   -> [sep [ptext (sLit "add instance declarations for"),
                                pprTheta instance_dicts]]
540 541 542 543 544
        fixes3 = case orig of
                   DerivOrigin -> [drv_fix]
                   _           -> []

        instance_dicts = filterOut isTyVarClassPred min_wanteds
545 546 547
		-- Insts for which it is worth suggesting an adding an 
		-- instance declaration.  Exclude tyvar dicts.

548 549 550
        drv_fix = vcat [ptext (sLit "use a standalone 'deriving instance' declaration,"),
                        nest 2 $ ptext (sLit "so you can specify the instance context yourself")]

551 552 553 554 555
	show_fixes :: [SDoc] -> SDoc
	show_fixes []     = empty
	show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"), 
				 nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]

556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643
reportOverlap :: ReportErrCtxt -> (InstEnv,InstEnv) -> CtOrigin
              -> PredType -> TcM (Maybe PredType)
-- Report an overlap error if this class constraint results
-- from an overlap (returning Nothing), otherwise return (Just pred)
reportOverlap ctxt inst_envs orig pred@(ClassP clas tys)
  = do { tys_flat <- mapM quickFlattenTy tys
           -- Note [Flattening in error message generation]

       ; case lookupInstEnv inst_envs clas tys_flat of
                ([], _) -> return (Just pred)               -- No match
		-- The case of exactly one match and no unifiers means a
		-- successful lookup.  That can't happen here, because dicts
		-- only end up here if they didn't match in Inst.lookupInst
		([_],[])
		 | debugIsOn -> pprPanic "check_overlap" (ppr pred)
                res          -> do { addErrorReport ctxt (mk_overlap_msg res)
                                   ; return Nothing } }
  where
    mk_overlap_msg (matches, unifiers)
      = ASSERT( not (null matches) )
        vcat [	addArising orig (ptext (sLit "Overlapping instances for") 
				<+> pprPred pred)
    	     ,	sep [ptext (sLit "Matching instances") <> colon,
    		     nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
	     ,	if not (isSingleton matches)
    		then 	-- Two or more matches
		     empty
    		else 	-- One match, plus some unifiers
		ASSERT( not (null unifiers) )
		parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
	    		         quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
			      ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
			      ptext (sLit "when compiling the other instance declarations")])]
      where
    	ispecs = [ispec | (ispec, _) <- matches]

reportOverlap _ _ _ _ = panic "reportOverlap"    -- Not a ClassP

----------------------
quickFlattenTy :: TcType -> TcM TcType
-- See Note [Flattening in error message generation]
quickFlattenTy ty | Just ty' <- tcView ty = quickFlattenTy ty'
quickFlattenTy ty@(TyVarTy {})  = return ty
quickFlattenTy ty@(ForAllTy {}) = return ty     -- See
quickFlattenTy ty@(PredTy {})   = return ty     -- Note [Quick-flatten polytypes]
  -- Don't flatten because of the danger or removing a bound variable
quickFlattenTy (AppTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
                                    ; fy2 <- quickFlattenTy ty2
                                    ; return (AppTy fy1 fy2) }
quickFlattenTy (FunTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
                                    ; fy2 <- quickFlattenTy ty2
                                    ; return (FunTy fy1 fy2) }
quickFlattenTy (TyConApp tc tys)
    | not (isSynFamilyTyCon tc)
    = do { fys <- mapM quickFlattenTy tys 
         ; return (TyConApp tc fys) }
    | otherwise
    = do { let (funtys,resttys) = splitAt (tyConArity tc) tys
                -- Ignore the arguments of the type family funtys
         ; v <- newMetaTyVar TauTv (typeKind (TyConApp tc funtys))
         ; flat_resttys <- mapM quickFlattenTy resttys
         ; return (foldl AppTy (mkTyVarTy v) flat_resttys) }
\end{code}

Note [Flattening in error message generation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider (C (Maybe (F x))), where F is a type function, and we have
instances
                C (Maybe Int) and C (Maybe a)
Since (F x) might turn into Int, this is an overlap situation, and
indeed (because of flattening) the main solver will have refrained
from solving.  But by the time we get to error message generation, we've
un-flattened the constraint.  So we must *re*-flatten it before looking
up in the instance environment, lest we only report one matching
instance when in fact there are two.

Re-flattening is pretty easy, because we don't need to keep track of
evidence.  We don't re-use the code in TcCanonical because that's in
the TcS monad, and we are in TcM here.

Note [Quick-flatten polytypes]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If we see C (Ix a => blah) or C (forall a. blah) we simply refrain from
flattening any further.  After all, there can be no instance declarations
that match such things.  And flattening under a for-all is problematic
anyway; consider C (forall a. F a)

\begin{code}
644 645 646 647 648
reportAmbigErrs :: ReportErrCtxt -> TcTyVarSet -> [WantedEvVar] -> TcM ()
reportAmbigErrs ctxt skols ambigs 
-- Divide into groups that share a common set of ambiguous tyvars
  = mapM_ report (equivClasses cmp ambigs_w_tvs)
  where
649
    ambigs_w_tvs = [ (d, varSetElems (tyVarsOfEvVarX d `minusVarSet` skols))
650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672
                   | d <- ambigs ]
    cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2

    report :: [(WantedEvVar, [TcTyVar])] -> TcM ()
    report pairs
       = setCtLoc loc $
         do { let main_msg = sep [ text "Ambiguous type variable" <> plural tvs
	         	           <+> pprQuotedList tvs
                                   <+> text "in the constraint" <> plural pairs <> colon
                                 , nest 2 pp_wanteds ]
             ; (tidy_env, mono_msg) <- mkMonomorphismMsg ctxt tvs
            ; addErrTcM (tidy_env, main_msg $$ mono_msg) }
       where
         (_, tvs) : _ = pairs
         (loc, pp_wanteds) = pprWithArising (map fst pairs)

mkMonomorphismMsg :: ReportErrCtxt -> [TcTyVar] -> TcM (TidyEnv, SDoc)
-- There's an error with these Insts; if they have free type variables
-- it's probably caused by the monomorphism restriction. 
-- Try to identify the offending variable
-- ASSUMPTION: the Insts are fully zonked
mkMonomorphismMsg ctxt inst_tvs
  = do	{ dflags <- getDOpts
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
673
        ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
674 675
	; return (tidy_env, mk_msg dflags docs) }
  where
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
676
    mk_msg _ _ | any isRuntimeUnkSkol inst_tvs  -- See Note [Runtime skolems]
677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692
        =  vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+>
                   (pprWithCommas ppr inst_tvs),
                ptext (sLit "Use :print or :force to determine these types")]
    mk_msg _ []   = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)")
			-- This happens in things like
			--	f x = show (read "foo")
			-- where monomorphism doesn't play any role
    mk_msg dflags docs 
	= vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"),
		nest 2 (vcat docs),
		monomorphism_fix dflags]

monomorphism_fix :: DynFlags -> SDoc
monomorphism_fix dflags
  = ptext (sLit "Probable fix:") <+> vcat
	[ptext (sLit "give these definition(s) an explicit type signature"),
693
	 if xopt Opt_MonomorphismRestriction dflags
694 695 696 697
           then ptext (sLit "or use -XNoMonomorphismRestriction")
           else empty]	-- Only suggest adding "-XNoMonomorphismRestriction"
			-- if it is not already set!

698 699 700 701 702 703 704 705
getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo
getSkolemInfo [] tv
  = WARN( True, ptext (sLit "No skolem info:") <+> ppr tv )
    UnkSkol
getSkolemInfo (implic:implics) tv
  | tv `elemVarSet` ic_skols implic = ctLocOrigin (ic_loc implic)
  | otherwise                       = getSkolemInfo implics tv

706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740
-----------------------
-- findGlobals looks at the value environment and finds values whose
-- types mention any of the offending type variables.  It has to be
-- careful to zonk the Id's type first, so it has to be in the monad.
-- We must be careful to pass it a zonked type variable, too.

mkEnvSigMsg :: SDoc -> [SDoc] -> SDoc
mkEnvSigMsg what env_sigs
 | null env_sigs = empty
 | otherwise = vcat [ ptext (sLit "The following variables have types that mention") <+> what
                    , nest 2 (vcat env_sigs) ]

findGlobals :: ReportErrCtxt
            -> TcTyVarSet
            -> TcM (TidyEnv, [SDoc])

findGlobals ctxt tvs 
  = do { lcl_ty_env <- case cec_encl ctxt of 
                        []    -> getLclTypeEnv
                        (i:_) -> return (ic_env i)
       ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) }
  where
    go tidy_env acc [] = return (tidy_env, acc)
    go tidy_env acc (thing : things) = do
        (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing
	case maybe_doc of
	  Just d  -> go tidy_env1 (d:acc) things
	  Nothing -> go tidy_env1 acc     things

    ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty

-----------------------
find_thing :: TidyEnv -> (TcType -> Bool)
           -> TcTyThing -> TcM (TidyEnv, Maybe SDoc)
find_thing tidy_env ignore_it (ATcId { tct_id = id })
741 742
  = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id)
       ; if ignore_it tidy_ty then
743 744
	   return (tidy_env, Nothing)
         else do 
745
       { let msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty
746 747 748 749 750
		       , nest 2 (parens (ptext (sLit "bound at") <+>
			 	   ppr (getSrcLoc id)))]
       ; return (tidy_env', Just msg) } }

find_thing tidy_env ignore_it (ATyVar tv ty)
751 752
  = do { (tidy_env1, tidy_ty) <- zonkTidyTcType tidy_env ty
       ; if ignore_it tidy_ty then
753 754 755 756 757 758
	    return (tidy_env, Nothing)
         else do
       { let -- The name tv is scoped, so we don't need to tidy it
            msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff
                      , nest 2 bound_at]

759
            eq_stuff | Just tv' <- tcGetTyVar_maybe tidy_ty
760 761 762 763 764 765 766 767 768
		     , getOccName tv == getOccName tv' = empty
		     | otherwise = equals <+> ppr tidy_ty
		-- It's ok to use Type.getTyVar_maybe because ty is zonked by now
	    bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv)
 
       ; return (tidy_env1, Just msg) } }

find_thing _ _ thing = pprPanic "find_thing" (ppr thing)

769
warnDefaulting :: [FlavoredEvVar] -> Type -> TcM ()
770 771
warnDefaulting wanteds default_ty
  = do { warn_default <- doptM Opt_WarnTypeDefaults
772 773 774 775 776 777 778 779 780
       ; env0 <- tcInitTidyEnv
       ; let wanted_bag = listToBag wanteds
             tidy_env = tidyFreeTyVars env0 $
                        tyVarsOfEvVarXs wanted_bag
             tidy_wanteds = mapBag (tidyFlavoredEvVar tidy_env) wanted_bag
             (loc, ppr_wanteds) = pprWithArising (map get_wev (bagToList tidy_wanteds))
             warn_msg  = hang (ptext (sLit "Defaulting the following constraint(s) to type")
                                <+> quotes (ppr default_ty))
                            2 ppr_wanteds
781 782
       ; setCtLoc loc $ warnTc warn_default warn_msg }
  where
783 784
    get_wev (EvVarX ev (Wanted loc)) = EvVarX ev loc    -- Yuk
    get_wev ev = pprPanic "warnDefaulting" (ppr ev)
785 786
\end{code}

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
787 788 789
Note [Runtime skolems]
~~~~~~~~~~~~~~~~~~~~~~
We want to give a reasonably helpful error message for ambiguity
790 791
arising from *runtime* skolems in the debugger.  These
are created by in RtClosureInspect.zonkRTTIType.  
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
792

793 794 795
%************************************************************************
%*									*
                 Error from the canonicaliser
796
	 These ones are called *during* constraint simplification
797 798 799 800 801 802 803 804 805 806 807
%*									*
%************************************************************************

\begin{code}
solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a
solverDepthErrorTcS depth stack
  | null stack	    -- Shouldn't happen unless you say -fcontext-stack=0
  = wrapErrTcS $ failWith msg
  | otherwise
  = wrapErrTcS $ 
    setCtFlavorLoc (cc_flavor top_item) $
808 809 810 811 812
    do { ev_vars <- mapM (zonkEvVar . cc_id) stack
       ; env0 <- tcInitTidyEnv
       ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfEvVars ev_vars)
             tidy_ev_vars = map (tidyEvVar tidy_env) ev_vars
       ; failWithTcM (tidy_env, hang msg 2 (pprEvVars tidy_ev_vars)) }
813 814 815 816 817 818 819
  where
    top_item = head stack
    msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
               , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]

flattenForAllErrorTcS :: CtFlavor -> TcType -> Bag CanonicalCt -> TcS a
flattenForAllErrorTcS fl ty _bad_eqs
820
  = wrapErrTcS        $ 
821 822 823 824 825 826 827
    setCtFlavorLoc fl $ 
    do { env0 <- tcInitTidyEnv
       ; let (env1, ty') = tidyOpenType env0 ty 
             msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:")
                       , ppr ty' ]
       ; failWithTcM (env1, msg) }
\end{code}
828 829 830 831 832 833 834 835 836

%************************************************************************
%*									*
                 Setting the context
%*									*
%************************************************************************

\begin{code}
setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860
setCtFlavorLoc (Wanted  loc) thing = setCtLoc loc thing
setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing
setCtFlavorLoc (Given   loc) thing = setCtLoc loc thing
\end{code}

%************************************************************************
%*									*
                 Tidying
%*									*
%************************************************************************

\begin{code}
zonkTidyTcType :: TidyEnv -> TcType -> TcM (TidyEnv, TcType)
zonkTidyTcType env ty = do { ty' <- zonkTcType ty
                           ; return (tidyOpenType env ty') }

zonkTidyOrigin :: ReportErrCtxt -> CtOrigin -> TcM CtOrigin
zonkTidyOrigin ctxt (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp }))
  = do { (env1,  act') <- zonkTidyTcType (cec_tidy ctxt) act
       ; (_env2, exp') <- zonkTidyTcType env1            exp
       ; return (TypeEqOrigin (UnifyOrigin { uo_actual = act', uo_expected = exp' })) }
       -- Drop the returned env on the floor; we may conceivably thereby get
       -- inconsistent naming between uses of this function
zonkTidyOrigin _ orig = return orig
861
\end{code}