From: simonpj@microsoft.com Date: Fri, 17 Sep 2010 08:07:26 +0000 (+0000) Subject: Refactor type errors a bit X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=af2e0d24abe49e06fdee4a95530af8a5c33da4a3 Refactor type errors a bit Improves kind error messages in paticular --- diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index e0c8520..415365f 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -527,7 +527,8 @@ canEqLeafOriented :: CtFlavor -> CoVar -- First argument is not OtherCls canEqLeafOriented fl cv cls1@(FunCls fn tys) s2 | not (kindAppResult (tyConKind fn) tys `eqKind` typeKind s2 ) - = kindErrorTcS fl (unClassify cls1) s2 + = do { kindErrorTcS fl (unClassify cls1) s2 + ; return emptyCCan } | otherwise = ASSERT2( isSynFamilyTyCon fn, ppr (unClassify cls1) ) do { (xis1,ccs1) <- flattenMany fl tys -- flatten type function arguments @@ -544,7 +545,8 @@ canEqLeafOriented fl cv cls1@(FunCls fn tys) s2 canEqLeafOriented fl cv (VarCls tv) s2 | not (k1 `eqKind` k2 || (isMetaTyVar tv && k2 `isSubKind` k1)) -- Establish the kind invariant for CTyEqCan - = kindErrorTcS fl (mkTyVarTy tv) s2 + = do { kindErrorTcS fl (mkTyVarTy tv) s2 + ; return emptyCCan } | otherwise = do { (xi2,ccs2) <- flatten fl s2 -- flatten RHS diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index 533520f..b3dfb9c 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -1,7 +1,8 @@ \begin{code} module TcErrors( reportUnsolved, reportUnsolvedImplication, reportUnsolvedDeriv, - reportUnsolvedWantedEvVars, warnDefaulting, typeExtraInfoMsg, + reportUnsolvedWantedEvVars, warnDefaulting, + unifyCtxt, typeExtraInfoMsg, kindErrorTcS, misMatchErrorTcS, flattenForAllErrorTcS, occursCheckErrorTcS, solverDepthErrorTcS ) where @@ -81,13 +82,14 @@ reportUnsolvedDeriv unsolved loc | null unsolved = return () | otherwise - = do { env0 <- tcInitTidyEnv + = setCtLoc loc $ + do { env0 <- tcInitTidyEnv ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfTheta unsolved) tidy_unsolved = map (tidyPred tidy_env) unsolved err_ctxt = CEC { cec_encl = [] , cec_extra = alt_fix , cec_tidy = tidy_env } - ; reportFlat err_ctxt tidy_unsolved loc } + ; reportFlat err_ctxt tidy_unsolved (ctLocOrigin loc) } where alt_fix = vcat [ptext (sLit "Alternatively, use a standalone 'deriving instance' declaration,"), nest 2 $ ptext (sLit "so you can specify the instance context yourself")] @@ -153,11 +155,11 @@ reportTidyWanteds ctxt unsolved where pred = wantedEvVarPred d -reportFlat :: ReportErrCtxt -> [PredType] -> WantedLoc -> TcM () -reportFlat ctxt flats loc - = do { unless (null dicts) $ reportDictErrs ctxt dicts loc - ; unless (null eqs) $ reportEqErrs ctxt eqs loc - ; unless (null ips) $ reportIPErrs ctxt ips loc +reportFlat :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM () +reportFlat ctxt flats origin + = do { unless (null dicts) $ reportDictErrs ctxt dicts origin + ; unless (null eqs) $ reportEqErrs ctxt eqs + ; unless (null ips) $ reportIPErrs ctxt ips origin ; ASSERT( null others ) return () } where (dicts, non_dicts) = partition isClassPred flats @@ -168,8 +170,8 @@ reportFlat ctxt flats loc -- Support code -------------------------------------------- -groupErrs :: ([PredType] -> WantedLoc -> TcM ()) -- Deal with one group - -> [WantedEvVar] -- Unsolved wanteds +groupErrs :: ([PredType] -> CtOrigin -> TcM ()) -- Deal with one group + -> [WantedEvVar] -- Unsolved wanteds -> TcM () -- Group together insts with the same origin -- We want to report them together in error messages @@ -177,7 +179,8 @@ groupErrs :: ([PredType] -> WantedLoc -> TcM ()) -- Deal with one group groupErrs _ [] = return () groupErrs report_err (wanted : wanteds) - = do { setCtLoc the_loc $ report_err the_vars the_loc + = do { setCtLoc the_loc $ + report_err the_vars (ctLocOrigin the_loc) ; groupErrs report_err others } where the_loc = wantedEvVarLoc wanted @@ -193,8 +196,8 @@ groupErrs report_err (wanted : wanteds) -- and it avoids need equality on InstLocs. -- Add the "arising from..." part to a message about bunch of dicts -addArising :: WantedLoc -> SDoc -> SDoc -addArising loc msg = msg $$ nest 2 (pprArising loc) +addArising :: CtOrigin -> SDoc -> SDoc +addArising orig msg = msg $$ nest 2 (pprArising orig) pprWithArising :: [WantedEvVar] -> (WantedLoc, SDoc) -- Print something like @@ -204,7 +207,7 @@ pprWithArising :: [WantedEvVar] -> (WantedLoc, SDoc) pprWithArising [] = panic "pprWithArising" pprWithArising [WantedEvVar ev loc] - = (loc, pprEvVarTheta [ev] <+> pprArising loc) + = (loc, pprEvVarTheta [ev] <+> pprArising (ctLocOrigin loc)) pprWithArising ev_vars = (first_loc, vcat (map ppr_one ev_vars)) where @@ -255,9 +258,9 @@ getUserGivens (CEC {cec_encl = ctxt}) %************************************************************************ \begin{code} -reportIPErrs :: ReportErrCtxt -> [PredType] -> WantedLoc -> TcM () -reportIPErrs ctxt ips loc - = addErrorReport ctxt $ addArising loc msg +reportIPErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM () +reportIPErrs ctxt ips orig + = addErrorReport ctxt $ addArising orig msg where msg | Just givens <- getUserGivens ctxt = couldNotDeduce givens ips @@ -274,32 +277,33 @@ reportIPErrs ctxt ips loc %************************************************************************ \begin{code} -reportEqErrs :: ReportErrCtxt -> [PredType] -> WantedLoc -> TcM () -reportEqErrs ctxt eqs loc = mapM_ (reportEqErr ctxt loc) eqs +reportEqErrs :: ReportErrCtxt -> [PredType] -> TcM () +reportEqErrs ctxt eqs + = mapM_ report_one eqs + where + report_one (EqPred ty1 ty2) = reportEqErr ctxt ty1 ty2 + report_one pred = pprPanic "reportEqErrs" (ppr pred) -reportEqErr :: ReportErrCtxt -> WantedLoc -> PredType -> TcM () -reportEqErr ctxt loc pred@(EqPred ty1 ty2) - | Just tv1 <- tcGetTyVar_maybe ty1 = reportTyVarEqErr ctxt loc tv1 ty2 - | Just tv2 <- tcGetTyVar_maybe ty2 = reportTyVarEqErr ctxt loc tv2 ty1 +reportEqErr :: ReportErrCtxt -> TcType -> TcType -> TcM () +reportEqErr ctxt ty1 ty2 + | Just tv1 <- tcGetTyVar_maybe ty1 = reportTyVarEqErr ctxt tv1 ty2 + | Just tv2 <- tcGetTyVar_maybe ty2 = reportTyVarEqErr ctxt tv2 ty1 | otherwise -- Neither side is a type variable -- Since the unsolved constraint is canonical, -- it must therefore be of form (F tys ~ ty) = addErrorReport ctxt (msg $$ mkTyFunInfoMsg ty1 ty2) where msg = case getUserGivens ctxt of - Just givens -> couldNotDeduce givens [pred] + Just givens -> couldNotDeduce givens [EqPred ty1 ty2] Nothing -> misMatchMsg ty1 ty2 -reportEqErr _ _ _ = panic "reportEqErr" -- Must be equality pred - -reportTyVarEqErr :: ReportErrCtxt -> WantedLoc - -> TcTyVar -> TcType -> TcM () -reportTyVarEqErr ctxt loc tv1 ty2 +reportTyVarEqErr :: ReportErrCtxt -> TcTyVar -> TcType -> TcM () +reportTyVarEqErr ctxt tv1 ty2 | not is_meta1 , Just tv2 <- tcGetTyVar_maybe ty2 , isMetaTyVar tv2 = -- sk ~ alpha: swap - reportTyVarEqErr ctxt loc tv2 ty1 + reportTyVarEqErr ctxt tv2 ty1 | not is_meta1 = -- sk ~ ty, where ty isn't a meta-tyvar: mis-match @@ -398,6 +402,20 @@ typeExtraInfoMsg env ty = (env1, pprSkolTvBinding tv1) where typeExtraInfoMsg env _ty = (env, empty) -- Normal case + +-------------------- +unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc) +unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env + = do { act_ty' <- zonkTcType act_ty + ; exp_ty' <- zonkTcType exp_ty + ; let (env1, exp_ty'') = tidyOpenType tidy_env exp_ty' + (env2, act_ty'') = tidyOpenType env1 act_ty' + ; return (env2, mkExpectedActualMsg act_ty'' exp_ty'') } + +mkExpectedActualMsg :: Type -> Type -> SDoc +mkExpectedActualMsg act_ty exp_ty + = vcat [ text "Expected type" <> colon <+> ppr exp_ty + , text " Actual type" <> colon <+> ppr act_ty ] \end{code} Note [Non-injective type functions] @@ -418,8 +436,8 @@ Warn of loopy local equalities that were dropped. %************************************************************************ \begin{code} -reportDictErrs :: ReportErrCtxt -> [PredType] -> WantedLoc -> TcM () -reportDictErrs ctxt wanteds loc +reportDictErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM () +reportDictErrs ctxt wanteds orig = do { inst_envs <- tcGetInstEnvs ; let (others, overlaps) = partitionWith (check_overlap inst_envs) wanteds ; unless (null others) $ @@ -442,7 +460,7 @@ reportDictErrs ctxt wanteds loc mk_overlap_msg pred (matches, unifiers) = ASSERT( not (null matches) ) - vcat [ addArising loc (ptext (sLit "Overlapping instances for") + vcat [ addArising orig (ptext (sLit "Overlapping instances for") <+> pprPred pred) , sep [ptext (sLit "Matching instances") <> colon, nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])] @@ -461,11 +479,11 @@ reportDictErrs ctxt wanteds loc mk_no_inst_err :: [PredType] -> SDoc mk_no_inst_err wanteds | Just givens <- getUserGivens ctxt - = vcat [ addArising loc $ couldNotDeduce givens wanteds + = vcat [ addArising orig $ couldNotDeduce givens wanteds , show_fixes (fix1 : fixes2) ] | otherwise -- Top level - = vcat [ addArising loc $ + = vcat [ addArising orig $ ptext (sLit "No instance") <> plural wanteds <+> ptext (sLit "for") <+> pprTheta wanteds , show_fixes fixes2 ] @@ -626,19 +644,27 @@ warnDefaulting wanteds default_ty %************************************************************************ \begin{code} -kindErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a +kindErrorTcS :: CtFlavor -> TcType -> TcType -> TcS () +-- If there's a kind error, we don't want to blindly say "kind error" +-- We might, say, be unifying a skolem 'a' with a type 'Int', +-- in which case that's the error to report. So we set things +-- up to call reportEqErr, which does the business properly kindErrorTcS fl ty1 ty2 = wrapErrTcS $ setCtFlavorLoc fl $ do { env0 <- tcInitTidyEnv ; let (env1, ty1') = tidyOpenType env0 ty1 (env2, ty2') = tidyOpenType env1 ty2 - ; failWithTcM (env2, kindErrorMsg ty1' ty2') } + ctxt = CEC { cec_encl = [] + , cec_extra = empty + , cec_tidy = env2 } + ; reportEqErr ctxt ty1' ty2' } misMatchErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a misMatchErrorTcS fl ty1 ty2 - = wrapErrTcS $ - setCtFlavorLoc fl $ + = wrapErrTcS $ + setCtFlavorLocNoEq fl $ -- Don't add the "When matching t1 with t2" + -- part, because it duplciates what we say now do { env0 <- tcInitTidyEnv ; let (env1, ty1') = tidyOpenType env0 ty1 (env2, ty2') = tidyOpenType env1 ty2 @@ -669,11 +695,6 @@ occursCheckErrorTcS fl tv ty where msg = text $ "Occurs check: cannot construct the infinite type:" -setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a -setCtFlavorLoc (Wanted loc) thing = setCtLoc loc thing -setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing -setCtFlavorLoc (Given loc) thing = setCtLoc loc thing - solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a solverDepthErrorTcS depth stack | null stack -- Shouldn't happen unless you say -fcontext-stack=0 @@ -694,7 +715,7 @@ solverDepthErrorTcS depth stack flattenForAllErrorTcS :: CtFlavor -> TcType -> Bag CanonicalCt -> TcS a flattenForAllErrorTcS fl ty _bad_eqs - = wrapErrTcS $ + = wrapErrTcS $ setCtFlavorLoc fl $ do { env0 <- tcInitTidyEnv ; let (env1, ty') = tidyOpenType env0 ty @@ -702,3 +723,38 @@ flattenForAllErrorTcS fl ty _bad_eqs , ppr ty' ] ; failWithTcM (env1, msg) } \end{code} + +%************************************************************************ +%* * + Setting the context +%* * +%************************************************************************ + +\begin{code} +setCtFlavorLocNoEq :: CtFlavor -> TcM a -> TcM a +setCtFlavorLocNoEq (Wanted loc) thing = setCtLoc loc thing +setCtFlavorLocNoEq (Derived loc) thing = setCtLoc loc thing +setCtFlavorLocNoEq (Given loc) thing = setCtLoc loc thing + +setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a +setCtFlavorLoc (Wanted loc) thing = setWantedLoc loc thing +setCtFlavorLoc (Derived loc) thing = setWantedLoc loc thing +setCtFlavorLoc (Given loc) thing = setGivenLoc loc thing + +setWantedLoc :: WantedLoc -> TcM a -> TcM a +setWantedLoc loc thing_inside + = setCtLoc loc $ + add_origin (ctLocOrigin loc) $ + thing_inside + where + add_origin (TypeEqOrigin item) = addErrCtxtM (unifyCtxt item) + add_origin orig = addErrCtxt (ptext (sLit "At") <+> ppr orig) + +setGivenLoc :: GivenLoc -> TcM a -> TcM a +setGivenLoc loc thing_inside + = setCtLoc loc $ + add_origin (ctLocOrigin loc) $ + thing_inside + where + add_origin skol = addErrCtxt (ptext (sLit "In") <+> pprSkolInfo skol) +\end{code} diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 7357669..ca17355 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -848,13 +848,12 @@ ctLocOrigin (CtLoc o _ _) = o setCtLocOrigin :: CtLoc o -> o' -> CtLoc o' setCtLocOrigin (CtLoc _ s c) o = CtLoc o s c -pprArising :: CtLoc CtOrigin -> SDoc -pprArising loc = case ctLocOrigin loc of - TypeEqOrigin -> empty - _ -> text "arising from" <+> ppr (ctLocOrigin loc) +pprArising :: CtOrigin -> SDoc +pprArising (TypeEqOrigin {}) = empty +pprArising orig = text "arising from" <+> ppr orig pprArisingAt :: CtLoc CtOrigin -> SDoc -pprArisingAt loc = sep [pprArising loc, text "at" <+> ppr (ctLocSpan loc)] +pprArisingAt (CtLoc o s _) = sep [pprArising o, text "at" <+> ppr s] ------------------------------------------- -- CtOrigin gives the origin of *wanted* constraints @@ -864,7 +863,7 @@ data CtOrigin | SpecPragOrigin Name -- Specialisation pragma for identifier - | TypeEqOrigin + | TypeEqOrigin EqOrigin | IPOccOrigin (IPName Name) -- Occurrence of an implicit parameter @@ -919,7 +918,7 @@ pprO StandAloneDerivOrigin = ptext (sLit "a 'deriving' declaration") pprO DefaultOrigin = ptext (sLit "a 'default' declaration") pprO DoOrigin = ptext (sLit "a do statement") pprO ProcOrigin = ptext (sLit "a proc expression") -pprO TypeEqOrigin = ptext (sLit "an equality") +pprO (TypeEqOrigin eq) = ptext (sLit "an equality") <+> ppr eq pprO AnnOrigin = ptext (sLit "an annotation") instance Outputable EqOrigin where diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 535b561..d7da17f 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -787,7 +787,8 @@ defaultTyVar untch the_tv , not (the_tv `elemVarSet` untch) , not (k `eqKind` default_k) = do { (ev, better_ty) <- TcSMonad.newKindConstraint (mkTyVarTy the_tv) default_k - ; let loc = CtLoc TypeEqOrigin (getSrcSpan the_tv) [] -- Yuk + ; let loc = CtLoc DefaultOrigin (getSrcSpan the_tv) [] -- Yuk + -- 'DefaultOrigin' is strictly the declaration, but it's convenient wanted_eq = CTyEqCan { cc_id = ev , cc_flavor = Wanted loc , cc_tyvar = the_tv diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index 3360f5d..340be9a 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -14,9 +14,6 @@ module TcUnify ( -- Various unifications unifyType, unifyTypeList, unifyTheta, unifyKind, - -- Occurs check error - typeExtraInfoMsg, emitMisMatchErr, - -------------------------------- -- Holes tcInfer, @@ -31,7 +28,7 @@ module TcUnify ( import HsSyn import TypeRep -import TcErrors ( typeExtraInfoMsg ) +import TcErrors ( typeExtraInfoMsg, unifyCtxt ) import TcMType import TcEnv import TcIface @@ -526,13 +523,15 @@ uType, uType_np, uType_defer -------------- -- It is always safe to defer unification to the main constraint solver -- See Note [Deferred unification] -uType_defer origin ty1 ty2 +uType_defer (item : origin) ty1 ty2 = do { co_var <- newWantedCoVar ty1 ty2 ; traceTc "utype_defer" (vcat [ppr co_var, ppr ty1, ppr ty2, ppr origin]) - ; loc <- getCtLoc TypeEqOrigin + ; loc <- getCtLoc (TypeEqOrigin item) ; wrapEqCtxt origin $ emitConstraint (WcEvVar (WantedEvVar co_var loc)) ; return $ ACo $ mkTyVarTy co_var } +uType_defer [] _ _ + = panic "uType_defer" -------------- -- Push a new item on the origin stack (the most common case) @@ -970,33 +969,25 @@ wrapEqCtxt :: [EqOrigin] -> TcM a -> TcM a -- and, if there is more than one item, the "Expected/inferred" part -- comes from the outermost item wrapEqCtxt [] thing_inside = thing_inside -wrapEqCtxt [_] thing_inside = thing_inside wrapEqCtxt items thing_inside = addErrCtxtM (unifyCtxt (last items)) thing_inside --------------- failWithMisMatch :: [EqOrigin] -> TcM a -- Generate the message when two types fail to match, -- going to some trouble to make it helpful. --- The argument order is: actual type, expected type -failWithMisMatch [] - = panic "failWithMisMatch" -failWithMisMatch origin@(item:_) +-- We take the failing types from the top of the origin stack +-- rather than reporting the particular ones we are looking +-- at right now +failWithMisMatch (item:origin) = wrapEqCtxt origin $ - emitMisMatchErr (uo_actual item) (uo_expected item) - -mkExpectedActualMsg :: Type -> Type -> SDoc -mkExpectedActualMsg act_ty exp_ty - = nest 2 (vcat [ text "Expected type" <> colon <+> ppr exp_ty, - text " Actual type" <> colon <+> ppr act_ty ]) - -emitMisMatchErr :: TcType -> TcType -> TcM a -emitMisMatchErr ty_act ty_exp - = do { ty_act <- zonkTcType ty_act - ; ty_exp <- zonkTcType ty_exp + do { ty_act <- zonkTcType (uo_actual item) + ; ty_exp <- zonkTcType (uo_expected item) ; env0 <- tcInitTidyEnv ; let (env1, pp_exp) = tidyOpenType env0 ty_exp (env2, pp_act) = tidyOpenType env1 ty_act ; failWithTcM (misMatchMsg env2 pp_act pp_exp) } +failWithMisMatch [] + = panic "failWithMisMatch" misMatchMsg :: TidyEnv -> TcType -> TcType -> (TidyEnv, SDoc) misMatchMsg env ty_act ty_exp @@ -1006,15 +997,6 @@ misMatchMsg env ty_act ty_exp where (env1, extra1) = typeExtraInfoMsg env ty_exp (env2, extra2) = typeExtraInfoMsg env1 ty_act - --------------------- -unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc) -unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env - = do { act_ty' <- zonkTcType act_ty - ; exp_ty' <- zonkTcType exp_ty - ; let (env1, exp_ty'') = tidyOpenType tidy_env exp_ty' - (env2, act_ty'') = tidyOpenType env1 act_ty' - ; return (env2, mkExpectedActualMsg act_ty'' exp_ty'') } \end{code}