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 | isSingleton esc_skols
 441                      = ptext (sLit "because this skolem type variable would escape:")
 442                      | otherwise
 443                      = ptext (sLit "because these skolem type variables would escape:")
 444              extra1 = vcat [ nest 2 $ esc_doc <+> pprQuotedList esc_skols
 445                            , sep [ (if isSingleton esc_skols
 446                                       then ptext (sLit "This skolem is")
 447                                       else ptext (sLit "These skolems are"))
 448                                    <+> ptext (sLit "bound by")
 449                                  , nest 2 $ pprSkolInfo (ctLocOrigin implic_loc) ] ]
 450        ; addErrTcM (env1, msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) }
 451
 452   -- Nastiest case: attempt to unify an untouchable variable
 453   | (implic:_) <- cec_encl ctxt   -- Get the innermost context
 454   , let implic_loc = ic_loc implic
 455         given      = ic_given implic
 456   = setCtLoc (ic_loc implic) $
 457     do { let msg = misMatchMsg ty1 ty2
 458              extra = quotes (ppr tv1)
 459                  <+> sep [ ptext (sLit "is untouchable")
 460                          , ptext (sLit "inside the constraints") <+> pprEvVarTheta given
 461                          , ptext (sLit "bound at") <+> pprSkolInfo (ctLocOrigin implic_loc)]
 462        ; addErrorReport (addExtraInfo ctxt ty1 ty2) (msg $$ nest 2 extra) }
 463
 464   | otherwise      -- This can happen, by a recursive decomposition of frozen
 465                    -- occurs check constraints
 466                    -- Example: alpha ~ T Int alpha has frozen.
 467                    --          Then alpha gets unified to T beta gamma
 468                    -- So now we have  T beta gamma ~ T Int (T beta gamma)
 469                    -- Decompose to (beta ~ Int, gamma ~ T beta gamma)
 470                    -- The (gamma ~ T beta gamma) is the occurs check, but
 471                    -- the (beta ~ Int) isn't an error at all.  So return ()
 472   = return ()
 473
 474   where
 475     is_meta1 = isMetaTyVar tv1
 476     k1       = tyVarKind tv1
 477     k2       = typeKind ty2
 478     ty1      = mkTyVarTy tv1
 479
 480 mkTyFunInfoMsg :: TcType -> TcType -> SDoc
 481 -- See Note [Non-injective type functions]
 482 mkTyFunInfoMsg ty1 ty2
 483   | Just (tc1,_) <- tcSplitTyConApp_maybe ty1
 484   , Just (tc2,_) <- tcSplitTyConApp_maybe ty2
 485   , tc1 == tc2, isSynFamilyTyCon tc1
 486   = ptext (sLit "NB:") <+> quotes (ppr tc1)
 487     <+> ptext (sLit "is a type function") <> (pp_inj tc1)
 488   | otherwise = empty
 489   where
 490     pp_inj tc | isInjectiveTyCon tc = empty
 491               | otherwise = ptext (sLit (", and may not be injective"))
 492
 493 misMatchOrCND :: ReportErrCtxt -> TcType -> TcType -> SDoc
 494 misMatchOrCND ctxt ty1 ty2
 495   = case getUserGivens ctxt of
 496       Just givens -> couldNotDeduce givens [EqPred ty1 ty2]
 497       Nothing     -> misMatchMsg ty1 ty2
 498
 499 couldNotDeduce :: [EvVar] -> [PredType] -> SDoc
 500 couldNotDeduce givens wanteds
 501   = sep [ ptext (sLit "Could not deduce") <+> pprTheta wanteds
 502         , nest 2 $ ptext (sLit "from the context")
 503                      <+> pprEvVarTheta givens]
 504
 505 addExtraInfo :: ReportErrCtxt -> TcType -> TcType -> ReportErrCtxt
 506 -- Add on extra info about the types themselves
 507 -- NB: The types themselves are already tidied
 508 addExtraInfo ctxt ty1 ty2
 509   = ctxt { cec_tidy  = env2
 510          , cec_extra = nest 2 (extra1 $$ extra2) $$ cec_extra ctxt }
 511   where
 512     (env1, extra1) = typeExtraInfoMsg (cec_tidy ctxt) ty1
 513     (env2, extra2) = typeExtraInfoMsg env1            ty2
 514
 515 misMatchMsg :: TcType -> TcType -> SDoc    -- Types are already tidy
 516 misMatchMsg ty1 ty2 = sep [ ptext (sLit "Couldn't match type") <+> quotes (ppr ty1)
 517                           , nest 15 $ ptext (sLit "with") <+> quotes (ppr ty2)]
 518
 519 kindErrorMsg :: TcType -> TcType -> SDoc   -- Types are already tidy
 520 kindErrorMsg ty1 ty2
 521   = vcat [ ptext (sLit "Kind incompatibility when matching types:")
 522          , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1
 523                         , ppr ty2 <+> dcolon <+> ppr k2 ]) ]
 524   where
 525     k1 = typeKind ty1
 526     k2 = typeKind ty2
 527
 528 typeExtraInfoMsg :: TidyEnv -> Type -> (TidyEnv, SDoc)
 529 -- Shows a bit of extra info about skolem constants
 530 typeExtraInfoMsg env ty
 531   | Just tv <- tcGetTyVar_maybe ty
 532   , isTcTyVar tv
 533   , isSkolemTyVar tv || isSigTyVar tv
 534   , not (isUnkSkol tv)
 535   , let (env1, tv1) = tidySkolemTyVar env tv
 536   = (env1, pprSkolTvBinding tv1)
 537   where
 538 typeExtraInfoMsg env _ty = (env, empty)         -- Normal case
 539
 540 --------------------
 541 unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc)
 542 unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env
 543   = do  { act_ty' <- zonkTcType act_ty
 544         ; exp_ty' <- zonkTcType exp_ty
 545         ; let (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
 546               (env2, act_ty'') = tidyOpenType env1     act_ty'
 547         ; return (env2, mkExpectedActualMsg act_ty'' exp_ty'') }
 548
 549 mkExpectedActualMsg :: Type -> Type -> SDoc
 550 mkExpectedActualMsg act_ty exp_ty
 551   = vcat [ text "Expected type" <> colon <+> ppr exp_ty
 552          , text "  Actual type" <> colon <+> ppr act_ty ]
 553 \end{code}
 554
 555 Note [Non-injective type functions]
 556 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 557 It's very confusing to get a message like
 558      Couldn't match expected type `Depend s'
 559             against inferred type `Depend s1'
 560 so mkTyFunInfoMsg adds:
 561        NB: `Depend' is type function, and hence may not be injective
 562
 563 Warn of loopy local equalities that were dropped.
 564
 565
 566 %************************************************************************
 567 %*                                                                      *
 568                  Type-class errors
 569 %*                                                                      *
 570 %************************************************************************
 571
 572 \begin{code}
 573 reportDictErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
 574 reportDictErrs ctxt wanteds orig
 575   = do { inst_envs <- tcGetInstEnvs
 576        ; let (others, overlaps) = partitionWith (check_overlap inst_envs) wanteds
 577        ; unless (null others) $
 578          addErrorReport ctxt (mk_no_inst_err others)
 579        ; mapM_ (addErrorReport ctxt) overlaps }
 580   where
 581     check_overlap :: (InstEnv,InstEnv) -> PredType -> Either PredType SDoc
 582         -- Right msg  => overlap message
 583         -- Left  inst => no instance
 584     check_overlap inst_envs pred@(ClassP clas tys)
 585         = case lookupInstEnv inst_envs clas tys of
 586                 ([], _) -> Left pred            -- No match
 587                 -- The case of exactly one match and no unifiers means a
 588                 -- successful lookup.  That can't happen here, because dicts
 589                 -- only end up here if they didn't match in Inst.lookupInst
 590                 ([_],[])
 591                  | debugIsOn -> pprPanic "check_overlap" (ppr pred)
 592                 res -> Right (mk_overlap_msg pred res)
 593     check_overlap _ _ = panic "check_overlap"
 594
 595     mk_overlap_msg pred (matches, unifiers)
 596       = ASSERT( not (null matches) )
 597         vcat [  addArising orig (ptext (sLit "Overlapping instances for")
 598                                 <+> pprPred pred)
 599              ,  sep [ptext (sLit "Matching instances") <> colon,
 600                      nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
 601              ,  if not (isSingleton matches)
 602                 then    -- Two or more matches
 603                      empty
 604                 else    -- One match, plus some unifiers
 605                 ASSERT( not (null unifiers) )
 606                 parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
 607                                  quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
 608                               ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
 609                               ptext (sLit "when compiling the other instance declarations")])]
 610       where
 611         ispecs = [ispec | (ispec, _) <- matches]
 612
 613     mk_no_inst_err :: [PredType] -> SDoc
 614     mk_no_inst_err wanteds
 615       | Just givens <- getUserGivens ctxt
 616       = vcat [ addArising orig $ couldNotDeduce givens wanteds
 617              , show_fixes (fix1 : fixes2) ]
 618
 619       | otherwise       -- Top level
 620       = vcat [ addArising orig $
 621                ptext (sLit "No instance") <> plural wanteds
 622                     <+> ptext (sLit "for") <+> pprTheta wanteds
 623              , show_fixes fixes2 ]
 624
 625       where
 626         fix1 = sep [ ptext (sLit "add") <+> pprTheta wanteds
 627                           <+> ptext (sLit "to the context of")
 628                    , nest 2 $ pprErrCtxtLoc ctxt ]
 629
 630         fixes2 | null instance_dicts = []
 631                | otherwise           = [sep [ptext (sLit "add an instance declaration for"),
 632                                         pprTheta instance_dicts]]
 633         instance_dicts = filterOut isTyVarClassPred wanteds
 634                 -- Insts for which it is worth suggesting an adding an
 635                 -- instance declaration.  Exclude tyvar dicts.
 636
 637         show_fixes :: [SDoc] -> SDoc
 638         show_fixes []     = empty
 639         show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"),
 640                                  nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
 641
 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 (tyVarsOfWantedEvVar 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         ; traceTc "Mono" (vcat (map pprSkolTvBinding inst_tvs))
 672         ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
 673         ; return (tidy_env, mk_msg dflags docs) }
 674   where
 675     mk_msg _ _ | any isRuntimeUnkSkol inst_tvs  -- See Note [Runtime skolems]
 676         =  vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+>
 677                    (pprWithCommas ppr inst_tvs),
 678                 ptext (sLit "Use :print or :force to determine these types")]
 679     mk_msg _ []   = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)")
 680                         -- This happens in things like
 681                         --      f x = show (read "foo")
 682                         -- where monomorphism doesn't play any role
 683     mk_msg dflags docs
 684         = vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"),
 685                 nest 2 (vcat docs),
 686                 monomorphism_fix dflags]
 687
 688 monomorphism_fix :: DynFlags -> SDoc
 689 monomorphism_fix dflags
 690   = ptext (sLit "Probable fix:") <+> vcat
 691         [ptext (sLit "give these definition(s) an explicit type signature"),
 692          if xopt Opt_MonomorphismRestriction dflags
 693            then ptext (sLit "or use -XNoMonomorphismRestriction")
 694            else empty]  -- Only suggest adding "-XNoMonomorphismRestriction"
 695                         -- if it is not already set!
 696
 697
 698 -----------------------
 699 -- findGlobals looks at the value environment and finds values whose
 700 -- types mention any of the offending type variables.  It has to be
 701 -- careful to zonk the Id's type first, so it has to be in the monad.
 702 -- We must be careful to pass it a zonked type variable, too.
 703
 704 mkEnvSigMsg :: SDoc -> [SDoc] -> SDoc
 705 mkEnvSigMsg what env_sigs
 706  | null env_sigs = empty
 707  | otherwise = vcat [ ptext (sLit "The following variables have types that mention") <+> what
 708                     , nest 2 (vcat env_sigs) ]
 709
 710 findGlobals :: ReportErrCtxt
 711             -> TcTyVarSet
 712             -> TcM (TidyEnv, [SDoc])
 713
 714 findGlobals ctxt tvs
 715   = do { lcl_ty_env <- case cec_encl ctxt of
 716                         []    -> getLclTypeEnv
 717                         (i:_) -> return (ic_env i)
 718        ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) }
 719   where
 720     go tidy_env acc [] = return (tidy_env, acc)
 721     go tidy_env acc (thing : things) = do
 722         (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing
 723         case maybe_doc of
 724           Just d  -> go tidy_env1 (d:acc) things
 725           Nothing -> go tidy_env1 acc     things
 726
 727     ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
 728
 729 -----------------------
 730 find_thing :: TidyEnv -> (TcType -> Bool)
 731            -> TcTyThing -> TcM (TidyEnv, Maybe SDoc)
 732 find_thing tidy_env ignore_it (ATcId { tct_id = id })
 733   = do { id_ty <- zonkTcType  (idType id)
 734        ; if ignore_it id_ty then
 735            return (tidy_env, Nothing)
 736          else do
 737        { let (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
 738              msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty
 739                        , nest 2 (parens (ptext (sLit "bound at") <+>
 740                                    ppr (getSrcLoc id)))]
 741        ; return (tidy_env', Just msg) } }
 742
 743 find_thing tidy_env ignore_it (ATyVar tv ty)
 744   = do { tv_ty <- zonkTcType ty
 745        ; if ignore_it tv_ty then
 746             return (tidy_env, Nothing)
 747          else do
 748        { let -- The name tv is scoped, so we don't need to tidy it
 749             (tidy_env1, tidy_ty) = tidyOpenType  tidy_env tv_ty
 750             msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff
 751                       , nest 2 bound_at]
 752
 753             eq_stuff | Just tv' <- tcGetTyVar_maybe tv_ty
 754                      , getOccName tv == getOccName tv' = empty
 755                      | otherwise = equals <+> ppr tidy_ty
 756                 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
 757             bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv)
 758
 759        ; return (tidy_env1, Just msg) } }
 760
 761 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
 762
 763 warnDefaulting :: [WantedEvVar] -> Type -> TcM ()
 764 warnDefaulting wanteds default_ty
 765   = do { warn_default <- doptM Opt_WarnTypeDefaults
 766        ; setCtLoc loc $ warnTc warn_default warn_msg }
 767   where
 768         -- Tidy them first
 769     warn_msg  = vcat [ ptext (sLit "Defaulting the following constraint(s) to type") <+>
 770                                 quotes (ppr default_ty),
 771                       nest 2 ppr_wanteds ]
 772     (loc, ppr_wanteds) = pprWithArising wanteds
 773 \end{code}
 774
 775 Note [Runtime skolems]
 776 ~~~~~~~~~~~~~~~~~~~~~~
 777 We want to give a reasonably helpful error message for ambiguity
 778 arising from *runtime* skolems in the debugger.  These
 779 are created by in RtClosureInspect.zonkRTTIType.
 780
 781
 782 %************************************************************************
 783 %*                                                                      *
 784                  Error from the canonicaliser
 785          These ones are called *during* constraint simplification
 786 %*                                                                      *
 787 %************************************************************************
 788
 789 \begin{code}
 790
 791 solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a
 792 solverDepthErrorTcS depth stack
 793   | null stack      -- Shouldn't happen unless you say -fcontext-stack=0
 794   = wrapErrTcS $ failWith msg
 795   | otherwise
 796   = wrapErrTcS $
 797     setCtFlavorLoc (cc_flavor top_item) $
 798     do { env0 <- tcInitTidyEnv
 799        ; let ev_vars  = map cc_id stack
 800              env1     = tidyFreeTyVars env0 free_tvs
 801              free_tvs = foldr (unionVarSet . tyVarsOfEvVar) emptyVarSet ev_vars
 802              extra    = pprEvVars (map (tidyEvVar env1) ev_vars)
 803        ; failWithTcM (env1, hang msg 2 extra) }
 804   where
 805     top_item = head stack
 806     msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
 807                , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
 808
 809 flattenForAllErrorTcS :: CtFlavor -> TcType -> Bag CanonicalCt -> TcS a
 810 flattenForAllErrorTcS fl ty _bad_eqs
 811   = wrapErrTcS        $
 812     setCtFlavorLoc fl $
 813     do { env0 <- tcInitTidyEnv
 814        ; let (env1, ty') = tidyOpenType env0 ty
 815              msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:")
 816                        , ppr ty' ]
 817        ; failWithTcM (env1, msg) }
 818 \end{code}
 819
 820 %************************************************************************
 821 %*                                                                      *
 822                  Setting the context
 823 %*                                                                      *
 824 %************************************************************************
 825
 826 \begin{code}
 827 setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
 828 setCtFlavorLoc (Wanted  loc)   thing = setCtLoc loc thing
 829 setCtFlavorLoc (Derived loc _) thing = setCtLoc loc thing
 830 setCtFlavorLoc (Given   loc)   thing = setCtLoc loc thing
 831
 832 getWantedEqExtra :: TvSubst -> TidyEnv -> CtOrigin -> TcType -> TcType
 833                  -> TcM (TidyEnv, SDoc)
 834 getWantedEqExtra subst env0 (TypeEqOrigin item) ty1 ty2
 835   -- If the types in the error message are the same
 836   -- as the types we are unifying (remember to zonk the latter)
 837   -- don't add the extra expected/actual message
 838   --
 839   -- The complication is that the types in the TypeEqOrigin must
 840   --   (a) be zonked
 841   --   (b) have any TcS-monad pending equalities applied to them
 842   --            (hence the passed-in substitution)
 843   = do { (env1, act) <- zonkSubstTidy env0 subst (uo_actual item)
 844        ; (env2, exp) <- zonkSubstTidy env1 subst (uo_expected item)
 845        ; if (act `tcEqType` ty1 && exp `tcEqType` ty2)
 846          || (exp `tcEqType` ty1 && act `tcEqType` ty2)
 847          then
 848             return (env0, empty)
 849          else
 850             return (env2, mkExpectedActualMsg act exp) }
 851
 852 getWantedEqExtra _ env0 orig _ _
 853   = return (env0, pprArising orig)
 854
 855 zonkSubstTidy :: TidyEnv -> TvSubst -> TcType -> TcM (TidyEnv, TcType)
 856 -- In general, becore printing a type, we want to
 857 --   a) Zonk it.  Even during constraint simplification this is
 858 --      is important, to un-flatten the flatten skolems in a type
 859 --   b) Substitute any solved unification variables.  This is
 860 --      only important *during* solving, becuase after solving
 861 --      the substitution is expressed in the mutable type variables
 862 --      But during solving there may be constraint (F xi ~ ty)
 863 --      where the substitution has not been applied to the RHS
 864 zonkSubstTidy env subst ty
 865   = do { ty' <- zonkTcTypeAndSubst subst ty
 866        ; return (tidyOpenType env ty') }
 867 \end{code}