Apoorv Ingle pushed to branch wip/ani/ctorig-stuff at Glasgow Haskell Compiler / GHC Commits: e12c1e9d by Apoorv Ingle at 2025-06-29T20:27:28-05:00 fix exprCtOrigin for HsProjection case. It was assigned to be SectionOrigin, but it should be GetFieldOrigin - - - - - d37adc69 by Apoorv Ingle at 2025-06-29T21:37:38-05:00 undo test changes - - - - - bde2465e by Apoorv Ingle at 2025-07-02T16:02:03-05:00 fix unused do binding warning error location - - - - - e199446b by Apoorv Ingle at 2025-07-02T16:11:44-05:00 FRRRecordUpdate message change - - - - - 2fb3b1ba by Apoorv Ingle at 2025-07-07T00:16:14-05:00 - kill tcl_in_gen_code - It is subsumed by `ErrCtxtStack` which keep tracks of `ErrCtxt` and code ctxt - - - - - e1864b1a by Apoorv Ingle at 2025-07-13T21:14:25-05:00 kill ExpectedFunTyOrig - - - - - 17 changed files: - compiler/GHC/Hs.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Pat.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 - compiler/GHC/Tc/Utils/Unify.hs - testsuite/tests/deSugar/should_compile/T10662.stderr - testsuite/tests/deSugar/should_compile/T3263-1.stderr - testsuite/tests/deSugar/should_compile/T3263-2.stderr - testsuite/tests/ghci.debugger/scripts/break029.script - testsuite/tests/rep-poly/RepPolyRecordUpdate.stderr Changes: ===================================== compiler/GHC/Hs.hs ===================================== @@ -38,8 +38,6 @@ module GHC.Hs ( HsModule(..), AnnsModule(..), HsParsedModule(..), XModulePs(..), - SrcCodeCtxt(..), isUserCodeCtxt, isGeneratedCodeCtxt - ) where -- friends: @@ -149,17 +147,3 @@ data HsParsedModule = HsParsedModule { -- the .hi file, so that we can force recompilation if any of -- them change (#3589) } - --- Used in TcLclCtxt.tcl_in_gen_code to mark if the current expression --- is a user generated code or a compiler generated expansion of some user written code -data SrcCodeCtxt - = UserCode - | GeneratedCode SrcCodeOrigin - -isUserCodeCtxt :: SrcCodeCtxt -> Bool -isUserCodeCtxt UserCode = True -isUserCodeCtxt _ = False - -isGeneratedCodeCtxt :: SrcCodeCtxt -> Bool -isGeneratedCodeCtxt UserCode = False -isGeneratedCodeCtxt _ = True ===================================== compiler/GHC/HsToCore/Expr.hs ===================================== @@ -1234,8 +1234,8 @@ Other places that requires from the same treatment: -- Warn about certain types of values discarded in monadic bindings (#3263) warnDiscardedDoBindings :: LHsExpr GhcTc -> Type -> Type -> DsM () -warnDiscardedDoBindings rhs m_ty elt_ty - = do { warn_unused <- woptM Opt_WarnUnusedDoBind +warnDiscardedDoBindings rhs@(L rhs_loc _) m_ty elt_ty + = putSrcSpanDsA rhs_loc $ do { warn_unused <- woptM Opt_WarnUnusedDoBind ; warn_wrong <- woptM Opt_WarnWrongDoBind ; when (warn_unused || warn_wrong) $ do { fam_inst_envs <- dsGetFamInstEnvs ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -189,8 +189,8 @@ tcExprSigma inst rn_expr = do { (fun@(rn_fun,fun_ctxt), rn_args) <- splitHsApps rn_expr ; do_ql <- wantQuickLook rn_fun ; (tc_fun, fun_sigma) <- tcInferAppHead fun - ; code_ctxt <- getSrcCodeCtxt - ; let fun_orig = srcCodeCtxtCtOrigin rn_expr code_ctxt + ; 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 ; let tc_expr = rebuildHsApps (tc_fun, fun_ctxt) tc_args @@ -417,8 +417,8 @@ tcApp rn_expr exp_res_ty ; let tc_head = (tc_fun, fun_loc) -- Step 3: Instantiate the function type (taking a quick look at args) ; do_ql <- wantQuickLook rn_fun - ; code_ctxt <- getSrcCodeCtxt - ; let fun_orig = srcCodeCtxtCtOrigin rn_fun code_ctxt + ; code_orig <- getSrcCodeOrigin + ; let fun_orig = srcCodeOriginCtOrigin rn_fun code_orig ; traceTc "tcApp:inferAppHead" $ vcat [ text "tc_fun:" <+> ppr tc_fun , text "fun_sigma:" <+> ppr fun_sigma @@ -857,8 +857,7 @@ tcInstFun do_ql inst_final fun_orig (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args -- Rule IARG from Fig 4 of the QL paper: go1 pos acc fun_ty (EValArg { ea_arg = arg, ea_ctxt = ctxt } : rest_args) - = do { let herald | DoStmtOrigin <- fun_orig = ExpectedFunTySyntaxOp fun_orig tc_fun -- cf. RepPolyDoBind.hs - | otherwise = ExpectedFunTyArg (HsExprTcThing tc_fun) (unLoc arg) + = do { let herald = ExpectedFunTyArg pos (HsExprTcThing tc_fun) (unLoc arg) ; (wrap, arg_ty, res_ty) <- -- NB: matchActualFunTy does the rep-poly check. -- For example, suppose we have f :: forall r (a::TYPE r). a -> Int @@ -877,7 +876,7 @@ tcInstFun do_ql inst_final fun_orig (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args -- Make a fresh nus for each argument in rule IVAR new_arg_ty (L _ arg) i = do { arg_nu <- newOpenFlexiFRRTyVarTy $ - FRRExpectedFunTy (ExpectedFunTyArg (HsExprTcThing tc_fun) arg) i + FRRExpectedFunTy (ExpectedFunTyArg i (HsExprTcThing tc_fun) arg) i -- Following matchActualFunTy, we create nu_i :: TYPE kappa_i[conc], -- thereby ensuring that the arguments have concrete runtime representations ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -976,7 +976,7 @@ tcSynArgE orig op sigma_ty syn_ty thing_inside -- fixed RuntimeRep, as needed to call mkWpFun. ; return (result, match_wrapper <.> fun_wrap) } where - herald = ExpectedFunTySyntaxOp orig op + herald = ExpectedFunTySyntaxOp 1 orig op go rho_ty (SynType the_ty) = do { wrap <- tcSubTypePat orig GenSigCtxt the_ty rho_ty @@ -1005,7 +1005,7 @@ tcSynArgA orig op sigma_ty arg_shapes res_shape thing_inside thing_inside (arg_results ++ res_results) (map scaledMult arg_tys ++ arg_res_mults) ; return (result, match_wrapper, arg_wrappers, res_wrapper) } where - herald = ExpectedFunTySyntaxOp orig op + herald = ExpectedFunTySyntaxOp (length arg_shapes) orig op tc_syn_args_e :: [TcSigmaTypeFRR] -> [SyntaxOpType] -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -655,7 +655,7 @@ tcInferOverLit lit@(OverLit { ol_val = val ; let thing = NameThing from_name mb_thing = Just thing - herald = ExpectedFunTyArg thing (HsLit noExtField hs_lit) + herald = ExpectedFunTyArg 1 thing (HsLit noExtField hs_lit) ; (wrap2, sarg_ty, res_ty) <- matchActualFunTy herald mb_thing (1, from_ty) from_ty ; co <- unifyType mb_thing (hsLitType hs_lit) (scaledThing sarg_ty) ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -118,7 +118,7 @@ tcFunBindMatches ctxt fun_name mult matches invis_pat_tys exp_ty = assertPpr (funBindPrecondition matches) (pprMatches matches) $ do { -- Check that they all have the same no of arguments arity <- checkArgCounts matches - + ; let herald = ExpectedFunTyMatches arity (NameThing fun_name) matches ; traceTc "tcFunBindMatches 1" (ppr fun_name $$ ppr mult $$ ppr exp_ty $$ ppr arity) ; (wrap_fun, r) @@ -138,7 +138,7 @@ tcFunBindMatches ctxt fun_name mult matches invis_pat_tys exp_ty ; return (wrap_fun, r) } where mctxt = mkPrefixFunRhs (noLocA fun_name) noAnn - herald = ExpectedFunTyMatches (NameThing fun_name) matches + funBindPrecondition :: MatchGroup GhcRn (LHsExpr GhcRn) -> Bool funBindPrecondition (MG { mg_alts = L _ alts }) ===================================== compiler/GHC/Tc/Gen/Pat.hs ===================================== @@ -698,7 +698,7 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of -- Note [View patterns and polymorphism] -- Expression must be a function - ; let herald = ExpectedFunTyViewPat $ unLoc expr + ; let herald = ExpectedFunTyViewPat 1 $ unLoc expr ; (expr_wrap1, Scaled _mult inf_arg_ty, inf_res_sigma) <- matchActualFunTy herald (Just . HsExprRnThing $ unLoc expr) (1,expr_ty) expr_ty -- See Note [View patterns and polymorphism] ===================================== compiler/GHC/Tc/Types/ErrCtxt.hs ===================================== @@ -17,7 +17,7 @@ import GHC.Hs.Extension import GHC.Parser.Annotation ( LocatedN, SrcSpanAnnA ) import GHC.Tc.Errors.Types.PromotionErr ( TermLevelUseCtxt ) -import GHC.Tc.Types.Origin ( CtOrigin, UserTypeCtxt, ExpectedFunTyOrigin ) +import GHC.Tc.Types.Origin ( CtOrigin, UserTypeCtxt ) import GHC.Tc.Utils.TcType ( TcType, TcTyCon ) import GHC.Tc.Zonk.Monad ( ZonkM ) @@ -120,7 +120,7 @@ data ErrCtxtMsg -- | In a function application. | FunAppCtxt !FunAppCtxtFunArg !Int -- | In a function call. - | FunTysCtxt !ExpectedFunTyOrigin !Type !Int !Int + | FunTysCtxt !CtOrigin !Type !Int !Int -- | In the result of a function call. | FunResCtxt !(HsExpr GhcTc) !Int !Type !Type !Int !Int -- | In the declaration of a type constructor. ===================================== compiler/GHC/Tc/Types/LclEnv.hs ===================================== @@ -21,13 +21,14 @@ module GHC.Tc.Types.LclEnv ( , setLclEnvTypeEnv , modifyLclEnvTcLevel - , getLclEnvSrcCodeCtxt - , setLclEnvSrcCodeCtxt - , setLclCtxtSrcCodeCtxt + , getLclEnvSrcCodeOrigin + , setLclEnvSrcCodeOrigin + , setLclCtxtSrcCodeOrigin , lclEnvInGeneratedCode , addLclEnvErrCtxt + , ErrCtxtStack (..) , ArrowCtxt(..) , ThBindEnv , TcTypeEnv @@ -35,7 +36,7 @@ module GHC.Tc.Types.LclEnv ( import GHC.Prelude -import GHC.Hs ( SrcCodeCtxt (..), isGeneratedCodeCtxt ) +import GHC.Hs ( SrcCodeOrigin ) import GHC.Tc.Utils.TcType ( TcLevel ) import GHC.Tc.Errors.Types ( TcRnMessage ) @@ -90,11 +91,29 @@ data TcLclEnv -- Changes as we move inside an expression tcl_errs :: TcRef (Messages TcRnMessage) -- Place to accumulate diagnostics } + +data ErrCtxtStack + = UserCodeCtxt {err_ctxt :: [ErrCtxt]} + | GeneratedCodeCtxt { src_code_origin :: SrcCodeOrigin + , err_ctxt :: [ErrCtxt] } + +isGeneratedCodeCtxt :: ErrCtxtStack -> Bool +isGeneratedCodeCtxt UserCodeCtxt{} = False +isGeneratedCodeCtxt _ = True + +get_src_code_origin :: ErrCtxtStack -> Maybe SrcCodeOrigin +get_src_code_origin (UserCodeCtxt{}) = Nothing +get_src_code_origin es = Just $ src_code_origin es + +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 generated context should be ignored + + data TcLclCtxt = TcLclCtxt { tcl_loc :: RealSrcSpan, -- Source span - tcl_ctxt :: [ErrCtxt], -- Error context, innermost on top - tcl_in_gen_code :: SrcCodeCtxt, + tcl_ctxt :: ErrCtxtStack, tcl_tclvl :: TcLevel, tcl_bndrs :: TcBinderStack, -- Used for reporting relevant bindings, -- and for tidying type @@ -159,28 +178,28 @@ getLclEnvLoc :: TcLclEnv -> RealSrcSpan getLclEnvLoc = tcl_loc . tcl_lcl_ctxt getLclEnvErrCtxt :: TcLclEnv -> [ErrCtxt] -getLclEnvErrCtxt = tcl_ctxt . tcl_lcl_ctxt +getLclEnvErrCtxt = err_ctxt . tcl_ctxt . tcl_lcl_ctxt setLclEnvErrCtxt :: [ErrCtxt] -> TcLclEnv -> TcLclEnv -setLclEnvErrCtxt ctxt = modifyLclCtxt (\env -> env { tcl_ctxt = ctxt }) +setLclEnvErrCtxt ctxt = modifyLclCtxt (\env -> env { tcl_ctxt = modify_err_ctxt_stack (\ _ -> ctxt) (tcl_ctxt env) }) addLclEnvErrCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv -addLclEnvErrCtxt ctxt = modifyLclCtxt (\env -> env { tcl_ctxt = ctxt : (tcl_ctxt env) }) +addLclEnvErrCtxt ec = modifyLclCtxt (\env -> env { tcl_ctxt = modify_err_ctxt_stack (\ctxt -> ec : ctxt) (tcl_ctxt env) }) -getLclEnvSrcCodeCtxt :: TcLclEnv -> SrcCodeCtxt -getLclEnvSrcCodeCtxt = tcl_in_gen_code . tcl_lcl_ctxt +getLclEnvSrcCodeOrigin :: TcLclEnv -> Maybe SrcCodeOrigin +getLclEnvSrcCodeOrigin = get_src_code_origin . tcl_ctxt . tcl_lcl_ctxt -lclEnvInGeneratedCode :: TcLclEnv -> Bool -lclEnvInGeneratedCode = lclCtxtInGeneratedCode . tcl_lcl_ctxt +setLclEnvSrcCodeOrigin :: SrcCodeOrigin -> TcLclEnv -> TcLclEnv +setLclEnvSrcCodeOrigin o = modifyLclCtxt (setLclCtxtSrcCodeOrigin o) -lclCtxtInGeneratedCode :: TcLclCtxt -> Bool -lclCtxtInGeneratedCode = isGeneratedCodeCtxt . tcl_in_gen_code +setLclCtxtSrcCodeOrigin :: SrcCodeOrigin -> TcLclCtxt -> TcLclCtxt +setLclCtxtSrcCodeOrigin o ctxt = ctxt { tcl_ctxt = GeneratedCodeCtxt o (err_ctxt $ tcl_ctxt ctxt) } -setLclCtxtSrcCodeCtxt :: SrcCodeCtxt -> TcLclCtxt -> TcLclCtxt -setLclCtxtSrcCodeCtxt userOrGen env = env { tcl_in_gen_code = userOrGen } +lclCtxtInGeneratedCode :: TcLclCtxt -> Bool +lclCtxtInGeneratedCode = isGeneratedCodeCtxt . tcl_ctxt -setLclEnvSrcCodeCtxt :: SrcCodeCtxt -> TcLclEnv -> TcLclEnv -setLclEnvSrcCodeCtxt userOrGen = modifyLclCtxt (\ctxt -> setLclCtxtSrcCodeCtxt userOrGen ctxt) +lclEnvInGeneratedCode :: TcLclEnv -> Bool +lclEnvInGeneratedCode = lclCtxtInGeneratedCode . tcl_lcl_ctxt getLclEnvBinderStack :: TcLclEnv -> TcBinderStack getLclEnvBinderStack = tcl_bndrs . tcl_lcl_ctxt ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -19,7 +19,7 @@ module GHC.Tc.Types.Origin ( -- * CtOrigin CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin, - srcCodeCtxtCtOrigin, + srcCodeOriginCtOrigin, isVisibleOrigin, toInvisibleOrigin, pprCtOrigin, isGivenOrigin, isWantedWantedFunDepOrigin, isWantedSuperclassOrigin, @@ -45,7 +45,7 @@ module GHC.Tc.Types.Origin ( FRRArrowContext(..), pprFRRArrowContext, -- ** ExpectedFunTy FixedRuntimeRepOrigin - ExpectedFunTyOrigin(..), pprExpectedFunTyOrigin, pprExpectedFunTyHerald, + pprExpectedFunTyHerald, -- * InstanceWhat InstanceWhat(..), SafeOverlapping @@ -653,6 +653,62 @@ data CtOrigin | AmbiguityCheckOrigin UserTypeCtxt | ImplicitLiftOrigin HsImplicitLiftSplice + | ExpansionOrigin SrcCodeOrigin -- This is due to an expansion of the original thing given by SrcCodeOrigin + + + + -- | A rebindable syntax operator is expected to have a function type. + -- + -- Test cases for representation-polymorphism checks: + -- RepPolyDoBind, RepPolyDoBody{1,2}, RepPolyMc{Bind,Body,Guard}, RepPolyNPlusK + | forall (p :: Pass) + . (OutputableBndrId p) + => ExpectedFunTySyntaxOp Int + !CtOrigin !(HsExpr (GhcPass p)) + -- ^ rebindable syntax operator + + -- | A view pattern must have a function type. + -- + -- Test cases for representation-polymorphism checks: + -- RepPolyBinder + | ExpectedFunTyViewPat Int + !(HsExpr GhcRn) + -- ^ function used in the view pattern + + -- | Need to be able to extract an argument type from a function type. + -- + -- Test cases for representation-polymorphism checks: + -- RepPolyApp + | forall (p :: Pass) + . Outputable (HsExpr (GhcPass p)) => ExpectedFunTyArg + Int + -- ^ Argument number + !TypedThing + -- ^ function + !(HsExpr (GhcPass p)) + -- ^ argument + + -- | Ensure that a function defined by equations indeed has a function type + -- with the appropriate number of arguments. + -- + -- Test cases for representation-polymorphism checks: + -- RepPolyBinder, RepPolyRecordPattern, RepPolyWildcardPattern + | ExpectedFunTyMatches Int + !TypedThing + -- ^ name of the function + !(MatchGroup GhcRn (LHsExpr GhcRn)) + -- ^ equations + + -- | Ensure that a lambda abstraction has a function type. + -- + -- Test cases for representation-polymorphism checks: + -- RepPolyLambda, RepPolyMatch + | ExpectedFunTyLam HsLamVariant + !(HsExpr GhcRn) + -- ^ the entire lambda-case expression + + + data NonLinearPatternReason = LazyPatternReason | GeneralisedPatternReason @@ -737,7 +793,7 @@ exprCtOrigin (HsAppType _ e1 _) = lexprCtOrigin e1 exprCtOrigin (OpApp _ _ op _) = lexprCtOrigin op exprCtOrigin (NegApp _ e _) = lexprCtOrigin e exprCtOrigin (HsPar _ e) = lexprCtOrigin e -exprCtOrigin (HsProjection _ _) = SectionOrigin +exprCtOrigin e@(HsProjection _ _) = ExpansionOrigin (OrigExpr e) exprCtOrigin (SectionL _ _ _) = SectionOrigin exprCtOrigin (SectionR _ _ _) = SectionOrigin exprCtOrigin (ExplicitTuple {}) = Shouldn'tHappenOrigin "explicit tuple" @@ -763,18 +819,14 @@ exprCtOrigin (HsHole _) = Shouldn'tHappenOrigin "hole expression" exprCtOrigin (HsForAll {}) = Shouldn'tHappenOrigin "forall telescope" -- See Note [Types in terms] exprCtOrigin (HsQual {}) = Shouldn'tHappenOrigin "constraint context" -- See Note [Types in terms] exprCtOrigin (HsFunArr {}) = Shouldn'tHappenOrigin "function arrow" -- See Note [Types in terms] -exprCtOrigin (XExpr (ExpandedThingRn o _)) = srcCodeOriginCtOrigin o +exprCtOrigin (XExpr (ExpandedThingRn o _)) = ExpansionOrigin o exprCtOrigin (XExpr (PopErrCtxt e)) = exprCtOrigin e exprCtOrigin (XExpr (HsRecSelRn f)) = OccurrenceOfRecSel (foExt f) -srcCodeOriginCtOrigin :: SrcCodeOrigin -> CtOrigin -srcCodeOriginCtOrigin (OrigExpr e) = exprCtOrigin e -srcCodeOriginCtOrigin (OrigStmt{}) = DoStmtOrigin -srcCodeOriginCtOrigin (OrigPat p) = DoPatOrigin p -srcCodeCtxtCtOrigin :: HsExpr GhcRn -> SrcCodeCtxt -> CtOrigin -srcCodeCtxtCtOrigin e UserCode = exprCtOrigin e -srcCodeCtxtCtOrigin _ (GeneratedCode e) = srcCodeOriginCtOrigin e +srcCodeOriginCtOrigin :: HsExpr GhcRn -> Maybe SrcCodeOrigin -> CtOrigin +srcCodeOriginCtOrigin e Nothing = exprCtOrigin e +srcCodeOriginCtOrigin _ (Just e) = ExpansionOrigin e -- | Extract a suitable CtOrigin from a MatchGroup matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin @@ -800,6 +852,14 @@ pprCtOrigin :: CtOrigin -> SDoc pprCtOrigin (GivenOrigin sk) = ctoHerald <+> ppr sk +pprCtOrigin (ExpansionOrigin o) + = ctoHerald <+> what + where what :: SDoc + what = case o of + OrigStmt{} -> text "a do statement" + OrigExpr e -> pprCtO (exprCtOrigin e) + OrigPat p -> text "a pattern" <+> ppr p + pprCtOrigin (GivenSCOrigin sk d blk) = vcat [ ctoHerald <+> pprSkolInfo sk , whenPprDebug (braces (text "given-sc:" <+> ppr d <> comma <> ppr blk)) ] @@ -912,9 +972,38 @@ pprCtOrigin (NonLinearPatternOrigin reason pat) = hang (ctoHerald <+> text "a non-linear pattern" <+> quotes (ppr pat)) 2 (pprNonLinearPatternReason reason) +pprCtOrigin (ExpectedFunTySyntaxOp i orig op) = + vcat [ sep [ the_arg_of i + , text "the rebindable syntax operator" + , quotes (ppr op) ] + , nest 2 (ppr orig) ] +pprCtOrigin (ExpectedFunTyViewPat i expr) = + vcat [ the_arg_of i <+> text "the view pattern" + , nest 2 (ppr expr) ] +pprCtOrigin (ExpectedFunTyArg i fun arg) = + sep [ text "The" <+> speakNth i <+> text "argument" + , quotes (ppr arg) + , text "of" + , quotes (ppr fun) ] +pprCtOrigin (ExpectedFunTyMatches i fun (MG { mg_alts = L _ alts })) + | null alts + = the_arg_of i <+> quotes (ppr fun) + | otherwise + = text "The" <+> speakNth i <+> text "pattern in the equation" <> plural alts + <+> text "for" <+> quotes (ppr fun) +pprCtOrigin (ExpectedFunTyLam lam_variant _) = binder_of $ lamCaseKeyword lam_variant + pprCtOrigin simple_origin = ctoHerald <+> pprCtO simple_origin + +the_arg_of :: Int -> SDoc +the_arg_of i = text "The" <+> speakNth i <+> text "argument of" + +binder_of :: SDoc -> SDoc +binder_of what = text "The binder of the" <+> what <+> text "expression" + + -- | Short one-liners pprCtO :: HasDebugCallStack => CtOrigin -> SDoc pprCtO (OccurrenceOf name) = hsep [text "a use of", quotes (ppr name)] @@ -940,7 +1029,7 @@ pprCtO (ScOrigin (IsQC {}) _) = text "the head of a quantified constraint" pprCtO DerivClauseOrigin = text "the 'deriving' clause of a data type declaration" pprCtO StandAloneDerivOrigin = text "a 'deriving' declaration" pprCtO DefaultOrigin = text "a 'default' declaration" -pprCtO DoStmtOrigin = text "a do statement" +pprCtO DoStmtOrigin = text "a do statement" pprCtO MCompOrigin = text "a statement in a monad comprehension" pprCtO ProcOrigin = text "a proc expression" pprCtO ArrowCmdOrigin = text "an arrow command" @@ -983,6 +1072,14 @@ pprCtO (InstanceSigOrigin {}) = text "a type signature in an instance" pprCtO (AmbiguityCheckOrigin {}) = text "a type ambiguity check" pprCtO (ImpedanceMatching {}) = text "combining required constraints" pprCtO (NonLinearPatternOrigin _ pat) = hsep [text "a non-linear pattern" <+> quotes (ppr pat)] +pprCtO (ExpansionOrigin (OrigPat p)) = hsep [text "a pattern" <+> quotes (ppr p)] +pprCtO (ExpansionOrigin (OrigStmt{})) = text "a do statement" +pprCtO (ExpansionOrigin (OrigExpr e)) = text "an expression" <+> ppr e +pprCtO (ExpectedFunTySyntaxOp{}) = text "a rebindable syntax operator" +pprCtO (ExpectedFunTyViewPat{}) = text "a view pattern" +pprCtO (ExpectedFunTyArg{}) = text "a funtion head" +pprCtO (ExpectedFunTyMatches{}) = text "a match statement" +pprCtO (ExpectedFunTyLam{}) = text "a lambda expression" pprNonLinearPatternReason :: HasDebugCallStack => NonLinearPatternReason -> SDoc pprNonLinearPatternReason LazyPatternReason = parens (text "non-variable lazy pattern aren't linear") @@ -1195,7 +1292,7 @@ data FixedRuntimeRepContext -- -- See 'ExpectedFunTyOrigin' for more details. | FRRExpectedFunTy - !ExpectedFunTyOrigin + !CtOrigin -- !ExpectedFunTyOrigin !Int -- ^ argument position (1-indexed) @@ -1228,11 +1325,10 @@ mkFRRUnboxedSum = FRRUnboxedSum -- and is reported separately. pprFixedRuntimeRepContext :: FixedRuntimeRepContext -> SDoc pprFixedRuntimeRepContext (FRRRecordCon lbl _arg) - = sep [ text "The field", quotes (ppr lbl) + = sep [ text "The field", quotes (ppr lbl) -- TODO ANI: Where does this get used? Add missing test? , text "of the record constructor" ] -pprFixedRuntimeRepContext (FRRRecordUpdate lbl _arg) - = sep [ text "The record update at field" - , quotes (ppr lbl) ] +pprFixedRuntimeRepContext (FRRRecordUpdate lbl _) + = sep [ text "The field", quotes (ppr lbl) ] pprFixedRuntimeRepContext (FRRBinder binder) = sep [ text "The binder" , quotes (ppr binder) ] @@ -1277,8 +1373,8 @@ pprFixedRuntimeRepContext FRRBindStmtGuard = sep [ text "The body of the bind statement" ] pprFixedRuntimeRepContext (FRRArrow arrowContext) = pprFRRArrowContext arrowContext -pprFixedRuntimeRepContext (FRRExpectedFunTy funTyOrig arg_pos) - = pprExpectedFunTyOrigin funTyOrig arg_pos +pprFixedRuntimeRepContext (FRRExpectedFunTy funTyOrig _) + = pprCtOrigin funTyOrig instance Outputable FixedRuntimeRepContext where ppr = pprFixedRuntimeRepContext @@ -1431,102 +1527,56 @@ instance Outputable FRRArrowContext where -- Uses 'pprExpectedFunTyOrigin'. -- See 'FixedRuntimeRepContext' for the situations in which -- representation-polymorphism checks are performed. -data ExpectedFunTyOrigin - - -- | A rebindable syntax operator is expected to have a function type. - -- - -- Test cases for representation-polymorphism checks: - -- RepPolyDoBind, RepPolyDoBody{1,2}, RepPolyMc{Bind,Body,Guard}, RepPolyNPlusK - = forall (p :: Pass) - . (OutputableBndrId p) - => ExpectedFunTySyntaxOp !CtOrigin !(HsExpr (GhcPass p)) - -- ^ rebindable syntax operator - - -- | A view pattern must have a function type. - -- - -- Test cases for representation-polymorphism checks: - -- RepPolyBinder - | ExpectedFunTyViewPat - !(HsExpr GhcRn) - -- ^ function used in the view pattern - - -- | Need to be able to extract an argument type from a function type. - -- - -- Test cases for representation-polymorphism checks: - -- RepPolyApp - | forall (p :: Pass) - . Outputable (HsExpr (GhcPass p)) => ExpectedFunTyArg - !TypedThing - -- ^ function - !(HsExpr (GhcPass p)) - -- ^ argument - - -- | Ensure that a function defined by equations indeed has a function type - -- with the appropriate number of arguments. - -- - -- Test cases for representation-polymorphism checks: - -- RepPolyBinder, RepPolyRecordPattern, RepPolyWildcardPattern - | ExpectedFunTyMatches - !TypedThing - -- ^ name of the function - !(MatchGroup GhcRn (LHsExpr GhcRn)) - -- ^ equations - - -- | Ensure that a lambda abstraction has a function type. - -- - -- Test cases for representation-polymorphism checks: - -- RepPolyLambda, RepPolyMatch - | ExpectedFunTyLam HsLamVariant - !(HsExpr GhcRn) - -- ^ the entire lambda-case expression - -pprExpectedFunTyOrigin :: ExpectedFunTyOrigin - -> Int -- ^ argument position (starting at 1) - -> SDoc -pprExpectedFunTyOrigin funTy_origin i = - case funTy_origin of - ExpectedFunTySyntaxOp orig op -> - vcat [ sep [ the_arg_of - , text "the rebindable syntax operator" - , quotes (ppr op) ] - , nest 2 (ppr orig) ] - ExpectedFunTyViewPat expr -> - vcat [ the_arg_of <+> text "the view pattern" - , nest 2 (ppr expr) ] - ExpectedFunTyArg fun arg -> - sep [ text "The argument" - , quotes (ppr arg) - , text "of" - , quotes (ppr fun) ] - ExpectedFunTyMatches fun (MG { mg_alts = L _ alts }) - | null alts - -> the_arg_of <+> quotes (ppr fun) - | otherwise - -> text "The" <+> speakNth i <+> text "pattern in the equation" <> plural alts - <+> text "for" <+> quotes (ppr fun) - ExpectedFunTyLam lam_variant _ -> binder_of $ lamCaseKeyword lam_variant - where - the_arg_of :: SDoc - the_arg_of = text "The" <+> speakNth i <+> text "argument of" - binder_of :: SDoc -> SDoc - binder_of what = text "The binder of the" <+> what <+> text "expression" -pprExpectedFunTyHerald :: ExpectedFunTyOrigin -> SDoc +-- pprExpectedFunTyOrigin :: -- ExpectedFunTyOrigin +-- -- -> Int -- ^ argument position (starting at 1) +-- -> SDoc +-- pprExpectedFunTyOrigin funTy_origin = +-- case funTy_origin of +-- ExpectedFunTySyntaxOp i orig op -> +-- vcat [ sep [ the_arg_of +-- , text "the rebindable syntax operator" +-- , quotes (ppr op) ] +-- , nest 2 (ppr orig) ] +-- ExpectedFunTyViewPat i expr -> +-- vcat [ the_arg_of <+> text "the view pattern" +-- , nest 2 (ppr expr) ] +-- ExpectedFunTyArg fun arg -> +-- sep [ text "The argument" +-- , quotes (ppr arg) +-- , text "of" +-- , quotes (ppr fun) ] +-- ExpectedFunTyMatches i fun (MG { mg_alts = L _ alts }) +-- | null alts +-- -> the_arg_of <+> quotes (ppr fun) +-- | otherwise +-- -> text "The" <+> speakNth i <+> text "pattern in the equation" <> plural alts +-- <+> text "for" <+> quotes (ppr fun) +-- ExpectedFunTyLam lam_variant _ -> binder_of $ lamCaseKeyword lam_variant +-- where +-- the_arg_of :: Int -> SDoc +-- the_arg_of i = text "The" <+> speakNth i <+> text "argument of" + +-- binder_of :: SDoc -> SDoc +-- binder_of what = text "The binder of the" <+> what <+> text "expression" + +pprExpectedFunTyHerald :: CtOrigin -> SDoc pprExpectedFunTyHerald (ExpectedFunTySyntaxOp {}) = text "This rebindable syntax expects a function with" pprExpectedFunTyHerald (ExpectedFunTyViewPat {}) = text "A view pattern expression expects" -pprExpectedFunTyHerald (ExpectedFunTyArg fun _) +pprExpectedFunTyHerald (ExpectedFunTyArg _ fun _) = sep [ text "The function" <+> quotes (ppr fun) , text "is applied to" ] -pprExpectedFunTyHerald (ExpectedFunTyMatches fun (MG { mg_alts = L _ alts })) +pprExpectedFunTyHerald (ExpectedFunTyMatches _ fun (MG { mg_alts = L _ alts })) = text "The equation" <> plural alts <+> text "for" <+> quotes (ppr fun) <+> hasOrHave alts pprExpectedFunTyHerald (ExpectedFunTyLam lam_variant expr) = sep [ text "The" <+> lamCaseKeyword lam_variant <+> text "expression" <+> quotes (pprSetDepth (PartWay 1) (ppr expr)) -- The pprSetDepth makes the lambda abstraction print briefly , text "has" ] +pprExpectedFunTyHerald orig = ppr (Shouldn'tHappenOrigin "pprExpectedFunTyHerald") <+> ppr orig {- ******************************************************************* * * ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -58,7 +58,7 @@ module GHC.Tc.Utils.Monad( addDependentFiles, -- * Error management - getSrcCodeCtxt, + getSrcCodeOrigin, getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, inGeneratedCode, setInGeneratedCode, wrapLocM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_, @@ -400,8 +400,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_in_gen_code = UserCode, - tcl_ctxt = [], + tcl_ctxt = UserCodeCtxt [], tcl_rdr = emptyLocalRdrEnv, tcl_th_ctxt = topLevel, tcl_th_bndrs = emptyNameEnv, @@ -978,21 +977,21 @@ setSrcSpan :: SrcSpan -> TcRn a -> TcRn a -- See Note [Error contexts in generated code] -- for the tcl_in_gen_code manipulation setSrcSpan (RealSrcSpan loc _) thing_inside - = updLclCtxt (\env -> env { tcl_loc = loc, tcl_in_gen_code = UserCode }) + = updLclCtxt (\env -> env { tcl_loc = loc, tcl_ctxt = UserCodeCtxt (err_ctxt $ tcl_ctxt env)}) thing_inside setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside -getSrcCodeCtxt :: TcRn SrcCodeCtxt -getSrcCodeCtxt = getLclEnvSrcCodeCtxt <$> getLclEnv +getSrcCodeOrigin :: TcRn (Maybe SrcCodeOrigin) +getSrcCodeOrigin = getLclEnvSrcCodeOrigin <$> getLclEnv -- | Mark the inner computation as being done inside generated code. -- -- See Note [Error contexts in generated code] setInGeneratedCode :: SrcCodeOrigin -> TcRn a -> TcRn a -setInGeneratedCode scOrig thing_inside = - updLclCtxt (setLclCtxtSrcCodeCtxt (GeneratedCode scOrig)) thing_inside +setInGeneratedCode sco thing_inside = + updLclCtxt (setLclCtxtSrcCodeOrigin sco) thing_inside setSrcSpanA :: EpAnn ann -> TcRn a -> TcRn a setSrcSpanA l = setSrcSpan (locA l) ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -135,7 +135,7 @@ import Data.Traversable (for) -- -- See Note [Return arguments with a fixed RuntimeRep]. matchActualFunTy - :: ExpectedFunTyOrigin + :: CtOrigin -- ^ See Note [Herald for matchExpectedFunTys] -> Maybe TypedThing -- ^ The thing with type TcSigmaType @@ -241,7 +241,7 @@ Ugh! -- INVARIANT: the returned argument types all have a syntactically fixed RuntimeRep -- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. -- See Note [Return arguments with a fixed RuntimeRep]. -matchActualFunTys :: ExpectedFunTyOrigin -- ^ See Note [Herald for matchExpectedFunTys] +matchActualFunTys :: CtOrigin -- ^ See Note [Herald for matchExpectedFunTys] -> CtOrigin -> Arity -> TcSigmaType @@ -776,7 +776,7 @@ Example: -- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. -- See Note [Return arguments with a fixed RuntimeRep]. matchExpectedFunTys :: forall a. - ExpectedFunTyOrigin -- See Note [Herald for matchExpectedFunTys] + CtOrigin -- See Note [Herald for matchExpectedFunTys] -> UserTypeCtxt -> VisArity -> ExpSigmaType @@ -905,19 +905,19 @@ matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside ; co <- unifyType Nothing (mkScaledFunTys more_arg_tys res_ty) fun_ty ; return (mkWpCastN co, result) } -new_infer_arg_ty :: ExpectedFunTyOrigin -> Int -> TcM (Scaled ExpSigmaTypeFRR) +new_infer_arg_ty :: CtOrigin -> Int -> TcM (Scaled ExpSigmaTypeFRR) new_infer_arg_ty herald arg_pos -- position for error messages only = do { mult <- newFlexiTyVarTy multiplicityTy ; inf_hole <- newInferExpTypeFRR (FRRExpectedFunTy herald arg_pos) ; return (mkScaled mult inf_hole) } -new_check_arg_ty :: ExpectedFunTyOrigin -> Int -> TcM (Scaled TcType) +new_check_arg_ty :: CtOrigin -> Int -> TcM (Scaled TcType) new_check_arg_ty herald arg_pos -- Position for error messages only, 1 for first arg = do { mult <- newFlexiTyVarTy multiplicityTy ; arg_ty <- newOpenFlexiFRRTyVarTy (FRRExpectedFunTy herald arg_pos) ; return (mkScaled mult arg_ty) } -mkFunTysMsg :: ExpectedFunTyOrigin +mkFunTysMsg :: CtOrigin -> (VisArity, TcType) -> TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg) -- See Note [Reporting application arity errors] ===================================== testsuite/tests/deSugar/should_compile/T10662.stderr ===================================== @@ -1,6 +1,6 @@ -T10662.hs:2:8: warning: [GHC-81995] [-Wunused-do-bind (in -Wall)] + +T10662.hs:3:3: warning: [GHC-81995] [-Wunused-do-bind (in -Wall)] A do-notation statement discarded a result of type ‘String’ Suggested fix: Suppress this warning by saying ‘_ <- return $ let a = "hello" in a’ - ===================================== testsuite/tests/deSugar/should_compile/T3263-1.stderr ===================================== @@ -1,8 +1,8 @@ -T3263-1.hs:24:6: warning: [GHC-81995] [-Wunused-do-bind (in -Wall)] + +T3263-1.hs:25:3: warning: [GHC-81995] [-Wunused-do-bind (in -Wall)] A do-notation statement discarded a result of type ‘Int’ Suggested fix: Suppress this warning by saying ‘_ <- nonNullM’ -T3263-1.hs:34:6: warning: [GHC-81995] [-Wunused-do-bind (in -Wall)] +T3263-1.hs:35:3: warning: [GHC-81995] [-Wunused-do-bind (in -Wall)] A do-notation statement discarded a result of type ‘Int’ Suggested fix: Suppress this warning by saying ‘_ <- nonNullM’ - ===================================== testsuite/tests/deSugar/should_compile/T3263-2.stderr ===================================== @@ -1,10 +1,10 @@ -T3263-2.hs:24:6: warning: [GHC-08838] [-Wwrong-do-bind (in -Wdefault)] + +T3263-2.hs:25:3: warning: [GHC-08838] [-Wwrong-do-bind (in -Wdefault)] A do-notation statement discarded a result of type ‘m Int’ Suggested fix: Suppress this warning by saying ‘_ <- return (return 10 :: m Int)’ -T3263-2.hs:36:6: warning: [GHC-08838] [-Wwrong-do-bind (in -Wdefault)] +T3263-2.hs:37:3: warning: [GHC-08838] [-Wwrong-do-bind (in -Wdefault)] A do-notation statement discarded a result of type ‘m Int’ Suggested fix: Suppress this warning by saying ‘_ <- return (return 10 :: m Int)’ - ===================================== testsuite/tests/ghci.debugger/scripts/break029.script ===================================== @@ -1,4 +1,5 @@ :load break029.hs :step f 3 :step +:step y ===================================== testsuite/tests/rep-poly/RepPolyRecordUpdate.stderr ===================================== @@ -13,8 +13,7 @@ RepPolyRecordUpdate.hs:7:35: error: [GHC-55287] X a :: TYPE rep RepPolyRecordUpdate.hs:13:9: error: [GHC-55287] - • The argument ‘fld’ of ‘MkX’ - does not have a fixed runtime representation. + • The field ‘fld’ does not have a fixed runtime representation. Its type is: a0 :: TYPE rep0 When unifying: View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b8b26e98f2b3699aba58e9c3928e71c... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b8b26e98f2b3699aba58e9c3928e71c... You're receiving this email because of your account on gitlab.haskell.org.