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