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
 463   , isSkolemTyVar tv
 464  = pprSkolTvBinding implics tv
 465   where
 466 typeExtraInfoMsg _ _ = empty            -- Normal case
 467
 468 --------------------
 469 unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc)
 470 unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env
 471   = do  { (env1, act_ty') <- zonkTidyTcType tidy_env act_ty
 472         ; (env2, exp_ty') <- zonkTidyTcType env1 exp_ty
 473         ; return (env2, mkExpectedActualMsg act_ty' exp_ty') }
 474
 475 mkExpectedActualMsg :: Type -> Type -> SDoc
 476 mkExpectedActualMsg act_ty exp_ty
 477   = vcat [ text "Expected type" <> colon <+> ppr exp_ty
 478          , text "  Actual type" <> colon <+> ppr act_ty ]
 479 \end{code}
 480
 481 Note [Non-injective type functions]
 482 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 483 It's very confusing to get a message like
 484      Couldn't match expected type `Depend s'
 485             against inferred type `Depend s1'
 486 so mkTyFunInfoMsg adds:
 487        NB: `Depend' is type function, and hence may not be injective
 488
 489 Warn of loopy local equalities that were dropped.
 490
 491
 492 %************************************************************************
 493 %*                                                                      *
 494                  Type-class errors
 495 %*                                                                      *
 496 %************************************************************************
 497
 498 \begin{code}
 499 reportDictErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
 500 reportDictErrs ctxt wanteds orig
 501   = do { inst_envs <- tcGetInstEnvs
 502        ; non_overlaps <- mapMaybeM (reportOverlap ctxt inst_envs orig) wanteds
 503        ; unless (null non_overlaps) $
 504          addErrorReport ctxt (mk_no_inst_err non_overlaps) }
 505   where
 506     mk_no_inst_err :: [PredType] -> SDoc
 507     mk_no_inst_err wanteds
 508       | null givens     -- Top level
 509       = vcat [ addArising orig $
 510                ptext (sLit "No instance") <> plural min_wanteds
 511                     <+> ptext (sLit "for") <+> pprTheta min_wanteds
 512              , show_fixes (fixes2 ++ fixes3) ]
 513
 514       | otherwise
 515       = vcat [ couldNotDeduce givens (min_wanteds, orig)
 516              , show_fixes (fix1 : (fixes2 ++ fixes3)) ]
 517       where
 518         givens = getUserGivens ctxt
 519         min_wanteds = mkMinimalBySCs wanteds
 520         fix1 = sep [ ptext (sLit "add") <+> pprTheta min_wanteds
 521                           <+> ptext (sLit "to the context of")
 522                    , nest 2 $ pprErrCtxtLoc ctxt ]
 523
 524         fixes2 = case instance_dicts of
 525                    []  -> []
 526                    [_] -> [sep [ptext (sLit "add an instance declaration for"),
 527                                 pprTheta instance_dicts]]
 528                    _   -> [sep [ptext (sLit "add instance declarations for"),
 529                                 pprTheta instance_dicts]]
 530         fixes3 = case orig of
 531                    DerivOrigin -> [drv_fix]
 532                    _           -> []
 533
 534         instance_dicts = filterOut isTyVarClassPred min_wanteds
 535                 -- Insts for which it is worth suggesting an adding an
 536                 -- instance declaration.  Exclude tyvar dicts.
 537
 538         drv_fix = vcat [ptext (sLit "use a standalone 'deriving instance' declaration,"),
 539                         nest 2 $ ptext (sLit "so you can specify the instance context yourself")]
 540
 541         show_fixes :: [SDoc] -> SDoc
 542         show_fixes []     = empty
 543         show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"),
 544                                  nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
 545
 546 reportOverlap :: ReportErrCtxt -> (InstEnv,InstEnv) -> CtOrigin
 547               -> PredType -> TcM (Maybe PredType)
 548 -- Report an overlap error if this class constraint results
 549 -- from an overlap (returning Nothing), otherwise return (Just pred)
 550 reportOverlap ctxt inst_envs orig pred@(ClassP clas tys)
 551   = do { tys_flat <- mapM quickFlattenTy tys
 552            -- Note [Flattening in error message generation]
 553
 554        ; case lookupInstEnv inst_envs clas tys_flat of
 555                 ([], _) -> return (Just pred)               -- No match
 556                 -- The case of exactly one match and no unifiers means a
 557                 -- successful lookup.  That can't happen here, because dicts
 558                 -- only end up here if they didn't match in Inst.lookupInst
 559                 ([_],[])
 560                  | debugIsOn -> pprPanic "check_overlap" (ppr pred)
 561                 res          -> do { addErrorReport ctxt (mk_overlap_msg res)
 562                                    ; return Nothing } }
 563   where
 564     mk_overlap_msg (matches, unifiers)
 565       = ASSERT( not (null matches) )
 566         vcat [  addArising orig (ptext (sLit "Overlapping instances for")
 567                                 <+> pprPred pred)
 568              ,  sep [ptext (sLit "Matching instances") <> colon,
 569                      nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
 570              ,  if not (isSingleton matches)
 571                 then    -- Two or more matches
 572                      empty
 573                 else    -- One match, plus some unifiers
 574                 ASSERT( not (null unifiers) )
 575                 parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
 576                                  quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
 577                               ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
 578                               ptext (sLit "when compiling the other instance declarations")])]
 579       where
 580         ispecs = [ispec | (ispec, _) <- matches]
 581
 582 reportOverlap _ _ _ _ = panic "reportOverlap"    -- Not a ClassP
 583
 584 ----------------------
 585 quickFlattenTy :: TcType -> TcM TcType
 586 -- See Note [Flattening in error message generation]
 587 quickFlattenTy ty | Just ty' <- tcView ty = quickFlattenTy ty'
 588 quickFlattenTy ty@(TyVarTy {})  = return ty
 589 quickFlattenTy ty@(ForAllTy {}) = return ty     -- See
 590 quickFlattenTy ty@(PredTy {})   = return ty     -- Note [Quick-flatten polytypes]
 591   -- Don't flatten because of the danger or removing a bound variable
 592 quickFlattenTy (AppTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
 593                                     ; fy2 <- quickFlattenTy ty2
 594                                     ; return (AppTy fy1 fy2) }
 595 quickFlattenTy (FunTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
 596                                     ; fy2 <- quickFlattenTy ty2
 597                                     ; return (FunTy fy1 fy2) }
 598 quickFlattenTy (TyConApp tc tys)
 599     | not (isSynFamilyTyCon tc)
 600     = do { fys <- mapM quickFlattenTy tys
 601          ; return (TyConApp tc fys) }
 602     | otherwise
 603     = do { let (funtys,resttys) = splitAt (tyConArity tc) tys
 604                 -- Ignore the arguments of the type family funtys
 605          ; v <- newMetaTyVar TauTv (typeKind (TyConApp tc funtys))
 606          ; flat_resttys <- mapM quickFlattenTy resttys
 607          ; return (foldl AppTy (mkTyVarTy v) flat_resttys) }
 608 \end{code}
 609
 610 Note [Flattening in error message generation]
 611 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 612 Consider (C (Maybe (F x))), where F is a type function, and we have
 613 instances
 614                 C (Maybe Int) and C (Maybe a)
 615 Since (F x) might turn into Int, this is an overlap situation, and
 616 indeed (because of flattening) the main solver will have refrained
 617 from solving.  But by the time we get to error message generation, we've
 618 un-flattened the constraint.  So we must *re*-flatten it before looking
 619 up in the instance environment, lest we only report one matching
 620 instance when in fact there are two.
 621
 622 Re-flattening is pretty easy, because we don't need to keep track of
 623 evidence.  We don't re-use the code in TcCanonical because that's in
 624 the TcS monad, and we are in TcM here.
 625
 626 Note [Quick-flatten polytypes]
 627 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 628 If we see C (Ix a => blah) or C (forall a. blah) we simply refrain from
 629 flattening any further.  After all, there can be no instance declarations
 630 that match such things.  And flattening under a for-all is problematic
 631 anyway; consider C (forall a. F a)
 632
 633 \begin{code}
 634 reportAmbigErrs :: ReportErrCtxt -> TcTyVarSet -> [WantedEvVar] -> TcM ()
 635 reportAmbigErrs ctxt skols ambigs
 636 -- Divide into groups that share a common set of ambiguous tyvars
 637   = mapM_ report (equivClasses cmp ambigs_w_tvs)
 638   where
 639     ambigs_w_tvs = [ (d, varSetElems (tyVarsOfEvVarX d `minusVarSet` skols))
 640                    | d <- ambigs ]
 641     cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2
 642
 643     report :: [(WantedEvVar, [TcTyVar])] -> TcM ()
 644     report pairs
 645        = setCtLoc loc $
 646          do { let main_msg = sep [ text "Ambiguous type variable" <> plural tvs
 647                                    <+> pprQuotedList tvs
 648                                    <+> text "in the constraint" <> plural pairs <> colon
 649                                  , nest 2 pp_wanteds ]
 650              ; (tidy_env, mono_msg) <- mkMonomorphismMsg ctxt tvs
 651             ; addErrTcM (tidy_env, main_msg $$ mono_msg) }
 652        where
 653          (_, tvs) : _ = pairs
 654          (loc, pp_wanteds) = pprWithArising (map fst pairs)
 655
 656 mkMonomorphismMsg :: ReportErrCtxt -> [TcTyVar] -> TcM (TidyEnv, SDoc)
 657 -- There's an error with these Insts; if they have free type variables
 658 -- it's probably caused by the monomorphism restriction.
 659 -- Try to identify the offending variable
 660 -- ASSUMPTION: the Insts are fully zonked
 661 mkMonomorphismMsg ctxt inst_tvs
 662   = do  { dflags <- getDOpts
 663         ; traceTc "Mono" (vcat (map (pprSkolTvBinding (cec_encl ctxt)) inst_tvs))
 664         ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
 665         ; return (tidy_env, mk_msg dflags docs) }
 666   where
 667     mk_msg _ _ | any isRuntimeUnkSkol inst_tvs  -- See Note [Runtime skolems]
 668         =  vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+>
 669                    (pprWithCommas ppr inst_tvs),
 670                 ptext (sLit "Use :print or :force to determine these types")]
 671     mk_msg _ []   = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)")
 672                         -- This happens in things like
 673                         --      f x = show (read "foo")
 674                         -- where monomorphism doesn't play any role
 675     mk_msg dflags docs
 676         = vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"),
 677                 nest 2 (vcat docs),
 678                 monomorphism_fix dflags]
 679
 680 monomorphism_fix :: DynFlags -> SDoc
 681 monomorphism_fix dflags
 682   = ptext (sLit "Probable fix:") <+> vcat
 683         [ptext (sLit "give these definition(s) an explicit type signature"),
 684          if xopt Opt_MonomorphismRestriction dflags
 685            then ptext (sLit "or use -XNoMonomorphismRestriction")
 686            else empty]  -- Only suggest adding "-XNoMonomorphismRestriction"
 687                         -- if it is not already set!
 688
 689
 690 pprSkolTvBinding :: [Implication] -> TcTyVar -> SDoc
 691 -- Print info about the binding of a skolem tyvar,
 692 -- or nothing if we don't have anything useful to say
 693 pprSkolTvBinding implics tv
 694   | isTcTyVar tv = quotes (ppr tv) <+> ppr_details (tcTyVarDetails tv)
 695   | otherwise    = quotes (ppr tv) <+> ppr_skol    (getSkolemInfo implics tv)
 696   where
 697     ppr_details (SkolemTv {})        = ppr_skol (getSkolemInfo implics tv)
 698     ppr_details (FlatSkol {})        = ptext (sLit "is a flattening type variable")
 699     ppr_details (RuntimeUnk {})      = ptext (sLit "is an interactive-debugger skolem")
 700     ppr_details (MetaTv (SigTv n) _) = ptext (sLit "is bound by the type signature for")
 701                                        <+> quotes (ppr n)
 702     ppr_details (MetaTv _ _)         = ptext (sLit "is a meta type variable")
 703
 704
 705     ppr_skol UnkSkol        = ptext (sLit "is an unknown type variable")        -- Unhelpful
 706     ppr_skol RuntimeUnkSkol = ptext (sLit "is an unknown runtime type")
 707     ppr_skol info           = sep [ptext (sLit "is a rigid type variable bound by"),
 708                                    sep [ppr info,
 709                                         ptext (sLit "at") <+> ppr (getSrcLoc tv)]]
 710
 711 getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo
 712 getSkolemInfo [] tv
 713   = WARN( True, ptext (sLit "No skolem info:") <+> ppr tv )
 714     UnkSkol
 715 getSkolemInfo (implic:implics) tv
 716   | tv `elemVarSet` ic_skols implic = ctLocOrigin (ic_loc implic)
 717   | otherwise                       = getSkolemInfo implics tv
 718
 719 -----------------------
 720 -- findGlobals looks at the value environment and finds values whose
 721 -- types mention any of the offending type variables.  It has to be
 722 -- careful to zonk the Id's type first, so it has to be in the monad.
 723 -- We must be careful to pass it a zonked type variable, too.
 724
 725 mkEnvSigMsg :: SDoc -> [SDoc] -> SDoc
 726 mkEnvSigMsg what env_sigs
 727  | null env_sigs = empty
 728  | otherwise = vcat [ ptext (sLit "The following variables have types that mention") <+> what
 729                     , nest 2 (vcat env_sigs) ]
 730
 731 findGlobals :: ReportErrCtxt
 732             -> TcTyVarSet
 733             -> TcM (TidyEnv, [SDoc])
 734
 735 findGlobals ctxt tvs
 736   = do { lcl_ty_env <- case cec_encl ctxt of
 737                         []    -> getLclTypeEnv
 738                         (i:_) -> return (ic_env i)
 739        ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) }
 740   where
 741     go tidy_env acc [] = return (tidy_env, acc)
 742     go tidy_env acc (thing : things) = do
 743         (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing
 744         case maybe_doc of
 745           Just d  -> go tidy_env1 (d:acc) things
 746           Nothing -> go tidy_env1 acc     things
 747
 748     ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
 749
 750 -----------------------
 751 find_thing :: TidyEnv -> (TcType -> Bool)
 752            -> TcTyThing -> TcM (TidyEnv, Maybe SDoc)
 753 find_thing tidy_env ignore_it (ATcId { tct_id = id })
 754   = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id)
 755        ; if ignore_it tidy_ty then
 756            return (tidy_env, Nothing)
 757          else do
 758        { let msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty
 759                        , nest 2 (parens (ptext (sLit "bound at") <+>
 760                                    ppr (getSrcLoc id)))]
 761        ; return (tidy_env', Just msg) } }
 762
 763 find_thing tidy_env ignore_it (ATyVar tv ty)
 764   = do { (tidy_env1, tidy_ty) <- zonkTidyTcType tidy_env ty
 765        ; if ignore_it tidy_ty then
 766             return (tidy_env, Nothing)
 767          else do
 768        { let -- The name tv is scoped, so we don't need to tidy it
 769             msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff
 770                       , nest 2 bound_at]
 771
 772             eq_stuff | Just tv' <- tcGetTyVar_maybe tidy_ty
 773                      , getOccName tv == getOccName tv' = empty
 774                      | otherwise = equals <+> ppr tidy_ty
 775                 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
 776             bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv)
 777
 778        ; return (tidy_env1, Just msg) } }
 779
 780 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
 781
 782 warnDefaulting :: [FlavoredEvVar] -> Type -> TcM ()
 783 warnDefaulting wanteds default_ty
 784   = do { warn_default <- doptM Opt_WarnTypeDefaults
 785        ; env0 <- tcInitTidyEnv
 786        ; let wanted_bag = listToBag wanteds
 787              tidy_env = tidyFreeTyVars env0 $
 788                         tyVarsOfEvVarXs wanted_bag
 789              tidy_wanteds = mapBag (tidyFlavoredEvVar tidy_env) wanted_bag
 790              (loc, ppr_wanteds) = pprWithArising (map get_wev (bagToList tidy_wanteds))
 791              warn_msg  = hang (ptext (sLit "Defaulting the following constraint(s) to type")
 792                                 <+> quotes (ppr default_ty))
 793                             2 ppr_wanteds
 794        ; setCtLoc loc $ warnTc warn_default warn_msg }
 795   where
 796     get_wev (EvVarX ev (Wanted loc)) = EvVarX ev loc    -- Yuk
 797     get_wev ev = pprPanic "warnDefaulting" (ppr ev)
 798 \end{code}
 799
 800 Note [Runtime skolems]
 801 ~~~~~~~~~~~~~~~~~~~~~~
 802 We want to give a reasonably helpful error message for ambiguity
 803 arising from *runtime* skolems in the debugger.  These
 804 are created by in RtClosureInspect.zonkRTTIType.
 805
 806 %************************************************************************
 807 %*                                                                      *
 808                  Error from the canonicaliser
 809          These ones are called *during* constraint simplification
 810 %*                                                                      *
 811 %************************************************************************
 812
 813 \begin{code}
 814 solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a
 815 solverDepthErrorTcS depth stack
 816   | null stack      -- Shouldn't happen unless you say -fcontext-stack=0
 817   = wrapErrTcS $ failWith msg
 818   | otherwise
 819   = wrapErrTcS $
 820     setCtFlavorLoc (cc_flavor top_item) $
 821     do { ev_vars <- mapM (zonkEvVar . cc_id) stack
 822        ; env0 <- tcInitTidyEnv
 823        ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfEvVars ev_vars)
 824              tidy_ev_vars = map (tidyEvVar tidy_env) ev_vars
 825        ; failWithTcM (tidy_env, hang msg 2 (pprEvVars tidy_ev_vars)) }
 826   where
 827     top_item = head stack
 828     msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
 829                , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
 830
 831 flattenForAllErrorTcS :: CtFlavor -> TcType -> Bag CanonicalCt -> TcS a
 832 flattenForAllErrorTcS fl ty _bad_eqs
 833   = wrapErrTcS        $
 834     setCtFlavorLoc fl $
 835     do { env0 <- tcInitTidyEnv
 836        ; let (env1, ty') = tidyOpenType env0 ty
 837              msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:")
 838                        , ppr ty' ]
 839        ; failWithTcM (env1, msg) }
 840 \end{code}
 841
 842 %************************************************************************
 843 %*                                                                      *
 844                  Setting the context
 845 %*                                                                      *
 846 %************************************************************************
 847
 848 \begin{code}
 849 setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
 850 setCtFlavorLoc (Wanted  loc) thing = setCtLoc loc thing
 851 setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing
 852 setCtFlavorLoc (Given   loc) thing = setCtLoc loc thing
 853 \end{code}
 854
 855 %************************************************************************
 856 %*                                                                      *
 857                  Tidying
 858 %*                                                                      *
 859 %************************************************************************
 860
 861 \begin{code}
 862 zonkTidyTcType :: TidyEnv -> TcType -> TcM (TidyEnv, TcType)
 863 zonkTidyTcType env ty = do { ty' <- zonkTcType ty
 864                            ; return (tidyOpenType env ty') }
 865
 866 zonkTidyOrigin :: ReportErrCtxt -> CtOrigin -> TcM CtOrigin
 867 zonkTidyOrigin ctxt (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp }))
 868   = do { (env1,  act') <- zonkTidyTcType (cec_tidy ctxt) act
 869        ; (_env2, exp') <- zonkTidyTcType env1            exp
 870        ; return (TypeEqOrigin (UnifyOrigin { uo_actual = act', uo_expected = exp' })) }
 871        -- Drop the returned env on the floor; we may conceivably thereby get
 872        -- inconsistent naming between uses of this function
 873 zonkTidyOrigin _ orig = return orig
 874 \end{code}