compiler/typecheck/TcErrors.lhs

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