[Git][ghc/ghc][wip/spj-apporv-Oct24] fix for MonadFailErrors test case

24 Nov 2025


      Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC


Commits:
bc6cb681 by Apoorv Ingle at 2025-11-23T19:02:48-06:00
fix for MonadFailErrors test case

- - - - -


4 changed files:

- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Types/ErrCtxt.hs
- compiler/GHC/Tc/Types/Origin.hs


Changes:

=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -675,7 +675,7 @@ type instance XXExpr GhcTc = XXExprGhcTc
 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
+  | OrigPat  (ExprLStmt GhcRn) (Pat GhcRn) -- ^ Used for failable patterns that trigger MonadFail constraints
 
 data XXExprGhcRn
   = ExpandedThingRn { xrn_orig     :: SrcCodeOrigin   -- The original source thing to be used for error messages
@@ -1076,7 +1076,7 @@ instance Outputable SrcCodeOrigin where
     = case thing of
         OrigExpr x    -> ppr_builder "<OrigExpr>:" x
         OrigStmt x _  -> ppr_builder "<OrigStmt>:" x
-        OrigPat  x    -> ppr_builder "<OrigPat>:" x
+        OrigPat  _ x  -> ppr_builder "<OrigPat>:" x
     where ppr_builder prefix x = ifPprDebug (braces (text prefix <+> parens (ppr x))) (ppr x)
 
 instance Outputable XXExprGhcRn where


=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -110,7 +110,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 expand_stmts_expr fail_op
+       failable_expr <- mk_failable_expr doFlavour pat stmt expand_stmts_expr fail_op
        let expansion = genHsExpApps bind_op  -- (>>=)
                        [ e
                        , failable_expr ]
@@ -181,8 +181,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 -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn)
-mk_failable_expr doFlav lpat expr@(L _exprloc _) fail_op =
+mk_failable_expr :: HsDoFlavour -> LPat GhcRn -> ExprLStmt GhcRn -> LHsExpr GhcRn
+                 -> FailOperator GhcRn -> TcM (LHsExpr GhcRn)
+mk_failable_expr doFlav lpat stmt expr fail_op =
   do { is_strict <- xoptM LangExt.Strict
      ; hscEnv <- getTopEnv
      ; rdrEnv <- getGlobalRdrEnv
@@ -194,15 +195,16 @@ mk_failable_expr doFlav lpat expr@(L _exprloc _) 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 expr fail_op
+       else wrapGenSpan <$> mk_fail_block doFlav lpat stmt 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 -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (HsExpr GhcRn)
-mk_fail_block doFlav pat e (Just (SyntaxExprRn fail_op)) =
+              -> LPat GhcRn -> ExprLStmt GhcRn
+              -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (HsExpr GhcRn)
+mk_fail_block doFlav pat stmt e (Just (SyntaxExprRn fail_op)) =
   do  dflags <- getDynFlags
       return $ HsLam noAnn LamCases $ mkMatchGroup (doExpansionOrigin doFlav) -- \
                 (wrapGenSpan [ genHsCaseAltDoExp doFlav pat e                 --  pat -> expr
@@ -210,12 +212,12 @@ mk_fail_block doFlav pat e (Just (SyntaxExprRn fail_op)) =
                              ])
         where
           fail_alt_case :: DynFlags -> LPat GhcRn -> HsExpr GhcRn -> LMatch GhcRn (LHsExpr GhcRn)
-          fail_alt_case dflags pat fail_op = genHsCaseAltDoExp doFlav genWildPat $
-                                             wrapGenSpan (fail_op_expr dflags pat fail_op)
+          fail_alt_case dflags pat@(L pat_span _) fail_op = genHsCaseAltDoExp doFlav genWildPat $
+                                                               fail_op_expr dflags pat fail_op
 
-          fail_op_expr :: DynFlags -> LPat GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
-          fail_op_expr dflags pat fail_op
-            = mkExpandedPatRn (unLoc pat) $ genHsApp fail_op (mk_fail_msg_expr dflags pat)
+          fail_op_expr :: DynFlags -> LPat GhcRn -> HsExpr GhcRn -> LHsExpr GhcRn
+          fail_op_expr dflags pat@(L pat_lspan _) fail_op
+            = L pat_lspan $ mkExpandedPatRn (unLoc pat) stmt $ genHsApp fail_op (mk_fail_msg_expr dflags pat)
 
           mk_fail_msg_expr :: DynFlags -> LPat GhcRn -> LHsExpr GhcRn
           mk_fail_msg_expr dflags pat
@@ -223,8 +225,7 @@ mk_fail_block doFlav pat e (Just (SyntaxExprRn fail_op)) =
               text "Pattern match failure in" <+> pprHsDoFlavour (DoExpr Nothing)
                    <+> 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]
@@ -484,5 +485,5 @@ It stores the original statement (with location) and the expanded expression
 -}
 
 
-mkExpandedPatRn :: Pat GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
-mkExpandedPatRn pat e = XExpr (ExpandedThingRn (OrigPat pat) e)
+mkExpandedPatRn :: Pat GhcRn -> ExprLStmt GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
+mkExpandedPatRn pat stmt e = XExpr (ExpandedThingRn (OrigPat stmt pat) e)


=====================================
compiler/GHC/Tc/Types/ErrCtxt.hs
=====================================
@@ -233,4 +233,4 @@ data ErrCtxtMsg
 srcCodeOriginErrCtxMsg :: SrcCodeOrigin -> ErrCtxtMsg
 srcCodeOriginErrCtxMsg (OrigExpr e) = ExprCtxt e
 srcCodeOriginErrCtxMsg (OrigStmt s f) = StmtErrCtxt (HsDoStmt f) (unLoc s)
-srcCodeOriginErrCtxMsg (OrigPat  p) = PatCtxt p
+srcCodeOriginErrCtxMsg (OrigPat s _) = StmtErrCtxt (HsDoStmt (DoExpr Nothing)) (unLoc s)


=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -879,7 +879,7 @@ pprCtOrigin (ExpansionOrigin o)
       what = case o of
         OrigStmt{} ->
           text "a do statement"
-        OrigPat p ->
+        OrigPat _ p ->
           text "a do statement" $$
              text "with the failable pattern" <+> quotes (ppr p)
         OrigExpr (HsGetField _ _ (L _ f)) ->



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bc6cb6814faf6974610c7e4ba01f836e...

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bc6cb6814faf6974610c7e4ba01f836e...
You're receiving this email because of your account on gitlab.haskell.org.

    

Apoorv Ingle (＠ani)

tags

participants (1)