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