compiler/typecheck/TcErrors.lhs

   1 \begin{code}
   2 module TcErrors(
   3        reportUnsolved, reportUnsolvedDeriv,
   4        reportUnsolvedWantedEvVars, warnDefaulting,
   5        unifyCtxt, typeExtraInfoMsg,
   6        kindErrorTcS, misMatchErrorTcS, flattenForAllErrorTcS,
   7        occursCheckErrorTcS, solverDepthErrorTcS
   8   ) where
   9
  10 #include "HsVersions.h"
  11
  12 import TcRnMonad
  13 import TcMType
  14 import TcSMonad
  15 import TcType
  16 import Inst
  17 import InstEnv
  18
  19 import TyCon
  20 import Name
  21 import NameEnv
  22 import Id       ( idType )
  23 import HsExpr   ( pprMatchContext )
  24 import Var
  25 import VarSet
  26 import VarEnv
  27 import SrcLoc
  28 import Bag
  29 import ListSetOps( equivClasses )
  30 import Util
  31 import FastString
  32 import Outputable
  33 import DynFlags
  34 import StaticFlags( opt_PprStyle_Debug )
  35 import Data.List( partition )
  36 import Control.Monad( when, unless )
  37 \end{code}
  38
  39 %************************************************************************
  40 %*                                                                      *
  41 \section{Errors and contexts}
  42 %*                                                                      *
  43 %************************************************************************
  44
  45 ToDo: for these error messages, should we note the location as coming
  46 from the insts, or just whatever seems to be around in the monad just
  47 now?
  48
  49 \begin{code}
  50 reportUnsolved :: (CanonicalCts, Bag Implication) -> TcM ()
  51 reportUnsolved (unsolved_flats, unsolved_implics)
  52   | isEmptyBag unsolved
  53   = return ()
  54   | otherwise
  55   = do { unsolved <- mapBagM zonkWanted unsolved
  56                      -- Zonk to un-flatten any flatten-skols
  57        ; env0 <- tcInitTidyEnv
  58        ; let tidy_env      = tidyFreeTyVars env0 (tyVarsOfWanteds unsolved)
  59              tidy_unsolved = tidyWanteds tidy_env unsolved
  60              err_ctxt = CEC { cec_encl = []
  61                             , cec_extra = empty
  62                             , cec_tidy = tidy_env }
  63        ; traceTc "reportUnsolved" (ppr unsolved)
  64        ; reportTidyWanteds err_ctxt tidy_unsolved }
  65   where
  66     unsolved = mkWantedConstraints unsolved_flats unsolved_implics
  67
  68
  69 reportUnsolvedWantedEvVars :: Bag WantedEvVar -> TcM ()
  70 reportUnsolvedWantedEvVars wanteds
  71   | isEmptyBag wanteds
  72   = return ()
  73   | otherwise
  74   = do { wanteds <- mapBagM zonkWantedEvVar wanteds
  75        ; env0 <- tcInitTidyEnv
  76        ; let tidy_env      = tidyFreeTyVars env0 (tyVarsOfWantedEvVars wanteds)
  77              tidy_unsolved = tidyWantedEvVars tidy_env wanteds
  78              err_ctxt = CEC { cec_encl  = []
  79                             , cec_extra = empty
  80                             , cec_tidy  = tidy_env }
  81        ; groupErrs (reportFlat err_ctxt) (bagToList tidy_unsolved) }
  82
  83 reportUnsolvedDeriv :: [PredType] -> WantedLoc -> TcM ()
  84 reportUnsolvedDeriv unsolved loc
  85   | null unsolved
  86   = return ()
  87   | otherwise
  88   = setCtLoc loc $
  89     do { unsolved <- zonkTcThetaType unsolved
  90        ; env0 <- tcInitTidyEnv
  91        ; let tidy_env      = tidyFreeTyVars env0 (tyVarsOfTheta unsolved)
  92              tidy_unsolved = map (tidyPred tidy_env) unsolved
  93              err_ctxt = CEC { cec_encl  = []
  94                             , cec_extra = alt_fix
  95                             , cec_tidy  = tidy_env }
  96        ; reportFlat err_ctxt tidy_unsolved (ctLocOrigin loc) }
  97   where
  98     alt_fix = vcat [ptext (sLit "Alternatively, use a standalone 'deriving instance' declaration,"),
  99                     nest 2 $ ptext (sLit "so you can specify the instance context yourself")]
 100
 101 --------------------------------------------
 102 --      Internal functions
 103 --------------------------------------------
 104
 105 data ReportErrCtxt
 106     = CEC { cec_encl :: [Implication]  -- Enclosing implications
 107                                        --   (innermost first)
 108           , cec_tidy :: TidyEnv
 109           , cec_extra :: SDoc          -- Add this to each error message
 110       }
 111
 112 reportTidyImplic :: ReportErrCtxt -> Implication -> TcM ()
 113 reportTidyImplic ctxt implic
 114   = reportTidyWanteds ctxt' (ic_wanted implic)
 115   where
 116     ctxt' = ctxt { cec_encl = implic : cec_encl ctxt }
 117
 118 reportTidyWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
 119 reportTidyWanteds ctxt unsolved
 120   = do { let (flats,  implics)    = splitWanteds unsolved
 121              (ambigs, non_ambigs) = partition is_ambiguous (bagToList flats)
 122              (tv_eqs, others)     = partition is_tv_eq non_ambigs
 123
 124        ; groupErrs (reportEqErrs ctxt) tv_eqs
 125        ; when (null tv_eqs) $ groupErrs (reportFlat ctxt) others
 126        ; when (null tv_eqs) $ mapBagM_ (reportTidyImplic ctxt) implics
 127
 128            -- Only report ambiguity if no other errors happened
 129            -- See Note [Avoiding spurious errors]
 130        ; when (isEmptyBag implics && null non_ambigs) $
 131          reportAmbigErrs ctxt skols ambigs }
 132   where
 133     skols = foldr (unionVarSet . ic_skols) emptyVarSet (cec_encl ctxt)
 134
 135         -- Report equalities of form (a~ty) first.  They are usually
 136         -- skolem-equalities, and they cause confusing knock-on
 137         -- effects in other errors; see test T4093b.
 138     is_tv_eq c | EqPred ty1 ty2 <- wantedEvVarPred c
 139                = tcIsTyVarTy ty1 || tcIsTyVarTy ty2
 140                | otherwise = False
 141
 142         -- Treat it as "ambiguous" if
 143         --   (a) it is a class constraint
 144         --   (b) it constrains only type variables
 145         --       (else we'd prefer to report it as "no instance for...")
 146         --   (c) it mentions type variables that are not skolems
 147     is_ambiguous d = isTyVarClassPred pred
 148                   && not (tyVarsOfPred pred `subVarSet` skols)
 149                   where
 150                      pred = wantedEvVarPred d
 151
 152 reportFlat :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
 153 reportFlat ctxt flats origin
 154   = do { unless (null dicts) $ reportDictErrs ctxt dicts origin
 155        ; unless (null eqs)   $ reportEqErrs   ctxt eqs   origin
 156        ; unless (null ips)   $ reportIPErrs   ctxt ips   origin
 157        ; ASSERT( null others ) return () }
 158   where
 159     (dicts, non_dicts) = partition isClassPred flats
 160     (eqs, non_eqs)     = partition isEqPred    non_dicts
 161     (ips, others)      = partition isIPPred    non_eqs
 162
 163 --------------------------------------------
 164 --      Support code
 165 --------------------------------------------
 166
 167 groupErrs :: ([PredType] -> CtOrigin -> TcM ()) -- Deal with one group
 168           -> [WantedEvVar]                      -- Unsolved wanteds
 169           -> TcM ()
 170 -- Group together insts with the same origin
 171 -- We want to report them together in error messages
 172
 173 groupErrs _ []
 174   = return ()
 175 groupErrs report_err (wanted : wanteds)
 176   = do  { setCtLoc the_loc $
 177           report_err the_vars (ctLocOrigin the_loc)
 178         ; groupErrs report_err others }
 179   where
 180    the_loc           = wantedEvVarLoc wanted
 181    the_key           = mk_key the_loc
 182    the_vars          = map wantedEvVarPred (wanted:friends)
 183    (friends, others) = partition is_friend wanteds
 184    is_friend friend  = mk_key (wantedEvVarLoc friend) == the_key
 185
 186    mk_key :: WantedLoc -> (SrcSpan, String)
 187    mk_key loc = (ctLocSpan loc, showSDoc (ppr (ctLocOrigin loc)))
 188         -- It may seem crude to compare the error messages,
 189         -- but it makes sure that we combine just what the user sees,
 190         -- and it avoids need equality on InstLocs.
 191
 192 -- Add the "arising from..." part to a message about bunch of dicts
 193 addArising :: CtOrigin -> SDoc -> SDoc
 194 addArising orig msg = msg $$ nest 2 (pprArising orig)
 195
 196 pprWithArising :: [WantedEvVar] -> (WantedLoc, SDoc)
 197 -- Print something like
 198 --    (Eq a) arising from a use of x at y
 199 --    (Show a) arising froma use of p at q
 200 -- Also return a location for the erroe message
 201 pprWithArising []
 202   = panic "pprWithArising"
 203 pprWithArising [WantedEvVar ev loc]
 204   = (loc, pprEvVarTheta [ev] <+> pprArising (ctLocOrigin loc))
 205 pprWithArising ev_vars
 206   = (first_loc, vcat (map ppr_one ev_vars))
 207   where
 208     first_loc = wantedEvVarLoc (head ev_vars)
 209     ppr_one (WantedEvVar v loc)
 210        = parens (pprPred (evVarPred v)) <+> pprArisingAt loc
 211
 212 addErrorReport :: ReportErrCtxt -> SDoc -> TcM ()
 213 addErrorReport ctxt msg = addErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt)
 214
 215 pprErrCtxtLoc :: ReportErrCtxt -> SDoc
 216 pprErrCtxtLoc ctxt
 217   = case map (ctLocOrigin . ic_loc) (cec_encl ctxt) of
 218        []           -> ptext (sLit "the top level")     -- Should not happen
 219        (orig:origs) -> ppr_skol orig $$
 220                        vcat [ ptext (sLit "or") <+> ppr_skol orig | orig <- origs ]
 221   where
 222     ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc)
 223     ppr_skol skol_info      = pprSkolInfo skol_info
 224
 225 couldNotDeduce :: [EvVar] -> [PredType] -> SDoc
 226 couldNotDeduce givens wanteds
 227   = sep [ ptext (sLit "Could not deduce") <+> pprTheta wanteds
 228         , nest 2 $ ptext (sLit "from the context")
 229                      <+> pprEvVarTheta givens]
 230
 231 getUserGivens :: ReportErrCtxt -> Maybe [EvVar]
 232 -- Just gs => Say "could not deduce ... from gs"
 233 -- Nothing => No interesting givens, say something else
 234 getUserGivens (CEC {cec_encl = ctxt})
 235   | null user_givens = Nothing
 236   | otherwise        = Just user_givens
 237   where
 238     givens = foldl (\gs ic -> ic_given ic ++ gs) [] ctxt
 239     user_givens | opt_PprStyle_Debug = givens
 240                 | otherwise          = filterOut isSelfDict givens
 241        -- In user mode, don't show the "self-dict" given
 242        -- which is only added to do co-inductive solving
 243        -- Rather an awkward hack, but there we are
 244        -- This is the only use of isSelfDict, so it's not in an inner loop
 245 \end{code}
 246
 247
 248 %************************************************************************
 249 %*                                                                      *
 250                 Implicit parameter errors
 251 %*                                                                      *
 252 %************************************************************************
 253
 254 \begin{code}
 255 reportIPErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
 256 reportIPErrs ctxt ips orig
 257   = addErrorReport ctxt $ addArising orig msg
 258   where
 259     msg | Just givens <- getUserGivens ctxt
 260         = couldNotDeduce givens ips
 261         | otherwise
 262         = sep [ ptext (sLit "Unbound implicit parameter") <> plural ips
 263               , nest 2 (pprTheta ips) ]
 264 \end{code}
 265
 266
 267 %************************************************************************
 268 %*                                                                      *
 269                 Equality errors
 270 %*                                                                      *
 271 %************************************************************************
 272
 273 \begin{code}
 274 reportEqErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
 275 reportEqErrs ctxt eqs orig
 276   = mapM_ report_one eqs
 277   where
 278     env0 = cec_tidy ctxt
 279     report_one (EqPred ty1 ty2)
 280       = do { (env1, extra) <- getWantedEqExtra emptyTvSubst env0 orig ty1 ty2
 281            ; let ctxt' = ctxt { cec_tidy = env1
 282                                , cec_extra = cec_extra ctxt $$ extra }
 283            ; reportEqErr ctxt' ty1 ty2 }
 284     report_one pred
 285       = pprPanic "reportEqErrs" (ppr pred)
 286
 287 reportEqErr :: ReportErrCtxt -> TcType -> TcType -> TcM ()
 288 reportEqErr ctxt ty1 ty2
 289   | Just tv1 <- tcGetTyVar_maybe ty1 = reportTyVarEqErr ctxt tv1 ty2
 290   | Just tv2 <- tcGetTyVar_maybe ty2 = reportTyVarEqErr ctxt tv2 ty1
 291   | otherwise   -- Neither side is a type variable
 292                 -- Since the unsolved constraint is canonical,
 293                 -- it must therefore be of form (F tys ~ ty)
 294   = addErrorReport ctxt (msg $$ mkTyFunInfoMsg ty1 ty2)
 295   where
 296     msg = case getUserGivens ctxt of
 297             Just givens -> couldNotDeduce givens [EqPred ty1 ty2]
 298             Nothing     -> misMatchMsg ty1 ty2
 299
 300 reportTyVarEqErr :: ReportErrCtxt -> TcTyVar -> TcType -> TcM ()
 301 reportTyVarEqErr ctxt tv1 ty2
 302   | not is_meta1
 303   , Just tv2 <- tcGetTyVar_maybe ty2
 304   , isMetaTyVar tv2
 305   = -- sk ~ alpha: swap
 306     reportTyVarEqErr ctxt tv2 ty1
 307
 308   | not is_meta1
 309   = -- sk ~ ty, where ty isn't a meta-tyvar: mis-match
 310     addErrTcM (misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2)
 311
 312   -- So tv is a meta tyvar, and presumably it is
 313   -- an *untouchable* meta tyvar, else it'd have been unified
 314   | not (k2 `isSubKind` k1)      -- Kind error
 315   = addErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2)
 316
 317   -- Check for skolem escape
 318   | (implic:_) <- cec_encl ctxt   -- Get the innermost context
 319   , let esc_skols = varSetElems (tyVarsOfType ty2 `intersectVarSet` ic_skols implic)
 320         implic_loc = ic_loc implic
 321   , not (null esc_skols)
 322   = setCtLoc implic_loc $       -- Override the error message location from the
 323                                 -- place the equality arose to the implication site
 324     do { (env1, env_sigs) <- findGlobals ctxt (unitVarSet tv1)
 325        ; let msg = misMatchMsg ty1 ty2
 326              esc_doc | isSingleton esc_skols
 327                      = ptext (sLit "because this skolem type variable would escape:")
 328                      | otherwise
 329                      = ptext (sLit "because these skolem type variables would escape:")
 330              extra1 = vcat [ nest 2 $ esc_doc <+> pprQuotedList esc_skols
 331                            , sep [ (if isSingleton esc_skols
 332                                       then ptext (sLit "This skolem is")
 333                                       else ptext (sLit "These skolems are"))
 334                                    <+> ptext (sLit "bound by")
 335                                  , nest 2 $ pprSkolInfo (ctLocOrigin implic_loc) ] ]
 336        ; addErrTcM (env1, msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) }
 337
 338   -- Nastiest case: attempt to unify an untouchable variable
 339   | (implic:_) <- cec_encl ctxt   -- Get the innermost context
 340   , let implic_loc = ic_loc implic
 341         given      = ic_given implic
 342   = setCtLoc (ic_loc implic) $
 343     do { let (env1, msg) = misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2
 344              extra = vcat [ ptext (sLit "because") <+> ppr tv1 <+> ptext (sLit "is untouchable")
 345                           , ptext (sLit "inside the constraints") <+> pprEvVarTheta given
 346                           , nest 2 (ptext (sLit "bound at")
 347                              <+> pprSkolInfo (ctLocOrigin implic_loc)) ]
 348        ; addErrTcM (env1, msg $$ extra) }
 349
 350   | otherwise      -- I'm not sure how this can happen!
 351   = addErrTcM (misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2)
 352   where
 353     is_meta1 = isMetaTyVar tv1
 354     k1       = tyVarKind tv1
 355     k2       = typeKind ty2
 356     ty1      = mkTyVarTy tv1
 357
 358 mkTyFunInfoMsg :: TcType -> TcType -> SDoc
 359 -- See Note [Non-injective type functions]
 360 mkTyFunInfoMsg ty1 ty2
 361   | Just (tc1,_) <- tcSplitTyConApp_maybe ty1
 362   , Just (tc2,_) <- tcSplitTyConApp_maybe ty2
 363   , tc1 == tc2, isSynFamilyTyCon tc1
 364   = ptext (sLit "NB:") <+> quotes (ppr tc1)
 365     <+> ptext (sLit "is a type function") <> (pp_inj tc1)
 366   | otherwise = empty
 367   where
 368     pp_inj tc | isInjectiveTyCon tc = empty
 369               | otherwise = ptext (sLit (", and may not be injective"))
 370
 371 misMatchMsgWithExtras :: TidyEnv -> TcType -> TcType -> (TidyEnv, SDoc)
 372 -- This version is used by TcSimplify too, which doesn't track the
 373 -- expected/acutal thing, so we just have ty1 ty2 here
 374 -- NB: The types are already tidied
 375 misMatchMsgWithExtras env ty1 ty2
 376   = (env2, sep [ misMatchMsg ty1 ty2, nest 2 (extra1 $$ extra2) ])
 377   where
 378     (env1, extra1) = typeExtraInfoMsg env ty1
 379     (env2, extra2) = typeExtraInfoMsg env1 ty2
 380
 381 misMatchMsg :: TcType -> TcType -> SDoc    -- Types are already tidy
 382 misMatchMsg ty1 ty2 = sep [ ptext (sLit "Couldn't match type") <+> quotes (ppr ty1)
 383                           , nest 15 $ ptext (sLit "with") <+> quotes (ppr ty2)]
 384
 385 kindErrorMsg :: TcType -> TcType -> SDoc   -- Types are already tidy
 386 kindErrorMsg ty1 ty2
 387   = vcat [ ptext (sLit "Kind incompatibility when matching types:")
 388          , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1
 389                         , ppr ty2 <+> dcolon <+> ppr k2 ]) ]
 390   where
 391     k1 = typeKind ty1
 392     k2 = typeKind ty2
 393
 394 typeExtraInfoMsg :: TidyEnv -> Type -> (TidyEnv, SDoc)
 395 -- Shows a bit of extra info about skolem constants
 396 typeExtraInfoMsg env ty
 397   | Just tv <- tcGetTyVar_maybe ty
 398   , isTcTyVar tv
 399   , isSkolemTyVar tv || isSigTyVar tv
 400   , not (isUnk tv)
 401   , let (env1, tv1) = tidySkolemTyVar env tv
 402   = (env1, pprSkolTvBinding tv1)
 403   where
 404 typeExtraInfoMsg env _ty = (env, empty)         -- Normal case
 405
 406 --------------------
 407 unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc)
 408 unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env
 409   = do  { act_ty' <- zonkTcType act_ty
 410         ; exp_ty' <- zonkTcType exp_ty
 411         ; let (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
 412               (env2, act_ty'') = tidyOpenType env1     act_ty'
 413         ; return (env2, mkExpectedActualMsg act_ty'' exp_ty'') }
 414
 415 mkExpectedActualMsg :: Type -> Type -> SDoc
 416 mkExpectedActualMsg act_ty exp_ty
 417   = vcat [ text "Expected type" <> colon <+> ppr exp_ty
 418          , text "  Actual type" <> colon <+> ppr act_ty ]
 419 \end{code}
 420
 421 Note [Non-injective type functions]
 422 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 423 It's very confusing to get a message like
 424      Couldn't match expected type `Depend s'
 425             against inferred type `Depend s1'
 426 so mkTyFunInfoMsg adds:
 427        NB: `Depend' is type function, and hence may not be injective
 428
 429 Warn of loopy local equalities that were dropped.
 430
 431
 432 %************************************************************************
 433 %*                                                                      *
 434                  Type-class errors
 435 %*                                                                      *
 436 %************************************************************************
 437
 438 \begin{code}
 439 reportDictErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
 440 reportDictErrs ctxt wanteds orig
 441   = do { inst_envs <- tcGetInstEnvs
 442        ; let (others, overlaps) = partitionWith (check_overlap inst_envs) wanteds
 443        ; unless (null others) $
 444          addErrorReport ctxt (mk_no_inst_err others)
 445        ; mapM_ (addErrorReport ctxt) overlaps }
 446   where
 447     check_overlap :: (InstEnv,InstEnv) -> PredType -> Either PredType SDoc
 448         -- Right msg  => overlap message
 449         -- Left  inst => no instance
 450     check_overlap inst_envs pred@(ClassP clas tys)
 451         = case lookupInstEnv inst_envs clas tys of
 452                 ([], _) -> Left pred            -- No match
 453                 -- The case of exactly one match and no unifiers means a
 454                 -- successful lookup.  That can't happen here, because dicts
 455                 -- only end up here if they didn't match in Inst.lookupInst
 456                 ([_],[])
 457                  | debugIsOn -> pprPanic "check_overlap" (ppr pred)
 458                 res -> Right (mk_overlap_msg pred res)
 459     check_overlap _ _ = panic "check_overlap"
 460
 461     mk_overlap_msg pred (matches, unifiers)
 462       = ASSERT( not (null matches) )
 463         vcat [  addArising orig (ptext (sLit "Overlapping instances for")
 464                                 <+> pprPred pred)
 465              ,  sep [ptext (sLit "Matching instances") <> colon,
 466                      nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
 467              ,  if not (isSingleton matches)
 468                 then    -- Two or more matches
 469                      empty
 470                 else    -- One match, plus some unifiers
 471                 ASSERT( not (null unifiers) )
 472                 parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
 473                                  quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
 474                               ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
 475                               ptext (sLit "when compiling the other instance declarations")])]
 476       where
 477         ispecs = [ispec | (ispec, _) <- matches]
 478
 479     mk_no_inst_err :: [PredType] -> SDoc
 480     mk_no_inst_err wanteds
 481       | Just givens <- getUserGivens ctxt
 482       = vcat [ addArising orig $ couldNotDeduce givens wanteds
 483              , show_fixes (fix1 : fixes2) ]
 484
 485       | otherwise       -- Top level
 486       = vcat [ addArising orig $
 487                ptext (sLit "No instance") <> plural wanteds
 488                     <+> ptext (sLit "for") <+> pprTheta wanteds
 489              , show_fixes fixes2 ]
 490
 491       where
 492         fix1 = sep [ ptext (sLit "add") <+> pprTheta wanteds
 493                           <+> ptext (sLit "to the context of")
 494                    , nest 2 $ pprErrCtxtLoc ctxt ]
 495
 496         fixes2 | null instance_dicts = []
 497                | otherwise           = [sep [ptext (sLit "add an instance declaration for"),
 498                                         pprTheta instance_dicts]]
 499         instance_dicts = filterOut isTyVarClassPred wanteds
 500                 -- Insts for which it is worth suggesting an adding an
 501                 -- instance declaration.  Exclude tyvar dicts.
 502
 503         show_fixes :: [SDoc] -> SDoc
 504         show_fixes []     = empty
 505         show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"),
 506                                  nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
 507
 508 reportAmbigErrs :: ReportErrCtxt -> TcTyVarSet -> [WantedEvVar] -> TcM ()
 509 reportAmbigErrs ctxt skols ambigs
 510 -- Divide into groups that share a common set of ambiguous tyvars
 511   = mapM_ report (equivClasses cmp ambigs_w_tvs)
 512   where
 513     ambigs_w_tvs = [ (d, varSetElems (tyVarsOfWantedEvVar d `minusVarSet` skols))
 514                    | d <- ambigs ]
 515     cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2
 516
 517     report :: [(WantedEvVar, [TcTyVar])] -> TcM ()
 518     report pairs
 519        = setCtLoc loc $
 520          do { let main_msg = sep [ text "Ambiguous type variable" <> plural tvs
 521                                    <+> pprQuotedList tvs
 522                                    <+> text "in the constraint" <> plural pairs <> colon
 523                                  , nest 2 pp_wanteds ]
 524              ; (tidy_env, mono_msg) <- mkMonomorphismMsg ctxt tvs
 525             ; addErrTcM (tidy_env, main_msg $$ mono_msg) }
 526        where
 527          (_, tvs) : _ = pairs
 528          (loc, pp_wanteds) = pprWithArising (map fst pairs)
 529
 530 mkMonomorphismMsg :: ReportErrCtxt -> [TcTyVar] -> TcM (TidyEnv, SDoc)
 531 -- There's an error with these Insts; if they have free type variables
 532 -- it's probably caused by the monomorphism restriction.
 533 -- Try to identify the offending variable
 534 -- ASSUMPTION: the Insts are fully zonked
 535 mkMonomorphismMsg ctxt inst_tvs
 536   = do  { dflags <- getDOpts
 537         ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
 538         ; return (tidy_env, mk_msg dflags docs) }
 539   where
 540     mk_msg _ _ | any isRuntimeUnk inst_tvs
 541         =  vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+>
 542                    (pprWithCommas ppr inst_tvs),
 543                 ptext (sLit "Use :print or :force to determine these types")]
 544     mk_msg _ []   = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)")
 545                         -- This happens in things like
 546                         --      f x = show (read "foo")
 547                         -- where monomorphism doesn't play any role
 548     mk_msg dflags docs
 549         = vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"),
 550                 nest 2 (vcat docs),
 551                 monomorphism_fix dflags]
 552
 553 monomorphism_fix :: DynFlags -> SDoc
 554 monomorphism_fix dflags
 555   = ptext (sLit "Probable fix:") <+> vcat
 556         [ptext (sLit "give these definition(s) an explicit type signature"),
 557          if xopt Opt_MonomorphismRestriction dflags
 558            then ptext (sLit "or use -XNoMonomorphismRestriction")
 559            else empty]  -- Only suggest adding "-XNoMonomorphismRestriction"
 560                         -- if it is not already set!
 561
 562
 563 -----------------------
 564 -- findGlobals looks at the value environment and finds values whose
 565 -- types mention any of the offending type variables.  It has to be
 566 -- careful to zonk the Id's type first, so it has to be in the monad.
 567 -- We must be careful to pass it a zonked type variable, too.
 568
 569 mkEnvSigMsg :: SDoc -> [SDoc] -> SDoc
 570 mkEnvSigMsg what env_sigs
 571  | null env_sigs = empty
 572  | otherwise = vcat [ ptext (sLit "The following variables have types that mention") <+> what
 573                     , nest 2 (vcat env_sigs) ]
 574
 575 findGlobals :: ReportErrCtxt
 576             -> TcTyVarSet
 577             -> TcM (TidyEnv, [SDoc])
 578
 579 findGlobals ctxt tvs
 580   = do { lcl_ty_env <- case cec_encl ctxt of
 581                         []    -> getLclTypeEnv
 582                         (i:_) -> return (ic_env i)
 583        ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) }
 584   where
 585     go tidy_env acc [] = return (tidy_env, acc)
 586     go tidy_env acc (thing : things) = do
 587         (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing
 588         case maybe_doc of
 589           Just d  -> go tidy_env1 (d:acc) things
 590           Nothing -> go tidy_env1 acc     things
 591
 592     ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
 593
 594 -----------------------
 595 find_thing :: TidyEnv -> (TcType -> Bool)
 596            -> TcTyThing -> TcM (TidyEnv, Maybe SDoc)
 597 find_thing tidy_env ignore_it (ATcId { tct_id = id })
 598   = do { id_ty <- zonkTcType  (idType id)
 599        ; if ignore_it id_ty then
 600            return (tidy_env, Nothing)
 601          else do
 602        { let (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
 603              msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty
 604                        , nest 2 (parens (ptext (sLit "bound at") <+>
 605                                    ppr (getSrcLoc id)))]
 606        ; return (tidy_env', Just msg) } }
 607
 608 find_thing tidy_env ignore_it (ATyVar tv ty)
 609   = do { tv_ty <- zonkTcType ty
 610        ; if ignore_it tv_ty then
 611             return (tidy_env, Nothing)
 612          else do
 613        { let -- The name tv is scoped, so we don't need to tidy it
 614             (tidy_env1, tidy_ty) = tidyOpenType  tidy_env tv_ty
 615             msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff
 616                       , nest 2 bound_at]
 617
 618             eq_stuff | Just tv' <- tcGetTyVar_maybe tv_ty
 619                      , getOccName tv == getOccName tv' = empty
 620                      | otherwise = equals <+> ppr tidy_ty
 621                 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
 622             bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv)
 623
 624        ; return (tidy_env1, Just msg) } }
 625
 626 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
 627
 628 warnDefaulting :: [WantedEvVar] -> Type -> TcM ()
 629 warnDefaulting wanteds default_ty
 630   = do { warn_default <- doptM Opt_WarnTypeDefaults
 631        ; setCtLoc loc $ warnTc warn_default warn_msg }
 632   where
 633         -- Tidy them first
 634     warn_msg  = vcat [ ptext (sLit "Defaulting the following constraint(s) to type") <+>
 635                                 quotes (ppr default_ty),
 636                       nest 2 ppr_wanteds ]
 637     (loc, ppr_wanteds) = pprWithArising wanteds
 638 \end{code}
 639
 640 %************************************************************************
 641 %*                                                                      *
 642                  Error from the canonicaliser
 643          These ones are called *during* constraint simplification
 644 %*                                                                      *
 645 %************************************************************************
 646
 647 \begin{code}
 648 kindErrorTcS :: CtFlavor -> TcType -> TcType -> TcS ()
 649 -- If there's a kind error, we don't want to blindly say "kind error"
 650 -- We might, say, be unifying a skolem 'a' with a type 'Int',
 651 -- in which case that's the error to report.  So we set things
 652 -- up to call reportEqErr, which does the business properly
 653 kindErrorTcS fl ty1 ty2
 654   = wrapEqErrTcS fl ty1 ty2 $ \ env0 ty1 ty2 extra ->
 655     do { let ctxt = CEC { cec_encl = []
 656                         , cec_extra = extra
 657                         , cec_tidy = env0 }
 658        ; reportEqErr ctxt ty1 ty2 }
 659
 660 misMatchErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a
 661 misMatchErrorTcS fl ty1 ty2
 662   = wrapEqErrTcS fl ty1 ty2 $ \ env0 ty1 ty2 extra ->
 663     do { let (env1, msg)  = misMatchMsgWithExtras env0 ty1 ty2
 664        ; failWithTcM (env1, inaccessible_msg $$ msg $$ extra) }
 665   where
 666     inaccessible_msg
 667       = case fl of
 668           Given loc -> hang (ptext (sLit "Inaccessible code in"))
 669                           2 (mk_what loc)
 670           _         -> empty
 671     mk_what loc
 672       = case ctLocOrigin loc of
 673           PatSkol dc mc -> sep [ ptext (sLit "a pattern with constructor")
 674                                    <+> quotes (ppr dc) <> comma
 675                                , ptext (sLit "in") <+> pprMatchContext mc ]
 676           other_skol -> pprSkolInfo other_skol
 677
 678 occursCheckErrorTcS :: CtFlavor -> TcTyVar -> TcType -> TcS a
 679 occursCheckErrorTcS fl tv ty
 680   = wrapEqErrTcS fl (mkTyVarTy tv) ty $ \ env0 ty1 ty2 extra2 ->
 681     do  { let extra1 = sep [ppr ty1, char '=', ppr ty2]
 682         ; failWithTcM (env0, hang msg 2 (extra1 $$ extra2)) }
 683   where
 684     msg = text $ "Occurs check: cannot construct the infinite type:"
 685
 686 solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a
 687 solverDepthErrorTcS depth stack
 688   | null stack      -- Shouldn't happen unless you say -fcontext-stack=0
 689   = wrapErrTcS $ failWith msg
 690   | otherwise
 691   = wrapErrTcS $
 692     setCtFlavorLoc (cc_flavor top_item) $
 693     do { env0 <- tcInitTidyEnv
 694        ; let ev_vars  = map cc_id stack
 695              env1     = tidyFreeTyVars env0 free_tvs
 696              free_tvs = foldr (unionVarSet . tyVarsOfEvVar) emptyVarSet ev_vars
 697              extra    = pprEvVars (map (tidyEvVar env1) ev_vars)
 698        ; failWithTcM (env1, hang msg 2 extra) }
 699   where
 700     top_item = head stack
 701     msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
 702                , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
 703
 704 flattenForAllErrorTcS :: CtFlavor -> TcType -> Bag CanonicalCt -> TcS a
 705 flattenForAllErrorTcS fl ty _bad_eqs
 706   = wrapErrTcS        $
 707     setCtFlavorLoc fl $
 708     do { env0 <- tcInitTidyEnv
 709        ; let (env1, ty') = tidyOpenType env0 ty
 710              msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:")
 711                        , ppr ty' ]
 712        ; failWithTcM (env1, msg) }
 713 \end{code}
 714
 715 %************************************************************************
 716 %*                                                                      *
 717                  Setting the context
 718 %*                                                                      *
 719 %************************************************************************
 720
 721 \begin{code}
 722 setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
 723 setCtFlavorLoc (Wanted  loc) thing = setCtLoc loc thing
 724 setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing
 725 setCtFlavorLoc (Given   loc) thing = setCtLoc loc thing
 726
 727 wrapEqErrTcS :: CtFlavor -> TcType -> TcType
 728              -> (TidyEnv -> TcType -> TcType -> SDoc -> TcM a)
 729              -> TcS a
 730 wrapEqErrTcS fl ty1 ty2 thing_inside
 731   = do { ty_binds_var <- getTcSTyBinds
 732        ; wrapErrTcS $ setCtFlavorLoc fl $
 733     do {   -- Apply the current substitition
 734            -- and zonk to get rid of flatten-skolems
 735        ; ty_binds_map <- readTcRef ty_binds_var
 736        ; let subst = mkOpenTvSubst (mapVarEnv snd ty_binds_map)
 737        ; env0 <- tcInitTidyEnv
 738        ; (env1, ty1) <- zonkSubstTidy env0 subst ty1
 739        ; (env2, ty2) <- zonkSubstTidy env1 subst ty2
 740        ; let do_wanted loc = do { (env3, extra) <- getWantedEqExtra subst env2
 741                                                      (ctLocOrigin loc) ty1 ty2
 742                                 ; thing_inside env3 ty1 ty2 extra }
 743        ; case fl of
 744            Wanted  loc -> do_wanted loc
 745            Derived loc -> do_wanted loc
 746            Given {}    -> thing_inside env2 ty1 ty2 empty
 747                                  -- We could print more info, but it
 748                                  -- seems to be coming out already
 749        } }
 750   where
 751
 752 getWantedEqExtra :: TvSubst -> TidyEnv -> CtOrigin -> TcType -> TcType
 753                  -> TcM (TidyEnv, SDoc)
 754 getWantedEqExtra subst env0 (TypeEqOrigin item) ty1 ty2
 755   -- If the types in the error message are the same
 756   -- as the types we are unifying (remember to zonk the latter)
 757   -- don't add the extra expected/actual message
 758   --
 759   -- The complication is that the types in the TypeEqOrigin must
 760   --   (a) be zonked
 761   --   (b) have any TcS-monad pending equalities applied to them
 762   --            (hence the passed-in substitution)
 763   = do { (env1, act) <- zonkSubstTidy env0 subst (uo_actual item)
 764        ; (env2, exp) <- zonkSubstTidy env1 subst (uo_expected item)
 765        ; if (act `tcEqType` ty1 && exp `tcEqType` ty2)
 766          || (exp `tcEqType` ty1 && act `tcEqType` ty2)
 767          then
 768             return (env0, empty)
 769          else
 770             return (env2, mkExpectedActualMsg act exp) }
 771
 772 getWantedEqExtra _ env0 orig _ _
 773   = return (env0, pprArising orig)
 774
 775 zonkSubstTidy :: TidyEnv -> TvSubst -> TcType -> TcM (TidyEnv, TcType)
 776 -- In general, becore printing a type, we want to
 777 --   a) Zonk it.  Even during constraint simplification this is
 778 --      is important, to un-flatten the flatten skolems in a type
 779 --   b) Substitute any solved unification variables.  This is
 780 --      only important *during* solving, becuase after solving
 781 --      the substitution is expressed in the mutable type variables
 782 --      But during solving there may be constraint (F xi ~ ty)
 783 --      where the substitution has not been applied to the RHS
 784 zonkSubstTidy env subst ty
 785   = do { ty' <- zonkTcTypeAndSubst subst ty
 786        ; return (tidyOpenType env ty') }
 787 \end{code}