[Git][ghc/ghc][wip/T18126-deep] Improving error messages
Simon Peyton Jones
gitlab at gitlab.haskell.org
Mon Jun 1 22:21:15 UTC 2020
Simon Peyton Jones pushed to branch wip/T18126-deep at Glasgow Haskell Compiler / GHC
Commits:
372da668 by Simon Peyton Jones at 2020-06-01T23:20:19+01:00
Improving error messages
- - - - -
28 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Tc/Utils/Unify.hs
- compiler/GHC/Tc/Utils/Unify.hs-boot
- compiler/GHC/Tc/Utils/Zonk.hs
- testsuite/tests/impredicative/T18126-nasty.hs
- testsuite/tests/indexed-types/should_fail/T4485.stderr
- testsuite/tests/typecheck/should_compile/T13050.hs
- testsuite/tests/typecheck/should_compile/T5490.hs
- testsuite/tests/typecheck/should_fail/T15862.stderr
- testsuite/tests/typecheck/should_fail/T2846b.hs
- testsuite/tests/typecheck/should_fail/T2846b.stderr
- testsuite/tests/typecheck/should_fail/T3176.stderr
- testsuite/tests/typecheck/should_fail/T6069.stderr
- testsuite/tests/typecheck/should_fail/T8450.stderr
- testsuite/tests/typecheck/should_fail/all.T
- testsuite/tests/typecheck/should_fail/tcfail140.stderr
- testsuite/tests/typecheck/should_fail/tcfail204.stderr
- + testsuite/tests/typecheck/should_fail/too-many.hs
- + testsuite/tests/typecheck/should_fail/too-many.stderr
- testsuite/tests/warnings/should_compile/PluralS.stderr
Changes:
=====================================
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
=====================================
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"
=====================================
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]
=====================================
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
=====================================
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))
=====================================
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 }
{- *********************************************************************
=====================================
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
=====================================
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
=====================================
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)
=====================================
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 }
=====================================
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
=====================================
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)
=====================================
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))
=====================================
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’
=====================================
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
=====================================
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
=====================================
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
=====================================
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
=====================================
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])
=====================================
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
=====================================
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
=====================================
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 ()
=====================================
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, [''])
=====================================
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
=====================================
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
=====================================
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
=====================================
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)
=====================================
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’:
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/372da668e8a570f4ffb0020adb67e8c9fbf3d728
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/372da668e8a570f4ffb0020adb67e8c9fbf3d728
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200601/bab08004/attachment-0001.html>
More information about the ghc-commits
mailing list