[Git][ghc/ghc][wip/expansions-appdo] fix for 1 failing testcase 4 remain

Apoorv Ingle (@ani) gitlab at gitlab.haskell.org
Mon May 27 05:41:36 UTC 2024



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


Commits:
4b491840 by Apoorv Ingle at 2024-05-27T00:41:07-05:00
fix for 1 failing testcase 4 remain

- - - - -


8 changed files:

- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Utils/Unify.hs
- testsuite/tests/ado/T13242a.stderr


Changes:

=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -528,10 +528,10 @@ mkExpandedStmt
 mkExpandedStmt oStmt flav eExpr = XExpr (ExpandedThingRn (OrigStmt oStmt flav) eExpr)
 
 mkExpandedPatRn
-  :: LPat   GhcRn      -- ^ source pattern
-  -> Maybe (HsDoFlavour, ExprLStmt GhcRn) -- ^ pattern statement origin
-  -> HsExpr GhcRn      -- ^ expanded expression
-  -> HsExpr GhcRn      -- ^ suitably wrapped 'XXExprGhcRn'
+  :: LPat   GhcRn             -- ^ source pattern
+  -> Maybe  (HsDoFlavour, ExprLStmt GhcRn) -- ^ pattern statement origin
+  -> HsExpr GhcRn             -- ^ expanded expression
+  -> HsExpr GhcRn             -- ^ suitably wrapped 'XXExprGhcRn'
 mkExpandedPatRn oPat stmt eExpr = XExpr (ExpandedThingRn (OrigPat oPat stmt) eExpr)
 
 -- | Build an expression using the extension constructor `XExpr`,
@@ -1736,7 +1736,7 @@ data ApplicativeArg idL
   | ApplicativeArgMany     -- do { stmts; return vars }
     { xarg_app_arg_many :: XApplicativeArgMany idL
     , app_stmts         :: [ExprLStmt idL] -- stmts
-    , final_expr        :: HsExpr idL    -- return (v1,..,vn), or just (v1,..,vn)
+    , final_expr        :: LHsExpr idL    -- return (v1,..,vn), or just (v1,..,vn)
     , bv_pattern        :: LPat idL      -- (v1,...,vn)
     , stmt_context      :: HsDoFlavour
       -- ^ context of the do expression, used in pprArg


=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -824,7 +824,7 @@ dsDo ctx stmts
                do_arg (ApplicativeArgOne fail_op pat expr _) =
                  ((pat, fail_op), dsLExpr expr)
                do_arg (ApplicativeArgMany _ stmts ret pat _) =
-                 ((pat, Nothing), dsDo ctx (stmts ++ [noLocA $ mkLastStmt (noLocA ret)]))
+                 ((pat, Nothing), dsDo ctx (stmts ++ [noLocA $ mkLastStmt ret]))
 
            ; rhss' <- sequence rhss
 


=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -464,10 +464,12 @@ tcValArgs do_ql args
 
              -- Now check the argument
            ; arg' <- tcScalingUsage mult $
-                     do { traceTc "tcEValArg" $
-                          vcat [ ppr ctxt
-                               , text "arg type:" <+> ppr arg_ty
-                               , text "arg:" <+> ppr arg ]
+                     do { ingencode <- inGeneratedCode
+                        ; traceTc "tcEValArg" $
+                            vcat [ ppr ctxt
+                                 , text "arg type:" <+> ppr arg_ty
+                                 , text "arg:" <+> ppr arg
+                                 , ppr ingencode ]
                         ; tcEValArg ctxt arg arg_ty }
 
            ; return (eva { eva_arg    = ValArg arg'
@@ -721,9 +723,7 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
     -- Rule IARG from Fig 4 of the QL paper:
     go1 delta acc so_far fun_ty
         (eva@(EValArg { eva_arg = ValArg arg, eva_ctxt = ctxt }) : rest_args)
-      = do { let herald = case fun_ctxt of
-                             VAExpansion (OrigStmt{}) _ _ -> ExpectedFunTySyntaxOp DoOrigin tc_fun
-                             _ ->  ExpectedFunTyArg (HsExprTcThing tc_fun) (unLoc arg)
+      = do { let herald = ExpectedFunTyArg (HsExprTcThing tc_fun) (unLoc arg)
            ; (wrap, arg_ty, res_ty) <-
                 -- NB: matchActualFunTy does the rep-poly check.
                 -- For example, suppose we have f :: forall r (a::TYPE r). a -> Int
@@ -731,9 +731,8 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
                 -- representation; matchActualFunTy checks that when
                 -- taking apart the arrow type (a -> Int).
                 matchActualFunTy herald
-                  (Just $ HsExprTcThing tc_fun)
-                  (n_val_args, fun_sigma) fun_ty
-
+                     (Just $ HsExprTcThing tc_fun)
+                     (n_val_args, fun_sigma) fun_ty
            ; (delta', arg') <- if do_ql
                                then addArgCtxt ctxt arg $
                                     -- Context needed for constraints
@@ -796,21 +795,26 @@ addArgCtxt :: AppCtxt -> LHsExpr GhcRn
 addArgCtxt ctxt (L arg_loc arg) thing_inside
   = do { in_generated_code <- inGeneratedCode
        ; case ctxt of
+           VACall _ _ _
+             | XExpr (PopErrCtxt{}) <- arg
+             -> thing_inside
+           VACall _ _ _
+             | XExpr (ExpandedThingRn o _) <- arg
+             , isHsThingRnStmt o || isHsThingRnPat o
+             -> thing_inside
+
            VACall fun arg_no _
              | not in_generated_code
              -> do setSrcSpanA arg_loc                    $
                      addErrCtxt (funAppCtxt fun arg arg_no) $
                      thing_inside
 
-             | XExpr{} <- arg, in_generated_code
-             -> thing_inside -- AppDo case for <*>'s second argument, the ctxt will be set by addHeadCtxt
-
            VAExpansion (OrigStmt (L _ stmt@(BindStmt {})) flav) _ loc
              | isGeneratedSrcSpan (locA arg_loc) -- This arg is the second argument to generated (>>=)
              -> setSrcSpan loc $
                   addStmtCtxt stmt flav $
                   thing_inside
-             | otherwise                        -- This arg is the first argument to generated (>>=)
+             | otherwise                         -- This arg is the first argument to generated (>>=)
              -> setSrcSpanA arg_loc $
                   addStmtCtxt stmt flav $
                   thing_inside


=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -22,7 +22,7 @@ module GHC.Tc.Gen.Do (expandDoStmts) where
 import GHC.Prelude
 
 import GHC.Rename.Utils ( wrapGenSpan, genHsExpApps, genHsApp, genHsLet, genLHsApp,
-                          genHsLamDoExp, genHsCaseAltDoExp, genWildPat )
+                          genHsLamDoExp, genHsCaseAltDoExp )
 import GHC.Tc.Utils.Monad
 import GHC.Tc.Gen.Pat
 import GHC.Tc.Utils.TcMType
@@ -86,20 +86,14 @@ expand_do_stmts flav [stmt@(L loc (LastStmt _ (L body_loc body) _ ret_expr))]
 -- 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
-   = do appDo <- xoptM LangExt.ApplicativeDo
-        if appDo
-          then do traceTc "expand_do_stmts last no pop" (ppr $ (L body_loc body))
-                  return $ mkExpandedStmtAt loc stmt flav body
-          else do traceTc "expand_do_stmts last pop" (ppr $ (L body_loc body))
-                  return $ mkExpandedStmtPopAt loc stmt flav body
+   = return $ mkExpandedStmtPopAt loc stmt flav body
 
    | SyntaxExprRn ret <- ret_expr
    --
    --    ------------------------------------------------
    --               return e  ~~> return e
    -- to make T18324 work
-   = do traceTc "expand_do_stmts last" (ppr ret_expr)
-        let expansion = genHsApp ret (L body_loc body)
+   = do let expansion = genHsApp ret (L body_loc body)
         return $ mkExpandedStmtPopAt loc stmt flav expansion
 
 expand_do_stmts doFlavour (stmt@(L loc (LetStmt _ bs)) : lstmts) =
@@ -190,8 +184,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 loc (XStmtLR (ApplicativeStmt _ args mb_join))): lstmts) =
+expand_do_stmts doFlavour ((L _ (XStmtLR (ApplicativeStmt _ args mb_join))): lstmts) =
 -- See Note [Applicative BodyStmt]
 --
 --                  stmts ~~> stmts'
@@ -201,13 +194,16 @@ expand_do_stmts doFlavour ((L loc (XStmtLR (ApplicativeStmt _ args mb_join))): l
 -- Very similar to HsToCore.Expr.dsDo
 
 -- args are [(<$>, e1), (<*>, e2), .., ]
-  do { expr' <- expand_do_stmts doFlavour lstmts
+  do { xexpr' <- expand_do_stmts 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
 
      -- add blocks for failable patterns
-     ; body_with_fails <- foldrM match_args expr' (zip pats_can_fail rhss)
+     ; body_with_fails <- foldrM match_args xexpr (zip pats_can_fail rhss)
 
      -- builds (body <$> e1 <*> e2 ...)
      ; let expand_ado_expr = foldl mk_apps body_with_fails (zip (map fst args) rhss)
@@ -231,18 +227,18 @@ expand_do_stmts doFlavour ((L loc (XStmtLR (ApplicativeStmt _ args mb_join))): l
             , arg_expr        = (L rhs_loc rhs)
             , is_body_stmt    = is_body_stmt
             }) =
-      do let xx_stmt = mkExpandedStmtAt rhs_loc stmt doFlavour rhs
-         traceTc "do_arg" (text "OneArg" <+> vcat [ppr pat, ppr xx_stmt])
+      do let xx_expr = mkExpandedStmtAt rhs_loc stmt doFlavour rhs
+         traceTc "do_arg" (text "OneArg" <+> vcat [ppr pat, ppr xx_expr])
          return ((pat, mb_fail_op)
-                , xx_stmt)
+                , xx_expr)
         where stmt = if is_body_stmt
                       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 { expr <- expand_do_stmts ctxt $ stmts ++ [L ret_loc $ mkLastStmt ret]
-         ; traceTc "do_arg" (text "ManyArg" <+> vcat [ppr pat, ppr expr])
+      do { xx_expr <- expandDoStmts ctxt $ stmts ++ [L ret_loc $ mkLastStmt ret]
+         ; traceTc "do_arg" (text "ManyArg" <+> vcat [ppr pat, ppr xx_expr])
          ; return ((pat, Nothing)
-                  , expr) }
+                  , wrapGenSpan 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
@@ -265,17 +261,19 @@ expand_do_stmts _ stmts = pprPanic "expand_do_stmts: impossible happened" $ (ppr
 -- 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)
                  -> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn)
-mk_failable_expr doFlav mb_stmt_info pat@(L loc _) expr fail_op =
+mk_failable_expr doFlav mb_stmt_info lpat@(L loc pat) expr fail_op =
   do { is_strict <- xoptM LangExt.Strict
-     ; irrf_pat <- isIrrefutableHsPatRnTcM is_strict pat
-     ; traceTc "mk_failable_expr" (vcat [ text "pat:" <+> ppr pat
+     ; irrf_pat <- isIrrefutableHsPatRnTcM is_strict lpat
+     ; traceTc "mk_failable_expr" (vcat [ text "pat:" <+> ppr lpat
                                         , text "isIrrefutable:" <+> ppr irrf_pat
                                         ])
 
      ; if irrf_pat                        -- don't wrap with fail block if
                                           -- the pattern is irrefutable
-       then return $ genHsLamDoExp doFlav [pat] expr
-       else L loc <$> mk_fail_block doFlav mb_stmt_info pat expr fail_op
+       then case pat of
+              (WildPat{}) -> return $ genHsLamDoExp doFlav [L noSrcSpanA pat] expr
+              _ -> return $ genHsLamDoExp doFlav [lpat] expr
+       else L loc <$> mk_fail_block doFlav mb_stmt_info lpat expr fail_op
      }
 
 -- makes the fail block with a given fail_op
@@ -289,7 +287,7 @@ mk_fail_block doFlav mb_stmt_info pat@(L ploc _) 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 $
+          fail_alt_case dflags pat fail_op = genHsCaseAltDoExp doFlav (L ploc $ WildPat noExtField) $
                                              L ploc (fail_op_expr dflags pat fail_op)
 
           fail_op_expr :: DynFlags -> LPat GhcRn -> HsExpr GhcRn -> HsExpr GhcRn


=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -90,7 +90,6 @@ import GHC.Utils.Panic
 
 import Control.Monad
 import qualified Data.List.NonEmpty as NE
-import qualified GHC.LanguageExtensions as LangExt
 
 {-
 ************************************************************************
@@ -729,14 +728,9 @@ tcXExpr xe@(ExpandedThingRn o e') res_ty
                 -- `e` is the last statement's body expression
                 -- and not a HsApp of a generated (>>) or (>>=)
                 -- This improves error messages e.g. tests: DoExpansion1, DoExpansion2, DoExpansion3
-  | OrigStmt ls@(L loc s) flav <- o
+  | OrigStmt ls@(L loc _) flav <- o
   = setSrcSpanA loc $
-    do appDo <- xoptM LangExt.ApplicativeDo
-       if appDo
-         then addStmtCtxt s flav $
-              mkExpandedStmtTc ls flav <$> tcExpr e' res_ty
-
-         else mkExpandedStmtTc ls flav <$> tcApp (XExpr xe) res_ty
+      mkExpandedStmtTc ls flav <$> tcApp (XExpr xe) res_ty
 
 tcXExpr xe res_ty = tcApp (XExpr xe) res_ty
 


=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -323,7 +323,7 @@ splitHsApps e = go e (top_ctxt 0 e) []
       = go e (VAExpansion o (appCtxtLoc ctxt) (appCtxtLoc ctxt))
                (EWrap (EExpand o) : args)
 
-      | OrigStmt (L _ stmt) _ <- o                -- so that we set `(>>)` as generated
+      | OrigStmt (L _ stmt) _ <- o              -- so that we set `(>>)` as generated
       , BodyStmt{} <- stmt                      -- and get the right unused bind warnings
       = go e (VAExpansion o generatedSrcSpan generatedSrcSpan)
                                                 -- See Part 3. in Note [Expanding HsDo with XXExprGhcRn]
@@ -1607,6 +1607,7 @@ addExprCtxt e thing_inside
   = case e of
       HsUnboundVar {} -> thing_inside
       XExpr (ExpandedThingRn (OrigStmt stmt flav) _) -> addStmtCtxt (unLoc stmt) flav thing_inside
+      -- XExpr (PopErrCtxt (L _ e)) -> addExprCtxt e thing_inside
       _ -> addErrCtxt (exprCtxt e) thing_inside
    -- The HsUnboundVar special case addresses situations like
    --    f x = _


=====================================
compiler/GHC/Tc/Utils/Unify.hs
=====================================
@@ -133,8 +133,8 @@ matchActualFunTy
 -- and NB: res_ty is an (uninstantiated) SigmaType
 
 matchActualFunTy herald mb_thing err_info fun_ty
-  = assertPpr (isRhoTy fun_ty) (ppr fun_ty) $
-    go fun_ty
+  = do assertPpr (isRhoTy fun_ty) (ppr fun_ty) $
+         go fun_ty
   where
     -- Does not allocate unnecessary meta variables: if the input already is
     -- a function, we just take it apart.  Not only is this efficient,


=====================================
testsuite/tests/ado/T13242a.stderr
=====================================
@@ -1,13 +1,13 @@
-
 T13242a.hs:10:5: error: [GHC-46956]
     • Couldn't match expected type ‘a0’ with actual type ‘a’
-    • because type variable ‘a’ would escape its scope
-    This (rigid, skolem) type variable is bound by
-      a pattern with constructor: A :: forall a. Eq a => a -> T,
-      in a pattern binding in
-           a 'do' block
-      at T13242a.hs:10:3-5
-    • In the expression:
+        because type variable ‘a’ would escape its scope
+      This (rigid, skolem) type variable is bound by
+        a pattern with constructor: A :: forall a. Eq a => a -> T,
+        in a pattern binding in
+             a 'do' block
+        at T13242a.hs:10:3-5
+    • In a stmt of a 'do' block: A x <- undefined
+      In the expression:
         do A x <- undefined
            _ <- return 'a'
            _ <- return 'b'
@@ -29,7 +29,7 @@ T13242a.hs:13:13: error: [GHC-39999]
         instance Eq Ordering -- Defined in ‘GHC.Classes’
         instance Eq Integer -- Defined in ‘GHC.Num.Integer’
         ...plus 23 others
-        ...plus five instances involving out-of-scope types
+        ...plus six instances involving out-of-scope types
         (use -fprint-potential-instances to see them all)
     • In a stmt of a 'do' block: return (x == x)
       In the expression:
@@ -43,3 +43,4 @@ T13242a.hs:13:13: error: [GHC-39999]
                  _ <- return 'a'
                  _ <- return 'b'
                  return (x == x)
+



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4b4918406b042ddcfec7f0933da0b61d8f2ceae9
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/20240527/9e299a2c/attachment-0001.html>


More information about the ghc-commits mailing list