compiler/typecheck/TcErrors.lhs

   1 \begin{code}
   2 module TcErrors(
   3        reportUnsolved,
   4        warnDefaulting,
   5        unifyCtxt,
   6
   7        flattenForAllErrorTcS,
   8        solverDepthErrorTcS
   9   ) where
  10
  11 #include "HsVersions.h"
  12
  13 import TcRnMonad
  14 import TcMType
  15 import TcSMonad
  16 import TcType
  17 import TypeRep
  18 import Type( isTyVarTy )
  19
  20 import Inst
  21 import InstEnv
  22
  23 import TyCon
  24 import Name
  25 import NameEnv
  26 import Id       ( idType )
  27 import Var
  28 import VarSet
  29 import VarEnv
  30 import SrcLoc
  31 import Bag
  32 import ListSetOps( equivClasses )
  33 import Util
  34 import FastString
  35 import Outputable
  36 import DynFlags
  37 import StaticFlags( opt_PprStyle_Debug )
  38 import Data.List( partition )
  39 import Control.Monad( when, unless )
  40 \end{code}
  41
  42 %************************************************************************
  43 %*                                                                      *
  44 \section{Errors and contexts}
  45 %*                                                                      *
  46 %************************************************************************
  47
  48 ToDo: for these error messages, should we note the location as coming
  49 from the insts, or just whatever seems to be around in the monad just
  50 now?
  51
  52 \begin{code}
  53 reportUnsolved :: WantedConstraints -> TcM ()
  54 reportUnsolved wanted
  55   | isEmptyWC wanted
  56   = return ()
  57   | otherwise
  58   = do {   -- Zonk to un-flatten any flatten-skols
  59        ; wanted  <- zonkWC wanted
  60
  61        ; env0 <- tcInitTidyEnv
  62        ; let tidy_env = tidyFreeTyVars env0 free_tvs
  63              free_tvs = tyVarsOfWC wanted
  64              err_ctxt = CEC { cec_encl  = []
  65                             , cec_insol = insolubleWC wanted
  66                             , cec_extra = empty
  67                             , cec_tidy  = tidy_env }
  68              tidy_wanted = tidyWC tidy_env wanted
  69
  70        ; traceTc "reportUnsolved" (ppr tidy_wanted)
  71
  72        ; reportTidyWanteds err_ctxt tidy_wanted }
  73
  74 --------------------------------------------
  75 --      Internal functions
  76 --------------------------------------------
  77
  78 data ReportErrCtxt
  79     = CEC { cec_encl :: [Implication]  -- Enclosing implications
  80                                        --   (innermost first)
  81           , cec_tidy  :: TidyEnv
  82           , cec_extra :: SDoc       -- Add this to each error message
  83           , cec_insol :: Bool       -- True <=> we are reporting insoluble errors only
  84                                     --      Main effect: don't say "Cannot deduce..."
  85                                     --      when reporting equality errors; see misMatchOrCND
  86       }
  87
  88 reportTidyImplic :: ReportErrCtxt -> Implication -> TcM ()
  89 reportTidyImplic ctxt implic
  90   | BracketSkol <- ctLocOrigin (ic_loc implic)
  91   , not insoluble  -- For Template Haskell brackets report only
  92   = return ()      -- definite errors. The whole thing will be re-checked
  93                    -- later when we plug it in, and meanwhile there may
  94                    -- certainly be un-satisfied constraints
  95
  96   | otherwise
  97   = reportTidyWanteds ctxt' (ic_wanted implic)
  98   where
  99     insoluble = ic_insol implic
 100     ctxt' = ctxt { cec_encl = implic : cec_encl ctxt
 101                  , cec_insol = insoluble }
 102
 103 reportTidyWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
 104 reportTidyWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = implics })
 105   | cec_insol ctxt     -- If there are any insolubles, report only them
 106                        -- because they are unconditionally wrong
 107                        -- Moreover, if any of the insolubles are givens, stop right there
 108                        -- ignoring nested errors, because the code is inaccessible
 109   = do { let (given, other) = partitionBag (isGiven . evVarX) insols
 110              insol_implics  = filterBag ic_insol implics
 111        ; if isEmptyBag given
 112          then do { mapBagM_ (reportInsoluble ctxt) other
 113                  ; mapBagM_ (reportTidyImplic ctxt) insol_implics }
 114          else mapBagM_ (reportInsoluble ctxt) given }
 115
 116   | otherwise          -- No insoluble ones
 117   = ASSERT( isEmptyBag insols )
 118     do { let (ambigs, non_ambigs) = partition is_ambiguous (bagToList flats)
 119              (tv_eqs, others)     = partition is_tv_eq non_ambigs
 120
 121        ; groupErrs (reportEqErrs ctxt) tv_eqs
 122        ; when (null tv_eqs) $ groupErrs (reportFlat ctxt) others
 123        ; mapBagM_ (reportTidyImplic ctxt) implics
 124
 125            -- Only report ambiguity if no other errors (at all) happened
 126            -- See Note [Avoiding spurious errors] in TcSimplify
 127        ; ifErrsM (return ()) $ reportAmbigErrs ctxt skols ambigs }
 128   where
 129     skols = foldr (unionVarSet . ic_skols) emptyVarSet (cec_encl ctxt)
 130
 131         -- Report equalities of form (a~ty) first.  They are usually
 132         -- skolem-equalities, and they cause confusing knock-on
 133         -- effects in other errors; see test T4093b.
 134     is_tv_eq c | EqPred ty1 ty2 <- evVarOfPred c
 135                = tcIsTyVarTy ty1 || tcIsTyVarTy ty2
 136                | otherwise = False
 137
 138         -- Treat it as "ambiguous" if
 139         --   (a) it is a class constraint
 140         --   (b) it constrains only type variables
 141         --       (else we'd prefer to report it as "no instance for...")
 142         --   (c) it mentions type variables that are not skolems
 143     is_ambiguous d = isTyVarClassPred pred
 144                   && not (tyVarsOfPred pred `subVarSet` skols)
 145                   where
 146                      pred = evVarOfPred d
 147
 148 reportInsoluble :: ReportErrCtxt -> FlavoredEvVar -> TcM ()
 149 reportInsoluble ctxt (EvVarX ev flav)
 150   | EqPred ty1 ty2 <- evVarPred ev
 151   = setCtFlavorLoc flav $
 152     do { let ctxt2 = ctxt { cec_extra = cec_extra ctxt $$ inaccessible_msg }
 153        ; reportEqErr ctxt2 ty1 ty2 }
 154   | otherwise
 155   = pprPanic "reportInsoluble" (pprEvVarWithType ev)
 156   where
 157     inaccessible_msg | Given loc <- flav
 158                      = hang (ptext (sLit "Inaccessible code in"))
 159                           2 (ppr (ctLocOrigin loc))
 160                      | otherwise = empty
 161
 162 reportFlat :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
 163 -- The [PredType] are already tidied
 164 reportFlat ctxt flats origin
 165   = 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        ; ASSERT( null others ) return () }
 169   where
 170     (dicts, non_dicts) = partition isClassPred flats
 171     (eqs, non_eqs)     = partition isEqPred    non_dicts
 172     (ips, others)      = partition isIPPred    non_eqs
 173
 174 --------------------------------------------
 175 --      Support code
 176 --------------------------------------------
 177
 178 groupErrs :: ([PredType] -> CtOrigin -> TcM ()) -- Deal with one group
 179           -> [WantedEvVar]                      -- Unsolved wanteds
 180           -> TcM ()
 181 -- Group together insts with the same origin
 182 -- We want to report them together in error messages
 183
 184 groupErrs _ []
 185   = return ()
 186 groupErrs report_err (wanted : wanteds)
 187   = do  { setCtLoc the_loc $
 188           report_err the_vars (ctLocOrigin the_loc)
 189         ; groupErrs report_err others }
 190   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    is_friend friend  = mk_key (evVarX friend) `same_key` the_key
 196
 197    mk_key :: WantedLoc -> (SrcSpan, CtOrigin)
 198    mk_key loc = (ctLocSpan loc, ctLocOrigin loc)
 199
 200    same_key (s1, o1) (s2, o2) = s1==s2 && o1 `same_orig` o2
 201    same_orig (OccurrenceOf n1) (OccurrenceOf n2) = n1==n2
 202    same_orig ScOrigin          ScOrigin          = True
 203    same_orig DerivOrigin       DerivOrigin       = True
 204    same_orig DefaultOrigin     DefaultOrigin     = True
 205    same_orig _ _ = False
 206
 207
 208 -- Add the "arising from..." part to a message about bunch of dicts
 209 addArising :: CtOrigin -> SDoc -> SDoc
 210 addArising orig msg = msg $$ nest 2 (pprArising orig)
 211
 212 pprWithArising :: [WantedEvVar] -> (WantedLoc, SDoc)
 213 -- Print something like
 214 --    (Eq a) arising from a use of x at y
 215 --    (Show a) arising from a use of p at q
 216 -- Also return a location for the error message
 217 pprWithArising []
 218   = panic "pprWithArising"
 219 pprWithArising [EvVarX ev loc]
 220   = (loc, pprEvVarTheta [ev] <+> pprArising (ctLocOrigin loc))
 221 pprWithArising ev_vars
 222   = (first_loc, vcat (map ppr_one ev_vars))
 223   where
 224     first_loc = evVarX (head ev_vars)
 225     ppr_one (EvVarX v loc)
 226        = parens (pprPred (evVarPred v)) <+> pprArisingAt loc
 227
 228 addErrorReport :: ReportErrCtxt -> SDoc -> TcM ()
 229 addErrorReport ctxt msg = addErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt)
 230
 231 pprErrCtxtLoc :: ReportErrCtxt -> SDoc
 232 pprErrCtxtLoc ctxt
 233   = case map (ctLocOrigin . ic_loc) (cec_encl ctxt) of
 234        []           -> ptext (sLit "the top level")     -- Should not happen
 235        (orig:origs) -> ppr_skol orig $$
 236                        vcat [ ptext (sLit "or") <+> ppr_skol orig | orig <- origs ]
 237   where
 238     ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc)
 239     ppr_skol skol_info      = ppr skol_info
 240
 241 getUserGivens :: ReportErrCtxt -> [([EvVar], GivenLoc)]
 242 -- One item for each enclosing implication
 243 getUserGivens (CEC {cec_encl = ctxt})
 244   = reverse $
 245     [ (givens', loc) | Implic {ic_given = givens, ic_loc = loc} <- ctxt
 246                      , let givens' = get_user_givens givens
 247                      , not (null givens') ]
 248   where
 249     get_user_givens givens | opt_PprStyle_Debug = givens
 250                            | otherwise          = filterOut isSilentEvVar givens
 251        -- In user mode, don't show the "silent" givens, used for
 252        -- the "self" dictionary and silent superclass arguments for dfuns
 253
 254 \end{code}
 255
 256
 257 %************************************************************************
 258 %*                                                                      *
 259                 Implicit parameter errors
 260 %*                                                                      *
 261 %************************************************************************
 262
 263 \begin{code}
 264 reportIPErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
 265 reportIPErrs ctxt ips orig
 266   = addErrorReport ctxt msg
 267   where
 268     givens = getUserGivens ctxt
 269     msg | null givens
 270         = addArising orig $
 271           sep [ ptext (sLit "Unbound implicit parameter") <> plural ips
 272               , nest 2 (pprTheta ips) ]
 273         | otherwise
 274         = couldNotDeduce givens (ips, orig)
 275 \end{code}
 276
 277
 278 %************************************************************************
 279 %*                                                                      *
 280                 Equality errors
 281 %*                                                                      *
 282 %************************************************************************
 283
 284 \begin{code}
 285 reportEqErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
 286 -- The [PredType] are already tidied
 287 reportEqErrs ctxt eqs orig
 288   = do { orig' <- zonkTidyOrigin ctxt orig
 289        ; mapM_ (report_one orig') eqs }
 290   where
 291     report_one orig (EqPred ty1 ty2)
 292       = do { let extra = getWantedEqExtra orig ty1 ty2
 293                  ctxt' = ctxt { cec_extra = extra $$ cec_extra ctxt }
 294            ; reportEqErr ctxt' ty1 ty2 }
 295     report_one _ pred
 296       = pprPanic "reportEqErrs" (ppr pred)
 297
 298 getWantedEqExtra ::  CtOrigin -> TcType -> TcType -> SDoc
 299 getWantedEqExtra (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp }))
 300                  ty1 ty2
 301   -- If the types in the error message are the same as the types we are unifying,
 302   -- don't add the extra expected/actual message
 303   | act `tcEqType` ty1 && exp `tcEqType` ty2 = empty
 304   | exp `tcEqType` ty1 && act `tcEqType` ty2 = empty
 305   | otherwise                                = mkExpectedActualMsg act exp
 306
 307 getWantedEqExtra orig _ _ = pprArising orig
 308
 309 reportEqErr :: ReportErrCtxt -> TcType -> TcType -> TcM ()
 310 -- ty1 and ty2 are already tidied
 311 reportEqErr ctxt ty1 ty2
 312   | Just tv1 <- tcGetTyVar_maybe ty1 = reportTyVarEqErr ctxt tv1 ty2
 313   | Just tv2 <- tcGetTyVar_maybe ty2 = reportTyVarEqErr ctxt tv2 ty1
 314
 315   | otherwise   -- Neither side is a type variable
 316                 -- Since the unsolved constraint is canonical,
 317                 -- it must therefore be of form (F tys ~ ty)
 318   = addErrorReport ctxt (misMatchOrCND ctxt ty1 ty2 $$ mkTyFunInfoMsg ty1 ty2)
 319
 320
 321 reportTyVarEqErr :: ReportErrCtxt -> TcTyVar -> TcType -> TcM ()
 322 -- tv1 and ty2 are already tidied
 323 reportTyVarEqErr ctxt tv1 ty2
 324   |  isSkolemTyVar tv1    -- ty2 won't be a meta-tyvar, or else the thing would
 325                           -- be oriented the other way round; see TcCanonical.reOrient
 326   || isSigTyVar tv1 && not (isTyVarTy ty2)
 327   = addErrorReport (addExtraInfo ctxt ty1 ty2)
 328                    (misMatchOrCND ctxt ty1 ty2)
 329
 330   -- So tv is a meta tyvar, and presumably it is
 331   -- an *untouchable* meta tyvar, else it'd have been unified
 332   | not (k2 `isSubKind` k1)      -- Kind error
 333   = addErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2)
 334
 335   -- Occurs check
 336   | tv1 `elemVarSet` tyVarsOfType ty2
 337   = let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:") 2
 338                            (sep [ppr ty1, char '=', ppr ty2])
 339     in addErrorReport ctxt occCheckMsg
 340
 341   -- Check for skolem escape
 342   | (implic:_) <- cec_encl ctxt   -- Get the innermost context
 343   , let esc_skols = varSetElems (tyVarsOfType ty2 `intersectVarSet` ic_skols implic)
 344         implic_loc = ic_loc implic
 345   , not (null esc_skols)
 346   = setCtLoc implic_loc $       -- Override the error message location from the
 347                                 -- place the equality arose to the implication site
 348     do { (env1, env_sigs) <- findGlobals ctxt (unitVarSet tv1)
 349        ; let msg = misMatchMsg ty1 ty2
 350              esc_doc = sep [ ptext (sLit "because type variable") <> plural esc_skols
 351                              <+> pprQuotedList esc_skols
 352                            , ptext (sLit "would escape") <+>
 353                              if isSingleton esc_skols then ptext (sLit "its scope")
 354                                                       else ptext (sLit "their scope") ]
 355              extra1 = vcat [ nest 2 $ esc_doc
 356                            , sep [ (if isSingleton esc_skols
 357                                     then ptext (sLit "This (rigid, skolem) type variable is")
 358                                     else ptext (sLit "These (rigid, skolem) type variables are"))
 359                                    <+> ptext (sLit "bound by")
 360                                  , nest 2 $ ppr (ctLocOrigin implic_loc) ] ]
 361        ; addErrTcM (env1, msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) }
 362
 363   -- Nastiest case: attempt to unify an untouchable variable
 364   | (implic:_) <- cec_encl ctxt   -- Get the innermost context
 365   , let implic_loc = ic_loc implic
 366         given      = ic_given implic
 367   = setCtLoc (ic_loc implic) $
 368     do { let msg = misMatchMsg ty1 ty2
 369              extra = quotes (ppr tv1)
 370                  <+> sep [ ptext (sLit "is untouchable")
 371                          , ptext (sLit "inside the constraints") <+> pprEvVarTheta given
 372                          , ptext (sLit "bound at") <+> ppr (ctLocOrigin implic_loc)]
 373        ; addErrorReport (addExtraInfo ctxt ty1 ty2) (msg $$ nest 2 extra) }
 374
 375   | otherwise
 376   = pprTrace "reportTyVarEqErr" (ppr tv1 $$ ppr ty2 $$ ppr (cec_encl ctxt)) $
 377     return ()
 378         -- I don't think this should happen, and if it does I want to know
 379         -- Trac #5130 happened because an actual type error was not
 380         -- reported at all!  So not reporting is pretty dangerous.
 381         --
 382         -- OLD, OUT OF DATE COMMENT
 383         -- This can happen, by a recursive decomposition of frozen
 384         -- occurs check constraints
 385         -- Example: alpha ~ T Int alpha has frozen.
 386         --          Then alpha gets unified to T beta gamma
 387         -- So now we have  T beta gamma ~ T Int (T beta gamma)
 388         -- Decompose to (beta ~ Int, gamma ~ T beta gamma)
 389         -- The (gamma ~ T beta gamma) is the occurs check, but
 390         -- the (beta ~ Int) isn't an error at all.  So return ()
 391   where
 392     k1  = tyVarKind tv1
 393     k2  = typeKind ty2
 394     ty1 = mkTyVarTy tv1
 395
 396 mkTyFunInfoMsg :: TcType -> TcType -> SDoc
 397 -- See Note [Non-injective type functions]
 398 mkTyFunInfoMsg ty1 ty2
 399   | Just (tc1,_) <- tcSplitTyConApp_maybe ty1
 400   , Just (tc2,_) <- tcSplitTyConApp_maybe ty2
 401   , tc1 == tc2, isSynFamilyTyCon tc1
 402   = ptext (sLit "NB:") <+> quotes (ppr tc1)
 403     <+> ptext (sLit "is a type function") <> (pp_inj tc1)
 404   | otherwise = empty
 405   where
 406     pp_inj tc | isInjectiveTyCon tc = empty
 407               | otherwise = ptext (sLit (", and may not be injective"))
 408
 409 misMatchOrCND :: ReportErrCtxt -> TcType -> TcType -> SDoc
 410 misMatchOrCND ctxt ty1 ty2
 411   | cec_insol ctxt = misMatchMsg ty1 ty2    -- If the equality is unconditionally
 412                                             -- insoluble, don't report the context
 413   | null givens    = misMatchMsg ty1 ty2
 414   | otherwise      = couldNotDeduce givens ([EqPred ty1 ty2], orig)
 415   where
 416     givens = getUserGivens ctxt
 417     orig   = TypeEqOrigin (UnifyOrigin ty1 ty2)
 418
 419 couldNotDeduce :: [([EvVar], GivenLoc)] -> (ThetaType, CtOrigin) -> SDoc
 420 couldNotDeduce givens (wanteds, orig)
 421   = vcat [ hang (ptext (sLit "Could not deduce") <+> pprTheta wanteds)
 422               2 (pprArising orig)
 423          , vcat pp_givens ]
 424   where
 425     pp_givens
 426       = case givens of
 427          []     -> []
 428          (g:gs) ->      ppr_given (ptext (sLit "from the context")) g
 429                  : map (ppr_given (ptext (sLit "or from"))) gs
 430
 431     ppr_given herald (gs,loc)
 432       = hang (herald <+> pprEvVarTheta gs)
 433            2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin loc)
 434                   , ptext (sLit "at") <+> ppr (ctLocSpan loc)])
 435
 436 addExtraInfo :: ReportErrCtxt -> TcType -> TcType -> ReportErrCtxt
 437 -- Add on extra info about the types themselves
 438 -- NB: The types themselves are already tidied
 439 addExtraInfo ctxt ty1 ty2
 440   = ctxt { cec_extra = nest 2 (extra1 $$ extra2) $$ cec_extra ctxt }
 441   where
 442     extra1 = typeExtraInfoMsg (cec_encl ctxt) ty1
 443     extra2 = typeExtraInfoMsg (cec_encl ctxt) ty2
 444
 445 misMatchMsg :: TcType -> TcType -> SDoc    -- Types are already tidy
 446 misMatchMsg ty1 ty2 = sep [ ptext (sLit "Couldn't match type") <+> quotes (ppr ty1)
 447                           , nest 15 $ ptext (sLit "with") <+> quotes (ppr ty2)]
 448
 449 kindErrorMsg :: TcType -> TcType -> SDoc   -- Types are already tidy
 450 kindErrorMsg ty1 ty2
 451   = vcat [ ptext (sLit "Kind incompatibility when matching types:")
 452          , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1
 453                         , ppr ty2 <+> dcolon <+> ppr k2 ]) ]
 454   where
 455     k1 = typeKind ty1
 456     k2 = typeKind ty2
 457
 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
 462   , isTcTyVar tv, isSkolemTyVar tv
 463   , let pp_tv = quotes (ppr tv)
 464  = case tcTyVarDetails tv of
 465     SkolemTv {}   -> pp_tv <+> ppr_skol (getSkolemInfo implics tv) (getSrcLoc tv)
 466     FlatSkol {}   -> pp_tv <+> ptext (sLit "is a flattening type variable")
 467     RuntimeUnk {} -> pp_tv <+> ptext (sLit "is an interactive-debugger skolem")
 468     MetaTv {}     -> empty
 469
 470  | otherwise             -- Normal case
 471  = empty
 472
 473  where
 474    ppr_skol UnkSkol _   = ptext (sLit "is an unknown type variable")  -- Unhelpful
 475    ppr_skol info    loc = sep [ptext (sLit "is a rigid type variable bound by"),
 476                                sep [ppr info, ptext (sLit "at") <+> ppr loc]]
 477
 478 --------------------
 479 unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc)
 480 unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env
 481   = do  { (env1, act_ty') <- zonkTidyTcType tidy_env act_ty
 482         ; (env2, exp_ty') <- zonkTidyTcType env1 exp_ty
 483         ; return (env2, mkExpectedActualMsg act_ty' exp_ty') }
 484
 485 mkExpectedActualMsg :: Type -> Type -> SDoc
 486 mkExpectedActualMsg act_ty exp_ty
 487   = vcat [ text "Expected type" <> colon <+> ppr exp_ty
 488          , text "  Actual type" <> colon <+> ppr act_ty ]
 489 \end{code}
 490
 491 Note [Non-injective type functions]
 492 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 493 It's very confusing to get a message like
 494      Couldn't match expected type `Depend s'
 495             against inferred type `Depend s1'
 496 so mkTyFunInfoMsg adds:
 497        NB: `Depend' is type function, and hence may not be injective
 498
 499 Warn of loopy local equalities that were dropped.
 500
 501
 502 %************************************************************************
 503 %*                                                                      *
 504                  Type-class errors
 505 %*                                                                      *
 506 %************************************************************************
 507
 508 \begin{code}
 509 reportDictErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
 510 reportDictErrs ctxt wanteds orig
 511   = do { inst_envs <- tcGetInstEnvs
 512        ; non_overlaps <- mapMaybeM (reportOverlap ctxt inst_envs orig) wanteds
 513        ; unless (null non_overlaps) $
 514          addErrorReport ctxt (mk_no_inst_err non_overlaps) }
 515   where
 516     mk_no_inst_err :: [PredType] -> SDoc
 517     mk_no_inst_err wanteds
 518       | null givens     -- Top level
 519       = vcat [ addArising orig $
 520                ptext (sLit "No instance") <> plural min_wanteds
 521                     <+> ptext (sLit "for") <+> pprTheta min_wanteds
 522              , show_fixes (fixes2 ++ fixes3) ]
 523
 524       | otherwise
 525       = vcat [ couldNotDeduce givens (min_wanteds, orig)
 526              , show_fixes (fix1 : (fixes2 ++ fixes3)) ]
 527       where
 528         givens = getUserGivens ctxt
 529         min_wanteds = mkMinimalBySCs wanteds
 530         fix1 = sep [ ptext (sLit "add") <+> pprTheta min_wanteds
 531                           <+> ptext (sLit "to the context of")
 532                    , nest 2 $ pprErrCtxtLoc ctxt ]
 533
 534         fixes2 = case instance_dicts of
 535                    []  -> []
 536                    [_] -> [sep [ptext (sLit "add an instance declaration for"),
 537                                 pprTheta instance_dicts]]
 538                    _   -> [sep [ptext (sLit "add instance declarations for"),
 539                                 pprTheta instance_dicts]]
 540         fixes3 = case orig of
 541                    DerivOrigin -> [drv_fix]
 542                    _           -> []
 543
 544         instance_dicts = filterOut isTyVarClassPred min_wanteds
 545                 -- Insts for which it is worth suggesting an adding an
 546                 -- instance declaration.  Exclude tyvar dicts.
 547
 548         drv_fix = vcat [ptext (sLit "use a standalone 'deriving instance' declaration,"),
 549                         nest 2 $ ptext (sLit "so you can specify the instance context yourself")]
 550
 551         show_fixes :: [SDoc] -> SDoc
 552         show_fixes []     = empty
 553         show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"),
 554                                  nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
 555
 556 reportOverlap :: ReportErrCtxt -> (InstEnv,InstEnv) -> CtOrigin
 557               -> PredType -> TcM (Maybe PredType)
 558 -- Report an overlap error if this class constraint results
 559 -- from an overlap (returning Nothing), otherwise return (Just pred)
 560 reportOverlap ctxt inst_envs orig pred@(ClassP clas tys)
 561   = do { tys_flat <- mapM quickFlattenTy tys
 562            -- Note [Flattening in error message generation]
 563
 564        ; case lookupInstEnv inst_envs clas tys_flat of
 565                 ([], _) -> return (Just pred)               -- No match
 566                 -- The case of exactly one match and no unifiers means a
 567                 -- successful lookup.  That can't happen here, because dicts
 568                 -- only end up here if they didn't match in Inst.lookupInst
 569                 ([_],[])
 570                  | debugIsOn -> pprPanic "check_overlap" (ppr pred)
 571                 res          -> do { addErrorReport ctxt (mk_overlap_msg res)
 572                                    ; return Nothing } }
 573   where
 574     mk_overlap_msg (matches, unifiers)
 575       = ASSERT( not (null matches) )
 576         vcat [  addArising orig (ptext (sLit "Overlapping instances for")
 577                                 <+> pprPred pred)
 578              ,  sep [ptext (sLit "Matching instances") <> colon,
 579                      nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
 580              ,  if not (isSingleton matches)
 581                 then    -- Two or more matches
 582                      empty
 583                 else    -- One match, plus some unifiers
 584                 ASSERT( not (null unifiers) )
 585                 parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
 586                                  quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
 587                               ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
 588                               ptext (sLit "when compiling the other instance declarations")])]
 589       where
 590         ispecs = [ispec | (ispec, _) <- matches]
 591
 592 reportOverlap _ _ _ _ = panic "reportOverlap"    -- Not a ClassP
 593
 594 ----------------------
 595 quickFlattenTy :: TcType -> TcM TcType
 596 -- See Note [Flattening in error message generation]
 597 quickFlattenTy ty | Just ty' <- tcView ty = quickFlattenTy ty'
 598 quickFlattenTy ty@(TyVarTy {})  = return ty
 599 quickFlattenTy ty@(ForAllTy {}) = return ty     -- See
 600 quickFlattenTy ty@(PredTy {})   = return ty     -- Note [Quick-flatten polytypes]
 601   -- Don't flatten because of the danger or removing a bound variable
 602 quickFlattenTy (AppTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
 603                                     ; fy2 <- quickFlattenTy ty2
 604                                     ; return (AppTy fy1 fy2) }
 605 quickFlattenTy (FunTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
 606                                     ; fy2 <- quickFlattenTy ty2
 607                                     ; return (FunTy fy1 fy2) }
 608 quickFlattenTy (TyConApp tc tys)
 609     | not (isSynFamilyTyCon tc)
 610     = do { fys <- mapM quickFlattenTy tys
 611          ; return (TyConApp tc fys) }
 612     | otherwise
 613     = do { let (funtys,resttys) = splitAt (tyConArity tc) tys
 614                 -- Ignore the arguments of the type family funtys
 615          ; v <- newMetaTyVar TauTv (typeKind (TyConApp tc funtys))
 616          ; flat_resttys <- mapM quickFlattenTy resttys
 617          ; return (foldl AppTy (mkTyVarTy v) flat_resttys) }
 618 \end{code}
 619
 620 Note [Flattening in error message generation]
 621 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 622 Consider (C (Maybe (F x))), where F is a type function, and we have
 623 instances
 624                 C (Maybe Int) and C (Maybe a)
 625 Since (F x) might turn into Int, this is an overlap situation, and
 626 indeed (because of flattening) the main solver will have refrained
 627 from solving.  But by the time we get to error message generation, we've
 628 un-flattened the constraint.  So we must *re*-flatten it before looking
 629 up in the instance environment, lest we only report one matching
 630 instance when in fact there are two.
 631
 632 Re-flattening is pretty easy, because we don't need to keep track of
 633 evidence.  We don't re-use the code in TcCanonical because that's in
 634 the TcS monad, and we are in TcM here.
 635
 636 Note [Quick-flatten polytypes]
 637 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 638 If we see C (Ix a => blah) or C (forall a. blah) we simply refrain from
 639 flattening any further.  After all, there can be no instance declarations
 640 that match such things.  And flattening under a for-all is problematic
 641 anyway; consider C (forall a. F a)
 642
 643 \begin{code}
 644 reportAmbigErrs :: ReportErrCtxt -> TcTyVarSet -> [WantedEvVar] -> TcM ()
 645 reportAmbigErrs ctxt skols ambigs
 646 -- Divide into groups that share a common set of ambiguous tyvars
 647   = mapM_ report (equivClasses cmp ambigs_w_tvs)
 648   where
 649     ambigs_w_tvs = [ (d, varSetElems (tyVarsOfEvVarX d `minusVarSet` skols))
 650                    | d <- ambigs ]
 651     cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2
 652
 653     report :: [(WantedEvVar, [TcTyVar])] -> TcM ()
 654     report pairs
 655        = setCtLoc loc $
 656          do { let main_msg = sep [ text "Ambiguous type variable" <> plural tvs
 657                                    <+> pprQuotedList tvs
 658                                    <+> text "in the constraint" <> plural pairs <> colon
 659                                  , nest 2 pp_wanteds ]
 660              ; (tidy_env, mono_msg) <- mkMonomorphismMsg ctxt tvs
 661             ; addErrTcM (tidy_env, main_msg $$ mono_msg) }
 662        where
 663          (_, tvs) : _ = pairs
 664          (loc, pp_wanteds) = pprWithArising (map fst pairs)
 665
 666 mkMonomorphismMsg :: ReportErrCtxt -> [TcTyVar] -> TcM (TidyEnv, SDoc)
 667 -- There's an error with these Insts; if they have free type variables
 668 -- it's probably caused by the monomorphism restriction.
 669 -- Try to identify the offending variable
 670 -- ASSUMPTION: the Insts are fully zonked
 671 mkMonomorphismMsg ctxt inst_tvs
 672   = do  { dflags <- getDOpts
 673         ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
 674         ; return (tidy_env, mk_msg dflags docs) }
 675   where
 676     mk_msg _ _ | any isRuntimeUnkSkol inst_tvs  -- See Note [Runtime skolems]
 677         =  vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+>
 678                    (pprWithCommas ppr inst_tvs),
 679                 ptext (sLit "Use :print or :force to determine these types")]
 680     mk_msg _ []   = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)")
 681                         -- This happens in things like
 682                         --      f x = show (read "foo")
 683                         -- where monomorphism doesn't play any role
 684     mk_msg dflags docs
 685         = vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"),
 686                 nest 2 (vcat docs),
 687                 monomorphism_fix dflags]
 688
 689 monomorphism_fix :: DynFlags -> SDoc
 690 monomorphism_fix dflags
 691   = ptext (sLit "Probable fix:") <+> vcat
 692         [ptext (sLit "give these definition(s) an explicit type signature"),
 693          if xopt Opt_MonomorphismRestriction dflags
 694            then ptext (sLit "or use -XNoMonomorphismRestriction")
 695            else empty]  -- Only suggest adding "-XNoMonomorphismRestriction"
 696                         -- if it is not already set!
 697
 698 getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo
 699 getSkolemInfo [] tv
 700   = WARN( True, ptext (sLit "No skolem info:") <+> ppr tv )
 701     UnkSkol
 702 getSkolemInfo (implic:implics) tv
 703   | tv `elemVarSet` ic_skols implic = ctLocOrigin (ic_loc implic)
 704   | otherwise                       = getSkolemInfo implics tv
 705
 706 -----------------------
 707 -- findGlobals looks at the value environment and finds values whose
 708 -- types mention any of the offending type variables.  It has to be
 709 -- careful to zonk the Id's type first, so it has to be in the monad.
 710 -- We must be careful to pass it a zonked type variable, too.
 711
 712 mkEnvSigMsg :: SDoc -> [SDoc] -> SDoc
 713 mkEnvSigMsg what env_sigs
 714  | null env_sigs = empty
 715  | otherwise = vcat [ ptext (sLit "The following variables have types that mention") <+> what
 716                     , nest 2 (vcat env_sigs) ]
 717
 718 findGlobals :: ReportErrCtxt
 719             -> TcTyVarSet
 720             -> TcM (TidyEnv, [SDoc])
 721
 722 findGlobals ctxt tvs
 723   = do { lcl_ty_env <- case cec_encl ctxt of
 724                         []    -> getLclTypeEnv
 725                         (i:_) -> return (ic_env i)
 726        ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) }
 727   where
 728     go tidy_env acc [] = return (tidy_env, acc)
 729     go tidy_env acc (thing : things) = do
 730         (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing
 731         case maybe_doc of
 732           Just d  -> go tidy_env1 (d:acc) things
 733           Nothing -> go tidy_env1 acc     things
 734
 735     ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
 736
 737 -----------------------
 738 find_thing :: TidyEnv -> (TcType -> Bool)
 739            -> TcTyThing -> TcM (TidyEnv, Maybe SDoc)
 740 find_thing tidy_env ignore_it (ATcId { tct_id = id })
 741   = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id)
 742        ; if ignore_it tidy_ty then
 743            return (tidy_env, Nothing)
 744          else do
 745        { let msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty
 746                        , nest 2 (parens (ptext (sLit "bound at") <+>
 747                                    ppr (getSrcLoc id)))]
 748        ; return (tidy_env', Just msg) } }
 749
 750 find_thing tidy_env ignore_it (ATyVar tv ty)
 751   = do { (tidy_env1, tidy_ty) <- zonkTidyTcType tidy_env ty
 752        ; if ignore_it tidy_ty then
 753             return (tidy_env, Nothing)
 754          else do
 755        { let -- The name tv is scoped, so we don't need to tidy it
 756             msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff
 757                       , nest 2 bound_at]
 758
 759             eq_stuff | Just tv' <- tcGetTyVar_maybe tidy_ty
 760                      , getOccName tv == getOccName tv' = empty
 761                      | otherwise = equals <+> ppr tidy_ty
 762                 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
 763             bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv)
 764
 765        ; return (tidy_env1, Just msg) } }
 766
 767 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
 768
 769 warnDefaulting :: [FlavoredEvVar] -> Type -> TcM ()
 770 warnDefaulting wanteds default_ty
 771   = do { warn_default <- doptM Opt_WarnTypeDefaults
 772        ; env0 <- tcInitTidyEnv
 773        ; let wanted_bag = listToBag wanteds
 774              tidy_env = tidyFreeTyVars env0 $
 775                         tyVarsOfEvVarXs wanted_bag
 776              tidy_wanteds = mapBag (tidyFlavoredEvVar tidy_env) wanted_bag
 777              (loc, ppr_wanteds) = pprWithArising (map get_wev (bagToList tidy_wanteds))
 778              warn_msg  = hang (ptext (sLit "Defaulting the following constraint(s) to type")
 779                                 <+> quotes (ppr default_ty))
 780                             2 ppr_wanteds
 781        ; setCtLoc loc $ warnTc warn_default warn_msg }
 782   where
 783     get_wev (EvVarX ev (Wanted loc)) = EvVarX ev loc    -- Yuk
 784     get_wev ev = pprPanic "warnDefaulting" (ppr ev)
 785 \end{code}
 786
 787 Note [Runtime skolems]
 788 ~~~~~~~~~~~~~~~~~~~~~~
 789 We want to give a reasonably helpful error message for ambiguity
 790 arising from *runtime* skolems in the debugger.  These
 791 are created by in RtClosureInspect.zonkRTTIType.
 792
 793 %************************************************************************
 794 %*                                                                      *
 795                  Error from the canonicaliser
 796          These ones are called *during* constraint simplification
 797 %*                                                                      *
 798 %************************************************************************
 799
 800 \begin{code}
 801 solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a
 802 solverDepthErrorTcS depth stack
 803   | null stack      -- Shouldn't happen unless you say -fcontext-stack=0
 804   = wrapErrTcS $ failWith msg
 805   | otherwise
 806   = wrapErrTcS $
 807     setCtFlavorLoc (cc_flavor top_item) $
 808     do { ev_vars <- mapM (zonkEvVar . cc_id) stack
 809        ; env0 <- tcInitTidyEnv
 810        ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfEvVars ev_vars)
 811              tidy_ev_vars = map (tidyEvVar tidy_env) ev_vars
 812        ; failWithTcM (tidy_env, hang msg 2 (pprEvVars tidy_ev_vars)) }
 813   where
 814     top_item = head stack
 815     msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
 816                , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
 817
 818 flattenForAllErrorTcS :: CtFlavor -> TcType -> Bag CanonicalCt -> TcS a
 819 flattenForAllErrorTcS fl ty _bad_eqs
 820   = wrapErrTcS        $
 821     setCtFlavorLoc fl $
 822     do { env0 <- tcInitTidyEnv
 823        ; let (env1, ty') = tidyOpenType env0 ty
 824              msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:")
 825                        , ppr ty' ]
 826        ; failWithTcM (env1, msg) }
 827 \end{code}
 828
 829 %************************************************************************
 830 %*                                                                      *
 831                  Setting the context
 832 %*                                                                      *
 833 %************************************************************************
 834
 835 \begin{code}
 836 setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
 837 setCtFlavorLoc (Wanted  loc) thing = setCtLoc loc thing
 838 setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing
 839 setCtFlavorLoc (Given   loc) thing = setCtLoc loc thing
 840 \end{code}
 841
 842 %************************************************************************
 843 %*                                                                      *
 844                  Tidying
 845 %*                                                                      *
 846 %************************************************************************
 847
 848 \begin{code}
 849 zonkTidyTcType :: TidyEnv -> TcType -> TcM (TidyEnv, TcType)
 850 zonkTidyTcType env ty = do { ty' <- zonkTcType ty
 851                            ; return (tidyOpenType env ty') }
 852
 853 zonkTidyOrigin :: ReportErrCtxt -> CtOrigin -> TcM CtOrigin
 854 zonkTidyOrigin ctxt (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp }))
 855   = do { (env1,  act') <- zonkTidyTcType (cec_tidy ctxt) act
 856        ; (_env2, exp') <- zonkTidyTcType env1            exp
 857        ; return (TypeEqOrigin (UnifyOrigin { uo_actual = act', uo_expected = exp' })) }
 858        -- Drop the returned env on the floor; we may conceivably thereby get
 859        -- inconsistent naming between uses of this function
 860 zonkTidyOrigin _ orig = return orig
 861 \end{code}