[Git][ghc/ghc][wip/expansions-appdo] 2 commits: make all error messages match

Apoorv Ingle (@ani) gitlab at gitlab.haskell.org
Tue May 28 19:16:50 UTC 2024



Apoorv Ingle pushed to branch wip/expansions-appdo at Glasgow Haskell Compiler / GHC


Commits:
06273b79 by Apoorv Ingle at 2024-05-28T14:08:47-05:00
make all error messages match

- - - - -
5775afab by Apoorv Ingle at 2024-05-28T14:16:36-05:00
accepting T23540

- - - - -


5 changed files:

- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Utils/Unify.hs
- testsuite/tests/ado/ado002.stderr
- testsuite/tests/hiefile/should_run/T23540.stdout


Changes:

=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -1579,7 +1579,7 @@ pprMatch (Match { m_pats = pats, m_ctxt = ctxt, m_grhss = grhss })
                                      <+> pprInfixOcc fun
                                      <+> pprParendLPat opPrec p2
                      _ -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats)
-
+            StmtCtxt _                             -> (char '\\', pats)
             LamAlt LamSingle                       -> (char '\\', pats)
             ArrowMatchCtxt (ArrowLamAlt LamSingle) -> (char '\\', pats)
             LamAlt LamCases                        -> lam_cases_result
@@ -1620,6 +1620,7 @@ matchSeparator IfAlt            = text "->"
 matchSeparator ArrowMatchCtxt{} = text "->"
 matchSeparator PatBindRhs       = text "="
 matchSeparator PatBindGuards    = text "="
+matchSeparator (StmtCtxt (HsDoStmt{}))  = text "->"
 matchSeparator StmtCtxt{}       = text "<-"
 matchSeparator RecUpd           = text "="  -- This can be printed by the pattern
 matchSeparator PatSyn           = text "<-" -- match checker trace
@@ -1857,8 +1858,8 @@ instance (OutputableBndrId idL)
 
 pprArg :: forall idL . (OutputableBndrId idL) => ApplicativeArg (GhcPass idL) -> SDoc
 pprArg (ApplicativeArgOne _ pat expr isBody)
-  | isBody = ppr expr -- See Note [Applicative BodyStmt]
-  | otherwise = pprBindStmt pat expr
+  | isBody =  whenPprDebug (text "[AppStmt]") <+> ppr expr -- See Note [Applicative BodyStmt]
+  | otherwise = whenPprDebug (text "[AppStmt]") <+> pprBindStmt pat expr
 pprArg (ApplicativeArgMany _ stmts return pat ctxt) =
      ppr pat <+>
      text "<-" <+>


=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -54,39 +54,34 @@ import Data.List ((\\))
 --   See Note [Expanding HsDo with XXExprGhcRn] below for `HsDo` specific commentary
 --   and Note [Handling overloaded and rebindable constructs] for high level commentary
 expandDoStmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (HsExpr GhcRn)
-expandDoStmts doFlav stmts = do expanded_expr <- expand_do_stmts doFlav stmts
-                                case expanded_expr of
-                                         L _ (XExpr (PopErrCtxt e)) -> return $ unLoc e
-                                         -- The first expanded stmt doesn't need a pop as
-                                         -- it would otherwise pop the "In the expression do ... " from
-                                         -- the error context
-                                         _                          -> return $ unLoc expanded_expr
+expandDoStmts doFlav stmts = unLoc <$> expand_do_stmts False doFlav stmts
 
 -- | The main work horse for expanding do block statements into applications of binds and thens
 --   See Note [Expanding HsDo with XXExprGhcRn]
-expand_do_stmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (LHsExpr GhcRn)
+expand_do_stmts :: Bool -> HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (LHsExpr GhcRn)
 
-expand_do_stmts ListComp _ =
+expand_do_stmts _ ListComp _ =
   pprPanic "expand_do_stmts: impossible happened. ListComp" empty
         -- handeled by `GHC.Tc.Gen.Match.tcLcStmt`
 
-expand_do_stmts _ [] = pprPanic "expand_do_stmts: impossible happened. Empty stmts" empty
+expand_do_stmts _ _ [] = pprPanic "expand_do_stmts: impossible happened. Empty stmts" empty
 
-expand_do_stmts _ (stmt@(L _ (TransStmt {})):_) =
+expand_do_stmts _ _ (stmt@(L _ (TransStmt {})):_) =
   pprPanic "expand_do_stmts: TransStmt" $ ppr stmt
   -- handeled by `GHC.Tc.Gen.Match.tcLcStmt`
 
-expand_do_stmts _ (stmt@(L _ (ParStmt {})):_) =
+expand_do_stmts _ _ (stmt@(L _ (ParStmt {})):_) =
   pprPanic "expand_do_stmts: ParStmt" $ ppr stmt
   -- handeled by `GHC.Tc.Gen.Match.tcLcStmt`
 
-expand_do_stmts flav [stmt@(L loc (LastStmt _ (L body_loc body) _ ret_expr))]
+expand_do_stmts addPop flav [stmt@(L loc (LastStmt _ (L body_loc body) _ ret_expr))]
 -- See  Note [Expanding HsDo with XXExprGhcRn] Equation (5) below
 -- last statement of a list comprehension, needs to explicitly return it
 -- See `checkLastStmt` and `Syntax.Expr.StmtLR.LastStmt`
    | NoSyntaxExprRn <- ret_expr
    -- Last statement is just body if we are not in ListComp context. See Syntax.Expr.LastStmt
-   = return $ mkExpandedStmtPopAt loc stmt flav TcExpr body
+   = return $ if addPop then mkExpandedStmtPopAt loc stmt flav TcExpr body
+                        else mkExpandedStmtAt loc stmt flav TcExpr body
 
    | SyntaxExprRn ret <- ret_expr
    --
@@ -94,18 +89,20 @@ expand_do_stmts flav [stmt@(L loc (LastStmt _ (L body_loc body) _ ret_expr))]
    --               return e  ~~> return e
    -- to make T18324 work
    = do let expansion = genHsApp ret (L body_loc body)
-        return $ mkExpandedStmtPopAt loc stmt flav TcExpr expansion
+        return $ if addPop then mkExpandedStmtPopAt loc stmt flav TcExpr expansion
+                           else mkExpandedStmtAt loc stmt flav TcExpr expansion
 
-expand_do_stmts doFlavour (stmt@(L loc (LetStmt _ bs)) : lstmts) =
+expand_do_stmts addPop doFlavour (stmt@(L loc (LetStmt _ bs)) : lstmts) =
 -- See  Note [Expanding HsDo with XXExprGhcRn] Equation (3) below
 --                      stmts ~~> stmts'
 --    ------------------------------------------------
 --       let x = e ; stmts ~~> let x = e in stmts'
-  do expand_stmts <- expand_do_stmts doFlavour lstmts
+  do expand_stmts <- expand_do_stmts True doFlavour lstmts
      let expansion = genHsLet bs expand_stmts
-     return $ mkExpandedStmtPopAt loc stmt doFlavour TcExpr expansion
+     return $ if addPop then mkExpandedStmtPopAt loc stmt doFlavour TcExpr expansion
+                        else mkExpandedStmtAt loc stmt doFlavour TcExpr expansion
 
-expand_do_stmts doFlavour (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
+expand_do_stmts addPop doFlavour (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
   | SyntaxExprRn bind_op <- xbsrn_bindOp xbsrn
   , fail_op              <- xbsrn_failOp xbsrn
 -- See  Note [Expanding HsDo with XXExprGhcRn] Equation (2) below
@@ -114,29 +111,31 @@ expand_do_stmts doFlavour (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
 --                                   _   -> fail "Pattern match failure .."
 --    -------------------------------------------------------
 --       pat <- e ; stmts   ~~> (>>=) e f
-  = do expand_stmts <- expand_do_stmts doFlavour lstmts
+  = do expand_stmts <- expand_do_stmts True doFlavour lstmts
        failable_expr <- mk_failable_expr doFlavour Nothing pat expand_stmts fail_op
        let expansion = genHsExpApps bind_op  -- (>>=)
                        [ e
                        , failable_expr ]
-       return $ mkExpandedStmtPopAt loc stmt doFlavour TcApp expansion
+       return $ if addPop then mkExpandedStmtPopAt loc stmt doFlavour TcApp expansion
+                          else mkExpandedStmtAt loc stmt doFlavour TcApp expansion
 
   | otherwise
   = pprPanic "expand_do_stmts: The impossible happened, missing bind operator from renamer" (text "stmt" <+> ppr  stmt)
 
-expand_do_stmts doFlavour (stmt@(L loc (BodyStmt _ e (SyntaxExprRn then_op) _)) : lstmts) =
+expand_do_stmts addPop doFlavour (stmt@(L loc (BodyStmt _ e (SyntaxExprRn then_op) _)) : lstmts) =
 -- See Note [BodyStmt] in Language.Haskell.Syntax.Expr
 -- See  Note [Expanding HsDo with XXExprGhcRn] Equation (1) below
 --              stmts ~~> stmts'
 --    ----------------------------------------------
 --      e ; stmts ~~> (>>) e stmts'
-  do expand_stmts_expr <- expand_do_stmts doFlavour lstmts
+  do expand_stmts_expr <- expand_do_stmts True doFlavour lstmts
      let expansion = genHsExpApps then_op  -- (>>)
                                   [ e
                                   , expand_stmts_expr ]
-     return $ mkExpandedStmtPopAt loc stmt doFlavour TcApp expansion
+     return $ if addPop then mkExpandedStmtPopAt loc stmt doFlavour TcApp expansion
+                        else mkExpandedStmtAt loc stmt doFlavour TcApp expansion
 
-expand_do_stmts doFlavour
+expand_do_stmts _ doFlavour
        ((L loc (RecStmt { recS_stmts = L stmts_loc rec_stmts
                         , recS_later_ids = later_ids  -- forward referenced local ids
                         , recS_rec_ids = local_ids     -- ids referenced outside of the rec block
@@ -156,7 +155,7 @@ expand_do_stmts doFlavour
 --                                           -> do { rec_stmts
 --                                                 ; return (local_only_ids ++ later_ids) } ))
 --                              (\ [ local_only_ids ++ later_ids ] -> stmts')
-  do expand_stmts <- expand_do_stmts doFlavour lstmts
+  do expand_stmts <- expand_do_stmts True doFlavour lstmts
      -- NB: No need to wrap the expansion with an ExpandedStmt
      -- as we want to flatten the rec block statements into its parent do block anyway
      return $ mkHsApps (wrapGenSpan bind_fun)                                           -- (>>=)
@@ -184,7 +183,7 @@ expand_do_stmts doFlavour
                              -- NB: LazyPat because we do not want to eagerly evaluate the pattern
                              -- and potentially loop forever
 
-expand_do_stmts doFlavour ((L _ (XStmtLR (ApplicativeStmt _ args mb_join))): lstmts) =
+expand_do_stmts addPop doFlavour ((L _ (XStmtLR (ApplicativeStmt _ args mb_join))): lstmts) =
 -- See Note [Applicative BodyStmt]
 --
 --                  stmts ~~> stmts'
@@ -194,11 +193,8 @@ expand_do_stmts doFlavour ((L _ (XStmtLR (ApplicativeStmt _ args mb_join))): lst
 -- Very similar to HsToCore.Expr.dsDo
 
 -- args are [(<$>, e1), (<*>, e2), .., ]
-  do { xexpr' <- expand_do_stmts doFlavour lstmts
+  do { xexpr <- expand_do_stmts False doFlavour lstmts
      -- extracts pats and arg bodies (rhss) from args
-     ; let xexpr = case xexpr' of
-                     L _ (XExpr (PopErrCtxt e)) -> e
-                     _ -> xexpr'
 
      ; (pats_can_fail, rhss) <- unzip <$> mapM (do_arg . snd) args
 
@@ -217,7 +213,8 @@ expand_do_stmts doFlavour ((L _ (XStmtLR (ApplicativeStmt _ args mb_join))): lst
                                                , text "lstmts:" <+> ppr lstmts
                                                , text "mb_join:" <+> ppr mb_join
                                                , text "expansion:" <+> ppr final_expr])
-     ; return final_expr
+     ; return $ final_expr
+
      }
   where
     do_arg :: ApplicativeArg GhcRn -> TcM ((LPat GhcRn, FailOperator GhcRn), LHsExpr GhcRn)
@@ -227,7 +224,8 @@ expand_do_stmts doFlavour ((L _ (XStmtLR (ApplicativeStmt _ args mb_join))): lst
             , arg_expr        = (L rhs_loc rhs)
             , is_body_stmt    = is_body_stmt
             }) =
-      do let xx_expr = mkExpandedStmtAt rhs_loc stmt doFlavour TcExpr rhs
+      do let xx_expr = if addPop then mkExpandedStmtPopAt rhs_loc stmt doFlavour TcExpr rhs
+                                 else mkExpandedStmtAt rhs_loc stmt doFlavour TcExpr rhs
          traceTc "do_arg" (text "OneArg" <+> vcat [ppr pat, ppr xx_expr])
          return ((pat, mb_fail_op)
                 , xx_expr)
@@ -235,10 +233,10 @@ expand_do_stmts doFlavour ((L _ (XStmtLR (ApplicativeStmt _ args mb_join))): lst
                       then (L rhs_loc (BodyStmt NoExtField (L rhs_loc rhs) NoSyntaxExprRn NoSyntaxExprRn))
                       else (L rhs_loc (BindStmt xbsn pat (L rhs_loc rhs)))
     do_arg (ApplicativeArgMany _ stmts ret@(L ret_loc _) pat ctxt) =
-      do { xx_expr <- expandDoStmts ctxt $ stmts ++ [L ret_loc $ mkLastStmt ret]
-         ; traceTc "do_arg" (text "ManyArg" <+> vcat [ppr pat, ppr xx_expr])
+      do { xx_expr <- expand_do_stmts False ctxt $ stmts ++ [L ret_loc $ mkLastStmt ret]
+         ; traceTc "do_arg" (text "ManyArg" <+> vcat [ppr stmts, text "--", ppr xx_expr])
          ; return ((pat, Nothing)
-                  , wrapGenSpan xx_expr) }
+                  , xx_expr) }
 
     match_args :: ((LPat GhcRn, FailOperator GhcRn), LHsExpr GhcRn)  -> LHsExpr GhcRn -> TcM (LHsExpr GhcRn)
     match_args ((pat, fail_op), stmt_expr) body = mk_failable_expr doFlavour stmt_ctxt pat body fail_op
@@ -256,7 +254,7 @@ expand_do_stmts doFlavour ((L _ (XStmtLR (ApplicativeStmt _ args mb_join))): lst
     xbsn = XBindStmtRn NoSyntaxExprRn Nothing
 
 
-expand_do_stmts _ stmts = pprPanic "expand_do_stmts: impossible happened" $ (ppr stmts)
+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 -> Maybe (HsDoFlavour, ExprLStmt GhcRn)


=====================================
compiler/GHC/Tc/Utils/Unify.hs
=====================================
@@ -133,7 +133,7 @@ matchActualFunTy
 -- and NB: res_ty is an (uninstantiated) SigmaType
 
 matchActualFunTy herald mb_thing err_info fun_ty
-  = do assertPpr (isRhoTy fun_ty) (ppr fun_ty) $
+  = assertPpr (isRhoTy fun_ty) (ppr fun_ty) $
          go fun_ty
   where
     -- Does not allocate unnecessary meta variables: if the input already is


=====================================
testsuite/tests/ado/ado002.stderr
=====================================
@@ -1,4 +1,3 @@
-
 ado002.hs:8:8: error: [GHC-83865]
     • Couldn't match expected type: Char -> IO b0
                   with actual type: IO Char
@@ -96,3 +95,11 @@ ado002.hs:23:9: error: [GHC-83865]
     • The function ‘getChar’ is applied to one visible argument,
         but its type ‘IO Char’ has none
       In a stmt of a 'do' block: x5 <- getChar x4
+      In the expression:
+        do x1 <- getChar
+           x2 <- getChar
+           x3 <- const (return ()) x1
+           x4 <- getChar
+           x5 <- getChar x4
+           return (x2, x4)
+


=====================================
testsuite/tests/hiefile/should_run/T23540.stdout
=====================================
@@ -28,22 +28,6 @@ At point (15,8), we found:
 ==========================
 At point (30,8), we found:
 ==========================
-┌
-│ $dMonad at T23540.hs:1:1, of type: Monad Identity
-│     is an evidence variable bound by a let, depending on: [$fMonadIdentity]
-│           with scope: ModuleScope
-│           
-│     Defined at <no location info>
-└
-|
-`- ┌
-   │ $fMonadIdentity at T23540.hs:25:10-23, of type: Monad Identity
-   │     is an evidence variable bound by an instance of class Monad
-   │           with scope: ModuleScope
-   │           
-   │     Defined at T23540.hs:25:10
-   └
-
 ==========================
 At point (43,8), we found:
 ==========================
@@ -123,38 +107,6 @@ At point (49,14), we found:
 ==========================
 At point (61,7), we found:
 ==========================
-┌
-│ $dApplicative at T23540.hs:1:1, of type: Applicative Identity'
-│     is an evidence variable bound by a let, depending on: [$fApplicativeIdentity']
-│           with scope: ModuleScope
-│           
-│     Defined at <no location info>
-└
-|
-`- ┌
-   │ $fApplicativeIdentity' at T23540.hs:56:10-30, of type: Applicative Identity'
-   │     is an evidence variable bound by an instance of class Applicative
-   │           with scope: ModuleScope
-   │           
-   │     Defined at T23540.hs:56:10
-   └
-
-┌
-│ $dFunctor at T23540.hs:1:1, of type: Functor Identity'
-│     is an evidence variable bound by a let, depending on: [$fFunctorIdentity']
-│           with scope: ModuleScope
-│           
-│     Defined at <no location info>
-└
-|
-`- ┌
-   │ $fFunctorIdentity' at T23540.hs:54:10-26, of type: Functor Identity'
-   │     is an evidence variable bound by an instance of class Functor
-   │           with scope: ModuleScope
-   │           
-   │     Defined at T23540.hs:54:10
-   └
-
 ==========================
 At point (69,4), we found:
 ==========================



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/67c1f2990b0edbda1bae36018740b01f29a65974...5775afabeab4d1180a88cd161905c40115ca95bb

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/67c1f2990b0edbda1bae36018740b01f29a65974...5775afabeab4d1180a88cd161905c40115ca95bb
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/20240528/7f0ac72d/attachment-0001.html>


More information about the ghc-commits mailing list