Apoorv Ingle pushed to branch wip/ani/kill-SrcCodeOrigin at Glasgow Haskell Compiler / GHC Commits: d0f2dc6f by Apoorv Ingle at 2026-03-09T22:17:16-05:00 add zonking for PatSigErrCtxt, fix err string for pprExpectedFunTyCtxt - - - - - 3 changed files: - compiler/GHC/Tc/Gen/Do.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Zonk/TcType.hs Changes: ===================================== compiler/GHC/Tc/Gen/Do.hs ===================================== @@ -106,7 +106,7 @@ 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 stmt expand_stmts_expr fail_op + failable_expr <- mk_failable_expr doFlavour pat expand_stmts_expr fail_op let expansion = genHsExpApps bind_op -- (>>=) [ e , failable_expr ] @@ -177,9 +177,9 @@ expand_do_stmts doFlavour expand_do_stmts _ stmts = pprPanic "expand_do_stmts: impossible happened" $ (ppr stmts) -- checks the pattern `pat` for irrefutability which decides if we need to wrap it with a fail block -mk_failable_expr :: HsDoFlavour -> LPat GhcRn -> ExprLStmt GhcRn -> LHsExpr GhcRn +mk_failable_expr :: HsDoFlavour -> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn) -mk_failable_expr doFlav lpat stmt expr fail_op = +mk_failable_expr doFlav lpat expr fail_op = do { is_strict <- xoptM LangExt.Strict ; hscEnv <- getTopEnv ; rdrEnv <- getGlobalRdrEnv @@ -191,16 +191,16 @@ mk_failable_expr doFlav lpat stmt expr fail_op = ; if irrf_pat -- don't wrap with fail block if -- the pattern is irrefutable then return $ genHsLamDoExp doFlav [lpat] expr - else wrapGenSpan <$> mk_fail_block doFlav lpat stmt expr fail_op + else wrapGenSpan <$> mk_fail_block doFlav lpat expr fail_op } -- | Makes the fail block with a given fail_op -- mk_fail_block pat rhs fail builds -- \x. case x of {pat -> rhs; _ -> fail "Pattern match failure..."} mk_fail_block :: HsDoFlavour - -> LPat GhcRn -> ExprLStmt GhcRn + -> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (HsExpr GhcRn) -mk_fail_block doFlav pat stmt e (Just (SyntaxExprRn fail_op)) = +mk_fail_block doFlav pat e (Just (SyntaxExprRn fail_op)) = do dflags <- getDynFlags return $ HsLam noAnn LamCases $ mkMatchGroup (doExpansionOrigin doFlav) -- \ (wrapGenSpan [ genHsCaseAltDoExp doFlav pat e -- pat -> expr @@ -218,10 +218,10 @@ mk_fail_block doFlav pat stmt e (Just (SyntaxExprRn fail_op)) = mk_fail_msg_expr :: DynFlags -> LPat GhcRn -> LHsExpr GhcRn mk_fail_msg_expr dflags pat = nlHsLit $ mkHsString $ showPpr dflags $ - text "Pattern match failure in" <+> pprHsDoFlavour (DoExpr Nothing) + text "Pattern match failure in" <+> pprHsDoFlavour doFlav <+> text "at" <+> ppr (getLocA pat) -mk_fail_block _ _ _ _ _ = pprPanic "mk_fail_block: impossible happened" empty +mk_fail_block _ _ _ _ = pprPanic "mk_fail_block: impossible happened" empty {- Note [Expanding HsDo with XXExprGhcRn] ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -1484,7 +1484,7 @@ pprExpectedFunTyCtxt funTy_origin i = case funTy_origin of ExpectedFunTySyntaxOp orig op -> vcat [ sep [ the_arg_of - , text "The rebindable syntax operator" + , text "the rebindable syntax operator" , quotes (ppr op) ] , nest 2 (ppr orig) ] ExpectedTySyntax orig arg -> ===================================== compiler/GHC/Tc/Zonk/TcType.hs ===================================== @@ -91,12 +91,14 @@ import GHC.Core.Predicate import GHC.Utils.Constants import GHC.Utils.Outputable as Outputable import GHC.Utils.Misc -import GHC.Utils.Monad ( mapAccumLM ) +import GHC.Utils.Monad ( mapAccumLM, liftIO ) import GHC.Utils.Panic import GHC.Data.Bag import GHC.Data.Pair +import GHC.IORef (readIORef) + import Data.Semigroup import Data.Maybe @@ -795,11 +797,6 @@ tidyEvVar env var = updateIdTypeAndMult (tidyType env) var -- No need for tidyOpenType because all the free tyvars are already tidied - -{- -Zonk ErrCtxtMsg --} - zonkTidyErrCtxtMsg :: TidyEnv -> ErrCtxtMsg -> ZonkM (TidyEnv, ErrCtxtMsg) zonkTidyErrCtxtMsg env e@(ExprCtxt{}) = return (env, e) zonkTidyErrCtxtMsg env (ThetaCtxt ctxt theta_ty) = do @@ -823,7 +820,15 @@ zonkTidyErrCtxtMsg env (FunResCtxt e i1 ty1 ty2 i2 i3) = do (env', ty1') <- zonkTidyTcType env ty1 (env', ty2') <- zonkTidyTcType env' ty2 return $ (env', FunResCtxt e i1 ty1' ty2' i2 i3) --- zonkTidyErrCtxtMsg env (PatSigErrCtxt sig_ty res_ty) = do --- (env', sig_ty) <- zonkTidyTcType env sig_ty --- (env', res_ty) <- zonkZidy +zonkTidyErrCtxtMsg env (PatSigErrCtxt sig_ty res_ty) = do + (env', sig_ty') <- zonkTidyTcType env sig_ty + (env', res_ty') <- + case res_ty of + Check ty -> zonkTidyTcType env' ty + Infer (IR {ir_ref = ref}) -> do -- inlining readExpTyp_maybe to avoid module dep loops + mb_ty <- liftIO $ readIORef ref + case mb_ty of + Nothing -> error "zonkTidyErrCtxtMsg PatSigErrCtxt" + Just ty -> zonkTidyTcType env' ty + return (env', PatSigErrCtxt sig_ty' (Check res_ty')) zonkTidyErrCtxtMsg env p = return (env, p) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d0f2dc6f165950916dffea8aa0adc3de... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d0f2dc6f165950916dffea8aa0adc3de... You're receiving this email because of your account on gitlab.haskell.org.