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