compiler/typecheck/TcErrors.lhs

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