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
3 changed files:
Changes:
| ... | ... | @@ -106,7 +106,7 @@ expand_do_stmts doFlavour (stmt@(L loc (BindStmt xbsrn pat e)): lstmts) |
| 106 | 106 | -- -------------------------------------------------------
|
| 107 | 107 | -- pat <- e ; stmts ~~> (>>=) e f
|
| 108 | 108 | = do expand_stmts_expr <- expand_do_stmts doFlavour lstmts
|
| 109 | - failable_expr <- mk_failable_expr doFlavour pat stmt expand_stmts_expr fail_op
|
|
| 109 | + failable_expr <- mk_failable_expr doFlavour pat expand_stmts_expr fail_op
|
|
| 110 | 110 | let expansion = genHsExpApps bind_op -- (>>=)
|
| 111 | 111 | [ e
|
| 112 | 112 | , failable_expr ]
|
| ... | ... | @@ -177,9 +177,9 @@ expand_do_stmts doFlavour |
| 177 | 177 | expand_do_stmts _ stmts = pprPanic "expand_do_stmts: impossible happened" $ (ppr stmts)
|
| 178 | 178 | |
| 179 | 179 | -- checks the pattern `pat` for irrefutability which decides if we need to wrap it with a fail block
|
| 180 | -mk_failable_expr :: HsDoFlavour -> LPat GhcRn -> ExprLStmt GhcRn -> LHsExpr GhcRn
|
|
| 180 | +mk_failable_expr :: HsDoFlavour -> LPat GhcRn -> LHsExpr GhcRn
|
|
| 181 | 181 | -> FailOperator GhcRn -> TcM (LHsExpr GhcRn)
|
| 182 | -mk_failable_expr doFlav lpat stmt expr fail_op =
|
|
| 182 | +mk_failable_expr doFlav lpat expr fail_op =
|
|
| 183 | 183 | do { is_strict <- xoptM LangExt.Strict
|
| 184 | 184 | ; hscEnv <- getTopEnv
|
| 185 | 185 | ; rdrEnv <- getGlobalRdrEnv
|
| ... | ... | @@ -191,16 +191,16 @@ mk_failable_expr doFlav lpat stmt expr fail_op = |
| 191 | 191 | ; if irrf_pat -- don't wrap with fail block if
|
| 192 | 192 | -- the pattern is irrefutable
|
| 193 | 193 | then return $ genHsLamDoExp doFlav [lpat] expr
|
| 194 | - else wrapGenSpan <$> mk_fail_block doFlav lpat stmt expr fail_op
|
|
| 194 | + else wrapGenSpan <$> mk_fail_block doFlav lpat expr fail_op
|
|
| 195 | 195 | }
|
| 196 | 196 | |
| 197 | 197 | -- | Makes the fail block with a given fail_op
|
| 198 | 198 | -- mk_fail_block pat rhs fail builds
|
| 199 | 199 | -- \x. case x of {pat -> rhs; _ -> fail "Pattern match failure..."}
|
| 200 | 200 | mk_fail_block :: HsDoFlavour
|
| 201 | - -> LPat GhcRn -> ExprLStmt GhcRn
|
|
| 201 | + -> LPat GhcRn
|
|
| 202 | 202 | -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (HsExpr GhcRn)
|
| 203 | -mk_fail_block doFlav pat stmt e (Just (SyntaxExprRn fail_op)) =
|
|
| 203 | +mk_fail_block doFlav pat e (Just (SyntaxExprRn fail_op)) =
|
|
| 204 | 204 | do dflags <- getDynFlags
|
| 205 | 205 | return $ HsLam noAnn LamCases $ mkMatchGroup (doExpansionOrigin doFlav) -- \
|
| 206 | 206 | (wrapGenSpan [ genHsCaseAltDoExp doFlav pat e -- pat -> expr
|
| ... | ... | @@ -218,10 +218,10 @@ mk_fail_block doFlav pat stmt e (Just (SyntaxExprRn fail_op)) = |
| 218 | 218 | mk_fail_msg_expr :: DynFlags -> LPat GhcRn -> LHsExpr GhcRn
|
| 219 | 219 | mk_fail_msg_expr dflags pat
|
| 220 | 220 | = nlHsLit $ mkHsString $ showPpr dflags $
|
| 221 | - text "Pattern match failure in" <+> pprHsDoFlavour (DoExpr Nothing)
|
|
| 221 | + text "Pattern match failure in" <+> pprHsDoFlavour doFlav
|
|
| 222 | 222 | <+> text "at" <+> ppr (getLocA pat)
|
| 223 | 223 | |
| 224 | -mk_fail_block _ _ _ _ _ = pprPanic "mk_fail_block: impossible happened" empty
|
|
| 224 | +mk_fail_block _ _ _ _ = pprPanic "mk_fail_block: impossible happened" empty
|
|
| 225 | 225 | |
| 226 | 226 | |
| 227 | 227 | {- Note [Expanding HsDo with XXExprGhcRn]
|
| ... | ... | @@ -1484,7 +1484,7 @@ pprExpectedFunTyCtxt funTy_origin i = |
| 1484 | 1484 | case funTy_origin of
|
| 1485 | 1485 | ExpectedFunTySyntaxOp orig op ->
|
| 1486 | 1486 | vcat [ sep [ the_arg_of
|
| 1487 | - , text "The rebindable syntax operator"
|
|
| 1487 | + , text "the rebindable syntax operator"
|
|
| 1488 | 1488 | , quotes (ppr op) ]
|
| 1489 | 1489 | , nest 2 (ppr orig) ]
|
| 1490 | 1490 | ExpectedTySyntax orig arg ->
|
| ... | ... | @@ -91,12 +91,14 @@ import GHC.Core.Predicate |
| 91 | 91 | import GHC.Utils.Constants
|
| 92 | 92 | import GHC.Utils.Outputable as Outputable
|
| 93 | 93 | import GHC.Utils.Misc
|
| 94 | -import GHC.Utils.Monad ( mapAccumLM )
|
|
| 94 | +import GHC.Utils.Monad ( mapAccumLM, liftIO )
|
|
| 95 | 95 | import GHC.Utils.Panic
|
| 96 | 96 | |
| 97 | 97 | import GHC.Data.Bag
|
| 98 | 98 | import GHC.Data.Pair
|
| 99 | 99 | |
| 100 | +import GHC.IORef (readIORef)
|
|
| 101 | + |
|
| 100 | 102 | import Data.Semigroup
|
| 101 | 103 | import Data.Maybe
|
| 102 | 104 | |
| ... | ... | @@ -795,11 +797,6 @@ tidyEvVar env var = updateIdTypeAndMult (tidyType env) var |
| 795 | 797 | -- No need for tidyOpenType because all the free tyvars are already tidied
|
| 796 | 798 | |
| 797 | 799 | |
| 798 | - |
|
| 799 | -{-
|
|
| 800 | -Zonk ErrCtxtMsg
|
|
| 801 | --}
|
|
| 802 | - |
|
| 803 | 800 | zonkTidyErrCtxtMsg :: TidyEnv -> ErrCtxtMsg -> ZonkM (TidyEnv, ErrCtxtMsg)
|
| 804 | 801 | zonkTidyErrCtxtMsg env e@(ExprCtxt{}) = return (env, e)
|
| 805 | 802 | zonkTidyErrCtxtMsg env (ThetaCtxt ctxt theta_ty) = do
|
| ... | ... | @@ -823,7 +820,15 @@ zonkTidyErrCtxtMsg env (FunResCtxt e i1 ty1 ty2 i2 i3) = do |
| 823 | 820 | (env', ty1') <- zonkTidyTcType env ty1
|
| 824 | 821 | (env', ty2') <- zonkTidyTcType env' ty2
|
| 825 | 822 | return $ (env', FunResCtxt e i1 ty1' ty2' i2 i3)
|
| 826 | --- zonkTidyErrCtxtMsg env (PatSigErrCtxt sig_ty res_ty) = do
|
|
| 827 | --- (env', sig_ty) <- zonkTidyTcType env sig_ty
|
|
| 828 | --- (env', res_ty) <- zonkZidy
|
|
| 823 | +zonkTidyErrCtxtMsg env (PatSigErrCtxt sig_ty res_ty) = do
|
|
| 824 | + (env', sig_ty') <- zonkTidyTcType env sig_ty
|
|
| 825 | + (env', res_ty') <-
|
|
| 826 | + case res_ty of
|
|
| 827 | + Check ty -> zonkTidyTcType env' ty
|
|
| 828 | + Infer (IR {ir_ref = ref}) -> do -- inlining readExpTyp_maybe to avoid module dep loops
|
|
| 829 | + mb_ty <- liftIO $ readIORef ref
|
|
| 830 | + case mb_ty of
|
|
| 831 | + Nothing -> error "zonkTidyErrCtxtMsg PatSigErrCtxt"
|
|
| 832 | + Just ty -> zonkTidyTcType env' ty
|
|
| 833 | + return (env', PatSigErrCtxt sig_ty' (Check res_ty'))
|
|
| 829 | 834 | zonkTidyErrCtxtMsg env p = return (env, p) |