Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: dc871fb9 by Apoorv Ingle at 2025-11-02T13:37:09-06:00 - Move `PopErrCtxt` into `SrcCodeOrigin` - Pass in the location of the head of the application chain to `addArgCtxt` to print better error messages. Make `addArgCtxt` print in the nth argument if the head of the application chain is user located. - match context with record updates dont get added in error context - - - - - 18 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Do.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Types/ErrCtxt.hs - compiler/GHC/Tc/Types/LclEnv.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Monad.hs - testsuite/tests/rebindable/rebindable6.stderr - testsuite/tests/typecheck/should_fail/DoExpansion1.stderr - testsuite/tests/typecheck/should_fail/DoExpansion2.stderr Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -676,22 +676,22 @@ data SrcCodeOrigin = OrigExpr (HsExpr GhcRn) -- ^ The source, user written, expression | OrigStmt (ExprLStmt GhcRn) HsDoFlavour -- ^ which kind of do-block did this statement come from | OrigPat (Pat GhcRn) -- ^ Used for failable patterns that trigger MonadFail constraints + | PopErrCtxt -- A hint for typechecker to pop + -- the top of the error context stack + -- Does not presist post renaming phase + -- See Part 3. of Note [Expanding HsDo with XXExprGhcRn] + -- in `GHC.Tc.Gen.Do` + -- INVARIANT: SHOULD NEVER APPEAR IN A ExpansionCodeCtxt in CodeSrcFlag ErrCtxt on stack data XXExprGhcRn = ExpandedThingRn { xrn_orig :: SrcCodeOrigin -- The original source thing to be used for error messages , xrn_expanded :: HsExpr GhcRn -- The compiler generated, expanded thing } - | PopErrCtxt -- A hint for typechecker to pop - {-# UNPACK #-} !(HsExpr GhcRn) -- the top of the error context stack - -- Does not presist post renaming phase - -- See Part 3. of Note [Expanding HsDo with XXExprGhcRn] - -- in `GHC.Tc.Gen.Do` | HsRecSelRn (FieldOcc GhcRn) -- ^ Variable pointing to record selector -- See Note [Non-overloaded record field selectors] and -- Note [Record selectors in the AST] - -- | Build an expression using the extension constructor `XExpr`, -- and the two components of the expansion: original expression and -- expanded expressions. @@ -713,6 +713,12 @@ mkExpandedStmt mkExpandedStmt oStmt flav eExpr = XExpr (ExpandedThingRn { xrn_orig = OrigStmt oStmt flav , xrn_expanded = eExpr }) +mkExpandedLastStmt + :: HsExpr GhcRn -- ^ expanded expression + -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn' +mkExpandedLastStmt eExpr = XExpr (ExpandedThingRn { xrn_orig = PopErrCtxt + , xrn_expanded = eExpr }) + data XXExprGhcTc = WrapExpr -- Type and evidence application and abstractions HsWrapper (HsExpr GhcTc) @@ -1083,11 +1089,11 @@ instance Outputable SrcCodeOrigin where OrigExpr x -> ppr_builder "<OrigExpr>:" x OrigStmt x _ -> ppr_builder "<OrigStmt>:" x OrigPat x -> ppr_builder "<OrigPat>:" x + PopErrCtxt -> text "<PopErrCtxt>" where ppr_builder prefix x = ifPprDebug (braces (text prefix <+> parens (ppr x))) (ppr x) instance Outputable XXExprGhcRn where ppr (ExpandedThingRn o e) = ifPprDebug (braces $ vcat [ppr o, text ";;" , ppr e]) (ppr o) - ppr (PopErrCtxt e) = ifPprDebug (braces (text "<PopErrCtxt>" <+> ppr e)) (ppr e) ppr (HsRecSelRn f) = pprPrefixOcc f instance Outputable XXExprGhcTc where @@ -1133,7 +1139,6 @@ ppr_infix_expr _ = Nothing ppr_infix_expr_rn :: XXExprGhcRn -> Maybe SDoc ppr_infix_expr_rn (ExpandedThingRn thing _) = ppr_infix_hs_expansion thing -ppr_infix_expr_rn (PopErrCtxt a) = ppr_infix_expr a ppr_infix_expr_rn (HsRecSelRn f) = Just (pprInfixOcc f) ppr_infix_expr_tc :: XXExprGhcTc -> Maybe SDoc @@ -1233,7 +1238,6 @@ hsExprNeedsParens prec = go go_x_rn :: XXExprGhcRn -> Bool go_x_rn (ExpandedThingRn thing _ ) = hsExpandedNeedsParens thing - go_x_rn (PopErrCtxt a) = hsExprNeedsParens prec a go_x_rn (HsRecSelRn{}) = False hsExpandedNeedsParens :: SrcCodeOrigin -> Bool @@ -1286,7 +1290,6 @@ isAtomicHsExpr (XExpr x) go_x_rn :: XXExprGhcRn -> Bool go_x_rn (ExpandedThingRn thing _) = isAtomicExpandedThingRn thing - go_x_rn (PopErrCtxt a) = isAtomicHsExpr a go_x_rn (HsRecSelRn{}) = True isAtomicExpandedThingRn :: SrcCodeOrigin -> Bool ===================================== compiler/GHC/HsToCore/Quote.hs ===================================== @@ -1744,7 +1744,6 @@ repE e@(XExpr (ExpandedThingRn o x)) else repE e } | otherwise = notHandled (ThExpressionForm e) -repE (XExpr (PopErrCtxt e)) = repE e repE (XExpr (HsRecSelRn (FieldOcc _ (L _ x)))) = repE (mkHsVar (noLocA x)) repE e@(HsPragE _ (HsPragSCC {}) _) = notHandled (ThCostCentres e) repE e@(HsTypedBracket{}) = notHandled (ThExpressionForm e) ===================================== compiler/GHC/Rename/Utils.hs ===================================== @@ -20,7 +20,7 @@ module GHC.Rename.Utils ( DeprecationWarnings(..), warnIfDeprecated, checkUnusedRecordWildcard, badQualBndrErr, typeAppErr, badFieldConErr, - wrapGenSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genHsApps', genHsExpApps, + wrapGenSpan, wrapNoSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genHsApps', genHsExpApps, genLHsApp, genAppType, genLHsLit, genHsIntegralLit, genHsTyLit, genSimpleConPat, genVarPat, genWildPat, @@ -705,6 +705,12 @@ wrapGenSpan :: (HasAnnotation an) => a -> GenLocated an a -- See Note [Rebindable syntax and XXExprGhcRn] wrapGenSpan x = L (noAnnSrcSpan generatedSrcSpan) x +wrapNoSpan :: (HasAnnotation an) => a -> GenLocated an a +-- Wrap something in a "noSrcSpan" +-- See Note [Rebindable syntax and XXExprGhcRn] +wrapNoSpan x = L (noAnnSrcSpan noSrcSpan) x + + -- | Make a 'SyntaxExpr' from a 'Name' (the "rn" is because this is used in the -- renamer). mkRnSyntaxExpr :: Name -> SyntaxExprRn ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -26,10 +26,6 @@ import GHC.Driver.Config.Diagnostic import GHC.Rename.Unbound -import Language.Haskell.Syntax (DotFieldOcc (..)) -import Language.Haskell.Syntax.Basic (FieldLabelString (..)) -import GHC.Hs.Expr (SrcCodeOrigin (..), HsExpr (..)) - import GHC.Tc.Types import GHC.Tc.Utils.Monad import GHC.Tc.Errors.Types @@ -2394,43 +2390,6 @@ mk_dict_err ctxt (item, (matches, pot_unifiers, unsafe_overlapped)) in different_names && same_occ_names | otherwise = False - -- See Note [Out-of-scope fields with -XOverloadedRecordDot] - record_field_suggestions :: ErrorItem -> TcM ([ImportError], [GhcHint]) - record_field_suggestions item = flip (maybe $ return ([], noHints)) record_field $ \name -> - do { glb_env <- getGlobalRdrEnv - ; lcl_env <- getLocalRdrEnv - ; let field_name_hints = report_no_fieldnames item - ; (errs, hints) <- if occ_name_in_scope glb_env lcl_env name - then return ([], noHints) - else unknownNameSuggestions emptyLocalRdrEnv WL_RecField (mkRdrUnqual name) - ; pure (errs, hints ++ field_name_hints) - } - - -- get type names from instance - -- resolve the type - if it's in scope is it a record? - -- if it's a record, report an error - the record name + the field that could not be found - report_no_fieldnames :: ErrorItem -> [GhcHint] - report_no_fieldnames item - | Just (EvVarDest evvar) <- ei_evdest item - -- we can assume that here we have a `HasField @Symbol x r a` instance - -- because of GetFieldOrigin in record_field - , Just (_, [_symbol, x, r, a]) <- tcSplitTyConApp_maybe (varType evvar) - , Just (r_tycon, _) <- tcSplitTyConApp_maybe r - , Just x_name <- isStrLitTy x - -- we check that this is a record type by checking whether it has any - -- fields (in scope) - , not . null $ tyConFieldLabels r_tycon - = [RemindRecordMissingField x_name r a] - | otherwise = [] - - occ_name_in_scope glb_env lcl_env occ_name = not $ - null (lookupGRE glb_env (LookupOccName occ_name (RelevantGREsFOS WantNormal))) && - isNothing (lookupLocalRdrOcc lcl_env occ_name) - - record_field = case orig of - ExpansionOrigin (OrigExpr (HsGetField _ _ (L _ name))) -> Just (mkVarOccFS (field_label $ unLoc $ dfoLabel name)) - _ -> Nothing - {- Note [Report candidate instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we have an unsolved (Num Int), where `Int` is not the Prelude Int, ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -7564,10 +7564,6 @@ pprTyConInstFlavour pprErrCtxtMsg :: ErrCtxtMsg -> SDoc pprErrCtxtMsg = \case ExprCtxt expr - | XExpr (ExpandedThingRn (OrigStmt (L _ stmt) flav) _) <- expr - -> hang (text "In a stmt of" <+> pprAStmtContext @(LIdP GhcRn) (HsDoStmt flav) <> colon) - 2 (ppr_stmt stmt) - | otherwise -> hang (text "In the expression:") 2 (ppr (stripParensHsExpr expr)) ThetaCtxt ctxt theta -> ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -32,7 +32,8 @@ import GHC.Tc.Gen.HsType import GHC.Tc.Utils.Concrete ( unifyConcrete, idConcreteTvs ) import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Evidence -import GHC.Tc.Types.ErrCtxt ( FunAppCtxtFunArg(..) ) +import GHC.Tc.Types.ErrCtxt ( FunAppCtxtFunArg(..), ErrCtxt (..), CodeSrcFlag (..)) +import GHC.Tc.Errors.Ppr (pprErrCtxtMsg) import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType as TcType import GHC.Tc.Utils.Concrete( hasFixedRuntimeRep_syntactic ) @@ -173,6 +174,9 @@ Note [Instantiation variables are short lived] -- CAUTION: Any changes to tcApp should be reflected here -- cf. T19167. the head is an expanded expression applied to a type -- TODO: Use runInfer for tcExprSigma? +-- Caution: Currently we assume that the expression is compiler generated/expanded +-- Becuase that is that T19167 testcase generates. This function can possibly +-- take in the rn_expr and its location to pass into tcValArgs tcExprSigma :: Bool -> HsExpr GhcRn -> TcM (HsExpr GhcTc, TcSigmaType) tcExprSigma inst rn_expr = do { (fun@(rn_fun,fun_ctxt), rn_args) <- splitHsApps rn_expr @@ -181,7 +185,7 @@ tcExprSigma inst rn_expr ; code_orig <- getSrcCodeOrigin ; let fun_orig = srcCodeOriginCtOrigin rn_expr code_orig ; (inst_args, app_res_sigma) <- tcInstFun do_ql inst fun_orig (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args - ; tc_args <- tcValArgs do_ql rn_fun inst_args + ; tc_args <- tcValArgs do_ql (rn_fun, generatedSrcSpan) inst_args ; let tc_expr = rebuildHsApps (tc_fun, fun_ctxt) tc_args ; return (tc_expr, app_res_sigma) } @@ -394,16 +398,18 @@ tcApp :: HsExpr GhcRn -- See Note [tcApp: typechecking applications] tcApp rn_expr exp_res_ty = do { -- Step 1: Split the application chain - (fun@(rn_fun, fun_loc), rn_args) <- splitHsApps rn_expr + (fun@(rn_fun, fun_lspan), rn_args) <- splitHsApps rn_expr + ; inGenCode <- inGeneratedCode ; traceTc "tcApp {" $ - vcat [ text "rn_expr:" <+> ppr rn_expr + vcat [ text "generated? " <+> ppr inGenCode + , text "rn_expr:" <+> ppr rn_expr , text "rn_fun:" <+> ppr rn_fun - , text "fun_loc:" <+> ppr fun_loc + , text "fun_lspan:" <+> ppr fun_lspan , text "rn_args:" <+> ppr rn_args ] -- Step 2: Infer the type of `fun`, the head of the application ; (tc_fun, fun_sigma) <- tcInferAppHead fun - ; let tc_head = (tc_fun, fun_loc) + ; let tc_head = (tc_fun, fun_lspan) -- inst_final: top-instantiate the result type of the application, -- EXCEPT if we are trying to infer a sigma-type inst_final = case exp_res_ty of @@ -434,7 +440,7 @@ tcApp rn_expr exp_res_ty , text "fun_origin" <+> ppr fun_orig , text "do_ql:" <+> ppr do_ql] ; (inst_args, app_res_rho) - <- tcInstFun do_ql inst_final fun_orig (tc_fun, rn_fun, fun_loc) fun_sigma rn_args + <- tcInstFun do_ql inst_final fun_orig (tc_fun, rn_fun, fun_lspan) fun_sigma rn_args -- See (TCAPP1) and (TCAPP2) in -- Note [tcApp: typechecking applications] @@ -447,7 +453,7 @@ tcApp rn_expr exp_res_ty app_res_rho exp_res_ty -- Step 4.2: typecheck the arguments - ; tc_args <- tcValArgs NoQL rn_fun inst_args + ; tc_args <- tcValArgs NoQL (rn_fun, fun_lspan) inst_args -- Step 4.3: wrap up ; finishApp tc_head tc_args app_res_rho res_wrap } @@ -458,7 +464,7 @@ tcApp rn_expr exp_res_ty -- Step 5.2: typecheck the arguments, and monomorphise -- any un-unified instantiation variables - ; tc_args <- tcValArgs DoQL rn_fun inst_args + ; tc_args <- tcValArgs DoQL (rn_fun, fun_lspan) inst_args -- Step 5.3: zonk to expose the polymorphism hidden under -- QuickLook instantiation variables in `app_res_rho` ; app_res_rho <- liftZonkM $ zonkTcType app_res_rho @@ -545,16 +551,16 @@ checkResultTy rn_expr (tc_fun, fun_loc) inst_args app_res_rho (Check res_ty) thing_inside ---------------- -tcValArgs :: QLFlag -> HsExpr GhcRn -> [HsExprArg 'TcpInst] -> TcM [HsExprArg 'TcpTc] +tcValArgs :: QLFlag -> (HsExpr GhcRn, SrcSpan) -> [HsExprArg 'TcpInst] -> TcM [HsExprArg 'TcpTc] -- Importantly, tcValArgs works left-to-right, so that by the time we -- encounter an argument, we have monomorphised all the instantiation -- variables that its type contains. All that is left to do is an ordinary -- zonkTcType. See Note [Monomorphise instantiation variables]. -tcValArgs do_ql fun args = go do_ql 0 args +tcValArgs do_ql (fun, fun_lspan) args = go do_ql 0 args where go _ _ [] = return [] go do_ql pos (arg : args) = - do { arg' <- tcValArg do_ql pos' fun arg + do { arg' <- tcValArg do_ql pos' (fun, fun_lspan) arg ; args' <- go do_ql pos' args ; return (arg' : args') } where @@ -570,7 +576,7 @@ tcValArgs do_ql fun args = go do_ql 0 args = pos -tcValArg :: QLFlag -> Int -> HsExpr GhcRn -> HsExprArg 'TcpInst -- Actual argument +tcValArg :: QLFlag -> Int -> (HsExpr GhcRn, SrcSpan) -> HsExprArg 'TcpInst -- Actual argument -> TcM (HsExprArg 'TcpTc) -- Resulting argument tcValArg _ _ _ (EPrag l p) = return (EPrag l (tcExprPrag p)) tcValArg _ _ _ (ETypeArg l hty ty) = return (ETypeArg l hty ty) @@ -579,10 +585,10 @@ tcValArg do_ql _ _ (EWrap (EHsWrap w)) = do { whenQL do_ql $ qlMonoHsWrapper w -- qlMonoHsWrapper: see Note [Monomorphise instantiation variables] tcValArg _ _ _ (EWrap ew) = return (EWrap ew) -tcValArg do_ql pos fun (EValArg { ea_loc_span = ctxt +tcValArg do_ql pos (fun, fun_lspan) (EValArg { ea_loc_span = lspan , ea_arg = larg@(L arg_loc arg) , ea_arg_ty = sc_arg_ty }) - = addArgCtxt pos fun larg $ + = addArgCtxt pos (fun, fun_lspan) larg $ do { -- Crucial step: expose QL results before checking exp_arg_ty -- So far as the paper is concerned, this step applies -- the poly-substitution Theta, learned by QL, so that we @@ -596,7 +602,8 @@ tcValArg do_ql pos fun (EValArg { ea_loc_span = ctxt DoQL -> liftZonkM $ zonkScaledTcType sc_arg_ty NoQL -> return sc_arg_ty ; traceTc "tcValArg {" $ - vcat [ text "ctxt:" <+> ppr ctxt + vcat [ text "lspan:" <+> ppr lspan + , text "fun_lspan" <+> ppr fun_lspan , text "sigma_type" <+> ppr (mkCheckExpType exp_arg_ty) , text "arg:" <+> ppr larg ] @@ -607,13 +614,13 @@ tcValArg do_ql pos fun (EValArg { ea_loc_span = ctxt tcPolyExpr arg (mkCheckExpType exp_arg_ty) ; traceTc "tcValArg" $ vcat [ ppr arg' , text "}" ] - ; return (EValArg { ea_loc_span = ctxt + ; return (EValArg { ea_loc_span = lspan , ea_arg = L arg_loc arg' , ea_arg_ty = noExtField }) } -tcValArg _ pos fun (EValArgQL { +tcValArg _ pos (fun, fun_lspan) (EValArgQL { eaql_wanted = wanted - , eaql_loc_span = ctxt + , eaql_loc_span = lspan , eaql_arg_ty = sc_arg_ty , eaql_larg = larg@(L arg_loc rn_expr) , eaql_tc_fun = tc_head @@ -622,7 +629,7 @@ tcValArg _ pos fun (EValArgQL { , eaql_args = inst_args , eaql_encl = arg_influences_enclosing_call , eaql_res_rho = app_res_rho }) - = addArgCtxt pos fun larg $ + = addArgCtxt pos (fun, fun_lspan) larg $ do { -- Expose QL results to tcSkolemise, as in EValArg case Scaled mult exp_arg_ty <- liftZonkM $ zonkScaledTcType sc_arg_ty @@ -631,6 +638,8 @@ tcValArg _ pos fun (EValArgQL { , text "args:" <+> ppr inst_args , text "mult:" <+> ppr mult , text "fun" <+> ppr fun + , text "app_lspan" <+> ppr lspan + , text "head_lspan" <+> ppr fun_lspan , text "tc_head" <+> ppr tc_head]) ; ds_flag <- getDeepSubsumptionFlag @@ -649,7 +658,7 @@ tcValArg _ pos fun (EValArgQL { ; unless arg_influences_enclosing_call $ -- Don't repeat qlUnify app_res_rho exp_arg_rho -- the qlUnify - ; tc_args <- tcValArgs DoQL rn_fun inst_args + ; tc_args <- tcValArgs DoQL (rn_fun, snd tc_head) inst_args ; app_res_rho <- liftZonkM $ zonkTcType app_res_rho ; res_wrap <- checkResultTy rn_expr tc_head inst_args app_res_rho (mkCheckExpType exp_arg_rho) @@ -658,7 +667,7 @@ tcValArg _ pos fun (EValArgQL { ; traceTc "tcEValArgQL }" $ vcat [ text "app_res_rho:" <+> ppr app_res_rho ] - ; return (EValArg { ea_loc_span = ctxt + ; return (EValArg { ea_loc_span = lspan , ea_arg = L arg_loc (mkHsWrap wrap arg') , ea_arg_ty = noExtField }) } @@ -692,20 +701,20 @@ tcInstFun :: QLFlag -- Generally speaking we pass in True; in Fig 5 of the paper -- |-inst returns a rho-type -> CtOrigin - -> (HsExpr GhcTc, HsExpr GhcRn, SrcSpan) + -> (HsExpr GhcTc, HsExpr GhcRn, SrcSpan) -- ANI: TODO, move HsExpr GhcRn, SrcSpan to CtOrigin -> TcSigmaType -> [HsExprArg 'TcpRn] -> TcM ( [HsExprArg 'TcpInst] , TcSigmaType ) -- Does not instantiate trailing invisible foralls -- This crucial function implements the |-inst judgement in Fig 4, plus the -- modification in Fig 5, of the QL paper: -- "A quick look at impredicativity" (ICFP'20). -tcInstFun do_ql inst_final fun_orig (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args +tcInstFun do_ql inst_final fun_orig (tc_fun, rn_fun, fun_lspan) fun_sigma rn_args = do { traceTc "tcInstFun" (vcat [ text "origin" <+> ppr fun_orig , text "tc_fun" <+> ppr tc_fun , text "fun_sigma" <+> ppr fun_sigma , text "args:" <+> ppr rn_args , text "do_ql" <+> ppr do_ql - , text "ctx" <+> ppr fun_ctxt]) + , text "ctx" <+> ppr fun_lspan]) ; setQLInstLevel do_ql $ -- See (TCAPP1) and (TCAPP2) in -- Note [tcApp: typechecking applications] go 1 [] fun_sigma rn_args } @@ -782,7 +791,7 @@ tcInstFun do_ql inst_final fun_orig (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args = do { (_inst_tvs, wrap, fun_rho) <- -- addHeadCtxt: important for the class constraints -- that may be emitted from instantiating fun_sigma - setSrcSpan fun_ctxt $ + setSrcSpan fun_lspan $ instantiateSigma fun_orig fun_conc_tvs tvs theta body2 -- See Note [Representation-polymorphism checking built-ins] -- in GHC.Tc.Utils.Concrete. @@ -877,7 +886,7 @@ tcInstFun do_ql inst_final fun_orig (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args (Just $ HsExprTcThing tc_fun) (n_val_args, fun_sigma) fun_ty - ; arg' <- quickLookArg do_ql pos ctxt rn_fun arg arg_ty + ; arg' <- quickLookArg do_ql pos ctxt (rn_fun, fun_lspan) arg arg_ty ; let acc' = arg' : addArgWrap wrap acc ; go (pos+1) acc' res_ty rest_args } @@ -927,28 +936,48 @@ looks_like_type_arg EValArg{ ea_arg = L _ e } = _ -> False looks_like_type_arg _ = False -addArgCtxt :: Int -> HsExpr GhcRn -> LHsExpr GhcRn +addArgCtxt :: Int -> (HsExpr GhcRn, SrcSpan) -> LHsExpr GhcRn -> TcM a -> TcM a -- There are 2 cases: --- 1. In the normal case, we add an informative context --- "In the third argument of f, namely blah" --- 2. If we are deep inside generated code (<=> `isGeneratedCode` is `True`) --- "In the expression: arg" --- If the arg is also a generated thing, i.e. `arg_loc` is `generatedSrcSpan`, we would print nothing. +-- 1. In the normal case, we add an informative context (<=> `inGeneratedCode` is `False`) +-- "In the third argument of f, namely blah" +-- 2. If we are inside generated code (<=> `inGeneratedCode` is `True`) +-- (i) If arg_loc is generated do nothing to to LclEnv/LclCtxt +-- (ii) If arg_loc is Unhelpful UnhelpfulNoLocationInfo set `tcl_in_gen_code` to `True` +-- (iii) if arg_loc is RealSrcLoc then update tcl_loc and add "In the expression: arg" to ErrCtxtStack -- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr -- See Note [Expanding HsDo with XXExprGhcRn] in GHC.Tc.Gen.Do -addArgCtxt arg_no fun (L arg_loc arg) thing_inside +addArgCtxt arg_no (fun, fun_lspan) (L arg_loc arg) thing_inside = do { in_generated_code <- inGeneratedCode + ; err_ctx <- getErrCtxt + ; env0 <- liftZonkM tcInitTidyEnv + ; err_ctx_msg <- mkErrCtxt env0 err_ctx ; traceTc "addArgCtxt" (vcat [ text "generated:" <+> ppr in_generated_code - , text "arg: " <+> ppr arg - , text "arg_loc" <+> ppr arg_loc]) - ; if in_generated_code - then do setSrcSpanA arg_loc $ - addExprCtxt arg $ -- Auto-suppressed if arg_loc is generated - thing_inside - else do setSrcSpanA arg_loc $ - addErrCtxt (FunAppCtxt (FunAppCtxtExpr fun arg) arg_no) $ - thing_inside } + , text "arg: " <+> ppr (arg, arg_no) + , text "arg_loc:" <+> ppr arg_loc + , text "fun:" <+> ppr fun + , text "fun_lspan" <+> ppr fun_lspan + , text "err_ctx" <+> vcat (fmap (\ (x, y) -> + case x of + MkErrCtxt (ExpansionCodeCtxt{}) _ -> text "<EXPN>" <+> pprErrCtxtMsg y + _ -> text "<USER>" <+> pprErrCtxtMsg y) + (take 4 (zip err_ctx err_ctx_msg))) + ]) + ; if not (isGeneratedSrcSpan fun_lspan) + then setSrcSpanA arg_loc $ + addErrCtxt (FunAppCtxt (FunAppCtxtExpr fun arg) arg_no) $ + thing_inside + else updCtxtForArg (L arg_loc arg) $ + thing_inside + } + where + updCtxtForArg :: LHsExpr GhcRn -> TcRn a -> TcRn a + updCtxtForArg e@(L lspan _) thing_inside + = do setSrcSpan (locA lspan) $ + addLExprCtxt e $ -- addLExpr is no op for non-user located exprs + thing_inside + + {- ********************************************************************* * * @@ -1724,24 +1753,26 @@ This turned out to be more subtle than I expected. Wrinkles: -} -quickLookArg :: QLFlag -> Int -> SrcSpan -> HsExpr GhcRn +quickLookArg :: QLFlag -> Int + -> SrcSpan -- ^ location span of the whole application + -> (HsExpr GhcRn, SrcSpan) -- ^ Head of the application chain and its source span -> LHsExpr GhcRn -- ^ Argument -> Scaled TcSigmaTypeFRR -- ^ Type expected by the function -> TcM (HsExprArg 'TcpInst) -- See Note [Quick Look at value arguments] -quickLookArg NoQL _ ctxt _ larg orig_arg_ty - = skipQuickLook ctxt larg orig_arg_ty -quickLookArg DoQL pos ctxt fun larg orig_arg_ty +quickLookArg NoQL _ app_lspan _ larg orig_arg_ty + = skipQuickLook app_lspan larg orig_arg_ty +quickLookArg DoQL pos app_lspan fun_and_lspan larg orig_arg_ty = do { is_rho <- tcIsDeepRho (scaledThing orig_arg_ty) ; traceTc "qla" (ppr orig_arg_ty $$ ppr is_rho) ; if not is_rho - then skipQuickLook ctxt larg orig_arg_ty - else quickLookArg1 pos ctxt fun larg orig_arg_ty } + then skipQuickLook app_lspan larg orig_arg_ty + else quickLookArg1 pos app_lspan fun_and_lspan larg orig_arg_ty } skipQuickLook :: SrcSpan -> LHsExpr GhcRn -> Scaled TcRhoType -> TcM (HsExprArg 'TcpInst) -skipQuickLook ctxt larg arg_ty - = return (EValArg { ea_loc_span = ctxt +skipQuickLook app_lspan larg arg_ty + = return (EValArg { ea_loc_span = app_lspan , ea_arg = larg , ea_arg_ty = arg_ty }) @@ -1779,14 +1810,14 @@ isGuardedTy ty | Just {} <- tcSplitAppTy_maybe ty = True | otherwise = False -quickLookArg1 :: Int -> SrcSpan -> HsExpr GhcRn -> LHsExpr GhcRn +quickLookArg1 :: Int -> SrcSpan -> (HsExpr GhcRn, SrcSpan) -> LHsExpr GhcRn -> Scaled TcRhoType -- Deeply skolemised -> TcM (HsExprArg 'TcpInst) -- quickLookArg1 implements the "QL Argument" judgement in Fig 5 of the paper -quickLookArg1 pos ctxt fun larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho) - = addArgCtxt pos fun larg $ -- Context needed for constraints +quickLookArg1 pos app_lspan (fun, fun_lspan) larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho) + = addArgCtxt pos (fun, fun_lspan) larg $ -- Context needed for constraints -- generated by calls in arg - do { ((rn_fun, fun_ctxt), rn_args) <- splitHsApps arg + do { ((rn_fun, fun_lspan), rn_args) <- splitHsApps arg -- Step 1: get the type of the head of the argument ; (fun_ue, mb_fun_ty) <- tcCollectingUsage $ tcInferAppHead_maybe rn_fun @@ -1802,15 +1833,15 @@ quickLookArg1 pos ctxt fun larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho) , text "args:" <+> ppr rn_args ] ; case mb_fun_ty of { - Nothing -> skipQuickLook ctxt larg sc_arg_ty ; -- fun is too complicated + Nothing -> skipQuickLook app_lspan larg sc_arg_ty ; -- fun is too complicated Just (tc_fun, fun_sigma) -> -- step 2: use |-inst to instantiate the head applied to the arguments - do { let tc_head = (tc_fun, fun_ctxt) + do { let tc_head = (tc_fun, fun_lspan) ; do_ql <- wantQuickLook rn_fun ; ((inst_args, app_res_rho), wanted) <- captureConstraints $ - tcInstFun do_ql True (exprCtOrigin arg) (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args + tcInstFun do_ql True (exprCtOrigin arg) (tc_fun, rn_fun, fun_lspan) fun_sigma rn_args -- We must capture type-class and equality constraints here, but -- not equality constraints. See (QLA6) in Note [Quick Look at -- value arguments] @@ -1842,7 +1873,7 @@ quickLookArg1 pos ctxt fun larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho) ; traceTc "quickLookArg done }" (ppr rn_fun) - ; return (EValArgQL { eaql_loc_span = ctxt + ; return (EValArgQL { eaql_loc_span = app_lspan , eaql_arg_ty = sc_arg_ty , eaql_larg = larg , eaql_tc_fun = tc_head ===================================== compiler/GHC/Tc/Gen/Do.hs ===================================== @@ -97,7 +97,7 @@ expand_do_stmts doFlavour (stmt@(L loc (LetStmt _ bs)) : lstmts) = -- ------------------------------------------------ -- let x = e ; stmts ~~> let x = e in stmts' do expand_stmts_expr <- expand_do_stmts doFlavour lstmts - let expansion = genHsLet bs (genPopErrCtxtExpr expand_stmts_expr) + let expansion = genHsLet bs expand_stmts_expr return $ L loc (mkExpandedStmt stmt doFlavour expansion) expand_do_stmts doFlavour (stmt@(L loc (BindStmt xbsrn pat e)): lstmts) @@ -110,15 +110,15 @@ expand_do_stmts doFlavour (stmt@(L loc (BindStmt xbsrn pat e)): lstmts) -- ------------------------------------------------------- -- pat <- e ; stmts ~~> (>>=) e f = do expand_stmts_expr <- expand_do_stmts doFlavour lstmts - failable_expr <- mk_failable_expr doFlavour pat (genPopErrCtxtExpr expand_stmts_expr) fail_op + failable_expr <- mk_failable_expr doFlavour pat expand_stmts_expr fail_op let expansion = genHsExpApps bind_op -- (>>=) - [ genPopErrCtxtExpr e + [ e , failable_expr ] return $ L loc (mkExpandedStmt stmt doFlavour expansion) | otherwise = pprPanic "expand_do_stmts: The impossible happened, missing bind operator from renamer" (text "stmt" <+> ppr stmt) -expand_do_stmts doFlavour (stmt@(L loc (BodyStmt _ e (SyntaxExprRn then_op) _)) : lstmts) = +expand_do_stmts doFlavour (stmt@(L loc (BodyStmt _ (L e_lspan e) (SyntaxExprRn then_op) _)) : lstmts) = -- See Note [BodyStmt] in Language.Haskell.Syntax.Expr -- See Note [Expanding HsDo with XXExprGhcRn] Equation (1) below -- stmts ~~> stmts' @@ -126,8 +126,8 @@ expand_do_stmts doFlavour (stmt@(L loc (BodyStmt _ e (SyntaxExprRn then_op) _)) -- e ; stmts ~~> (>>) e stmts' do expand_stmts_expr <- expand_do_stmts doFlavour lstmts let expansion = genHsExpApps then_op -- (>>) - [ genPopErrCtxtExpr e - , genPopErrCtxtExpr $ expand_stmts_expr ] + [ L e_lspan (mkExpandedStmt stmt doFlavour e) + , expand_stmts_expr ] return $ L loc (mkExpandedStmt stmt doFlavour expansion) expand_do_stmts doFlavour @@ -484,12 +484,5 @@ It stores the original statement (with location) and the expanded expression -} --- | Wrap a located expression with a `PopErrCtxt` -mkPopErrCtxtExpr :: HsExpr GhcRn -> HsExpr GhcRn -mkPopErrCtxtExpr a = XExpr (PopErrCtxt a) - -genPopErrCtxtExpr :: LHsExpr GhcRn -> LHsExpr GhcRn -genPopErrCtxtExpr (L loc a) = L loc (mkPopErrCtxtExpr a) - mkExpandedPatRn :: Pat GhcRn -> HsExpr GhcRn -> HsExpr GhcRn mkExpandedPatRn pat e = XExpr (ExpandedThingRn (OrigPat pat) e) ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -122,7 +122,7 @@ tcPolyLExpr, tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType tcPolyLExpr (L loc expr) res_ty = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad - addExprCtxt expr $ -- Note [Error contexts in generated code] + addLExprCtxt (L loc expr) $ -- Note [Error contexts in generated code] do { expr' <- tcPolyExpr expr res_ty ; return (L loc expr') } @@ -241,7 +241,7 @@ tcInferRhoNC = tcInferExprNC IIF_DeepRho tcInferExpr, tcInferExprNC :: InferInstFlag -> LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType) tcInferExpr iif (L loc expr) = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad - addExprCtxt expr $ -- Note [Error contexts in generated code] + addLExprCtxt (L loc expr) $ -- Note [Error contexts in generated code] do { (expr', rho) <- runInfer iif IFRR_Any (tcExpr expr) ; return (L loc expr', rho) } @@ -268,7 +268,7 @@ tcMonoLExpr, tcMonoLExprNC tcMonoLExpr (L loc expr) res_ty = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad - addExprCtxt expr $ -- Note [Error contexts in generated code] + addLExprCtxt (L loc expr) $ -- Note [Error contexts in generated code] do { expr' <- tcExpr expr res_ty ; return (L loc expr') } @@ -660,10 +660,10 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr res_ty = assert (notNull rbnds) $ do { -- Expand the record update. See Note [Record Updates]. + ; (ds_expr, ds_res_ty, err_msg) <- expandRecordUpd record_expr possible_parents rbnds res_ty - ; addErrCtxt err_msg $ - setInGeneratedCode (OrigExpr expr) $ + ; addExpansionErrCtxt (OrigExpr expr) err_msg $ do { -- Typecheck the expanded expression. expr' <- tcExpr ds_expr (Check ds_res_ty) -- NB: it's important to use ds_res_ty and not res_ty here. @@ -718,7 +718,7 @@ tcExpr (HsProjection _ _) _ = panic "GHC.Tc.Gen.Expr: tcExpr: HsProjection: Not -- Here we get rid of it and add the finalizers to the global environment. -- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. tcExpr (HsTypedSplice ext splice) res_ty = tcTypedSplice ext splice res_ty -tcExpr e@(HsTypedBracket _ext body) res_ty = tcTypedBracket e body res_ty +tcExpr e@(HsTypedBracket _ext body) res_ty = tcTypedBracket e body res_ty tcExpr e@(HsUntypedBracket ps body) res_ty = tcUntypedBracket e body ps res_ty tcExpr (HsUntypedSplice splice _) res_ty @@ -753,18 +753,9 @@ tcExpr (SectionR {}) ty = pprPanic "tcExpr:SectionR" (ppr ty) -} tcXExpr :: XXExprGhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) - -tcXExpr (PopErrCtxt e) res_ty - = do popErrCtxt $ -- See Part 3 of Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do` - addExprCtxt e $ - tcExpr e res_ty - tcXExpr (ExpandedThingRn o e) res_ty - = setInGeneratedCode o $ - -- e is the expanded expression of o, so we need to set the error ctxt to generated - -- see Note [Error Context Stack] in `GHC.Tc.Type.LclEnv` - mkExpandedTc o <$> -- necessary for hpc ticks - tcExpr e res_ty + = mkExpandedTc o <$> -- necessary for hpc ticks + tcExpr e res_ty -- For record selection, same as HsVar case tcXExpr xe res_ty = tcApp (XExpr xe) res_ty @@ -1480,7 +1471,7 @@ expandRecordUpd record_expr possible_parents rbnds res_ty ds_expr = HsLet noExtField let_binds (wrapGenSpan case_expr) case_expr :: HsExpr GhcRn - case_expr = HsCase RecUpd record_expr + case_expr = HsCase RecUpd (wrapGenSpan (unLoc record_expr)) $ mkMatchGroup (Generated OtherExpansion DoPmc) (wrapGenSpan matches) matches :: [LMatch GhcRn (LHsExpr GhcRn)] matches = map make_pat (NE.toList relevant_cons) ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -26,7 +26,7 @@ module GHC.Tc.Gen.Head , nonBidirectionalErr , pprArgInst - , addExprCtxt, addFunResCtxt ) where + , addExprCtxt, addLExprCtxt, addFunResCtxt ) where import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckPolyExprNC, tcPolyLExprSig ) import {-# SOURCE #-} GHC.Tc.Gen.Splice( getUntypedSpliceBody ) @@ -49,6 +49,7 @@ import GHC.Tc.Solver ( InferMode(..), simplifyInfer ) import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Origin +import GHC.Tc.Types.ErrCtxt ( srcCodeOriginErrCtxMsg ) import GHC.Tc.Types.Constraint( WantedConstraints ) import GHC.Tc.Utils.TcType as TcType import GHC.Tc.Types.Evidence @@ -174,7 +175,7 @@ data HsExprArg (p :: TcPass) where -- See Note [HsExprArg] , eaql_larg :: LHsExpr GhcRn -- Original application, for -- location and error msgs , eaql_rn_fun :: HsExpr GhcRn -- Head of the argument if it is an application - , eaql_tc_fun :: (HsExpr GhcTc, SrcSpan) -- Typechecked head + , eaql_tc_fun :: (HsExpr GhcTc, SrcSpan) -- Typechecked head and its location span , eaql_fun_ue :: UsageEnv -- Usage environment of the typechecked head (QLA5) , eaql_args :: [HsExprArg 'TcpInst] -- Args: instantiated, not typechecked , eaql_wanted :: WantedConstraints @@ -217,7 +218,7 @@ type family XPass (p :: TcPass) where mkEValArg :: SrcSpan -> LHsExpr GhcRn -> HsExprArg 'TcpRn mkEValArg src_loc e = EValArg { ea_arg = e, ea_loc_span = src_loc - , ea_arg_ty = noExtField } + , ea_arg_ty = noExtField } mkETypeArg :: SrcSpan -> LHsWcType GhcRn -> HsExprArg 'TcpRn mkETypeArg src_loc hs_ty = @@ -244,18 +245,18 @@ splitHsApps e = go e noSrcSpan [] go :: HsExpr GhcRn -> SrcSpan -> [HsExprArg 'TcpRn] -> TcM ((HsExpr GhcRn, SrcSpan), [HsExprArg 'TcpRn]) -- Modify the SrcSpan as we walk inwards, so it describes the next argument - go (HsPar _ (L l fun)) sloc args = go fun (locA l) (EWrap (EPar sloc) : args) - go (HsPragE _ p (L l fun)) sloc args = go fun (locA l) (EPrag sloc p : args) - go (HsAppType _ (L l fun) ty) sloc args = go fun (locA l) (mkETypeArg sloc ty : args) - go (HsApp _ (L l fun) arg) sloc args = go fun (locA l) (mkEValArg sloc arg : args) + go (HsPar _ (L l fun)) lspan args = go fun (locA l) (EWrap (EPar lspan) : args) + go (HsPragE _ p (L l fun)) lspan args = go fun (locA l) (EPrag lspan p : args) + go (HsAppType _ (L l fun) ty) lspan args = go fun (locA l) (mkETypeArg lspan ty : args) + go (HsApp _ (L l fun) arg) lspan args = go fun (locA l) (mkEValArg lspan arg : args) -- See Note [Looking through Template Haskell splices in splitHsApps] go e@(HsUntypedSplice splice_res splice) _ args = do { fun <- getUntypedSpliceBody splice_res - ; go fun sloc' (EWrap (EExpand e) : args) } + ; go fun lspan' (EWrap (EExpand e) : args) } where - sloc' :: SrcSpan - sloc' = case splice of + lspan' :: SrcSpan + lspan' = case splice of HsUntypedSpliceExpr _ (L l _) -> locA l -- l :: SrcAnn AnnListItem HsQuasiQuote _ _ (L l _) -> locA l -- l :: SrcAnn NoEpAnns (XUntypedSplice (HsImplicitLiftSplice _ _ _ (L l _))) -> locA l @@ -269,11 +270,10 @@ splitHsApps e = go e noSrcSpan [] -- and its hard to say exactly what that is : EWrap (EExpand e) : args ) - go (XExpr (PopErrCtxt fun)) sloc args = go fun sloc args -- look through PopErrCtxt (cf. T17594f) we do not want to lose the opportunity of calling tcEValArgQL -- unlike HsPar, it is okay to forget about the PopErrCtxts as it does not persist over in GhcTc land - go e sloc args = pure ((e, sloc), args) + go e lspan args = pure ((e, lspan), args) -- | Rebuild an application: takes a type-checked application head @@ -456,8 +456,8 @@ tcInferAppHead :: (HsExpr GhcRn, SrcSpan) -- cases are dealt with by splitHsApps. -- -- See Note [tcApp: typechecking applications] in GHC.Tc.Gen.App -tcInferAppHead (fun,fun_loc) - = setSrcSpan fun_loc $ +tcInferAppHead (fun,fun_lspan) + = setSrcSpan fun_lspan $ do { mb_tc_fun <- tcInferAppHead_maybe fun ; case mb_tc_fun of Just (fun', fun_sigma) -> return (fun', fun_sigma) @@ -471,9 +471,9 @@ tcInferAppHead_maybe fun = case fun of HsVar _ nm -> Just <$> tcInferId nm XExpr (HsRecSelRn f) -> Just <$> tcInferRecSelId f - XExpr (ExpandedThingRn o e) -> Just <$> (setInGeneratedCode o $ -- We do not want to instantiate c.f. T19167 - tcExprSigma False e) - XExpr (PopErrCtxt e) -> tcInferAppHead_maybe e + XExpr (ExpandedThingRn o e) -> Just <$> (addExpansionErrCtxt o (srcCodeOriginErrCtxMsg o) $ + -- We do not want to instantiate c.f. T19167 + tcExprSigma False e) ExprWithTySig _ e hs_ty -> Just <$> tcExprWithSig e hs_ty HsOverLit _ lit -> Just <$> tcInferOverLit lit _ -> return Nothing @@ -1109,5 +1109,17 @@ addExprCtxt e thing_inside -- f x = _ -- when we don't want to say "In the expression: _", -- because it is mentioned in the error message itself - XExpr (PopErrCtxt _) -> thing_inside -- popErrCtxt shouldn't push ctxt. see typechecking let stmts + HsPar{} -> thing_inside + -- We don't want to say 'In the expression (e)', + -- we just want to say 'In the expression, 'e' + -- which will be handeled by the recursive call in thing_inside + XExpr (ExpandedThingRn o _) -> addExpansionErrCtxt o (srcCodeOriginErrCtxMsg o) thing_inside _ -> addErrCtxt (ExprCtxt e) thing_inside -- no op in generated code + + +addLExprCtxt :: LHsExpr GhcRn -> TcRn a -> TcRn a +addLExprCtxt (L lspan e) thing_inside + | (RealSrcSpan{}) <- locA lspan + = addExprCtxt e thing_inside + | otherwise + = thing_inside ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -57,6 +57,7 @@ import GHC.Tc.Gen.Bind import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.Unify import GHC.Tc.Types.Origin +import GHC.Tc.Types.ErrCtxt ( srcCodeOriginErrCtxMsg ) import GHC.Tc.Types.Evidence import GHC.Rename.Env ( irrefutableConLikeTc ) @@ -330,6 +331,7 @@ tcMatch tc_body pat_tys rhs_ty match add_match_ctxt thing_inside = case ctxt of LamAlt LamSingle -> thing_inside StmtCtxt (HsDoStmt{}) -> thing_inside -- this is an expanded do stmt + RecUpd -> thing_inside -- record update is Expanded out so ignore it _ -> addErrCtxt (MatchInCtxt match) thing_inside ------------- @@ -404,9 +406,9 @@ tcDoStmts doExpr@(DoExpr _) ss@(L l stmts) res_ty ; return (HsDo res_ty doExpr (L l stmts')) } else do { expanded_expr <- expandDoStmts doExpr stmts -- Do expansion on the fly ; let orig = HsDo noExtField doExpr ss - ; setInGeneratedCode (OrigExpr orig) $ do - { e' <- tcMonoLExpr expanded_expr res_ty - ; return (mkExpandedExprTc orig (unLoc e'))} + ; addExpansionErrCtxt (OrigExpr orig) (srcCodeOriginErrCtxMsg (OrigExpr orig)) $ + do { e' <- tcMonoLExpr expanded_expr res_ty + ; return (mkExpandedExprTc orig (unLoc e'))} } } ===================================== compiler/GHC/Tc/Instance/Class.hs ===================================== @@ -61,7 +61,6 @@ import GHC.Unit.Module.Warnings import GHC.Hs -import Language.Haskell.Syntax.Basic (FieldLabelString(..)) import GHC.Tc.Errors.Types import Data.Maybe ===================================== compiler/GHC/Tc/Types/ErrCtxt.hs ===================================== @@ -4,7 +4,7 @@ {-# LANGUAGE UndecidableInstances #-} module GHC.Tc.Types.ErrCtxt - ( ErrCtxt, ErrCtxtMsg(..) + ( ErrCtxt (..), ErrCtxtMsg(..), ErrCtxtMsgM, CodeSrcFlag (..), srcCodeOriginErrCtxMsg , UserSigType(..), FunAppCtxtFunArg(..) , TyConInstFlavour(..) ) @@ -23,7 +23,7 @@ import GHC.Tc.Zonk.Monad ( ZonkM ) import GHC.Types.Basic ( TyConFlavour ) import GHC.Types.Name ( Name ) -import GHC.Types.SrcLoc ( SrcSpan ) +import GHC.Types.SrcLoc ( SrcSpan, unLoc ) import GHC.Types.Var ( Id, TyCoVar ) import GHC.Types.Var.Env ( TidyEnv ) @@ -48,15 +48,22 @@ import qualified Data.List.NonEmpty as NE -------------------------------------------------------------------------------- +type ErrCtxtMsgM = TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg) + -- | Additional context to include in an error message, e.g. -- "In the type signature ...", "In the ambiguity check for ...", etc. -type ErrCtxt = (Bool, TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)) - -- Monadic so that we have a chance - -- to deal with bound type variables just before error - -- message construction +data ErrCtxt = MkErrCtxt CodeSrcFlag ErrCtxtMsgM + -- Monadic so that we have a chance + -- to deal with bound type variables just before error + -- message construction + + -- Bool: True <=> this is a landmark context; do not + -- discard it when trimming for display - -- Bool: True <=> this is a landmark context; do not - -- discard it when trimming for display +data CodeSrcFlag = VanillaUserSrcCode + | LandmarkUserSrcCode + | ExpansionCodeCtxt SrcCodeOrigin + -- INVARIANT: SHOULD NEVER APPEAR IN A ExpansionCodeCtxt in CodeSrcFlag ErrCtxt on stack -------------------------------------------------------------------------------- -- Error message contexts @@ -221,3 +228,10 @@ data ErrCtxtMsg | MergeSignaturesCtxt !UnitState !ModuleName ![InstantiatedModule] -- | While checking that a module implements a Backpack signature. | CheckImplementsCtxt !UnitState !Module !InstantiatedModule + + +srcCodeOriginErrCtxMsg :: SrcCodeOrigin -> ErrCtxtMsg +srcCodeOriginErrCtxMsg (OrigExpr e) = ExprCtxt e +srcCodeOriginErrCtxMsg (OrigStmt s f) = StmtErrCtxt (HsDoStmt f) (unLoc s) +srcCodeOriginErrCtxMsg (OrigPat p) = PatCtxt p +srcCodeOriginErrCtxMsg (PopErrCtxt) = error "Shouldn't happen srcCodeOriginErr" ===================================== compiler/GHC/Tc/Types/LclEnv.hs ===================================== @@ -28,7 +28,7 @@ module GHC.Tc.Types.LclEnv ( , addLclEnvErrCtxt - , ErrCtxtStack (..) + , ErrCtxtStack , ArrowCtxt(..) , ThBindEnv , TcTypeEnv @@ -36,7 +36,7 @@ module GHC.Tc.Types.LclEnv ( import GHC.Prelude -import GHC.Hs ( SrcCodeOrigin ) +import GHC.Hs ( SrcCodeOrigin (..) ) import GHC.Tc.Utils.TcType ( TcLevel ) import GHC.Tc.Errors.Types ( TcRnMessage ) @@ -92,15 +92,19 @@ data TcLclEnv -- Changes as we move inside an expression } {- -Note [Error Context Stack] -~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Note [ErrCtxtStack Manipulation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The ErrCtxtStack is a list of ErrCtxt +ANI: TODO. explain how this works. When is the top of the stack overwritten? When an error ctxt pushed on top + This data structure keeps track of two things: 1. Are we type checking a compiler generated/non-user written code. 2. The trail of the error messages that have been added in route to the current expression * When the `ErrCtxtStack` is a `UserCodeCtxt`, - the current expression being typechecked is user written -* When the `ErrorCtxtStack` is a `GeneratedCodeCtxt` +* When the `ErrorCtxtStack` is a `ExpansionCodeCtxt` - the current expression being typechecked is compiler generated; - the original, possibly user written, source code thing is stored in `src_code_origin` field. - the `src_code_origin` is what will be blamed in the error message @@ -109,39 +113,22 @@ This data structure keeps track of two things: -- See Note [Error Context Stack] -data ErrCtxtStack - = UserCodeCtxt { lcl_err_ctxt :: [ErrCtxt] } -- ^ Trail of error messages - | GeneratedCodeCtxt { src_code_origin :: SrcCodeOrigin -- ^ Original, user written code - , lcl_err_ctxt :: [ErrCtxt] } -- ^ Trail of error messages - --- | Are we in a generated context? -isGeneratedCodeCtxt :: ErrCtxtStack -> Bool -isGeneratedCodeCtxt UserCodeCtxt{} = False -isGeneratedCodeCtxt _ = True +type ErrCtxtStack = [ErrCtxt] -- | Get the original source code get_src_code_origin :: ErrCtxtStack -> Maybe SrcCodeOrigin -get_src_code_origin (UserCodeCtxt{}) = Nothing - -- we are in user code, so blame the expression in hand -get_src_code_origin es = Just $ src_code_origin es - -- we are in generated code, so extract the original expression - --- | Modify the error context stack --- N.B. If we are in a generated context, any updates to the context stack are ignored. --- We want to blame the errors that appear in a generated expression --- to the original, user written code -modify_err_ctxt_stack :: ([ErrCtxt] -> [ErrCtxt]) -> ErrCtxtStack -> ErrCtxtStack -modify_err_ctxt_stack f (UserCodeCtxt e) = UserCodeCtxt (f e) -modify_err_ctxt_stack _ c = c -- any updates on the err context in a generated context should be ignored - +get_src_code_origin (MkErrCtxt (ExpansionCodeCtxt origSrcCode) _ : _) = Just origSrcCode + -- we are in generated code, due to the expansion of the original syntax origSrcCode +get_src_code_origin _ = Nothing + -- we are in user code, so blame the expression in hand data TcLclCtxt = TcLclCtxt { - tcl_loc :: RealSrcSpan, -- Source span - tcl_ctxt :: ErrCtxtStack, -- See Note [Error Context Stack] - tcl_tclvl :: TcLevel, - tcl_bndrs :: TcBinderStack, -- Used for reporting relevant bindings, - -- and for tidying type + tcl_loc :: RealSrcSpan, -- Source span + tcl_err_ctxt :: ErrCtxtStack, -- See Note [Error Context Stack] + tcl_tclvl :: TcLevel, + tcl_bndrs :: TcBinderStack, -- Used for reporting relevant bindings, + -- and for tidying type tcl_rdr :: LocalRdrEnv, -- Local name envt -- Maintained during renaming, of course, but also during @@ -203,28 +190,40 @@ getLclEnvLoc :: TcLclEnv -> RealSrcSpan getLclEnvLoc = tcl_loc . tcl_lcl_ctxt getLclEnvErrCtxt :: TcLclEnv -> [ErrCtxt] -getLclEnvErrCtxt = lcl_err_ctxt . tcl_ctxt . tcl_lcl_ctxt +getLclEnvErrCtxt = tcl_err_ctxt . tcl_lcl_ctxt -setLclEnvErrCtxt :: [ErrCtxt] -> TcLclEnv -> TcLclEnv -setLclEnvErrCtxt ctxt = modifyLclCtxt (\env -> env { tcl_ctxt = modify_err_ctxt_stack (\ _ -> ctxt) (tcl_ctxt env) }) +setLclEnvErrCtxt :: ErrCtxtStack -> TcLclEnv -> TcLclEnv +setLclEnvErrCtxt ctxt = modifyLclCtxt (\env -> env { tcl_err_ctxt = ctxt }) addLclEnvErrCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv -addLclEnvErrCtxt ec = modifyLclCtxt (\env -> env { tcl_ctxt = modify_err_ctxt_stack (\ctxt -> ec : ctxt) (tcl_ctxt env) }) +addLclEnvErrCtxt ec = setLclEnvSrcCodeOrigin ec getLclEnvSrcCodeOrigin :: TcLclEnv -> Maybe SrcCodeOrigin -getLclEnvSrcCodeOrigin = get_src_code_origin . tcl_ctxt . tcl_lcl_ctxt - -setLclEnvSrcCodeOrigin :: SrcCodeOrigin -> TcLclEnv -> TcLclEnv -setLclEnvSrcCodeOrigin o = modifyLclCtxt (setLclCtxtSrcCodeOrigin o) - -setLclCtxtSrcCodeOrigin :: SrcCodeOrigin -> TcLclCtxt -> TcLclCtxt -setLclCtxtSrcCodeOrigin o ctxt = ctxt { tcl_ctxt = GeneratedCodeCtxt o (lcl_err_ctxt $ tcl_ctxt ctxt) } +getLclEnvSrcCodeOrigin = get_src_code_origin . tcl_err_ctxt . tcl_lcl_ctxt + +setLclEnvSrcCodeOrigin :: ErrCtxt -> TcLclEnv -> TcLclEnv +setLclEnvSrcCodeOrigin ec = modifyLclCtxt (setLclCtxtSrcCodeOrigin ec) + +-- See Note [ErrCtxt Stack Manipulation] +setLclCtxtSrcCodeOrigin :: ErrCtxt -> TcLclCtxt -> TcLclCtxt +setLclCtxtSrcCodeOrigin ec lclCtxt + | MkErrCtxt (ExpansionCodeCtxt PopErrCtxt) _ <- ec + = lclCtxt { tcl_err_ctxt = tail (tcl_err_ctxt lclCtxt) } + | MkErrCtxt (ExpansionCodeCtxt _) _ : ecs <- tcl_err_ctxt lclCtxt + , MkErrCtxt (ExpansionCodeCtxt _) _ <- ec + = lclCtxt { tcl_err_ctxt = ec : ecs } + | otherwise + = lclCtxt { tcl_err_ctxt = ec : tcl_err_ctxt lclCtxt } lclCtxtInGeneratedCode :: TcLclCtxt -> Bool -lclCtxtInGeneratedCode = isGeneratedCodeCtxt . tcl_ctxt +lclCtxtInGeneratedCode lclCtxt + | (MkErrCtxt (ExpansionCodeCtxt _) _ : _) <- tcl_err_ctxt lclCtxt + = True + | otherwise + = False lclEnvInGeneratedCode :: TcLclEnv -> Bool -lclEnvInGeneratedCode = lclCtxtInGeneratedCode . tcl_lcl_ctxt +lclEnvInGeneratedCode = lclCtxtInGeneratedCode . tcl_lcl_ctxt getLclEnvBinderStack :: TcLclEnv -> TcBinderStack getLclEnvBinderStack = tcl_bndrs . tcl_lcl_ctxt ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -837,8 +837,7 @@ exprCtOrigin e@(HsProjection _ _) = ExpansionOrigin (OrigExpr e) exprCtOrigin e@(RecordUpd{}) = ExpansionOrigin (OrigExpr e) exprCtOrigin e@(HsGetField{}) = ExpansionOrigin (OrigExpr e) exprCtOrigin (XExpr (ExpandedThingRn o _)) = ExpansionOrigin o -exprCtOrigin (XExpr (PopErrCtxt e)) = exprCtOrigin e -exprCtOrigin (XExpr (HsRecSelRn f)) = OccurrenceOfRecSel (foExt f) +exprCtOrigin (XExpr (HsRecSelRn f)) = OccurrenceOfRecSel $ L (getLoc $ foLabel f) (foExt f) srcCodeOriginCtOrigin :: HsExpr GhcRn -> Maybe SrcCodeOrigin -> CtOrigin srcCodeOriginCtOrigin e Nothing = exprCtOrigin e @@ -889,6 +888,7 @@ pprCtOrigin (ExpansionOrigin o) OrigExpr (ExplicitList{}) -> text "an overloaded list" OrigExpr (HsIf{}) -> text "an if-then-else expression" OrigExpr e -> text "the expression" <+> (ppr e) + PopErrCtxt -> text "Shouldn't Happen PopErrCtxt" pprCtOrigin (GivenSCOrigin sk d blk) = vcat [ ctoHerald <+> pprSkolInfo sk @@ -1121,6 +1121,7 @@ ppr_br (ExpansionOrigin (OrigExpr (HsIf{}))) = text "an if-then-else expression" ppr_br (ExpansionOrigin (OrigExpr e)) = text "an expression" <+> ppr e ppr_br (ExpansionOrigin (OrigStmt{})) = text "a do statement" ppr_br (ExpansionOrigin (OrigPat{})) = text "a do statement" +ppr_br (ExpansionOrigin PopErrCtxt) = text "SHOULDN'T HAPPEN POPERRORCTXT" ppr_br (ExpectedTySyntax o _) = ppr_br o ppr_br (ExpectedFunTySyntaxOp{}) = text "a rebindable syntax operator" ppr_br (ExpectedFunTyViewPat{}) = text "a view pattern" ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -63,7 +63,7 @@ module GHC.Tc.Utils.Monad( -- * Error management getSrcCodeOrigin, getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, - inGeneratedCode, setInGeneratedCode, + inGeneratedCode, -- setInGeneratedCode, wrapLocM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_, wrapLocMA_,wrapLocMA, getErrsVar, setErrsVar, @@ -88,6 +88,7 @@ module GHC.Tc.Utils.Monad( -- * Context management for the type checker getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt, + addExpansionErrCtxt, addExpansionErrCtxtM, addLandmarkErrCtxtM, popErrCtxt, getCtLocM, setCtLocM, mkCtLocEnv, -- * Diagnostic message generation (type checker) @@ -172,6 +173,7 @@ import GHC.Tc.Types -- Re-export all import GHC.Tc.Types.Constraint import GHC.Tc.Types.CtLoc import GHC.Tc.Types.Evidence +import GHC.Tc.Types.ErrCtxt import GHC.Tc.Types.LclEnv import GHC.Tc.Types.Origin import GHC.Tc.Types.TcRef @@ -418,7 +420,7 @@ initTcWithGbl hsc_env gbl_env loc do_this tcl_lcl_ctxt = TcLclCtxt { tcl_loc = loc, -- tcl_loc should be over-ridden very soon! - tcl_ctxt = UserCodeCtxt [], + tcl_err_ctxt = [], tcl_rdr = emptyLocalRdrEnv, tcl_th_ctxt = topLevel, tcl_th_bndrs = emptyNameEnv, @@ -1077,23 +1079,27 @@ inGeneratedCode = lclEnvInGeneratedCode <$> getLclEnv setSrcSpan :: SrcSpan -> TcRn a -> TcRn a -- See Note [Error contexts in generated code] setSrcSpan (RealSrcSpan loc _) thing_inside - = updLclCtxt (\env -> env { tcl_loc = loc - , tcl_ctxt = UserCodeCtxt (lcl_err_ctxt $ tcl_ctxt env)}) - thing_inside + = updLclCtxt (\env -> env { tcl_loc = loc }) thing_inside setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside getSrcCodeOrigin :: TcRn (Maybe SrcCodeOrigin) -getSrcCodeOrigin = getLclEnvSrcCodeOrigin <$> getLclEnv +getSrcCodeOrigin = + do inGenCode <- inGeneratedCode + if inGenCode + then getLclEnvSrcCodeOrigin <$> getLclEnv + else return Nothing + -- | Mark the inner computation as being done inside generated code. -- -- See Note [Error contexts in generated code] -- See Note [Error Context Stack] -setInGeneratedCode :: SrcCodeOrigin -> TcRn a -> TcRn a -setInGeneratedCode sco thing_inside = - updLclCtxt (setLclCtxtSrcCodeOrigin sco) thing_inside +-- setInGeneratedCode :: SrcCodeOrigin -> TcRn a -> TcRn a +-- setInGeneratedCode sco thing_inside = +-- -- updLclCtxt setLclCtxtInGenCode $ +-- updLclCtxt (setLclCtxtSrcCodeOrigin sco) thing_inside setSrcSpanA :: EpAnn ann -> TcRn a -> TcRn a setSrcSpanA l = setSrcSpan (locA l) @@ -1341,12 +1347,20 @@ addErrCtxt :: ErrCtxtMsg -> TcM a -> TcM a {-# INLINE addErrCtxt #-} -- Note [Inlining addErrCtxt] addErrCtxt msg = addErrCtxtM (\env -> return (env, msg)) +addExpansionErrCtxt :: SrcCodeOrigin -> ErrCtxtMsg -> TcM a -> TcM a +{-# INLINE addExpansionErrCtxt #-} -- Note [Inlining addErrCtxt] +addExpansionErrCtxt o msg = addExpansionErrCtxtM o (\env -> return (env, msg)) + -- | Add a message to the error context. This message may do tidying. -- NB. No op in generated code -- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr addErrCtxtM :: (TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)) -> TcM a -> TcM a {-# INLINE addErrCtxtM #-} -- Note [Inlining addErrCtxt] -addErrCtxtM ctxt = pushCtxt (False, ctxt) +addErrCtxtM ctxt = pushCtxt (MkErrCtxt VanillaUserSrcCode ctxt) + +addExpansionErrCtxtM :: SrcCodeOrigin -> (TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)) -> TcM a -> TcM a +{-# INLINE addExpansionErrCtxtM #-} -- Note [Inlining addErrCtxt] +addExpansionErrCtxtM o ctxt = pushCtxt (MkErrCtxt (ExpansionCodeCtxt o) ctxt) -- | Add a fixed landmark message to the error context. A landmark -- message is always sure to be reported, even if there is a lot of @@ -1360,7 +1374,7 @@ addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg)) -- and tidying. addLandmarkErrCtxtM :: (TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)) -> TcM a -> TcM a {-# INLINE addLandmarkErrCtxtM #-} -- Note [Inlining addErrCtxt] -addLandmarkErrCtxtM ctxt = pushCtxt (True, ctxt) +addLandmarkErrCtxtM ctxt = pushCtxt (MkErrCtxt LandmarkUserSrcCode ctxt) -- | NB. no op in generated code -- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr @@ -1371,9 +1385,7 @@ pushCtxt ctxt = updLclEnv (updCtxt ctxt) updCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv -- Do not update the context if we are in generated code -- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr -updCtxt ctxt env - | lclEnvInGeneratedCode env = env - | otherwise = addLclEnvErrCtxt ctxt env +updCtxt ctxt env = addLclEnvErrCtxt ctxt env popErrCtxt :: TcM a -> TcM a popErrCtxt thing_inside = updLclEnv (\env -> setLclEnvErrCtxt (pop $ getLclEnvErrCtxt env) env) $ @@ -1834,11 +1846,17 @@ mkErrCtxt env ctxts where go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM [ErrCtxtMsg] go _ _ _ [] = return [] - go dbg n env ((is_landmark, ctxt) : ctxts) - | is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg + go dbg n env (MkErrCtxt LandmarkUserSrcCode ctxt : ctxts) + | n < mAX_CONTEXTS -- Too verbose || dbg + = do { (env', msg) <- liftZonkM $ ctxt env + ; rest <- go dbg n env' ctxts + ; return (msg : rest) } + | otherwise + = go dbg n env ctxts + go dbg n env (MkErrCtxt _ ctxt : ctxts) + | n < mAX_CONTEXTS -- Too verbose || dbg = do { (env', msg) <- liftZonkM $ ctxt env - ; let n' = if is_landmark then n else n+1 - ; rest <- go dbg n' env' ctxts + ; rest <- go dbg (n+1) env' ctxts ; return (msg : rest) } | otherwise = go dbg n env ctxts ===================================== testsuite/tests/rebindable/rebindable6.stderr ===================================== @@ -1,9 +1,8 @@ - rebindable6.hs:110:17: error: [GHC-39999] • Ambiguous type variable ‘t0’ arising from a do statement prevents the constraint ‘(HasSeq (IO a -> t0 -> IO b))’ from being solved. - (maybe you haven't applied a function to enough arguments?) + (maybe you haven't applied a function to enough arguments?) Relevant bindings include g :: IO (Maybe b) (bound at rebindable6.hs:108:19) f :: IO a (bound at rebindable6.hs:108:17) @@ -28,7 +27,7 @@ rebindable6.hs:111:17: error: [GHC-39999] • Ambiguous type variables ‘t1’, ‘t0’ arising from a do statement prevents the constraint ‘(HasBind (IO (Maybe b) -> (Maybe b -> t1) -> t0))’ from being solved. - (maybe you haven't applied a function to enough arguments?) + (maybe you haven't applied a function to enough arguments?) Relevant bindings include g :: IO (Maybe b) (bound at rebindable6.hs:108:19) test_do :: IO a -> IO (Maybe b) -> IO b @@ -50,9 +49,9 @@ rebindable6.hs:111:17: error: [GHC-39999] return b rebindable6.hs:112:17: error: [GHC-39999] - • Ambiguous type variable ‘t1’ arising from a use of ‘return’ + • Ambiguous type variable ‘t1’ arising from a do statement prevents the constraint ‘(HasReturn (b -> t1))’ from being solved. - (maybe you haven't applied a function to enough arguments?) + (maybe you haven't applied a function to enough arguments?) Relevant bindings include b :: b (bound at rebindable6.hs:111:23) g :: IO (Maybe b) (bound at rebindable6.hs:108:19) @@ -71,3 +70,4 @@ rebindable6.hs:112:17: error: [GHC-39999] = do f Just (b :: b) <- g return b + ===================================== testsuite/tests/typecheck/should_fail/DoExpansion1.stderr ===================================== @@ -22,7 +22,7 @@ DoExpansion1.hs:15:54: warning: [GHC-39999] [-Wdeferred-type-errors (in -Wdefaul DoExpansion1.hs:19:21: warning: [GHC-39999] [-Wdeferred-type-errors (in -Wdefault)] • No instance for ‘Num String’ arising from the literal ‘1’ • In the first argument of ‘putStrLn’, namely ‘1’ - In the expression: putStrLn 1 + In a stmt of a 'do' block: putStrLn 1 In the expression: do putStrLn 1 putStrLn "r2" @@ -31,7 +31,7 @@ DoExpansion1.hs:19:21: warning: [GHC-39999] [-Wdeferred-type-errors (in -Wdefaul DoExpansion1.hs:25:21: warning: [GHC-39999] [-Wdeferred-type-errors (in -Wdefault)] • No instance for ‘Num String’ arising from the literal ‘2’ • In the first argument of ‘putStrLn’, namely ‘2’ - In the expression: putStrLn 2 + In a stmt of a 'do' block: putStrLn 2 In the expression: do putStrLn "r1" putStrLn 2 ===================================== testsuite/tests/typecheck/should_fail/DoExpansion2.stderr ===================================== @@ -57,9 +57,7 @@ DoExpansion2.hs:34:22: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefaul • The function ‘getVal’ is applied to two visible arguments, but its type ‘Int -> IO String’ has only one In the expression: getVal 3 4 - In the expression: - do Just x <- getVal 3 4 - return x + In a stmt of a 'do' block: Just x <- getVal 3 4 DoExpansion2.hs:39:19: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)] • Couldn't match type ‘[Char]’ with ‘Int’ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dc871fb970034810dc8854affdd642cc... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dc871fb970034810dc8854affdd642cc... You're receiving this email because of your account on gitlab.haskell.org.