[Git][ghc/ghc][wip/expand-do] 2 commits: add a more appropriate error context for case alternative in failable do stmt pattern binding

Apoorv Ingle (@ani) gitlab at gitlab.haskell.org
Mon May 29 23:43:41 UTC 2023



Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC


Commits:
83605216 by Apoorv Ingle at 2023-05-26T19:42:38-05:00
add a more appropriate error context for case alternative in failable do stmt pattern binding

- - - - -
ecdb4bd6 by Apoorv Ingle at 2023-05-29T18:43:31-05:00
more error context changes

- - - - -


3 changed files:

- compiler/GHC/Hs/Utils.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Match.hs


Changes:

=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -41,7 +41,7 @@ just attach noSrcSpan to everything.
 module GHC.Hs.Utils(
   -- * Terms
   mkHsPar, mkHsApp, mkHsAppWith, mkHsApps, mkHsAppsWith,
-  mkHsAppType, mkHsAppTypes, mkHsCaseAlt,
+  mkHsAppType, mkHsAppTypes, mkHsCaseAlt, mkHsCaseAltDoExp,
   mkSimpleMatch, unguardedGRHSs, unguardedRHS,
   mkMatchGroup, mkLamCaseMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf,
   mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,
@@ -282,7 +282,7 @@ mkHsLamDoExp :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin)
 mkHsLamDoExp pats body = mkHsPar (noLocA $ HsLam noExtField matches)
   where
     matches = mkMatchGroup (Generated DoExpansion)
-                           (noLocA [mkSimpleMatch LambdaExpr pats' body])
+                           (noLocA [mkSimpleMatch (StmtCtxt (HsDoStmt (DoExpr Nothing))) pats' body])
     pats' = map (parenthesizePat appPrec) pats
 
 mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc
@@ -300,6 +300,17 @@ mkHsCaseAlt :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 mkHsCaseAlt pat expr
   = mkSimpleMatch CaseAlt [pat] expr
 
+
+mkHsCaseAltDoExp :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
+                     ~ SrcAnn NoEpAnns,
+                 Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
+                        ~ SrcSpanAnnA)
+            => LPat (GhcPass p) -> (LocatedA (body (GhcPass p)))
+            -> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
+mkHsCaseAltDoExp pat expr
+  = mkSimpleMatch (StmtCtxt (HsDoStmt (DoExpr Nothing)))  [pat] expr
+
+
 nlHsTyApp :: Id -> [Type] -> LHsExpr GhcTc
 nlHsTyApp fun_id tys
   = noLocA (mkHsWrap (mkWpTyApps tys) (HsVar noExtField (noLocA fun_id)))


=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -269,7 +269,9 @@ tcExpr (HsLam _ match) res_ty
   where
     match_ctxt = MC { mc_what = case mg_ext match of
                                   Generated DoExpansion -> StmtCtxt (HsDoStmt (DoExpr Nothing))
+                                  -- Either this lambda expr was generated by expanding a do block
                                   _ -> LambdaExpr
+                                  -- Or it was a true lambda
                     , mc_body = tcBody }
     herald = ExpectedFunTyLam match
 
@@ -416,9 +418,10 @@ tcExpr (HsMultiIf _ alts) res_ty
 tcExpr (XExpr (ExpandedStmt (HsExpanded stmt expr))) res_ty
   =  do { traceTc "tcDoStmts" (vcat [ text "stmt:" <+> ppr stmt
                                     , text "expr:" <+> ppr expr
-                                    , text "res_ty" <+> ppr res_ty ])
+                                    , text "res_ty" <+> ppr res_ty
+                                    ])
         ; addErrCtxt (pprStmtInCtxt @Renamed @Renamed @Renamed (HsDoStmt (DoExpr Nothing)) (unLoc stmt)) $
-          tcExpr (unLoc expr) res_ty
+          tcApp (unLoc expr) res_ty
         }
 
 tcExpr hsDo@(HsDo _ doFlav@(DoExpr{}) (L _ stmts)) res_ty


=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -267,6 +267,7 @@ tcMatch ctxt pat_tys rhs_ty match
     add_match_ctxt match thing_inside
         = case mc_what ctxt of
             LambdaExpr -> thing_inside
+            StmtCtxt (HsDoStmt{}) -> thing_inside -- this is an expanded do stmt
             _          -> addErrCtxt (pprMatchInCtxt match) thing_inside
 
 -------------
@@ -1249,11 +1250,11 @@ expand_do_stmts do_or_lc (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
 --    -------------------------------------------------------
 --       pat <- e ; stmts   ~~> (>>=) e f
       do expand_stmts <- expand_do_stmts do_or_lc lstmts
-         expr <- mk_failable_lexpr_tcm pat expand_stmts fail_op
-         return $ mkHsApps (wrapGenSpan bind_op)  -- (>>=)
-                    [ genPopSrcSpanExpr $ L loc (mkExpandedStmt stmt e)
-                    , expr
-                    ]
+         expr <- mk_failable_lexpr_tcm pat (noLocA $ mkExpandedStmt stmt expand_stmts) fail_op
+         return $ (mkHsApps (wrapGenSpan bind_op)  -- (>>=)
+                             [ genPopSrcSpanExpr $ L loc (mkExpandedStmt stmt e)
+                             , genPopSrcSpanExpr expr
+                             ])
 
   | otherwise = pprPanic "expand do: shouldn't happen"  (text "stmt" <+> ppr  stmt)
 
@@ -1339,10 +1340,14 @@ expand_do_stmts do_or_lc ((L _ (ApplicativeStmt _ args mb_join)): lstmts) =
      }
   where
     do_arg :: ApplicativeArg GhcRn -> TcM ((LPat GhcRn, FailOperator GhcRn), LHsExpr GhcRn)
-    do_arg (ApplicativeArgOne mb_fail_op pat expr _) =
-      return ((pat, mb_fail_op), expr)
-    do_arg (ApplicativeArgMany _ stmts ret pat _) =
-      do { expr <- expand_do_stmts do_or_lc $ stmts ++ [wrapGenSpan $ mkLastStmt (wrapGenSpan ret)]
+    do_arg (ApplicativeArgOne
+            { xarg_app_arg_one = mb_fail_op
+            , app_arg_pattern = pat@(L loc _)
+            , arg_expr        = rhs
+            }) =
+      return ((pat, mb_fail_op), wrapGenSpan (mkExpandedStmt (L loc (BindStmt xbsn pat rhs)) rhs))
+    do_arg (ApplicativeArgMany _ stmts ret pat ctxt) =
+      do { expr <- expand_do_stmts ctxt $ stmts ++ [wrapGenSpan $ mkLastStmt (wrapGenSpan ret)]
          ; return ((pat, Nothing), expr) }
 
     match_args :: (LPat GhcRn, FailOperator GhcRn) -> LHsExpr GhcRn -> TcM (LHsExpr GhcRn)
@@ -1353,6 +1358,9 @@ expand_do_stmts do_or_lc ((L _ (ApplicativeStmt _ args mb_join)): lstmts) =
         SyntaxExprRn op -> mkHsApps (wrapGenSpan op) [l_expr, r_expr]
         NoSyntaxExprRn -> pprPanic "expand_do_stmts op:" (ppr op)
 
+    xbsn :: XBindStmtRn
+    xbsn = XBindStmtRn NoSyntaxExprRn Nothing
+
 expand_do_stmts _ stmts = pprPanic "expand_do_stmts: impossible happened" $ (ppr stmts)
 
 
@@ -1374,7 +1382,7 @@ mk_failable_lexpr_tcm pat lexpr fail_op =
      ; if irrf_pat
           -- don't decorate with fail statement if
           -- the pattern is irrefutable
-       then return $ mkHsLamDoExp [pat] (genPopSrcSpanExpr lexpr)
+       then return $ mkHsLamDoExp [pat] lexpr
        else mk_fail_lexpr pat lexpr fail_op
      }
 
@@ -1385,9 +1393,9 @@ mk_fail_lexpr :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsEx
 mk_fail_lexpr pat lexpr (Just (SyntaxExprRn fail_op)) =
   do  dflags <- getDynFlags
       return $ wrapGenSpan (HsLam noExtField $ mkMatchGroup (Generated DoExpansion)    -- \
-                      (wrapGenSpan [ mkHsCaseAlt pat (genPopSrcSpanExpr lexpr)         --   pat -> expr
-                              , mkHsCaseAlt nlWildPatName                         --   _   -> fail "fail pattern"
-                                (wrapGenSpan $ genHsApp fail_op (mk_fail_msg_expr dflags pat))
+                (wrapGenSpan [ mkHsCaseAltDoExp pat lexpr         --   pat -> expr
+                             , mkHsCaseAlt nlWildPatName                         --   _   -> fail "fail pattern"
+                               (wrapGenSpan $ genHsApp fail_op (mk_fail_msg_expr dflags pat))
                               ]))
         where
           mk_fail_msg_expr :: DynFlags -> LPat GhcRn -> LHsExpr GhcRn



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7ff1c26dafd53b1c836df8f7d0db1b6c265ee6c4...ecdb4bd6e4b74a48208df4568a4f1d6ec89d62b0

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7ff1c26dafd53b1c836df8f7d0db1b6c265ee6c4...ecdb4bd6e4b74a48208df4568a4f1d6ec89d62b0
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230529/4fefd2e0/attachment-0001.html>


More information about the ghc-commits mailing list