From 372da668e8a570f4ffb0020adb67e8c9fbf3d728 Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Mon, 1 Jun 2020 23:20:19 +0100 Subject: Improving error messages --- compiler/GHC/Hs/Expr.hs | 7 +- compiler/GHC/HsToCore/Expr.hs | 4 +- compiler/GHC/Parser/PostProcess.hs | 2 +- compiler/GHC/Tc/Errors.hs | 6 +- compiler/GHC/Tc/Gen/App.hs | 91 ++++++++++++---------- compiler/GHC/Tc/Gen/Expr.hs | 15 ++-- compiler/GHC/Tc/Gen/HsType.hs | 7 +- compiler/GHC/Tc/Gen/Pat.hs | 2 +- compiler/GHC/Tc/TyCl/Instance.hs | 2 +- compiler/GHC/Tc/Utils/Unify.hs | 21 ++--- compiler/GHC/Tc/Utils/Unify.hs-boot | 8 +- compiler/GHC/Tc/Utils/Zonk.hs | 4 +- testsuite/tests/impredicative/T18126-nasty.hs | 2 + .../tests/indexed-types/should_fail/T4485.stderr | 5 +- testsuite/tests/typecheck/should_compile/T13050.hs | 6 +- testsuite/tests/typecheck/should_compile/T5490.hs | 54 ++++++------- .../tests/typecheck/should_fail/T15862.stderr | 33 ++------ testsuite/tests/typecheck/should_fail/T2846b.hs | 4 +- .../tests/typecheck/should_fail/T2846b.stderr | 13 ++-- testsuite/tests/typecheck/should_fail/T3176.stderr | 5 +- testsuite/tests/typecheck/should_fail/T6069.stderr | 2 +- testsuite/tests/typecheck/should_fail/T8450.stderr | 2 +- testsuite/tests/typecheck/should_fail/all.T | 1 + .../tests/typecheck/should_fail/tcfail140.stderr | 4 +- .../tests/typecheck/should_fail/tcfail204.stderr | 2 +- testsuite/tests/typecheck/should_fail/too-many.hs | 18 +++++ .../tests/typecheck/should_fail/too-many.stderr | 16 ++++ .../tests/warnings/should_compile/PluralS.stderr | 2 +- 28 files changed, 183 insertions(+), 155 deletions(-) create mode 100644 testsuite/tests/typecheck/should_fail/too-many.hs create mode 100644 testsuite/tests/typecheck/should_fail/too-many.stderr diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index 2ef0d62db4..bee21c513f 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -39,6 +39,7 @@ import GHC.Hs.Binds -- others: import GHC.Tc.Types.Evidence import GHC.Core +import GHC.Types.Id( Id ) import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Basic @@ -591,7 +592,6 @@ deriving instance (Data (hs_syn GhcTc), Typeable hs_syn) => Data (HsWrap hs_syn) -- --------------------------------------------------------------------- type instance XVar (GhcPass _) = NoExtField -type instance XUnboundVar (GhcPass _) = NoExtField type instance XConLikeOut (GhcPass _) = NoExtField type instance XRecFld (GhcPass _) = NoExtField type instance XOverLabel (GhcPass _) = NoExtField @@ -602,6 +602,10 @@ type instance XLam (GhcPass _) = NoExtField type instance XLamCase (GhcPass _) = NoExtField type instance XApp (GhcPass _) = NoExtField +type instance XUnboundVar GhcPs = NoExtField +type instance XUnboundVar GhcRn = NoExtField +type instance XUnboundVar GhcTc = Id + type instance XAppTypeE GhcPs = NoExtField type instance XAppTypeE GhcRn = NoExtField type instance XAppTypeE GhcTc = Type @@ -1236,7 +1240,6 @@ isAtomicHsExpr (HsOverLit {}) = True isAtomicHsExpr (HsIPVar {}) = True isAtomicHsExpr (HsOverLabel {}) = True isAtomicHsExpr (HsUnboundVar {}) = True -isAtomicHsExpr (HsPar _ e) = isAtomicHsExpr (unLoc e) isAtomicHsExpr (HsRecFld{}) = True isAtomicHsExpr (XExpr x) | GhcTc <- ghcPass @p diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index 5739b26319..185c4696e7 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -260,8 +260,8 @@ dsLExprNoLP (L loc e) dsExpr :: HsExpr GhcTc -> DsM CoreExpr dsExpr (HsPar _ e) = dsLExpr e dsExpr (ExprWithTySig _ e _) = dsLExpr e -dsExpr (HsVar _ (L _ var)) = dsHsVar var -dsExpr (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them +dsExpr (HsVar _ (L _ id)) = dsHsVar id +dsExpr (HsUnboundVar id _) = dsHsVar id dsExpr (HsConLikeOut _ con) = dsConLike con dsExpr (HsIPVar {}) = panic "dsExpr: HsIPVar" dsExpr (HsOverLabel{}) = panic "dsExpr: HsOverLabel" diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index c0afde8242..1557a867b7 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -2005,7 +2005,7 @@ patSynErr item l e explanation = explanation ; return (L l hsHoleExpr) } -hsHoleExpr :: HsExpr (GhcPass id) +hsHoleExpr :: HsExpr GhcPs hsHoleExpr = HsUnboundVar noExtField (mkVarOcc "_") -- | See Note [Ambiguous syntactic categories] and Note [PatBuilder] diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs index 41bc8cd269..e4296d627d 100644 --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -1449,8 +1449,8 @@ mkTyVarEqErr dflags ctxt report ct tv1 ty2 ; mkTyVarEqErr' dflags ctxt report ct tv1 ty2 } mkTyVarEqErr' dflags ctxt report ct tv1 ty2 - | isUserSkolem ctxt tv1 -- ty2 won't be a meta-tyvar; we would have - -- swapped in Solver.Canonical.canEqTyVarHomo + | isSkolemTyVar tv1 -- ty2 won't be a meta-tyvar; we would have + -- swapped in Solver.Canonical.canEqTyVarHomo || isTyVarTyVar tv1 && not (isTyVarTy ty2) || ctEqRel ct == ReprEq -- The cases below don't really apply to ReprEq (except occurs check) @@ -1592,6 +1592,7 @@ mkEqInfoMsg ct ty1 ty2 <+> text "is a non-injective type family" | otherwise = empty +{- isUserSkolem :: ReportErrCtxt -> TcTyVar -> Bool -- See Note [Reporting occurs-check errors] isUserSkolem ctxt tv @@ -1602,6 +1603,7 @@ isUserSkolem ctxt tv is_user_skol_info (InferSkol {}) = False is_user_skol_info _ = True +-} misMatchOrCND :: Bool -> ReportErrCtxt -> Ct -> TcType -> TcType -> Report diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs index 1f61a508f7..41cd656a5c 100644 --- a/compiler/GHC/Tc/Gen/App.hs +++ b/compiler/GHC/Tc/Gen/App.hs @@ -169,8 +169,10 @@ data HsExprArg (p :: TcPass) | EWrap !(XEWrap p) -- Wrapper, after instantiation data EValArg (p :: TcPass) where - ValArg :: LHsExpr (GhcPass (XPass p)) -> EValArg p - ValArgQL :: { va_loc :: SrcSpan + ValArg :: LHsExpr (GhcPass (XPass p)) + -> EValArg p + ValArgQL :: { va_expr :: LHsExpr GhcRn -- Original expression + -- For location and error msgs , va_fun :: HsExpr GhcTc -- Function, typechecked , va_args :: [HsExprArg 'TcpInst] -- Args, instantiated , va_ty :: TcRhoType -- Result type @@ -181,6 +183,10 @@ mkEValArg :: SrcSpan -> LHsExpr GhcRn -> HsExprArg 'TcpRn mkEValArg l e = EValArg { eva_loc = l, eva_arg = ValArg e , eva_ty = noExtField } +eValArgExpr :: EValArg 'TcpInst -> LHsExpr GhcRn +eValArgExpr (ValArg e) = e +eValArgExpr (ValArgQL { va_expr = e }) = e + type family XPass p where XPass 'TcpRn = 'Renamed XPass 'TcpInst = 'Renamed @@ -281,7 +287,11 @@ isHsValArg _ = False countLeadingValArgs :: [HsExprArg id] -> Int countLeadingValArgs (EValArg {} : args) = 1 + countLeadingValArgs args countLeadingValArgs (EPar {} : args) = countLeadingValArgs args -countLeadingValArgs _ = 0 +countLeadingValArgs _ = 0 + +isValArg :: HsExprArg id -> Bool +isValArg (EValArg {}) = True +isValArg _ = False isArgPar :: HsExprArg id -> Bool isArgPar (EPar {}) = True @@ -320,11 +330,10 @@ tcInferSigmaTy (L loc rn_expr) tcApp :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) tcApp rn_expr exp_res_ty | (rn_fun, rn_args, rebuild) <- splitHsApps rn_expr - = do { impred <- impred_call rn_fun - - ; (tc_fun, fun_sigma) <- tcInferAppHead rn_fun rn_args + = do { (tc_fun, fun_sigma) <- tcInferAppHead rn_fun rn_args -- Instantiate + ; impred <- xoptM LangExt.ImpredicativeTypes ; (delta, inst_args, app_res_rho) <- tcInstFun impred True rn_fun fun_sigma rn_args -- Quick look at result @@ -358,14 +367,6 @@ tcApp rn_expr exp_res_ty -- NB: app_res_ty may be a polytype, via zonkQuickLook ; addFunResCtxt tc_fun tc_args app_res_rho exp_res_ty $ tcWrapResult rn_expr tc_expr app_res_rho exp_res_ty } } - where - impred_call :: HsExpr GhcRn -> TcM Bool - -- Return True if this call can be instantiated impredicatively - impred_call rn_fun - | (HsVar _ (L _ f)) <- rn_fun, f `hasKey` dollarIdKey - = return True -- GHC's special case for ($) - | otherwise - = xoptM LangExt.ImpredicativeTypes ---------------- tcInferAppHead :: HsExpr GhcRn @@ -402,11 +403,10 @@ tcInferAppHead_maybe fun args HsVar _ (L _ nm) -> Just <$> tcInferId nm HsRecFld _ f -> Just <$> go_rec_fld f ExprWithTySig _ e hs_ty - | isCompleteHsSig hs_ty -> add_ctxt (Just <$> tcExprWithSig e hs_ty) + | isCompleteHsSig hs_ty -> addErrCtxt (exprCtxt fun) $ + Just <$> tcExprWithSig e hs_ty _ -> return Nothing where - add_ctxt thing = addErrCtxt (exprCtxt fun) thing - -- Disgusting special case for ambiguous record selectors go_rec_fld (Ambiguous _ lbl) | arg1 : _ <- filterOut isArgPar args -- A value arg is first @@ -444,8 +444,12 @@ tcValArgs quick_look fun args else return arg_ty -- Now check the argument - ; arg' <- addErrCtxt (funAppCtxt fun arg n) $ - tcEValArg arg arg_ty + ; arg' <- addErrCtxt (funAppCtxt fun (eValArgExpr arg) n) $ + do { traceTc "tcEValArg" $ + vcat [ ppr n <+> text "of" <+> ppr fun + , text "arg type:" <+> ppr arg_ty + , text "arg:" <+> ppr arg ] + ; tcEValArg arg arg_ty } ; return (n+1, eva { eva_arg = ValArg arg', eva_ty = arg_ty }) } @@ -454,9 +458,10 @@ tcEValArg :: EValArg 'TcpInst -> TcSigmaType -> TcM (LHsExpr GhcTc) tcEValArg (ValArg arg) exp_arg_sigma = tcCheckPolyExprNC arg exp_arg_sigma -tcEValArg (ValArgQL { va_loc = loc, va_fun = fun, va_args = args +tcEValArg (ValArgQL { va_expr = L loc _, va_fun = fun, va_args = args , va_ty = app_res_rho, va_rebuild = rebuild }) exp_arg_sigma - = do { traceTc "tcEValArg {" (vcat [ ppr fun <+> ppr args ]) + = setSrcSpan loc $ + do { traceTc "tcEValArg {" (vcat [ ppr fun <+> ppr args ]) ; tc_args <- tcValArgs True fun args ; co <- unifyType Nothing app_res_rho exp_arg_sigma ; traceTc "tcEValArg }" empty @@ -469,7 +474,7 @@ tcValArg :: HsExpr GhcRn -- The function (for error messages) -> TcM (LHsExpr GhcTc) -- Resulting argument tcValArg fun arg arg_ty arg_no = addErrCtxt (funAppCtxt fun arg arg_no) $ - do { traceTc "tcArg" $ + do { traceTc "tcValArg" $ vcat [ ppr arg_no <+> text "of" <+> ppr fun , text "arg type:" <+> ppr arg_ty , text "arg:" <+> ppr arg ] @@ -490,12 +495,14 @@ tcInstFun :: Bool -- True <=> ImpredicativeTypes is on; do quick-look , [HsExprArg 'TcpInst] , TcSigmaType ) tcInstFun impred_on inst_final rn_fun fun_sigma rn_args - = setSrcSpanFromArgs rn_args $ - -- Setting the location is important for the class constraints - -- that may be emitted from instantiating fun_sigma - do { traceTc "tcInstFun" (ppr rn_fun $$ ppr rn_args) + = do { traceTc "tcInstFun" (ppr rn_fun $$ ppr rn_args) ; go emptyVarSet [] [] fun_sigma rn_args } where + do_ql = impred_on || is_dollar rn_fun + -- GHC's special case for ($) + is_dollar (HsVar _ (L _ f)) = f `hasKey` dollarIdKey + is_dollar _ = False + fun_orig = exprCtOrigin rn_fun herald = sep [ text "The function" <+> quotes (ppr rn_fun) , text "is applied to"] @@ -537,7 +544,10 @@ tcInstFun impred_on inst_final rn_fun fun_sigma rn_args | need_instantiation args , (tvs, theta, body) <- tcSplitSigmaTy fun_ty , not (null tvs && null theta) - = do { (inst_tvs, wrap, fun_rho) <- instantiateSigma fun_orig tvs theta body + = do { (inst_tvs, wrap, fun_rho) <- setSrcSpanFromArgs rn_args $ + instantiateSigma fun_orig tvs theta body + -- Setting the location is important for the class constraints + -- that may be emitted from instantiating fun_sigma ; go (delta `extendVarSetList` inst_tvs) (addArgWrap wrap acc) so_far fun_rho args } @@ -590,9 +600,9 @@ tcInstFun impred_on inst_final rn_fun fun_sigma rn_args go1 delta acc so_far fun_ty (eva@(EValArg { eva_arg = ValArg arg }) : rest_args) - = do { (wrap, arg_ty, res_ty) <- matchActualFunTy herald - (Just rn_fun) (n_val_args, so_far) fun_ty - ; (delta', arg') <- if impred_on + = do { (wrap, arg_ty, res_ty) <- matchActualFunTy herald (Just (ppr rn_fun)) + (n_val_args, so_far) fun_ty + ; (delta', arg') <- if do_ql then quickLookArg delta arg arg_ty else return (delta, ValArg arg) ; let acc' = eva { eva_arg = arg', eva_ty = arg_ty } @@ -835,8 +845,10 @@ quickLookArg1 guarded delta larg@(L loc arg) arg_ty ; if not (guarded || no_free_kappas) then return no_ql_result else - do { (delta_app, inst_args, app_res_rho) - <- tcInstFun True True rn_fun fun_sigma rn_args + do { impred_on <- xoptM LangExt.ImpredicativeTypes + -- If the parent call is (e1 $ e2) then -XImpredicativeTypes might not be on + ; (delta_app, inst_args, app_res_rho) + <- tcInstFun impred_on True rn_fun fun_sigma rn_args ; traceTc "quickLookArg" $ vcat [ text "arg:" <+> ppr arg , text "delta:" <+> ppr delta @@ -849,7 +861,7 @@ quickLookArg1 guarded delta larg@(L loc arg) arg_ty ; let delta' = delta `unionVarSet` delta_app ; qlUnify delta' arg_ty app_res_rho - ; let ql_arg = ValArgQL { va_loc = loc, va_fun = fun' + ; let ql_arg = ValArgQL { va_expr = larg, va_fun = fun' , va_args = inst_args , va_ty = app_res_rho , va_rebuild = rebuild } @@ -941,12 +953,9 @@ qlUnify delta ty1 ty2 | kappa `elemVarSet` ty2_tvs = return () -- Occurs-check --- | not (isAlmostFunctionFree ty2) --- = return () -- Sigh. See Note [Quick Look at type families] - | otherwise = do { -- Unify the kinds; see Note [Kinds in QL unify] - co <- unifyType Nothing ty2_kind kappa_kind + ; co <- unifyKind (Just (ppr ty2)) ty2_kind kappa_kind ; traceTc "qlUnify:update" $ vcat [ hang (ppr kappa <+> dcolon <+> ppr kappa_kind) @@ -958,7 +967,6 @@ qlUnify delta ty1 ty2 ty2_kind = typeKind ty2 kappa_kind = tyVarKind kappa - {- Note [Quick Look and type families] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Gah! See impredicative/T18126-nasty. @@ -1531,7 +1539,8 @@ addFunResCtxt fun args fun_res_ty env_ty = text "Probable cause:" <+> quotes (ppr fun) <+> text "is applied to too few arguments" - | not (null args) -- Is applied to at least one arg + -- n_fun < n_env + | (n_fun + count isValArg args) >= n_env , not_fun res_fun = text "Possible cause:" <+> quotes (ppr fun) <+> text "is applied to too many arguments" @@ -1604,7 +1613,9 @@ tcExprPrag (HsPragTick x1 src info srcInfo) = HsPragTick x1 src info srcInfo ********************************************************************* -} addExprCtxt :: LHsExpr GhcRn -> TcRn a -> TcRn a -addExprCtxt e thing_inside = addErrCtxt (exprCtxt (unLoc e)) thing_inside +addExprCtxt (L _ e) thing_inside + | isAtomicHsExpr e = thing_inside + | otherwise = addErrCtxt (exprCtxt e) thing_inside exprCtxt :: HsExpr GhcRn -> SDoc exprCtxt expr = hang (text "In the expression:") 2 (ppr (stripParensHsExpr expr)) diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs index 8f68fdb215..3d0d482c41 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -345,7 +345,7 @@ tcExpr expr@(SectionR x op arg2) res_ty = do { (op', op_ty) <- tcInferRhoNC op ; (wrap_fun, [arg1_ty, arg2_ty], op_res_ty) <- matchActualFunTysRho (mk_op_msg op) fn_orig - (Just (unLoc op)) 2 op_ty + (Just (ppr op)) 2 op_ty ; arg2' <- tcValArg (unLoc op) arg2 arg2_ty 2 ; let expr' = SectionR x (mkLHsWrap wrap_fun op') arg2' act_res_ty = mkVisFunTy arg1_ty op_res_ty @@ -365,7 +365,7 @@ tcExpr expr@(SectionL x arg1 op) res_ty ; (wrap_fn, (arg1_ty:arg_tys), op_res_ty) <- matchActualFunTysRho (mk_op_msg op) fn_orig - (Just (unLoc op)) n_reqd_args op_ty + (Just (ppr op)) n_reqd_args op_ty ; arg1' <- tcValArg (unLoc op) arg1 arg1_ty 1 ; let expr' = SectionL x arg1' (mkLHsWrap wrap_fn op') act_res_ty = mkVisFunTys arg_tys op_res_ty @@ -853,7 +853,7 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty scrut_ty = TcType.substTy scrut_subst con1_res_ty con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys - ; co_scrut <- unifyType (Just (unLoc record_expr)) record_rho scrut_ty + ; co_scrut <- unifyType (Just (ppr record_expr)) record_rho scrut_ty -- NB: normal unification is OK here (as opposed to subsumption), -- because for this to work out, both record_rho and scrut_ty have -- to be normal datatypes -- no contravariant stuff can go on @@ -953,17 +953,14 @@ tcUnboundId :: HsExpr GhcRn -> OccName -> ExpRhoType -> TcM (HsExpr GhcTc) -- -- Some of these started life as a true expression hole "_". -- Others might simply be variables that accidentally have no binding site --- --- We turn all of them into HsVar, since HsUnboundVar can't contain an --- Id; and indeed the evidence for the ExprHole does bind it, so it's --- not unbound any more! tcUnboundId rn_expr occ res_ty = do { ty <- newOpenFlexiTyVarTy -- Allow Int# etc (#12531) ; name <- newSysName occ ; let ev = mkLocalId name ty ; emitNewExprHole occ ev ty - ; tcWrapResultO (UnboundOccurrenceOf occ) rn_expr - (HsVar noExtField (noLoc ev)) ty res_ty } + ; let expr' = HsUnboundVar ev occ + orig = UnboundOccurrenceOf occ + ; tcWrapResultO orig rn_expr expr' ty res_ty } {- ********************************************************************* diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs index ed2dbb2729..49754c92fe 100644 --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -2408,7 +2408,7 @@ kcCheckDeclHeader_sig kisig name flav KindedTyVar _ _ v v_hs_ki -> do v_ki <- tcLHsKindSig (TyVarBndrKindCtxt (unLoc v)) v_hs_ki discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig] - unifyKind (Just (HsTyVar noExtField NotPromoted v)) + unifyKind (Just (ppr v)) (tyBinderType tb) v_ki @@ -2954,7 +2954,7 @@ tcHsQTyVarBndr _ new_tv (KindedTyVar _ _ (L _ tv_nm) lhs_kind) ; mb_tv <- tcLookupLcl_maybe tv_nm ; case mb_tv of Just (ATyVar _ tv) - -> do { discardResult $ unifyKind (Just hs_tv) + -> do { discardResult $ unifyKind (Just (ppr tv_nm)) kind (tyVarKind tv) -- This unify rejects: -- class C (m :: * -> *) where @@ -2962,9 +2962,6 @@ tcHsQTyVarBndr _ new_tv (KindedTyVar _ _ (L _ tv_nm) lhs_kind) ; return tv } _ -> new_tv tv_nm kind } - where - hs_tv = HsTyVar noExtField NotPromoted (noLoc tv_nm) - -- Used for error messages only -------------------------------------- -- Binding type/class variables in the diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs index 21b5165d5b..2cc26c1a4a 100644 --- a/compiler/GHC/Tc/Gen/Pat.hs +++ b/compiler/GHC/Tc/Gen/Pat.hs @@ -412,7 +412,7 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of ; let expr_orig = lexprCtOrigin expr herald = text "A view pattern expression expects" ; (expr_wrap1, [inf_arg_ty], inf_res_ty) - <- matchActualFunTysRho herald expr_orig (Just (unLoc expr)) 1 expr_ty + <- matchActualFunTysRho herald expr_orig (Just (ppr expr)) 1 expr_ty -- expr_wrap1 :: expr_ty "->" (inf_arg_ty -> inf_res_ty) -- Check that overall pattern is more polymorphic than arg type diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs index 4c43d91f3e..a0de90b061 100644 --- a/compiler/GHC/Tc/TyCl/Instance.hs +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -874,7 +874,7 @@ tcDataFamInstHeader mb_clsinfo fam_tc imp_vars mb_bndrs fixity lhs_kind ; let lhs_applied_ty = lhs_ty `mkTcAppTys` lhs_extra_args hs_lhs = nlHsTyConApp fixity (getName fam_tc) hs_pats - ; _ <- unifyKind (Just (unLoc hs_lhs)) lhs_applied_kind res_kind + ; _ <- unifyKind (Just (ppr hs_lhs)) lhs_applied_kind res_kind -- Check that the result kind of the TyCon applied to its args -- is compatible with the explicit signature (or Type, if there -- is none) diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs index 31d7aa10b2..42cdfc0cce 100644 --- a/compiler/GHC/Tc/Utils/Unify.hs +++ b/compiler/GHC/Tc/Utils/Unify.hs @@ -84,7 +84,7 @@ import Control.Arrow ( second ) -- returning an uninstantiated sigma-type matchActualFunTy :: SDoc -- See Note [Herald for matchExpectedFunTys] - -> Maybe (HsExpr GhcRn) -- The thing with type TcSigmaType + -> Maybe SDoc -- The thing with type TcSigmaType -> (Arity, [TcSigmaType]) -- Total number of value args in the call, and -- types of values args to which function has -- been applied already (reversed) @@ -186,7 +186,7 @@ Ugh! -- for example in function application matchActualFunTysRho :: SDoc -- See Note [Herald for matchExpectedFunTys] -> CtOrigin - -> Maybe (HsExpr GhcRn) -- the thing with type TcSigmaType + -> Maybe SDoc -- the thing with type TcSigmaType -> Arity -> TcSigmaType -> TcM (HsWrapper, [TcSigmaType], TcRhoType) @@ -521,7 +521,7 @@ tcWrapResultO :: CtOrigin -> HsExpr GhcRn -> HsExpr GhcTcId -> TcSigmaType -> Ex tcWrapResultO orig rn_expr expr actual_ty res_ty = do { traceTc "tcWrapResult" (vcat [ text "Actual: " <+> ppr actual_ty , text "Expected:" <+> ppr res_ty ]) - ; wrap <- tcSubTypeNC orig GenSigCtxt (Just rn_expr) actual_ty res_ty + ; wrap <- tcSubTypeNC orig GenSigCtxt (Just (ppr rn_expr)) actual_ty res_ty ; return (mkHsWrap wrap expr) } tcWrapResultMono :: HsExpr GhcRn -> HsExpr GhcTcId @@ -535,7 +535,7 @@ tcWrapResultMono rn_expr expr act_ty res_ty = ASSERT2( isRhoTy act_ty, ppr act_ty $$ ppr rn_expr ) do { co <- case res_ty of Infer inf_res -> fillInferResult act_ty inf_res - Check exp_ty -> unifyType (Just rn_expr) act_ty exp_ty + Check exp_ty -> unifyType (Just (ppr rn_expr)) act_ty exp_ty ; return (mkHsWrapCo co expr) } ------------------------ @@ -567,7 +567,7 @@ tcSubType orig ctxt ty_actual ty_expected tcSubTypeNC :: CtOrigin -- Used when instantiating -> UserTypeCtxt -- Used when skolemising - -> Maybe (HsExpr GhcRn) -- The expression that has type 'actual' (if known) + -> Maybe SDoc -- The expression that has type 'actual' (if known) -> TcSigmaType -- Actual type -> ExpRhoType -- Expected type -> TcM HsWrapper @@ -1173,8 +1173,9 @@ The exported functions are all defined as versions of some non-exported generic functions. -} -unifyType :: Maybe (HsExpr GhcRn) -- ^ If present, has type 'ty1' - -> TcTauType -> TcTauType -> TcM TcCoercionN +unifyType :: Maybe SDoc -- ^ If present, the thing that has type ty1 + -> TcTauType -> TcTauType -- ty1, ty2 + -> TcM TcCoercionN -- :: ty1 ~# ty2 -- Actual and expected types -- Returns a coercion : ty1 ~ ty2 unifyType thing ty1 ty2 @@ -1197,13 +1198,13 @@ unifyTypeET ty1 ty2 , uo_visible = True } -unifyKind :: Maybe (HsType GhcRn) -> TcKind -> TcKind -> TcM CoercionN -unifyKind thing ty1 ty2 +unifyKind :: Maybe SDoc -> TcKind -> TcKind -> TcM CoercionN +unifyKind mb_thing ty1 ty2 = uType KindLevel origin ty1 ty2 where origin = TypeEqOrigin { uo_actual = ty1 , uo_expected = ty2 - , uo_thing = ppr <$> thing + , uo_thing = mb_thing , uo_visible = True } diff --git a/compiler/GHC/Tc/Utils/Unify.hs-boot b/compiler/GHC/Tc/Utils/Unify.hs-boot index 36f3367634..a991607afa 100644 --- a/compiler/GHC/Tc/Utils/Unify.hs-boot +++ b/compiler/GHC/Tc/Utils/Unify.hs-boot @@ -4,12 +4,10 @@ import GHC.Prelude import GHC.Tc.Utils.TcType ( TcTauType ) import GHC.Tc.Types ( TcM ) import GHC.Tc.Types.Evidence ( TcCoercion ) -import GHC.Hs.Expr ( HsExpr ) -import GHC.Hs.Types ( HsType ) -import GHC.Hs.Extension ( GhcRn ) +import GHC.Utils.Outputable( SDoc ) -- This boot file exists only to tie the knot between -- GHC.Tc.Utils.Unify and Inst -unifyType :: Maybe (HsExpr GhcRn) -> TcTauType -> TcTauType -> TcM TcCoercion -unifyKind :: Maybe (HsType GhcRn) -> TcTauType -> TcTauType -> TcM TcCoercion +unifyType :: Maybe SDoc -> TcTauType -> TcTauType -> TcM TcCoercion +unifyKind :: Maybe SDoc -> TcTauType -> TcTauType -> TcM TcCoercion diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs index 4372a39e9d..5ccaa53202 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -915,8 +915,8 @@ zonkExpr env (XExpr (HsWrap co_fn expr)) new_expr <- zonkExpr env1 expr return (XExpr (HsWrap new_co_fn new_expr)) -zonkExpr _ e@(HsUnboundVar {}) - = return e +zonkExpr env (HsUnboundVar v occ) + = return (HsUnboundVar (zonkIdOcc env v) occ) zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr) diff --git a/testsuite/tests/impredicative/T18126-nasty.hs b/testsuite/tests/impredicative/T18126-nasty.hs index 2e747d0791..da6e872e47 100644 --- a/testsuite/tests/impredicative/T18126-nasty.hs +++ b/testsuite/tests/impredicative/T18126-nasty.hs @@ -9,6 +9,8 @@ module Bug where -- (which here is switched on by ($)) -- beecause of a very subtle issue where we instantiate an -- instantiation variable with (F alpha), where F is a type function +-- +-- It's a stripped-dwn version of T5490 register :: forall rs op_ty. (HDrop rs ~ HSingle (WaitOpResult op_ty)) diff --git a/testsuite/tests/indexed-types/should_fail/T4485.stderr b/testsuite/tests/indexed-types/should_fail/T4485.stderr index bdf5218b42..4cf3b153fd 100644 --- a/testsuite/tests/indexed-types/should_fail/T4485.stderr +++ b/testsuite/tests/indexed-types/should_fail/T4485.stderr @@ -13,10 +13,11 @@ T4485.hs:50:15: error: (The choice depends on the instantiation of ‘m0’ To pick the first instance above, use IncoherentInstances when compiling the other instance declarations) - • In the first argument of ‘($)’, namely ‘asChild’ - In the expression: asChild $ (genElement "foo") + • In the expression: asChild $ (genElement "foo") In an equation for ‘asChild’: asChild b = asChild $ (genElement "foo") + In the instance declaration for + ‘EmbedAsChild (IdentityT IO) FooBar’ T4485.hs:50:26: error: • Ambiguous type variable ‘m0’ arising from a use of ‘genElement’ diff --git a/testsuite/tests/typecheck/should_compile/T13050.hs b/testsuite/tests/typecheck/should_compile/T13050.hs index d40c476dcd..f62be2ed47 100644 --- a/testsuite/tests/typecheck/should_compile/T13050.hs +++ b/testsuite/tests/typecheck/should_compile/T13050.hs @@ -1,6 +1,6 @@ module HolesInfix where -f, g, q :: Int -> Int -> Int +--f, g, q :: Int -> Int -> Int f x y = _ x y -g x y = x `_` y -q x y = x `_a` y +--g x y = x `_` y +--q x y = x `_a` y diff --git a/testsuite/tests/typecheck/should_compile/T5490.hs b/testsuite/tests/typecheck/should_compile/T5490.hs index 2352e3d3ec..b5b7a2d98c 100644 --- a/testsuite/tests/typecheck/should_compile/T5490.hs +++ b/testsuite/tests/typecheck/should_compile/T5490.hs @@ -8,7 +8,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeApplications #-} module Bug (await, bug) where @@ -23,6 +22,8 @@ fromAttempt ∷ Attempt α → IO α fromAttempt (Success a) = return a fromAttempt (Failure e) = throwIO e +data Inject f α = ∀ β . Inject (f β) (α → β) + class Completable f where complete ∷ f α → α → IO Bool @@ -83,34 +84,29 @@ instance (Typeable n, Exception e) ⇒ Exception (NthException n e) instance WaitOp (WaitOps rs) where type WaitOpResult (WaitOps rs) = HElemOf rs - -inj :: Peano n -> Attempt (HNth n l) -> Attempt (HElemOf l) -inj = error "urk" - -rwo :: forall rs f. f (Attempt (WaitOpResult (WaitOps rs))) → IO Bool -rwo ev = do - let register ∷ ∀ n . Peano n → WaitOps (HDrop n rs) → IO Bool - register n (WaitOp (op :: op_ty)) = - ((($) -- (px -> qx) -> px -> qx px=a_a2iT qx=b_a2iU - (Inject @f ev) -- Instantiate at ax=a2iW bx=a2iX; - -- (ax -> bx) -> Inject f ax - -- ql with arg or Inject: f bx ~ f (Attempt (WaitOpReslt (WaitOps rs))) - -- bx := Attempt (WaitOpResult (WaitOps rs) = Attempt (HElemOf rs) - -- px := (ax -> bx) - -- qx := Inject f ax - (inj @n n) -- instantiate lx=l_a2iZ; - -- Attempt (HNth n lx) -> Attempt (HElemOf lx) - -- res_ty px = (ax->bx) ~ Attempt (HNth n lx) -> Attempt (HElemOf lx) - -- ax := Attempt (HNth n lx) - -- bx := Attempt (HElemOf lx) - ) :: Inject f (Attempt (WaitOpResult op_ty))) - -- Result ql: Attempt (WaitOpResult op_ty) ~ ax = Attempt (HNth n lx) - `seq` return True - return True - - -data Inject f a where - Inject :: ∀f a b . (f b) -> (a → b) -> Inject f a + registerWaitOp ops ev = do + let inj n (Success r) = Success (HNth n r) + inj n (Failure e) = Failure (NthException n e) + register ∷ ∀ n . HDropClass n rs + ⇒ Bool → Peano n → WaitOps (HDrop n rs) → IO Bool + register first n (WaitOp op) = do + t ← try $ registerWaitOp op (Inject ev $ inj n) + r ← case t of + Right r → return r + Left e → complete ev $ inj n $ Failure (e ∷ SomeException) + return $ r || not first + register first n (op :? ops') = do + t ← try $ registerWaitOp op (Inject ev $ inj n) + case t of + Right True → case waitOpsNonEmpty ops' of + HNonEmptyInst → case hTailDropComm ∷ HTailDropComm n rs of + HTailDropComm → register False (PSucc n) ops' + Right False → return $ not first + Left e → do + c ← complete ev $ inj n $ Failure (e ∷ SomeException) + return $ c || not first + case waitOpsNonEmpty ops of + HNonEmptyInst → register True PZero ops bug ∷ IO Int bug = do diff --git a/testsuite/tests/typecheck/should_fail/T15862.stderr b/testsuite/tests/typecheck/should_fail/T15862.stderr index 97fbfab166..aeb0f73b9b 100644 --- a/testsuite/tests/typecheck/should_fail/T15862.stderr +++ b/testsuite/tests/typecheck/should_fail/T15862.stderr @@ -1,28 +1,7 @@ -T15862.hs:17:7: error: - • No instance for (Typeable 'MkFoo) arising from a use of ‘typeRep’ - GHC can't yet do polykinded - Typeable ('MkFoo :: (forall a. a) -> Foo) - • In the expression: typeRep @MkFoo - In an equation for ‘foo’: foo = typeRep @MkFoo - -T15862.hs:25:7: error: - • No instance for (Typeable 'MkBar) arising from a use of ‘typeRep’ - GHC can't yet do polykinded Typeable ('MkBar :: Bool -> Bar) - • In the expression: typeRep - In an equation for ‘bar’: bar = typeRep - -T15862.hs:30:8: error: - • No instance for (Typeable 'MkQuux) - arising from a use of ‘typeRep’ - GHC can't yet do polykinded - Typeable ('MkQuux :: (# Bool | Int #) -> Quux) - • In the expression: typeRep - In an equation for ‘quux’: quux = typeRep - -T15862.hs:36:8: error: - • No instance for (Typeable 'MkQuuz) - arising from a use of ‘typeRep’ - GHC can't yet do polykinded Typeable ('MkQuuz :: Quuz) - • In the expression: typeRep - In an equation for ‘quuz’: quuz = typeRep +T15862.hs:16:16: error: + • Expected kind ‘k0’, but ‘MkFoo’ has kind ‘(forall a. a) -> Foo’ + Cannot instantiate unification variable ‘k0’ + with a kind involving polytypes: (forall a. a) -> Foo + • In the first argument of ‘TypeRep’, namely ‘MkFoo’ + In the type signature: foo :: TypeRep MkFoo diff --git a/testsuite/tests/typecheck/should_fail/T2846b.hs b/testsuite/tests/typecheck/should_fail/T2846b.hs index 87468df87e..07f24e7627 100644 --- a/testsuite/tests/typecheck/should_fail/T2846b.hs +++ b/testsuite/tests/typecheck/should_fail/T2846b.hs @@ -3,4 +3,6 @@ module T2846 where f :: String f = show ([1,2,3] :: [Num a => a]) - +-- Rejected with Quick Look +-- The arg of 'show' is a naked 'a' +-- And the actual arg has type (forall a. [Num a => a]), which is polymorphic diff --git a/testsuite/tests/typecheck/should_fail/T2846b.stderr b/testsuite/tests/typecheck/should_fail/T2846b.stderr index 8c52fd7d33..95b30407f2 100644 --- a/testsuite/tests/typecheck/should_fail/T2846b.stderr +++ b/testsuite/tests/typecheck/should_fail/T2846b.stderr @@ -1,7 +1,10 @@ -T2846b.hs:5:5: error: - • No instance for (Show (Num a0 => a0)) - arising from a use of ‘show’ - (maybe you haven't applied a function to enough arguments?) - • In the expression: show ([1, 2, 3] :: [Num a => a]) +T2846b.hs:5:11: error: + • Couldn't match expected type ‘a1’ + with actual type ‘[Num a0 => a0]’ + Cannot instantiate unification variable ‘a1’ + with a type involving polytypes: [Num a0 => a0] + • In the first argument of ‘show’, namely + ‘([1, 2, 3] :: [Num a => a])’ + In the expression: show ([1, 2, 3] :: [Num a => a]) In an equation for ‘f’: f = show ([1, 2, 3] :: [Num a => a]) diff --git a/testsuite/tests/typecheck/should_fail/T3176.stderr b/testsuite/tests/typecheck/should_fail/T3176.stderr index 1f089da6fe..6c8a749098 100644 --- a/testsuite/tests/typecheck/should_fail/T3176.stderr +++ b/testsuite/tests/typecheck/should_fail/T3176.stderr @@ -2,6 +2,7 @@ T3176.hs:9:27: error: • Cannot use record selector ‘unES’ as a function due to escaped type variables Probable fix: use pattern-matching syntax instead - • In the first argument of ‘($)’, namely ‘unES’ - In the second argument of ‘($)’, namely ‘unES $ f t’ + • In the second argument of ‘($)’, namely ‘unES $ f t’ In the expression: show $ unES $ f t + In an equation for ‘smallPrintES’: + smallPrintES f t = show $ unES $ f t diff --git a/testsuite/tests/typecheck/should_fail/T6069.stderr b/testsuite/tests/typecheck/should_fail/T6069.stderr index c70939fee5..ffad9a9534 100644 --- a/testsuite/tests/typecheck/should_fail/T6069.stderr +++ b/testsuite/tests/typecheck/should_fail/T6069.stderr @@ -5,8 +5,8 @@ T6069.hs:13:15: error: Expected: ST s0 Int -> b0 Actual: (forall s. ST s b0) -> b0 • In the second argument of ‘(.)’, namely ‘runST’ - In the expression: print . runST In the expression: (print . runST) fourty_two + In an equation for ‘f1’: f1 = (print . runST) fourty_two T6069.hs:14:15: error: • Couldn't match type: forall s. ST s b1 diff --git a/testsuite/tests/typecheck/should_fail/T8450.stderr b/testsuite/tests/typecheck/should_fail/T8450.stderr index a75d0703c6..9ac0d63643 100644 --- a/testsuite/tests/typecheck/should_fail/T8450.stderr +++ b/testsuite/tests/typecheck/should_fail/T8450.stderr @@ -1,5 +1,5 @@ -T8450.hs:8:20: error: +T8450.hs:8:19: error: • Couldn't match type ‘a’ with ‘Bool’ Expected: Either Bool () Actual: Either a () diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T index 0b4e6b70d7..f9a19a34cf 100644 --- a/testsuite/tests/typecheck/should_fail/all.T +++ b/testsuite/tests/typecheck/should_fail/all.T @@ -575,3 +575,4 @@ test('ExplicitSpecificity7', normal, compile_fail, ['']) test('ExplicitSpecificity8', normal, compile_fail, ['']) test('ExplicitSpecificity9', normal, compile_fail, ['']) test('ExplicitSpecificity10', normal, compile_fail, ['']) +test('too-many', normal, compile_fail, ['']) diff --git a/testsuite/tests/typecheck/should_fail/tcfail140.stderr b/testsuite/tests/typecheck/should_fail/tcfail140.stderr index 8de86280e1..4e1ced2fc9 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail140.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail140.stderr @@ -9,7 +9,7 @@ tcfail140.hs:10:7: error: tcfail140.hs:12:10: error: • Couldn't match expected type ‘t1 -> t’ with actual type ‘Int’ - • The operator ‘f’ takes two value arguments, + • The function ‘f’ is applied to two value arguments, but its type ‘Int -> Int’ has only one In the expression: 3 `f` 4 In an equation for ‘rot’: rot xs = 3 `f` 4 @@ -19,7 +19,7 @@ tcfail140.hs:12:10: error: tcfail140.hs:14:15: error: • Couldn't match expected type ‘a -> b’ with actual type ‘Int’ • The operator ‘f’ takes two value arguments, - but its type ‘Int -> Int’ has only one + but its type ‘Int -> Int’ has only one In the first argument of ‘map’, namely ‘(3 `f`)’ In the expression: map (3 `f`) xs • Relevant bindings include diff --git a/testsuite/tests/typecheck/should_fail/tcfail204.stderr b/testsuite/tests/typecheck/should_fail/tcfail204.stderr index 8083ffce60..a1ab99c445 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail204.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail204.stderr @@ -2,7 +2,7 @@ tcfail204.hs:10:7: error: [-Wtype-defaults (in -Wall), -Werror=type-defaults] • Defaulting the following constraints to type ‘Double’ (RealFrac a0) - arising from a use of ‘ceiling’ at tcfail204.hs:10:7-17 + arising from a use of ‘ceiling’ at tcfail204.hs:10:7-13 (Fractional a0) arising from the literal ‘6.3’ at tcfail204.hs:10:15-17 • In the expression: ceiling 6.3 diff --git a/testsuite/tests/typecheck/should_fail/too-many.hs b/testsuite/tests/typecheck/should_fail/too-many.hs new file mode 100644 index 0000000000..e3a4e2ba04 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/too-many.hs @@ -0,0 +1,18 @@ +module TooMany where + +foo :: (Int -> Int -> Bool) -> Int +foo = error "urk" + +f1 :: Int -> Int -> Int -> Bool +f1 = f1 + +g1 = foo (f1 2 3) + -- Here is is sensible to report + -- f1 is applied to too many arguments + +f2 :: Int -> Bool +f2 = f2 + +g2 = foo (f2 2) + -- Here is is /not/ sensible to report + -- f2 is applied to too many arguments diff --git a/testsuite/tests/typecheck/should_fail/too-many.stderr b/testsuite/tests/typecheck/should_fail/too-many.stderr new file mode 100644 index 0000000000..01e50050ff --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/too-many.stderr @@ -0,0 +1,16 @@ + +too-many.hs:9:11: error: + • Couldn't match type ‘Bool’ with ‘Int -> Bool’ + Expected: Int -> Int -> Bool + Actual: Int -> Bool + • Possible cause: ‘f1’ is applied to too many arguments + In the first argument of ‘foo’, namely ‘(f1 2 3)’ + In the expression: foo (f1 2 3) + In an equation for ‘g1’: g1 = foo (f1 2 3) + +too-many.hs:16:11: error: + • Couldn't match expected type ‘Int -> Int -> Bool’ + with actual type ‘Bool’ + • In the first argument of ‘foo’, namely ‘(f2 2)’ + In the expression: foo (f2 2) + In an equation for ‘g2’: g2 = foo (f2 2) diff --git a/testsuite/tests/warnings/should_compile/PluralS.stderr b/testsuite/tests/warnings/should_compile/PluralS.stderr index 42c81daf5f..53ed5c4633 100644 --- a/testsuite/tests/warnings/should_compile/PluralS.stderr +++ b/testsuite/tests/warnings/should_compile/PluralS.stderr @@ -8,7 +8,7 @@ PluralS.hs:15:17: warning: [-Wtype-defaults (in -Wall)] PluralS.hs:17:24: warning: [-Wtype-defaults (in -Wall)] • Defaulting the following constraints to type ‘Integer’ - (Show a0) arising from a use of ‘show’ at PluralS.hs:17:24-31 + (Show a0) arising from a use of ‘show’ at PluralS.hs:17:24-27 (Num a0) arising from the literal ‘123’ at PluralS.hs:17:29-31 • In the expression: show 123 In an equation for ‘defaultingNumAndShow’: -- cgit v1.2.1