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        ; non_overlaps <- mapMaybeM (reportOverlap ctxt inst_envs orig) wanteds
 577        ; unless (null non_overlaps) $
 578          addErrorReport ctxt (mk_no_inst_err non_overlaps) }
 579   where
 580     mk_no_inst_err :: [PredType] -> SDoc
 581     mk_no_inst_err wanteds
 582       | Just givens <- getUserGivens ctxt
 583       = vcat [ addArising orig $ couldNotDeduce givens wanteds
 584              , show_fixes (fix1 : fixes2) ]
 585
 586       | otherwise       -- Top level
 587       = vcat [ addArising orig $
 588                ptext (sLit "No instance") <> plural wanteds
 589                     <+> ptext (sLit "for") <+> pprTheta wanteds
 590              , show_fixes fixes2 ]
 591
 592       where
 593         fix1 = sep [ ptext (sLit "add") <+> pprTheta wanteds
 594                           <+> ptext (sLit "to the context of")
 595                    , nest 2 $ pprErrCtxtLoc ctxt ]
 596
 597         fixes2 | null instance_dicts = []
 598                | otherwise           = [sep [ptext (sLit "add an instance declaration for"),
 599                                         pprTheta instance_dicts]]
 600         instance_dicts = filterOut isTyVarClassPred wanteds
 601                 -- Insts for which it is worth suggesting an adding an
 602                 -- instance declaration.  Exclude tyvar dicts.
 603
 604         show_fixes :: [SDoc] -> SDoc
 605         show_fixes []     = empty
 606         show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"),
 607                                  nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
 608
 609 reportOverlap :: ReportErrCtxt -> (InstEnv,InstEnv) -> CtOrigin
 610               -> PredType -> TcM (Maybe PredType)
 611 -- Report an overlap error if this class constraint results
 612 -- from an overlap (returning Nothing), otherwise return (Just pred)
 613 reportOverlap ctxt inst_envs orig pred@(ClassP clas tys)
 614   = do { tys_flat <- mapM quickFlattenTy tys
 615            -- Note [Flattening in error message generation]
 616
 617        ; case lookupInstEnv inst_envs clas tys_flat of
 618                 ([], _) -> return (Just pred)               -- No match
 619                 -- The case of exactly one match and no unifiers means a
 620                 -- successful lookup.  That can't happen here, because dicts
 621                 -- only end up here if they didn't match in Inst.lookupInst
 622                 ([_],[])
 623                  | debugIsOn -> pprPanic "check_overlap" (ppr pred)
 624                 res          -> do { addErrorReport ctxt (mk_overlap_msg res)
 625                                    ; return Nothing } }
 626   where
 627     mk_overlap_msg (matches, unifiers)
 628       = ASSERT( not (null matches) )
 629         vcat [  addArising orig (ptext (sLit "Overlapping instances for")
 630                                 <+> pprPred pred)
 631              ,  sep [ptext (sLit "Matching instances") <> colon,
 632                      nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
 633              ,  if not (isSingleton matches)
 634                 then    -- Two or more matches
 635                      empty
 636                 else    -- One match, plus some unifiers
 637                 ASSERT( not (null unifiers) )
 638                 parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
 639                                  quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
 640                               ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
 641                               ptext (sLit "when compiling the other instance declarations")])]
 642       where
 643         ispecs = [ispec | (ispec, _) <- matches]
 644
 645 reportOverlap _ _ _ _ = panic "reportOverlap"    -- Not a ClassP
 646
 647 ----------------------
 648 quickFlattenTy :: TcType -> TcM TcType
 649 -- See Note [Flattening in error message generation]
 650 quickFlattenTy ty | Just ty' <- tcView ty = quickFlattenTy ty'
 651 quickFlattenTy ty@(TyVarTy {})  = return ty
 652 quickFlattenTy ty@(ForAllTy {}) = return ty     -- See
 653 quickFlattenTy ty@(PredTy {})   = return ty     -- Note [Quick-flatten polytypes]
 654   -- Don't flatten because of the danger or removing a bound variable
 655 quickFlattenTy (AppTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
 656                                     ; fy2 <- quickFlattenTy ty2
 657                                     ; return (AppTy fy1 fy2) }
 658 quickFlattenTy (FunTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
 659                                     ; fy2 <- quickFlattenTy ty2
 660                                     ; return (FunTy fy1 fy2) }
 661 quickFlattenTy (TyConApp tc tys)
 662     | not (isSynFamilyTyCon tc)
 663     = do { fys <- mapM quickFlattenTy tys
 664          ; return (TyConApp tc fys) }
 665     | otherwise
 666     = do { let (funtys,resttys) = splitAt (tyConArity tc) tys
 667                 -- Ignore the arguments of the type family funtys
 668          ; v <- newMetaTyVar TauTv (typeKind (TyConApp tc funtys))
 669          ; flat_resttys <- mapM quickFlattenTy resttys
 670          ; return (foldl AppTy (mkTyVarTy v) flat_resttys) }
 671 \end{code}
 672
 673 Note [Flattening in error message generation]
 674 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 675 Consider (C (Maybe (F x))), where F is a type function, and we have
 676 instances
 677                 C (Maybe Int) and C (Maybe a)
 678 Since (F x) might turn into Int, this is an overlap situation, and
 679 indeed (because of flattening) the main solver will have refrained
 680 from solving.  But by the time we get to error message generation, we've
 681 un-flattened the constraint.  So we must *re*-flatten it before looking
 682 up in the instance environment, lest we only report one matching
 683 instance when in fact there are two.
 684
 685 Re-flattening is pretty easy, because we don't need to keep track of
 686 evidence.  We don't re-use the code in TcCanonical because that's in
 687 the TcS monad, and we are in TcM here.
 688
 689 Note [Quick-flatten polytypes]
 690 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 691 If we see C (Ix a => blah) or C (forall a. blah) we simply refrain from
 692 flattening any further.  After all, there can be no instance declarations
 693 that match such things.  And flattening under a for-all is problematic
 694 anyway; consider C (forall a. F a)
 695
 696 \begin{code}
 697 reportAmbigErrs :: ReportErrCtxt -> TcTyVarSet -> [WantedEvVar] -> TcM ()
 698 reportAmbigErrs ctxt skols ambigs
 699 -- Divide into groups that share a common set of ambiguous tyvars
 700   = mapM_ report (equivClasses cmp ambigs_w_tvs)
 701   where
 702     ambigs_w_tvs = [ (d, varSetElems (tyVarsOfWantedEvVar d `minusVarSet` skols))
 703                    | d <- ambigs ]
 704     cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2
 705
 706     report :: [(WantedEvVar, [TcTyVar])] -> TcM ()
 707     report pairs
 708        = setCtLoc loc $
 709          do { let main_msg = sep [ text "Ambiguous type variable" <> plural tvs
 710                                    <+> pprQuotedList tvs
 711                                    <+> text "in the constraint" <> plural pairs <> colon
 712                                  , nest 2 pp_wanteds ]
 713              ; (tidy_env, mono_msg) <- mkMonomorphismMsg ctxt tvs
 714             ; addErrTcM (tidy_env, main_msg $$ mono_msg) }
 715        where
 716          (_, tvs) : _ = pairs
 717          (loc, pp_wanteds) = pprWithArising (map fst pairs)
 718
 719 mkMonomorphismMsg :: ReportErrCtxt -> [TcTyVar] -> TcM (TidyEnv, SDoc)
 720 -- There's an error with these Insts; if they have free type variables
 721 -- it's probably caused by the monomorphism restriction.
 722 -- Try to identify the offending variable
 723 -- ASSUMPTION: the Insts are fully zonked
 724 mkMonomorphismMsg ctxt inst_tvs
 725   = do  { dflags <- getDOpts
 726         ; traceTc "Mono" (vcat (map pprSkolTvBinding inst_tvs))
 727         ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
 728         ; return (tidy_env, mk_msg dflags docs) }
 729   where
 730     mk_msg _ _ | any isRuntimeUnkSkol inst_tvs  -- See Note [Runtime skolems]
 731         =  vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+>
 732                    (pprWithCommas ppr inst_tvs),
 733                 ptext (sLit "Use :print or :force to determine these types")]
 734     mk_msg _ []   = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)")
 735                         -- This happens in things like
 736                         --      f x = show (read "foo")
 737                         -- where monomorphism doesn't play any role
 738     mk_msg dflags docs
 739         = vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"),
 740                 nest 2 (vcat docs),
 741                 monomorphism_fix dflags]
 742
 743 monomorphism_fix :: DynFlags -> SDoc
 744 monomorphism_fix dflags
 745   = ptext (sLit "Probable fix:") <+> vcat
 746         [ptext (sLit "give these definition(s) an explicit type signature"),
 747          if xopt Opt_MonomorphismRestriction dflags
 748            then ptext (sLit "or use -XNoMonomorphismRestriction")
 749            else empty]  -- Only suggest adding "-XNoMonomorphismRestriction"
 750                         -- if it is not already set!
 751
 752
 753 -----------------------
 754 -- findGlobals looks at the value environment and finds values whose
 755 -- types mention any of the offending type variables.  It has to be
 756 -- careful to zonk the Id's type first, so it has to be in the monad.
 757 -- We must be careful to pass it a zonked type variable, too.
 758
 759 mkEnvSigMsg :: SDoc -> [SDoc] -> SDoc
 760 mkEnvSigMsg what env_sigs
 761  | null env_sigs = empty
 762  | otherwise = vcat [ ptext (sLit "The following variables have types that mention") <+> what
 763                     , nest 2 (vcat env_sigs) ]
 764
 765 findGlobals :: ReportErrCtxt
 766             -> TcTyVarSet
 767             -> TcM (TidyEnv, [SDoc])
 768
 769 findGlobals ctxt tvs
 770   = do { lcl_ty_env <- case cec_encl ctxt of
 771                         []    -> getLclTypeEnv
 772                         (i:_) -> return (ic_env i)
 773        ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) }
 774   where
 775     go tidy_env acc [] = return (tidy_env, acc)
 776     go tidy_env acc (thing : things) = do
 777         (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing
 778         case maybe_doc of
 779           Just d  -> go tidy_env1 (d:acc) things
 780           Nothing -> go tidy_env1 acc     things
 781
 782     ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
 783
 784 -----------------------
 785 find_thing :: TidyEnv -> (TcType -> Bool)
 786            -> TcTyThing -> TcM (TidyEnv, Maybe SDoc)
 787 find_thing tidy_env ignore_it (ATcId { tct_id = id })
 788   = do { id_ty <- zonkTcType  (idType id)
 789        ; if ignore_it id_ty then
 790            return (tidy_env, Nothing)
 791          else do
 792        { let (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
 793              msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty
 794                        , nest 2 (parens (ptext (sLit "bound at") <+>
 795                                    ppr (getSrcLoc id)))]
 796        ; return (tidy_env', Just msg) } }
 797
 798 find_thing tidy_env ignore_it (ATyVar tv ty)
 799   = do { tv_ty <- zonkTcType ty
 800        ; if ignore_it tv_ty then
 801             return (tidy_env, Nothing)
 802          else do
 803        { let -- The name tv is scoped, so we don't need to tidy it
 804             (tidy_env1, tidy_ty) = tidyOpenType  tidy_env tv_ty
 805             msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff
 806                       , nest 2 bound_at]
 807
 808             eq_stuff | Just tv' <- tcGetTyVar_maybe tv_ty
 809                      , getOccName tv == getOccName tv' = empty
 810                      | otherwise = equals <+> ppr tidy_ty
 811                 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
 812             bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv)
 813
 814        ; return (tidy_env1, Just msg) } }
 815
 816 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
 817
 818 warnDefaulting :: [WantedEvVar] -> Type -> TcM ()
 819 warnDefaulting wanteds default_ty
 820   = do { warn_default <- doptM Opt_WarnTypeDefaults
 821        ; setCtLoc loc $ warnTc warn_default warn_msg }
 822   where
 823         -- Tidy them first
 824     warn_msg  = vcat [ ptext (sLit "Defaulting the following constraint(s) to type") <+>
 825                                 quotes (ppr default_ty),
 826                       nest 2 ppr_wanteds ]
 827     (loc, ppr_wanteds) = pprWithArising wanteds
 828 \end{code}
 829
 830 Note [Runtime skolems]
 831 ~~~~~~~~~~~~~~~~~~~~~~
 832 We want to give a reasonably helpful error message for ambiguity
 833 arising from *runtime* skolems in the debugger.  These
 834 are created by in RtClosureInspect.zonkRTTIType.
 835
 836 %************************************************************************
 837 %*                                                                      *
 838                  Error from the canonicaliser
 839          These ones are called *during* constraint simplification
 840 %*                                                                      *
 841 %************************************************************************
 842
 843 \begin{code}
 844
 845 solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a
 846 solverDepthErrorTcS depth stack
 847   | null stack      -- Shouldn't happen unless you say -fcontext-stack=0
 848   = wrapErrTcS $ failWith msg
 849   | otherwise
 850   = wrapErrTcS $
 851     setCtFlavorLoc (cc_flavor top_item) $
 852     do { env0 <- tcInitTidyEnv
 853        ; let ev_vars  = map cc_id stack
 854              env1     = tidyFreeTyVars env0 free_tvs
 855              free_tvs = foldr (unionVarSet . tyVarsOfEvVar) emptyVarSet ev_vars
 856              extra    = pprEvVars (map (tidyEvVar env1) ev_vars)
 857        ; failWithTcM (env1, hang msg 2 extra) }
 858   where
 859     top_item = head stack
 860     msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
 861                , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
 862
 863 flattenForAllErrorTcS :: CtFlavor -> TcType -> Bag CanonicalCt -> TcS a
 864 flattenForAllErrorTcS fl ty _bad_eqs
 865   = wrapErrTcS        $
 866     setCtFlavorLoc fl $
 867     do { env0 <- tcInitTidyEnv
 868        ; let (env1, ty') = tidyOpenType env0 ty
 869              msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:")
 870                        , ppr ty' ]
 871        ; failWithTcM (env1, msg) }
 872 \end{code}
 873
 874 %************************************************************************
 875 %*                                                                      *
 876                  Setting the context
 877 %*                                                                      *
 878 %************************************************************************
 879
 880 \begin{code}
 881 setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
 882 setCtFlavorLoc (Wanted  loc)   thing = setCtLoc loc thing
 883 setCtFlavorLoc (Derived loc _) thing = setCtLoc loc thing
 884 setCtFlavorLoc (Given   loc)   thing = setCtLoc loc thing
 885
 886 getWantedEqExtra :: TvSubst -> TidyEnv -> CtOrigin -> TcType -> TcType
 887                  -> TcM (TidyEnv, SDoc)
 888 getWantedEqExtra subst env0 (TypeEqOrigin item) ty1 ty2
 889   -- If the types in the error message are the same
 890   -- as the types we are unifying (remember to zonk the latter)
 891   -- don't add the extra expected/actual message
 892   --
 893   -- The complication is that the types in the TypeEqOrigin must
 894   --   (a) be zonked
 895   --   (b) have any TcS-monad pending equalities applied to them
 896   --            (hence the passed-in substitution)
 897   = do { (env1, act) <- zonkSubstTidy env0 subst (uo_actual item)
 898        ; (env2, exp) <- zonkSubstTidy env1 subst (uo_expected item)
 899        ; if (act `tcEqType` ty1 && exp `tcEqType` ty2)
 900          || (exp `tcEqType` ty1 && act `tcEqType` ty2)
 901          then
 902             return (env0, empty)
 903          else
 904             return (env2, mkExpectedActualMsg act exp) }
 905
 906 getWantedEqExtra _ env0 orig _ _
 907   = return (env0, pprArising orig)
 908
 909 zonkSubstTidy :: TidyEnv -> TvSubst -> TcType -> TcM (TidyEnv, TcType)
 910 -- In general, becore printing a type, we want to
 911 --   a) Zonk it.  Even during constraint simplification this is
 912 --      is important, to un-flatten the flatten skolems in a type
 913 --   b) Substitute any solved unification variables.  This is
 914 --      only important *during* solving, becuase after solving
 915 --      the substitution is expressed in the mutable type variables
 916 --      But during solving there may be constraint (F xi ~ ty)
 917 --      where the substitution has not been applied to the RHS
 918 zonkSubstTidy env subst ty
 919   = do { ty' <- zonkTcTypeAndSubst subst ty
 920        ; return (tidyOpenType env ty') }
 921 \end{code}