[Git][ghc/ghc][wip/expand-do] add correct source spans for warnDiscardedDoBindings

[Apoorv Ingle (@ani)]

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


Commits:
4fdaa4de by Apoorv Ingle at 2023-05-24T17:46:08-05:00
add correct source spans for warnDiscardedDoBindings

- - - - -


3 changed files:

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


Changes:

=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -752,9 +752,10 @@ ppr_expr (XExpr x) = case ghcPass @p of
   GhcTc -> ppr x
 
 instance Outputable XXExprGhcRn where
-  ppr (ExpansionExprRn (HsExpanded (Left e) _)) = ppr e
-  ppr (ExpansionExprRn (HsExpanded (Right e) _)) = ppr e
-  ppr (PopSrcSpan e) = ppr e
+  ppr (ExpansionExprRn (HsExpanded (Left o) e)) = ppr (HsExpanded o e)
+  ppr (ExpansionExprRn (HsExpanded (Right o) e)) = ppr (HsExpanded o e)
+  ppr (PopSrcSpan e) = ifPprDebug (text "PopSrcSpan" <+> ppr e)
+                                  (ppr e)
 
 
 instance Outputable XXExprGhcTc where


=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -855,7 +855,7 @@ warnDiscardedDoBindings rhs rhs_ty
 
 
 warnUnusedBindValue :: LHsExpr GhcTc -> LHsExpr GhcTc -> Type -> DsM ()
-warnUnusedBindValue fun arg arg_ty
+warnUnusedBindValue fun arg@(L loc _) arg_ty
   | Just (l, f) <- fish_var fun
   , f `hasKey` thenMClassOpKey -- it is a (>>)
   , isNoSrcSpan l || isGeneratedSrcSpan l -- it is compiler generated
@@ -865,7 +865,7 @@ warnUnusedBindValue fun arg arg_ty
                                            , text "locGen?" <+> ppr (isGeneratedSrcSpan l)
                                            , text "noLoc?" <+> ppr (isNoSrcSpan l)
                                            ])
-       warnDiscardedDoBindings arg arg_ty
+       putSrcSpanDs (locA loc) $ warnDiscardedDoBindings arg arg_ty
   where
     -- retrieve the location info and the head of the application
     -- It is important that we /do not/ look through HsApp to avoid


=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -1369,24 +1369,46 @@ mk_failable_lexpr_tcm pat lexpr fail_op =
 mk_fail_lexpr :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn)
 mk_fail_lexpr pat lexpr (Just (SyntaxExprRn fail_op)) =
   do  dflags <- getDynFlags
-      return $ noLocA (HsLam noExtField $ mkMatchGroup (Generated DoExpansion)            -- \
-                      (noLocA [ mkHsCaseAlt pat (genPopSrcSpanExpr lexpr) --   pat -> expr
+      return $ noLocA (HsLam noExtField $ mkMatchGroup (Generated DoExpansion)    -- \
+                      (noLocA [ mkHsCaseAlt pat (genPopSrcSpanExpr lexpr)         --   pat -> expr
                               , mkHsCaseAlt nlWildPatName                         --   _   -> fail "fail pattern"
-                                (noLocA $ genHsApp fail_op
-                                 (mk_fail_msg_expr dflags (DoExpr Nothing) pat))
+                                (noLocA $ genHsApp fail_op (mk_fail_msg_expr dflags pat))
                               ]))
         where
-          mk_fail_msg_expr :: DynFlags -> HsDoFlavour -> LPat GhcRn -> LHsExpr GhcRn
-          mk_fail_msg_expr dflags ctx pat
+          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 ctx
+              text "Pattern match failure in" <+> pprHsDoFlavour (DoExpr Nothing)
                    <+> text "at" <+> ppr (getLocA pat)
 
 mk_fail_lexpr _ _ _ = pprPanic "mk_fail_lexpr: impossible happened" empty
 
 {- Note [Desugaring Do with HsExpansion]
- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We expand do blocks before typeching it rather than after type checking it
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We expand do blocks before typechecking it rather than after type checking it using the
+HsExpansion mechanism similar to HsIf expansions for rebindable syntax.
+
+Consider a do expression written in by the user
+
+f = {l0} do {l1} p <- {l1'}e1
+            {l2} g p
+            {l3} return {l3'}p
+
+The {l1} etc are location/source span information stored in the AST,
+{g1} are compiler generated source spans
+
+The expanded version (performed by expand_do_stmts) looks as follows:
+
+f = {g1} (>>=) ({l1'} e1) (\ p ->
+               {g2} (>>) ({l2} g p)
+                         ({l3} return p)
+               )
+
+The points to consider are:
+1. Generate appropriate warnings for discarded results, eg. say g p :: m Int
+2. Decorate an expression a fail block if the pattern match is irrefutable
+3. Generating approprate type error messages that blame the correct source spans
+
 TODO expand using examples
 
 -}



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4fdaa4deec364fec555f4059db9ed66d9d088a30
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/20230524/ea7b320f/attachment-0001.html>