[Git][ghc/ghc][wip/expand-do] adjusting the generated spans for proper error messages

Apoorv Ingle (@ani) gitlab at gitlab.haskell.org
Tue Jun 6 16:27:47 UTC 2023



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


Commits:
39ac8d8f by Apoorv Ingle at 2023-06-06T11:27:36-05:00
adjusting the generated spans for proper error messages

- - - - -


5 changed files:

- compiler/GHC/Hs/Utils.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


Changes:

=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -45,7 +45,7 @@ module GHC.Hs.Utils(
   mkSimpleMatch, unguardedGRHSs, unguardedRHS,
   mkMatchGroup, mkLamCaseMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf,
   mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,
-  mkHsDictLet, mkHsLams, mkHsLamDoExp,
+  mkHsDictLet, mkHsLams,
   mkHsOpApp, mkHsDo, mkHsDoAnns, mkHsComp, mkHsCompAnns, mkHsWrapPat, mkHsWrapPatCo,
   mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap,
   mkHsCmdIf, mkConLikeTc,
@@ -275,16 +275,6 @@ mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noExtField matches))
                            (noLocA [mkSimpleMatch LambdaExpr pats' body])
     pats' = map (parenthesizePat appPrec) pats
 
-mkHsLamDoExp :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin)
-        => [LPat (GhcPass p)]
-        -> LHsExpr (GhcPass p)
-        -> LHsExpr (GhcPass p)
-mkHsLamDoExp pats body = mkHsPar (noLocA $ HsLam noExtField matches)
-  where
-    matches = mkMatchGroup (Generated DoExpansion)
-                           (noLocA [mkSimpleMatch (StmtCtxt (HsDoStmt (DoExpr Nothing))) pats' body])
-    pats' = map (parenthesizePat appPrec) pats
-
 mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc
 mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars
                                        <.> mkWpEvLams dicts) expr


=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -328,6 +328,8 @@ tcApp rn_expr exp_res_ty
            vcat [ text "rn_fun:" <+> ppr rn_fun
                 , text "rn_args:" <+> ppr rn_args
                 , text "fun_ctxt:" <+> ppr fun_ctxt <+> ppr (appCtxtLoc fun_ctxt)
+                                   <+> ppr (isGeneratedSrcSpan (appCtxtLoc fun_ctxt))
+                                   <+> ppr (insideExpansion fun_ctxt)
                 ]
 
        ; (tc_fun, fun_sigma) <- tcInferAppHead fun rn_args
@@ -349,7 +351,7 @@ tcApp rn_expr exp_res_ty
        --    the source program; it was added by the renamer.  See
        --    Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr
        ; let  perhaps_add_res_ty_ctxt thing_inside
-                 | insideExpansion fun_ctxt
+                 | insideExpansion fun_ctxt || isGeneratedSrcSpan (appCtxtLoc fun_ctxt)
                  = thing_inside
                  | otherwise
                  = addFunResCtxt rn_fun rn_args app_res_rho exp_res_ty $


=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -222,8 +222,6 @@ tcExpr (XExpr (ExpandedStmt (HsExpanded stmt expr))) res_ty
         }
 
 
-
-
 tcExpr e@(HsOverLit _ lit) res_ty
   = do { mb_res <- tcShortCutLit lit res_ty
          -- See Note [Short cut for overloaded literals] in GHC.Tc.Zonk.Type


=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -250,8 +250,8 @@ insideExpansion (VAExpansion {}) = True
 insideExpansion (VACall {})      = False
 
 instance Outputable AppCtxt where
-  ppr (VAExpansion e _) = text "VAExpansion" <+> ppr e
-  ppr (VACall f n _)    = text "VACall" <+> int n <+> ppr f
+  ppr (VAExpansion e l) = text "VAExpansion" <+> ppr e <+> ppr l
+  ppr (VACall f n l)    = text "VACall" <+> int n <+> ppr f <+> ppr l
 
 type family XPass p where
   XPass 'TcpRn   = 'Renamed


=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -78,7 +78,7 @@ import GHC.Types.Fixity (LexicalFixity(..))
 import GHC.Types.Name
 import GHC.Types.Id
 import GHC.Types.SrcLoc
-import GHC.Types.Basic (Origin (..), GenReason (..))
+import GHC.Types.Basic (Origin (..), GenReason (..), appPrec)
 import qualified GHC.LanguageExtensions as LangExt
 
 import Control.Monad
@@ -1225,8 +1225,7 @@ expand_do_stmts _ [stmt@(L loc (LastStmt _ body _ ret_expr))]
    --    ------------------------------------------------
    --               return e  ~~> return e
    -- to make T18324 work
-   = return $ L loc (mkExpandedStmt stmt
-                        ((L loc (HsApp noAnn (L loc ret) body))))
+   = return $ wrapGenSpan (mkExpandedStmt stmt (L loc $ genHsApp ret body))
 
 
 expand_do_stmts do_or_lc (stmt@(L loc (LetStmt _ bnds)) : lstmts) =
@@ -1249,12 +1248,13 @@ 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)  -- (>>=)
-                             [ L loc (mkPopSrcSpanExpr $ L loc (mkExpandedStmt stmt e))
-                             , expr
-                             ])
-
+         return $ (foldl genHsApp' (wrapGenSpan bind_op)  -- (>>=)
+                    [ L loc (mkPopSrcSpanExpr $ L loc (mkExpandedStmt stmt e))
+                    , expr
+                    ])
   | otherwise = pprPanic "expand do: shouldn't happen"  (text "stmt" <+> ppr  stmt)
+  where genHsApp' :: LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn
+        genHsApp' fun arg = wrapGenSpan (HsApp noAnn fun arg)
 
 expand_do_stmts do_or_lc (stmt@(L loc (BodyStmt _ e (SyntaxExprRn f) _)) : lstmts) =
 -- See Note [BodyStmt]
@@ -1262,9 +1262,12 @@ expand_do_stmts do_or_lc (stmt@(L loc (BodyStmt _ e (SyntaxExprRn f) _)) : lstmt
 --    ----------------------------------------------
 --      e ; stmts ~~> (>>) e stmts'
   do expand_stmts <- expand_do_stmts do_or_lc lstmts
-     return $ (mkHsApps (wrapGenSpan f) -- (>>)
-                [ L loc (mkPopSrcSpanExpr $ L loc (mkExpandedStmt stmt e)) -- e
-                , expand_stmts ])  -- stmts'
+     return $ (foldl genHsApp' (wrapGenSpan f) -- (>>)
+                  [ L loc (mkPopSrcSpanExpr $ L loc (mkExpandedStmt stmt e)) -- e
+                  , expand_stmts ])  -- stmts'
+  where
+    genHsApp' :: LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn
+    genHsApp' fun arg = wrapGenSpan (HsApp noAnn fun arg)
 
 expand_do_stmts do_or_lc
   ((L do_loc (RecStmt { recS_stmts = L stmts_loc rec_stmts
@@ -1405,6 +1408,32 @@ mk_fail_lexpr pat lexpr (Just (SyntaxExprRn fail_op)) =
 
 mk_fail_lexpr _ _ _ = pprPanic "mk_fail_lexpr: impossible happened" empty
 
+
+mkHsLamDoExp :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin)
+        => [LPat (GhcPass p)]
+        -> LHsExpr (GhcPass p)
+        -> LHsExpr (GhcPass p)
+mkHsLamDoExp pats body = mkHsPar (wrapGenSpan $ HsLam noExtField matches)
+  where
+    matches = mkMatchGroup (Generated DoExpansion)
+                           (wrapGenSpan [genSimpleMatch (StmtCtxt (HsDoStmt (DoExpr Nothing))) pats' body])
+    pats' = map (parenthesizePat appPrec) pats
+
+
+
+genSimpleMatch :: (Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
+                        ~ SrcSpanAnnA,
+                  Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
+                        ~ SrcAnn NoEpAnns)
+              => HsMatchContext (GhcPass p)
+              -> [LPat (GhcPass p)] -> LocatedA (body (GhcPass p))
+              -> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
+genSimpleMatch ctxt pats rhs
+  = wrapGenSpan $
+    Match { m_ext = noAnn, m_ctxt = ctxt, m_pats = pats
+          , m_grhss = unguardedGRHSs generatedSrcSpan rhs noAnn }
+
+
 {- Note [Expanding HsDo with HsExpansion]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We expand do blocks before typechecking it rather than after type checking it using the



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/39ac8d8f65452b619447c66770c5dc6f46a28219
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/20230606/dbfd5578/attachment-0001.html>


More information about the ghc-commits mailing list