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 isSilentEvVar givens
 347        -- In user mode, don't show the "silent" givens, used for
 348        -- the "self" dictionary and silent superclass arguments for dfuns
 349 \end{code}
 350
 351
 352 %************************************************************************
 353 %*                                                                      *
 354                 Implicit parameter errors
 355 %*                                                                      *
 356 %************************************************************************
 357
 358 \begin{code}
 359 reportIPErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
 360 reportIPErrs ctxt ips orig
 361   = addErrorReport ctxt $ addArising orig msg
 362   where
 363     msg | Just givens <- getUserGivens ctxt
 364         = couldNotDeduce givens ips
 365         | otherwise
 366         = sep [ ptext (sLit "Unbound implicit parameter") <> plural ips
 367               , nest 2 (pprTheta ips) ]
 368 \end{code}
 369
 370
 371 %************************************************************************
 372 %*                                                                      *
 373                 Equality errors
 374 %*                                                                      *
 375 %************************************************************************
 376
 377 \begin{code}
 378 reportEqErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
 379 -- The [PredType] are already tidied
 380 reportEqErrs ctxt eqs orig
 381   = mapM_ report_one eqs
 382   where
 383     env0 = cec_tidy ctxt
 384     report_one (EqPred ty1 ty2)
 385       = do { (env1, extra) <- getWantedEqExtra emptyTvSubst env0 orig ty1 ty2
 386             ; let ctxt' = ctxt { cec_tidy = env1
 387                                , cec_extra = extra $$ cec_extra ctxt }
 388            ; reportEqErr ctxt' ty1 ty2 }
 389     report_one pred
 390       = pprPanic "reportEqErrs" (ppr pred)
 391
 392 reportEqErr :: ReportErrCtxt -> TcType -> TcType -> TcM ()
 393 -- ty1 and ty2 are already tidied
 394 reportEqErr ctxt ty1 ty2
 395   | Just tv1 <- tcGetTyVar_maybe ty1 = reportTyVarEqErr ctxt tv1 ty2
 396   | Just tv2 <- tcGetTyVar_maybe ty2 = reportTyVarEqErr ctxt tv2 ty1
 397
 398   | otherwise   -- Neither side is a type variable
 399                 -- Since the unsolved constraint is canonical,
 400                 -- it must therefore be of form (F tys ~ ty)
 401   = addErrorReport ctxt (misMatchOrCND ctxt ty1 ty2 $$ mkTyFunInfoMsg ty1 ty2)
 402
 403
 404 reportTyVarEqErr :: ReportErrCtxt -> TcTyVar -> TcType -> TcM ()
 405 -- tv1 and ty2 are already tidied
 406 reportTyVarEqErr ctxt tv1 ty2
 407   | not is_meta1
 408   , Just tv2 <- tcGetTyVar_maybe ty2
 409   , isMetaTyVar tv2
 410   = -- sk ~ alpha: swap
 411     reportTyVarEqErr ctxt tv2 ty1
 412
 413   | not is_meta1
 414   = -- sk ~ ty, where ty isn't a meta-tyvar: mis-match
 415     addErrorReport (addExtraInfo ctxt ty1 ty2)
 416                    (misMatchOrCND ctxt ty1 ty2)
 417
 418   -- So tv is a meta tyvar, and presumably it is
 419   -- an *untouchable* meta tyvar, else it'd have been unified
 420   | not (k2 `isSubKind` k1)      -- Kind error
 421   = addErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2)
 422
 423   -- Occurs check
 424   | tv1 `elemVarSet` tyVarsOfType ty2
 425   = let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:") 2
 426                            (sep [ppr ty1, char '=', ppr ty2])
 427     in addErrorReport ctxt occCheckMsg
 428
 429   -- Check for skolem escape
 430   | (implic:_) <- cec_encl ctxt   -- Get the innermost context
 431   , let esc_skols = varSetElems (tyVarsOfType ty2 `intersectVarSet` ic_skols implic)
 432         implic_loc = ic_loc implic
 433   , not (null esc_skols)
 434   = setCtLoc implic_loc $       -- Override the error message location from the
 435                                 -- place the equality arose to the implication site
 436     do { (env1, env_sigs) <- findGlobals ctxt (unitVarSet tv1)
 437        ; let msg = misMatchMsg ty1 ty2
 438              esc_doc = sep [ ptext (sLit "because type variable") <> plural esc_skols
 439                              <+> pprQuotedList esc_skols
 440                            , ptext (sLit "would escape") <+>
 441                              if isSingleton esc_skols then ptext (sLit "its scope")
 442                                                       else ptext (sLit "their scope") ]
 443              extra1 = vcat [ nest 2 $ esc_doc
 444                            , sep [ (if isSingleton esc_skols
 445                                     then ptext (sLit "This (rigid, skolem) type variable is")
 446                                     else ptext (sLit "These (rigid, skolem) type variables are"))
 447                                    <+> ptext (sLit "bound by")
 448                                  , nest 2 $ pprSkolInfo (ctLocOrigin implic_loc) ] ]
 449        ; addErrTcM (env1, msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) }
 450
 451   -- Nastiest case: attempt to unify an untouchable variable
 452   | (implic:_) <- cec_encl ctxt   -- Get the innermost context
 453   , let implic_loc = ic_loc implic
 454         given      = ic_given implic
 455   = setCtLoc (ic_loc implic) $
 456     do { let msg = misMatchMsg ty1 ty2
 457              extra = quotes (ppr tv1)
 458                  <+> sep [ ptext (sLit "is untouchable")
 459                          , ptext (sLit "inside the constraints") <+> pprEvVarTheta given
 460                          , ptext (sLit "bound at") <+> pprSkolInfo (ctLocOrigin implic_loc)]
 461        ; addErrorReport (addExtraInfo ctxt ty1 ty2) (msg $$ nest 2 extra) }
 462
 463   | otherwise      -- This can happen, by a recursive decomposition of frozen
 464                    -- occurs check constraints
 465                    -- Example: alpha ~ T Int alpha has frozen.
 466                    --          Then alpha gets unified to T beta gamma
 467                    -- So now we have  T beta gamma ~ T Int (T beta gamma)
 468                    -- Decompose to (beta ~ Int, gamma ~ T beta gamma)
 469                    -- The (gamma ~ T beta gamma) is the occurs check, but
 470                    -- the (beta ~ Int) isn't an error at all.  So return ()
 471   = return ()
 472
 473   where
 474     is_meta1 = isMetaTyVar tv1
 475     k1       = tyVarKind tv1
 476     k2       = typeKind ty2
 477     ty1      = mkTyVarTy tv1
 478
 479 mkTyFunInfoMsg :: TcType -> TcType -> SDoc
 480 -- See Note [Non-injective type functions]
 481 mkTyFunInfoMsg ty1 ty2
 482   | Just (tc1,_) <- tcSplitTyConApp_maybe ty1
 483   , Just (tc2,_) <- tcSplitTyConApp_maybe ty2
 484   , tc1 == tc2, isSynFamilyTyCon tc1
 485   = ptext (sLit "NB:") <+> quotes (ppr tc1)
 486     <+> ptext (sLit "is a type function") <> (pp_inj tc1)
 487   | otherwise = empty
 488   where
 489     pp_inj tc | isInjectiveTyCon tc = empty
 490               | otherwise = ptext (sLit (", and may not be injective"))
 491
 492 misMatchOrCND :: ReportErrCtxt -> TcType -> TcType -> SDoc
 493 misMatchOrCND ctxt ty1 ty2
 494   = case getUserGivens ctxt of
 495       Just givens -> couldNotDeduce givens [EqPred ty1 ty2]
 496       Nothing     -> misMatchMsg ty1 ty2
 497
 498 couldNotDeduce :: [EvVar] -> [PredType] -> SDoc
 499 couldNotDeduce givens wanteds
 500   = sep [ ptext (sLit "Could not deduce") <+> pprTheta wanteds
 501         , nest 2 $ ptext (sLit "from the context")
 502                      <+> pprEvVarTheta givens]
 503
 504 addExtraInfo :: ReportErrCtxt -> TcType -> TcType -> ReportErrCtxt
 505 -- Add on extra info about the types themselves
 506 -- NB: The types themselves are already tidied
 507 addExtraInfo ctxt ty1 ty2
 508   = ctxt { cec_tidy  = env2
 509          , cec_extra = nest 2 (extra1 $$ extra2) $$ cec_extra ctxt }
 510   where
 511     (env1, extra1) = typeExtraInfoMsg (cec_tidy ctxt) ty1
 512     (env2, extra2) = typeExtraInfoMsg env1            ty2
 513
 514 misMatchMsg :: TcType -> TcType -> SDoc    -- Types are already tidy
 515 misMatchMsg ty1 ty2 = sep [ ptext (sLit "Couldn't match type") <+> quotes (ppr ty1)
 516                           , nest 15 $ ptext (sLit "with") <+> quotes (ppr ty2)]
 517
 518 kindErrorMsg :: TcType -> TcType -> SDoc   -- Types are already tidy
 519 kindErrorMsg ty1 ty2
 520   = vcat [ ptext (sLit "Kind incompatibility when matching types:")
 521          , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1
 522                         , ppr ty2 <+> dcolon <+> ppr k2 ]) ]
 523   where
 524     k1 = typeKind ty1
 525     k2 = typeKind ty2
 526
 527 typeExtraInfoMsg :: TidyEnv -> Type -> (TidyEnv, SDoc)
 528 -- Shows a bit of extra info about skolem constants
 529 typeExtraInfoMsg env ty
 530   | Just tv <- tcGetTyVar_maybe ty
 531   , isTcTyVar tv
 532   , isSkolemTyVar tv || isSigTyVar tv
 533   , not (isUnkSkol tv)
 534   , let (env1, tv1) = tidySkolemTyVar env tv
 535   = (env1, pprSkolTvBinding tv1)
 536   where
 537 typeExtraInfoMsg env _ty = (env, empty)         -- Normal case
 538
 539 --------------------
 540 unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc)
 541 unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env
 542   = do  { act_ty' <- zonkTcType act_ty
 543         ; exp_ty' <- zonkTcType exp_ty
 544         ; let (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
 545               (env2, act_ty'') = tidyOpenType env1     act_ty'
 546         ; return (env2, mkExpectedActualMsg act_ty'' exp_ty'') }
 547
 548 mkExpectedActualMsg :: Type -> Type -> SDoc
 549 mkExpectedActualMsg act_ty exp_ty
 550   = vcat [ text "Expected type" <> colon <+> ppr exp_ty
 551          , text "  Actual type" <> colon <+> ppr act_ty ]
 552 \end{code}
 553
 554 Note [Non-injective type functions]
 555 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 556 It's very confusing to get a message like
 557      Couldn't match expected type `Depend s'
 558             against inferred type `Depend s1'
 559 so mkTyFunInfoMsg adds:
 560        NB: `Depend' is type function, and hence may not be injective
 561
 562 Warn of loopy local equalities that were dropped.
 563
 564
 565 %************************************************************************
 566 %*                                                                      *
 567                  Type-class errors
 568 %*                                                                      *
 569 %************************************************************************
 570
 571 \begin{code}
 572 reportDictErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
 573 reportDictErrs ctxt wanteds orig
 574   = do { inst_envs <- tcGetInstEnvs
 575        ; non_overlaps <- mapMaybeM (reportOverlap ctxt inst_envs orig) wanteds
 576        ; unless (null non_overlaps) $
 577          addErrorReport ctxt (mk_no_inst_err non_overlaps) }
 578   where
 579     mk_no_inst_err :: [PredType] -> SDoc
 580     mk_no_inst_err wanteds
 581       | Just givens <- getUserGivens ctxt
 582       = vcat [ addArising orig $ couldNotDeduce givens wanteds
 583              , show_fixes (fix1 : fixes2) ]
 584
 585       | otherwise       -- Top level
 586       = vcat [ addArising orig $
 587                ptext (sLit "No instance") <> plural wanteds
 588                     <+> ptext (sLit "for") <+> pprTheta wanteds
 589              , show_fixes fixes2 ]
 590
 591       where
 592         fix1 = sep [ ptext (sLit "add") <+> pprTheta wanteds
 593                           <+> ptext (sLit "to the context of")
 594                    , nest 2 $ pprErrCtxtLoc ctxt ]
 595
 596         fixes2 = case instance_dicts of
 597                    []  -> []
 598                    [_] -> [sep [ptext (sLit "add an instance declaration for"),
 599                                 pprTheta instance_dicts]]
 600                    _   -> [sep [ptext (sLit "add instance declarations for"),
 601                                 pprTheta instance_dicts]]
 602         instance_dicts = filterOut isTyVarClassPred wanteds
 603                 -- Insts for which it is worth suggesting an adding an
 604                 -- instance declaration.  Exclude tyvar dicts.
 605
 606         show_fixes :: [SDoc] -> SDoc
 607         show_fixes []     = empty
 608         show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"),
 609                                  nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
 610
 611 reportOverlap :: ReportErrCtxt -> (InstEnv,InstEnv) -> CtOrigin
 612               -> PredType -> TcM (Maybe PredType)
 613 -- Report an overlap error if this class constraint results
 614 -- from an overlap (returning Nothing), otherwise return (Just pred)
 615 reportOverlap ctxt inst_envs orig pred@(ClassP clas tys)
 616   = do { tys_flat <- mapM quickFlattenTy tys
 617            -- Note [Flattening in error message generation]
 618
 619        ; case lookupInstEnv inst_envs clas tys_flat of
 620                 ([], _) -> return (Just pred)               -- No match
 621                 -- The case of exactly one match and no unifiers means a
 622                 -- successful lookup.  That can't happen here, because dicts
 623                 -- only end up here if they didn't match in Inst.lookupInst
 624                 ([_],[])
 625                  | debugIsOn -> pprPanic "check_overlap" (ppr pred)
 626                 res          -> do { addErrorReport ctxt (mk_overlap_msg res)
 627                                    ; return Nothing } }
 628   where
 629     mk_overlap_msg (matches, unifiers)
 630       = ASSERT( not (null matches) )
 631         vcat [  addArising orig (ptext (sLit "Overlapping instances for")
 632                                 <+> pprPred pred)
 633              ,  sep [ptext (sLit "Matching instances") <> colon,
 634                      nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
 635              ,  if not (isSingleton matches)
 636                 then    -- Two or more matches
 637                      empty
 638                 else    -- One match, plus some unifiers
 639                 ASSERT( not (null unifiers) )
 640                 parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
 641                                  quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
 642                               ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
 643                               ptext (sLit "when compiling the other instance declarations")])]
 644       where
 645         ispecs = [ispec | (ispec, _) <- matches]
 646
 647 reportOverlap _ _ _ _ = panic "reportOverlap"    -- Not a ClassP
 648
 649 ----------------------
 650 quickFlattenTy :: TcType -> TcM TcType
 651 -- See Note [Flattening in error message generation]
 652 quickFlattenTy ty | Just ty' <- tcView ty = quickFlattenTy ty'
 653 quickFlattenTy ty@(TyVarTy {})  = return ty
 654 quickFlattenTy ty@(ForAllTy {}) = return ty     -- See
 655 quickFlattenTy ty@(PredTy {})   = return ty     -- Note [Quick-flatten polytypes]
 656   -- Don't flatten because of the danger or removing a bound variable
 657 quickFlattenTy (AppTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
 658                                     ; fy2 <- quickFlattenTy ty2
 659                                     ; return (AppTy fy1 fy2) }
 660 quickFlattenTy (FunTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
 661                                     ; fy2 <- quickFlattenTy ty2
 662                                     ; return (FunTy fy1 fy2) }
 663 quickFlattenTy (TyConApp tc tys)
 664     | not (isSynFamilyTyCon tc)
 665     = do { fys <- mapM quickFlattenTy tys
 666          ; return (TyConApp tc fys) }
 667     | otherwise
 668     = do { let (funtys,resttys) = splitAt (tyConArity tc) tys
 669                 -- Ignore the arguments of the type family funtys
 670          ; v <- newMetaTyVar TauTv (typeKind (TyConApp tc funtys))
 671          ; flat_resttys <- mapM quickFlattenTy resttys
 672          ; return (foldl AppTy (mkTyVarTy v) flat_resttys) }
 673 \end{code}
 674
 675 Note [Flattening in error message generation]
 676 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 677 Consider (C (Maybe (F x))), where F is a type function, and we have
 678 instances
 679                 C (Maybe Int) and C (Maybe a)
 680 Since (F x) might turn into Int, this is an overlap situation, and
 681 indeed (because of flattening) the main solver will have refrained
 682 from solving.  But by the time we get to error message generation, we've
 683 un-flattened the constraint.  So we must *re*-flatten it before looking
 684 up in the instance environment, lest we only report one matching
 685 instance when in fact there are two.
 686
 687 Re-flattening is pretty easy, because we don't need to keep track of
 688 evidence.  We don't re-use the code in TcCanonical because that's in
 689 the TcS monad, and we are in TcM here.
 690
 691 Note [Quick-flatten polytypes]
 692 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 693 If we see C (Ix a => blah) or C (forall a. blah) we simply refrain from
 694 flattening any further.  After all, there can be no instance declarations
 695 that match such things.  And flattening under a for-all is problematic
 696 anyway; consider C (forall a. F a)
 697
 698 \begin{code}
 699 reportAmbigErrs :: ReportErrCtxt -> TcTyVarSet -> [WantedEvVar] -> TcM ()
 700 reportAmbigErrs ctxt skols ambigs
 701 -- Divide into groups that share a common set of ambiguous tyvars
 702   = mapM_ report (equivClasses cmp ambigs_w_tvs)
 703   where
 704     ambigs_w_tvs = [ (d, varSetElems (tyVarsOfWantedEvVar d `minusVarSet` skols))
 705                    | d <- ambigs ]
 706     cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2
 707
 708     report :: [(WantedEvVar, [TcTyVar])] -> TcM ()
 709     report pairs
 710        = setCtLoc loc $
 711          do { let main_msg = sep [ text "Ambiguous type variable" <> plural tvs
 712                                    <+> pprQuotedList tvs
 713                                    <+> text "in the constraint" <> plural pairs <> colon
 714                                  , nest 2 pp_wanteds ]
 715              ; (tidy_env, mono_msg) <- mkMonomorphismMsg ctxt tvs
 716             ; addErrTcM (tidy_env, main_msg $$ mono_msg) }
 717        where
 718          (_, tvs) : _ = pairs
 719          (loc, pp_wanteds) = pprWithArising (map fst pairs)
 720
 721 mkMonomorphismMsg :: ReportErrCtxt -> [TcTyVar] -> TcM (TidyEnv, SDoc)
 722 -- There's an error with these Insts; if they have free type variables
 723 -- it's probably caused by the monomorphism restriction.
 724 -- Try to identify the offending variable
 725 -- ASSUMPTION: the Insts are fully zonked
 726 mkMonomorphismMsg ctxt inst_tvs
 727   = do  { dflags <- getDOpts
 728         ; traceTc "Mono" (vcat (map pprSkolTvBinding inst_tvs))
 729         ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
 730         ; return (tidy_env, mk_msg dflags docs) }
 731   where
 732     mk_msg _ _ | any isRuntimeUnkSkol inst_tvs  -- See Note [Runtime skolems]
 733         =  vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+>
 734                    (pprWithCommas ppr inst_tvs),
 735                 ptext (sLit "Use :print or :force to determine these types")]
 736     mk_msg _ []   = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)")
 737                         -- This happens in things like
 738                         --      f x = show (read "foo")
 739                         -- where monomorphism doesn't play any role
 740     mk_msg dflags docs
 741         = vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"),
 742                 nest 2 (vcat docs),
 743                 monomorphism_fix dflags]
 744
 745 monomorphism_fix :: DynFlags -> SDoc
 746 monomorphism_fix dflags
 747   = ptext (sLit "Probable fix:") <+> vcat
 748         [ptext (sLit "give these definition(s) an explicit type signature"),
 749          if xopt Opt_MonomorphismRestriction dflags
 750            then ptext (sLit "or use -XNoMonomorphismRestriction")
 751            else empty]  -- Only suggest adding "-XNoMonomorphismRestriction"
 752                         -- if it is not already set!
 753
 754
 755 -----------------------
 756 -- findGlobals looks at the value environment and finds values whose
 757 -- types mention any of the offending type variables.  It has to be
 758 -- careful to zonk the Id's type first, so it has to be in the monad.
 759 -- We must be careful to pass it a zonked type variable, too.
 760
 761 mkEnvSigMsg :: SDoc -> [SDoc] -> SDoc
 762 mkEnvSigMsg what env_sigs
 763  | null env_sigs = empty
 764  | otherwise = vcat [ ptext (sLit "The following variables have types that mention") <+> what
 765                     , nest 2 (vcat env_sigs) ]
 766
 767 findGlobals :: ReportErrCtxt
 768             -> TcTyVarSet
 769             -> TcM (TidyEnv, [SDoc])
 770
 771 findGlobals ctxt tvs
 772   = do { lcl_ty_env <- case cec_encl ctxt of
 773                         []    -> getLclTypeEnv
 774                         (i:_) -> return (ic_env i)
 775        ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) }
 776   where
 777     go tidy_env acc [] = return (tidy_env, acc)
 778     go tidy_env acc (thing : things) = do
 779         (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing
 780         case maybe_doc of
 781           Just d  -> go tidy_env1 (d:acc) things
 782           Nothing -> go tidy_env1 acc     things
 783
 784     ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
 785
 786 -----------------------
 787 find_thing :: TidyEnv -> (TcType -> Bool)
 788            -> TcTyThing -> TcM (TidyEnv, Maybe SDoc)
 789 find_thing tidy_env ignore_it (ATcId { tct_id = id })
 790   = do { id_ty <- zonkTcType  (idType id)
 791        ; if ignore_it id_ty then
 792            return (tidy_env, Nothing)
 793          else do
 794        { let (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
 795              msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty
 796                        , nest 2 (parens (ptext (sLit "bound at") <+>
 797                                    ppr (getSrcLoc id)))]
 798        ; return (tidy_env', Just msg) } }
 799
 800 find_thing tidy_env ignore_it (ATyVar tv ty)
 801   = do { tv_ty <- zonkTcType ty
 802        ; if ignore_it tv_ty then
 803             return (tidy_env, Nothing)
 804          else do
 805        { let -- The name tv is scoped, so we don't need to tidy it
 806             (tidy_env1, tidy_ty) = tidyOpenType  tidy_env tv_ty
 807             msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff
 808                       , nest 2 bound_at]
 809
 810             eq_stuff | Just tv' <- tcGetTyVar_maybe tv_ty
 811                      , getOccName tv == getOccName tv' = empty
 812                      | otherwise = equals <+> ppr tidy_ty
 813                 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
 814             bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv)
 815
 816        ; return (tidy_env1, Just msg) } }
 817
 818 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
 819
 820 warnDefaulting :: [WantedEvVar] -> Type -> TcM ()
 821 warnDefaulting wanteds default_ty
 822   = do { warn_default <- doptM Opt_WarnTypeDefaults
 823        ; setCtLoc loc $ warnTc warn_default warn_msg }
 824   where
 825         -- Tidy them first
 826     warn_msg  = vcat [ ptext (sLit "Defaulting the following constraint(s) to type") <+>
 827                                 quotes (ppr default_ty),
 828                       nest 2 ppr_wanteds ]
 829     (loc, ppr_wanteds) = pprWithArising wanteds
 830 \end{code}
 831
 832 Note [Runtime skolems]
 833 ~~~~~~~~~~~~~~~~~~~~~~
 834 We want to give a reasonably helpful error message for ambiguity
 835 arising from *runtime* skolems in the debugger.  These
 836 are created by in RtClosureInspect.zonkRTTIType.
 837
 838 %************************************************************************
 839 %*                                                                      *
 840                  Error from the canonicaliser
 841          These ones are called *during* constraint simplification
 842 %*                                                                      *
 843 %************************************************************************
 844
 845 \begin{code}
 846
 847 solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a
 848 solverDepthErrorTcS depth stack
 849   | null stack      -- Shouldn't happen unless you say -fcontext-stack=0
 850   = wrapErrTcS $ failWith msg
 851   | otherwise
 852   = wrapErrTcS $
 853     setCtFlavorLoc (cc_flavor top_item) $
 854     do { env0 <- tcInitTidyEnv
 855        ; let ev_vars  = map cc_id stack
 856              env1     = tidyFreeTyVars env0 free_tvs
 857              free_tvs = foldr (unionVarSet . tyVarsOfEvVar) emptyVarSet ev_vars
 858              extra    = pprEvVars (map (tidyEvVar env1) ev_vars)
 859        ; failWithTcM (env1, hang msg 2 extra) }
 860   where
 861     top_item = head stack
 862     msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
 863                , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
 864
 865 flattenForAllErrorTcS :: CtFlavor -> TcType -> Bag CanonicalCt -> TcS a
 866 flattenForAllErrorTcS fl ty _bad_eqs
 867   = wrapErrTcS        $
 868     setCtFlavorLoc fl $
 869     do { env0 <- tcInitTidyEnv
 870        ; let (env1, ty') = tidyOpenType env0 ty
 871              msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:")
 872                        , ppr ty' ]
 873        ; failWithTcM (env1, msg) }
 874 \end{code}
 875
 876 %************************************************************************
 877 %*                                                                      *
 878                  Setting the context
 879 %*                                                                      *
 880 %************************************************************************
 881
 882 \begin{code}
 883 setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
 884 setCtFlavorLoc (Wanted  loc)   thing = setCtLoc loc thing
 885 setCtFlavorLoc (Derived loc _) thing = setCtLoc loc thing
 886 setCtFlavorLoc (Given   loc)   thing = setCtLoc loc thing
 887
 888 getWantedEqExtra :: TvSubst -> TidyEnv -> CtOrigin -> TcType -> TcType
 889                  -> TcM (TidyEnv, SDoc)
 890 getWantedEqExtra subst env0 (TypeEqOrigin item) ty1 ty2
 891   -- If the types in the error message are the same
 892   -- as the types we are unifying (remember to zonk the latter)
 893   -- don't add the extra expected/actual message
 894   --
 895   -- The complication is that the types in the TypeEqOrigin must
 896   --   (a) be zonked
 897   --   (b) have any TcS-monad pending equalities applied to them
 898   --            (hence the passed-in substitution)
 899   = do { (env1, act) <- zonkSubstTidy env0 subst (uo_actual item)
 900        ; (env2, exp) <- zonkSubstTidy env1 subst (uo_expected item)
 901        ; if (act `tcEqType` ty1 && exp `tcEqType` ty2)
 902          || (exp `tcEqType` ty1 && act `tcEqType` ty2)
 903          then
 904             return (env0, empty)
 905          else
 906             return (env2, mkExpectedActualMsg act exp) }
 907
 908 getWantedEqExtra _ env0 orig _ _
 909   = return (env0, pprArising orig)
 910
 911 zonkSubstTidy :: TidyEnv -> TvSubst -> TcType -> TcM (TidyEnv, TcType)
 912 -- In general, becore printing a type, we want to
 913 --   a) Zonk it.  Even during constraint simplification this is
 914 --      is important, to un-flatten the flatten skolems in a type
 915 --   b) Substitute any solved unification variables.  This is
 916 --      only important *during* solving, becuase after solving
 917 --      the substitution is expressed in the mutable type variables
 918 --      But during solving there may be constraint (F xi ~ ty)
 919 --      where the substitution has not been applied to the RHS
 920 zonkSubstTidy env subst ty
 921   = do { ty' <- zonkTcTypeAndSubst subst ty
 922        ; return (tidyOpenType env ty') }
 923 \end{code}