[Git][ghc/ghc][wip/expansions-appdo] Make ApplicativeDo work with HsExpansions

Apoorv Ingle (@ani) gitlab at gitlab.haskell.org
Wed May 29 16:39:15 UTC 2024



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


Commits:
0dd8fb6b by Apoorv Ingle at 2024-05-28T15:19:25-05:00
Make ApplicativeDo work with HsExpansions
testcase added: T24406
Issues Fixed: #24406, #16135

Code Changes:
- Remove `XStmtLR GhcTc` as `XStmtLR GhcRn` is now compiled to `HsExpr GhcTc`
- The expanded statements are guided by `GHC.Hs.Expr.TcFunInfo` which is used to decide
  if the `XExpr GhcRn` is to be typechecked using `tcApp` or `tcExpr`

- - - - -


30 changed files:

- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/GuardedRHSs.hs
- compiler/GHC/HsToCore/ListComp.hs
- compiler/GHC/HsToCore/Pmc/Desugar.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Rename/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/Gen/Match.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Tc/Utils/Unify.hs
- compiler/GHC/Tc/Zonk/Type.hs
- testsuite/tests/ado/T13242a.stderr
- − testsuite/tests/ado/T16135.stderr
- + testsuite/tests/ado/T24406.hs
- testsuite/tests/ado/ado002.stderr
- testsuite/tests/ado/ado003.stderr
- testsuite/tests/ado/ado004.stderr
- testsuite/tests/ado/all.T
- testsuite/tests/determinism/determ021/determ021.stdout
- testsuite/tests/ghci.debugger/scripts/break029.stdout
- testsuite/tests/hiefile/should_run/T23540.stdout


Changes:

=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -473,11 +473,13 @@ type instance XXExpr GhcTc = XXExprGhcTc
 *                                                                      *
 ********************************************************************* -}
 
+data TCFunInfo = TcApp | TcExpr
+
 -- | The different source constructs that we use to instantiate the "original" field
 --   in an `XXExprGhcRn original expansion`
 data HsThingRn = OrigExpr (HsExpr GhcRn)
-               | OrigStmt (ExprLStmt GhcRn)
-               | OrigPat  (LPat GhcRn)
+               | OrigStmt (ExprLStmt GhcRn) HsDoFlavour -- ^ which kind of do-block did this statement come from
+               | OrigPat  (LPat GhcRn) (Maybe (HsDoFlavour, ExprLStmt GhcRn))
 
 isHsThingRnExpr, isHsThingRnStmt, isHsThingRnPat :: HsThingRn -> Bool
 isHsThingRnExpr (OrigExpr{}) = True
@@ -491,7 +493,8 @@ isHsThingRnPat _ = False
 
 data XXExprGhcRn
   = ExpandedThingRn { xrn_orig     :: HsThingRn       -- The original source thing
-                    , xrn_expanded :: HsExpr GhcRn }  -- The compiler generated expanded thing
+                    , xrn_expanded :: HsExpr GhcRn    -- The compiler generated expanded thing
+                    , xrn_TCFunInfo :: TCFunInfo   }  -- A Hint to the type checker of how to proceed
 
   | PopErrCtxt                                     -- A hint for typechecker to pop
     {-# UNPACK #-} !(LHsExpr GhcRn)                -- the top of the error context stack
@@ -515,22 +518,25 @@ mkExpandedExpr
   :: HsExpr GhcRn         -- ^ source expression
   -> HsExpr GhcRn         -- ^ expanded expression
   -> HsExpr GhcRn         -- ^ suitably wrapped 'XXExprGhcRn'
-mkExpandedExpr oExpr eExpr = XExpr (ExpandedThingRn (OrigExpr oExpr) eExpr)
+mkExpandedExpr oExpr eExpr = XExpr (ExpandedThingRn (OrigExpr oExpr) eExpr TcExpr)
 
 -- | Build an expression using the extension constructor `XExpr`,
 --   and the two components of the expansion: original do stmt and
 --   expanded expression
 mkExpandedStmt
   :: ExprLStmt GhcRn      -- ^ source statement
+  -> HsDoFlavour
+  -> TCFunInfo
   -> HsExpr GhcRn         -- ^ expanded expression
   -> HsExpr GhcRn         -- ^ suitably wrapped 'XXExprGhcRn'
-mkExpandedStmt oStmt eExpr = XExpr (ExpandedThingRn (OrigStmt oStmt) eExpr)
+mkExpandedStmt oStmt flav tc_fun eExpr = XExpr (ExpandedThingRn (OrigStmt oStmt flav) eExpr tc_fun)
 
 mkExpandedPatRn
-  :: LPat   GhcRn      -- ^ source pattern
-  -> HsExpr GhcRn      -- ^ expanded expression
-  -> HsExpr GhcRn      -- ^ suitably wrapped 'XXExprGhcRn'
-mkExpandedPatRn oPat eExpr = XExpr (ExpandedThingRn (OrigPat oPat) eExpr)
+  :: LPat   GhcRn             -- ^ source pattern
+  -> Maybe  (HsDoFlavour, ExprLStmt GhcRn) -- ^ pattern statement origin
+  -> HsExpr GhcRn             -- ^ expanded expression
+  -> HsExpr GhcRn             -- ^ suitably wrapped 'XXExprGhcRn'
+mkExpandedPatRn oPat mb_stmt_info eExpr = XExpr (ExpandedThingRn (OrigPat oPat mb_stmt_info) eExpr TcExpr)
 
 -- | Build an expression using the extension constructor `XExpr`,
 --   and the two components of the expansion: original do stmt and
@@ -538,17 +544,21 @@ mkExpandedPatRn oPat eExpr = XExpr (ExpandedThingRn (OrigPat oPat) eExpr)
 mkExpandedStmtAt
   :: SrcSpanAnnA          -- ^ Location for the expansion expression
   -> ExprLStmt GhcRn      -- ^ source statement
+  -> HsDoFlavour
+  -> TCFunInfo
   -> HsExpr GhcRn         -- ^ expanded expression
   -> LHsExpr GhcRn        -- ^ suitably wrapped located 'XXExprGhcRn'
-mkExpandedStmtAt loc oStmt eExpr = L loc $ mkExpandedStmt oStmt eExpr
+mkExpandedStmtAt loc oStmt flav tcFun eExpr = L loc $ mkExpandedStmt oStmt flav tcFun eExpr
 
 -- | Wrap the expanded version of the expression with a pop.
 mkExpandedStmtPopAt
   :: SrcSpanAnnA          -- ^ Location for the expansion statement
   -> ExprLStmt GhcRn      -- ^ source statement
+  -> HsDoFlavour
+  -> TCFunInfo
   -> HsExpr GhcRn         -- ^ expanded expression
   -> LHsExpr GhcRn        -- ^ suitably wrapped 'XXExprGhcRn'
-mkExpandedStmtPopAt loc oStmt eExpr = mkPopErrCtxtExprAt loc $ mkExpandedStmtAt loc oStmt eExpr
+mkExpandedStmtPopAt loc oStmt flav tc_fun eExpr = mkPopErrCtxtExprAt loc $ mkExpandedStmtAt loc oStmt flav tc_fun eExpr
 
 
 data XXExprGhcTc
@@ -593,9 +603,10 @@ mkExpandedExprTc oExpr eExpr = XExpr (ExpandedThingTc (OrigExpr oExpr) eExpr)
 --   expanded typechecked expression.
 mkExpandedStmtTc
   :: ExprLStmt GhcRn        -- ^ source do statement
+  -> HsDoFlavour
   -> HsExpr GhcTc           -- ^ expanded typechecked expression
   -> HsExpr GhcTc           -- ^ suitably wrapped 'XXExprGhcRn'
-mkExpandedStmtTc oStmt eExpr = XExpr (ExpandedThingTc (OrigStmt oStmt) eExpr)
+mkExpandedStmtTc oStmt flav eExpr = XExpr (ExpandedThingTc (OrigStmt oStmt flav) eExpr)
 
 {- *********************************************************************
 *                                                                      *
@@ -836,13 +847,13 @@ instance Outputable HsThingRn where
   ppr thing
     = case thing of
         OrigExpr x -> ppr_builder "<OrigExpr>:" x
-        OrigStmt x -> ppr_builder "<OrigStmt>:" x
-        OrigPat x  -> ppr_builder "<OrigPat>:" x
+        OrigStmt x _ -> ppr_builder "<OrigStmt>:" x
+        OrigPat  x _ -> ppr_builder "<OrigPat>:" x
     where ppr_builder prefix x = ifPprDebug (braces (text prefix <+> parens (ppr x))) (ppr x)
 
 instance Outputable XXExprGhcRn where
-  ppr (ExpandedThingRn o e) = ifPprDebug (braces $ vcat [ppr o, ppr e]) (ppr o)
-  ppr (PopErrCtxt e)        = ifPprDebug (braces (text "<PopErrCtxt>" <+> ppr e)) (ppr e)
+  ppr (ExpandedThingRn o e _) = ifPprDebug (braces $ vcat [ppr o, text ";;" , ppr e]) (ppr o)
+  ppr (PopErrCtxt e)          = ifPprDebug (braces (text "<PopErrCtxt>" <+> ppr e)) (ppr e)
 
 instance Outputable XXExprGhcTc where
   ppr (WrapExpr (HsWrap co_fn e))
@@ -882,7 +893,7 @@ ppr_infix_expr (XExpr x)            = case ghcPass @p of
 ppr_infix_expr _ = Nothing
 
 ppr_infix_expr_rn :: XXExprGhcRn -> Maybe SDoc
-ppr_infix_expr_rn (ExpandedThingRn thing _) = ppr_infix_hs_expansion thing
+ppr_infix_expr_rn (ExpandedThingRn thing _ _) = ppr_infix_hs_expansion thing
 ppr_infix_expr_rn (PopErrCtxt (L _ a)) = ppr_infix_expr a
 
 ppr_infix_expr_tc :: XXExprGhcTc -> Maybe SDoc
@@ -993,7 +1004,7 @@ hsExprNeedsParens prec = go
     go_x_tc (HsBinTick _ _ (L _ e))          = hsExprNeedsParens prec e
 
     go_x_rn :: XXExprGhcRn -> Bool
-    go_x_rn (ExpandedThingRn thing _)    = hsExpandedNeedsParens thing
+    go_x_rn (ExpandedThingRn thing _ _)    = hsExpandedNeedsParens thing
     go_x_rn (PopErrCtxt (L _ a))         = hsExprNeedsParens prec a
 
     hsExpandedNeedsParens :: HsThingRn -> Bool
@@ -1045,7 +1056,7 @@ isAtomicHsExpr (XExpr x)
     go_x_tc (HsBinTick {}) = False
 
     go_x_rn :: XXExprGhcRn -> Bool
-    go_x_rn (ExpandedThingRn thing _)    = isAtomicExpandedThingRn thing
+    go_x_rn (ExpandedThingRn thing _ _)    = isAtomicExpandedThingRn thing
     go_x_rn (PopErrCtxt (L _ a))         = isAtomicHsExpr a
 
     isAtomicExpandedThingRn :: HsThingRn -> Bool
@@ -1568,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
@@ -1609,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
@@ -1690,7 +1702,7 @@ type instance XRecStmt         (GhcPass _) GhcTc b = RecStmtTc
 
 type instance XXStmtLR         (GhcPass _) GhcPs b = DataConCantHappen
 type instance XXStmtLR         (GhcPass x) GhcRn b = ApplicativeStmt (GhcPass x) GhcRn
-type instance XXStmtLR         (GhcPass x) GhcTc b = ApplicativeStmt (GhcPass x) GhcTc
+type instance XXStmtLR         (GhcPass x) GhcTc b = DataConCantHappen
 
 -- | 'ApplicativeStmt' represents an applicative expression built with
 -- '<$>' and '<*>'.  It is generated by the renamer, and is desugared into the
@@ -1731,7 +1743,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
@@ -1796,7 +1808,6 @@ pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids
 
 pprStmt (XStmtLR x) = case ghcPass :: GhcPass idR of
     GhcRn -> pprApplicativeStmt x
-    GhcTc -> pprApplicativeStmt x
 
   where
     pprApplicativeStmt :: (OutputableBndrId idL, OutputableBndrId idR) => ApplicativeStmt (GhcPass idL) (GhcPass idR) -> SDoc
@@ -1817,7 +1828,6 @@ pprStmt (XStmtLR x) = case ghcPass :: GhcPass idR of
         flattenStmt :: ExprLStmt (GhcPass idL) -> [SDoc]
         flattenStmt (L _ (XStmtLR x)) = case ghcPass :: GhcPass idL of
             GhcRn | (ApplicativeStmt _ args _) <- x -> concatMap flattenArg args
-            GhcTc | (ApplicativeStmt _ args _) <- x -> concatMap flattenArg args
         flattenStmt stmt = [ppr stmt]
 
         flattenArg :: (a, ApplicativeArg (GhcPass idL)) -> [SDoc]
@@ -1846,13 +1856,13 @@ 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 "<-" <+>
      pprDo ctxt (stmts ++
-                   [noLocA (LastStmt noExtField (noLocA return) Nothing noSyntaxExpr)])
+                   [noLocA (LastStmt noExtField return Nothing noSyntaxExpr)])
 
 pprTransformStmt :: (OutputableBndrId p)
                  => [IdP (GhcPass p)] -> LHsExpr (GhcPass p)


=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -569,6 +569,7 @@ deriving instance Eq (IE GhcTc)
 -- ---------------------------------------------------------------------
 
 deriving instance Data HsThingRn
+deriving instance Data TCFunInfo
 deriving instance Data XXExprGhcRn
 deriving instance Data XXExprGhcTc
 deriving instance Data XXPatGhcTc


=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -1188,7 +1188,6 @@ collectStmtBinders flag = \case
     RecStmt { recS_stmts = L _ ss } -> collectLStmtsBinders flag ss
     XStmtLR x -> case ghcPass :: GhcPass idR of
         GhcRn -> collectApplicativeStmtBndrs x
-        GhcTc -> collectApplicativeStmtBndrs x
   where
     collectApplicativeStmtBndrs :: ApplicativeStmt (GhcPass idL) a -> [IdP (GhcPass idL)]
     collectApplicativeStmtBndrs (ApplicativeStmt _ args _) = concatMap (collectArgBinders . snd) args
@@ -1777,7 +1776,6 @@ lStmtsImplicits = hs_lstmts
     hs_stmt (BindStmt _ pat _) = lPatImplicits pat
     hs_stmt (XStmtLR x) = case ghcPass :: GhcPass idR of
         GhcRn -> hs_applicative_stmt x
-        GhcTc -> hs_applicative_stmt x
     hs_stmt (LetStmt _ binds)     = hs_local_binds binds
     hs_stmt (BodyStmt {})         = []
     hs_stmt (LastStmt {})         = []


=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -315,7 +315,7 @@ dsExpr (HsOverLit _ lit)
 dsExpr e@(XExpr ext_expr_tc)
   = case ext_expr_tc of
       ExpandedThingTc o e
-        | OrigStmt (L loc _) <- o
+        | OrigStmt (L loc _) _ <- o
         -> putSrcSpanDsA loc $ dsExpr e
         | otherwise -> dsExpr e
       WrapExpr {}                    -> dsHsWrapped e
@@ -463,10 +463,10 @@ dsExpr (HsLet _ binds body) = do
 -- because the interpretation of `stmts' depends on what sort of thing it is.
 --
 dsExpr (HsDo res_ty ListComp (L _ stmts)) = dsListComp stmts res_ty
-dsExpr (HsDo _ ctx at DoExpr{}      (L _ stmts)) = dsDo ctx stmts
-dsExpr (HsDo _ ctx at GhciStmtCtxt  (L _ stmts)) = dsDo ctx stmts
-dsExpr (HsDo _ ctx at MDoExpr{}     (L _ stmts)) = dsDo ctx stmts
 dsExpr (HsDo _ MonadComp     (L _ stmts)) = dsMonadComp stmts
+dsExpr (HsDo _ ctx at GhciStmtCtxt  (L _ stmts)) = dsDo ctx stmts
+dsExpr (HsDo _ DoExpr{}      (L _ stmts)) = pprPanic "shouldn't happen dsDo DoExpr" (ppr stmts)
+dsExpr (HsDo _ MDoExpr{}     (L _ stmts)) = pprPanic "shouldn't happen dsDo MDoExpr" (ppr stmts)
 
 dsExpr (HsIf _ guard_expr then_expr else_expr)
   = do { pred <- dsLExpr guard_expr
@@ -815,38 +815,6 @@ dsDo ctx stmts
                      -- This LastStmt will be desugared with dsDo,
                      -- which ignores the return_op in the LastStmt,
                      -- so we must apply the return_op explicitly
-
-    go _ (XStmtLR (ApplicativeStmt body_ty args mb_join)) stmts
-      = do {
-             let
-               (pats, rhss) = unzip (map (do_arg . snd) args)
-
-               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)]))
-
-           ; rhss' <- sequence rhss
-
-           ; body' <- dsLExpr $ noLocA $ HsDo body_ty ctx (noLocA stmts)
-
-           ; let match_args (pat, fail_op) (vs,body)
-                   = putSrcSpanDs (getLocA pat) $
-                     do { var   <- selectSimpleMatchVarL ManyTy pat
-                        ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt ctx)) pat
-                                   body_ty (cantFailMatchResult body)
-                        ; match_code <- dsHandleMonadicFailure ctx pat match fail_op
-                        ; return (var:vs, match_code)
-                        }
-
-           ; (vars, body) <- foldrM match_args ([],body') pats
-           ; let fun' = mkLams vars body
-           ; let mk_ap_call l (op,r) = dsSyntaxExpr op [l,r]
-           ; expr <- foldlM mk_ap_call fun' (zip (map fst args) rhss')
-           ; case mb_join of
-               Nothing -> return expr
-               Just join_op -> dsSyntaxExpr join_op [expr] }
-
     go _ (ParStmt   {}) _ = panic "dsDo ParStmt"
     go _ (TransStmt {}) _ = panic "dsDo TransStmt"
 


=====================================
compiler/GHC/HsToCore/GuardedRHSs.hs
=====================================
@@ -144,8 +144,6 @@ matchGuards (LastStmt  {} : _) _ _ _ _ = panic "matchGuards LastStmt"
 matchGuards (ParStmt   {} : _) _ _ _ _ = panic "matchGuards ParStmt"
 matchGuards (TransStmt {} : _) _ _ _ _ = panic "matchGuards TransStmt"
 matchGuards (RecStmt   {} : _) _ _ _ _ = panic "matchGuards RecStmt"
-matchGuards (XStmtLR ApplicativeStmt {} : _) _ _ _ _ =
-  panic "matchGuards ApplicativeLastStmt"
 
 {-
 Should {\em fail} if @e@ returns @D@


=====================================
compiler/GHC/HsToCore/ListComp.hs
=====================================
@@ -257,9 +257,6 @@ deListComp (ParStmt _ stmtss_w_bndrs _ _ : quals) list
 
 deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt"
 
-deListComp (XStmtLR ApplicativeStmt {} : _) _ =
-  panic "deListComp ApplicativeStmt"
-
 deBindComp :: LPat GhcTc
            -> CoreExpr
            -> [ExprStmt GhcTc]
@@ -352,8 +349,6 @@ dfListComp c_id n_id (BindStmt _ pat list1 : quals) = do
 
 dfListComp _ _ (ParStmt {} : _) = panic "dfListComp ParStmt"
 dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt"
-dfListComp _ _ (XStmtLR ApplicativeStmt {} : _) =
-  panic "dfListComp ApplicativeStmt"
 
 dfBindComp :: Id -> Id             -- 'c' and 'n'
            -> (LPat GhcTc, CoreExpr)
@@ -580,7 +575,6 @@ dsMcStmt (ParStmt bind_ty blocks mzip_op bind_op) stmts_rest
        = do { exp <- dsInnerMonadComp stmts bndrs return_op
             ; return (exp, mkBigCoreVarTupTy bndrs) }
 
-dsMcStmt stmt@(XStmtLR ApplicativeStmt {}) _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)
 dsMcStmt stmt@(RecStmt {}) _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)
 
 matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr


=====================================
compiler/GHC/HsToCore/Pmc/Desugar.hs
=====================================
@@ -377,7 +377,6 @@ desugarGuard guard = case guard of
   ParStmt         {} -> panic "desugarGuard ParStmt"
   TransStmt       {} -> panic "desugarGuard TransStmt"
   RecStmt         {} -> panic "desugarGuard RecStmt"
-  XStmtLR ApplicativeStmt{} -> panic "desugarGuard ApplicativeLastStmt"
 
 -- | Desugar local bindings to a bunch of 'PmLet' guards.
 -- Deals only with simple @let@ or @where@ bindings without any polymorphism,


=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -1685,7 +1685,7 @@ repE (HsProjection _ xs) = repProjection (fmap (field_label . unLoc . dfoLabel .
 repE (HsEmbTy _ t) = do
   t1 <- repLTy (hswc_body t)
   rep2 typeEName [unC t1]
-repE e@(XExpr (ExpandedThingRn o x))
+repE e@(XExpr (ExpandedThingRn o x _))
   | OrigExpr e <- o
   = do { rebindable_on <- lift $ xoptM LangExt.RebindableSyntax
        ; if rebindable_on  -- See Note [Quotation and rebindable syntax]


=====================================
compiler/GHC/HsToCore/Ticks.hs
=====================================
@@ -611,7 +611,7 @@ addTickHsExpr (HsDo srcloc cxt (L l stmts))
                     _        -> Nothing
 
 addTickHsExpanded :: HsThingRn -> HsExpr GhcTc -> TM (HsExpr GhcTc)
-addTickHsExpanded o@(OrigStmt (L pos LastStmt{})) e
+addTickHsExpanded o@(OrigStmt (L pos LastStmt{}) _) e
   -- LastStmt always gets a tick for breakpoint and hpc coverage
   = do d <- getDensity
        case d of
@@ -752,33 +752,10 @@ addTickStmt isGuard stmt@(RecStmt {})
        ; return (stmt { recS_stmts = noLocA stmts', recS_ret_fn = ret'
                       , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
 
-addTickStmt isGuard (XStmtLR (ApplicativeStmt body_ty args mb_join)) = do
-    args' <- mapM (addTickApplicativeArg isGuard) args
-    return (XStmtLR (ApplicativeStmt body_ty args' mb_join))
-
 addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
 addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
                   | otherwise          = addTickLHsExprRHS e
 
-addTickApplicativeArg
-  :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
-  -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
-addTickApplicativeArg isGuard (op, arg) =
-  liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)
- where
-  addTickArg (ApplicativeArgOne m_fail pat expr isBody) =
-    ApplicativeArgOne
-      <$> mapM (addTickSyntaxExpr hpcSrcSpan) m_fail
-      <*> addTickLPat pat
-      <*> addTickLHsExpr expr
-      <*> pure isBody
-  addTickArg (ApplicativeArgMany x stmts ret pat ctxt) =
-    (ApplicativeArgMany x)
-      <$> addTickLStmts isGuard stmts
-      <*> (unLoc <$> addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) ret))
-      <*> addTickLPat pat
-      <*> pure ctxt
-
 addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc
                       -> TM (ParStmtBlock GhcTc GhcTc)
 addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) =
@@ -967,8 +944,6 @@ addTickCmdStmt stmt@(RecStmt {})
        ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
        ; return (stmt { recS_stmts = noLocA stmts', recS_ret_fn = ret'
                       , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
-addTickCmdStmt (XStmtLR (ApplicativeStmt{})) =
-  panic "ToDo: addTickCmdStmt ApplicativeLastStmt"
 
 -- Others should never happen in a command context.
 addTickCmdStmt stmt  = pprPanic "addTickHsCmd" (ppr stmt)


=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -1370,7 +1370,6 @@ instance ( ToHie (LocatedA (body (GhcPass p)))
         ]
       XStmtLR x -> case hiePass @p of
         HieRn -> extApplicativeStmt x
-        HieTc -> extApplicativeStmt x
     where
       node = case hiePass @p of
         HieTc -> makeNodeA stmt span


=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -2221,12 +2221,12 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
      (stmts',fvs2) <- stmtTreeToStmts monad_names ctxt tree [] pvarset
      (mb_ret, fvs1) <-
         if | L _ (XStmtLR ApplicativeStmt{}) <- last stmts' ->
-             return (unLoc tup, emptyNameSet)
+             return (tup, emptyNameSet)
            | otherwise -> do
              -- Need 'pureAName' and not 'returnMName' here, so that it requires
              -- 'Applicative' and not 'Monad' whenever possible (until #20540 is fixed).
              (ret, _) <- lookupQualifiedDoExpr (HsDoStmt ctxt) pureAName
-             let expr = HsApp noExtField (noLocA ret) tup
+             let expr = noLocA (HsApp noExtField (noLocA ret) tup)
              return (expr, emptyFVs)
      return ( ApplicativeArgMany
               { xarg_app_arg_many = noExtField


=====================================
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'
@@ -537,7 +539,7 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
     fun_orig
       | VAExpansion (OrigStmt{}) _ _ <- fun_ctxt
       = DoOrigin
-      | VAExpansion (OrigPat pat) _ _ <- fun_ctxt
+      | VAExpansion (OrigPat pat _) _ _ <- fun_ctxt
       = DoPatOrigin pat
       | VAExpansion (OrigExpr e) _ _ <- fun_ctxt
       = exprCtOrigin e
@@ -731,9 +733,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,28 +797,37 @@ addArgCtxt :: AppCtxt -> LHsExpr GhcRn
 addArgCtxt ctxt (L arg_loc arg) thing_inside
   = do { in_generated_code <- inGeneratedCode
        ; case ctxt of
-           VACall fun arg_no _ | not in_generated_code
+           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
 
-           VAExpansion (OrigStmt (L _ stmt@(BindStmt {}))) _ loc
+           VAExpansion (OrigStmt (L _ stmt@(BindStmt {})) flav) _ loc
              | isGeneratedSrcSpan (locA arg_loc) -- This arg is the second argument to generated (>>=)
              -> setSrcSpan loc $
-                  addStmtCtxt stmt $
+                  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 $
+                  addStmtCtxt stmt flav $
                   thing_inside
-           VAExpansion (OrigStmt (L loc stmt)) _ _
+           VAExpansion (OrigStmt (L loc stmt) flav) _ _
              -> setSrcSpanA loc $
-                  addStmtCtxt stmt $
+                  addStmtCtxt stmt flav $
                   thing_inside
 
            _ -> setSrcSpanA arg_loc $
-                  addExprCtxt arg     $  -- Auto-suppressed if arg_loc is generated
-                  thing_inside }
+                     addExprCtxt arg     $  -- Auto-suppressed if arg_loc is generated
+                     thing_inside }
 
 {- *********************************************************************
 *                                                                      *
@@ -943,7 +953,7 @@ expr_to_type earg =
       | otherwise = not_in_scope
       where occ = occName rdr
             not_in_scope = failWith $ mkTcRnNotInScope rdr NotInScope
-    go (L l (XExpr (ExpandedThingRn (OrigExpr orig) _))) =
+    go (L l (XExpr (ExpandedThingRn (OrigExpr orig) _ _))) =
       -- Use the original, user-written expression (before expansion).
       -- Example. Say we have   vfun :: forall a -> blah
       --          and the call  vfun (Maybe [1,2,3])


=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -21,8 +21,8 @@ module GHC.Tc.Gen.Do (expandDoStmts) where
 
 import GHC.Prelude
 
-import GHC.Rename.Utils ( wrapGenSpan, genHsExpApps, genHsApp, genHsLet,
-                          genHsLamDoExp, genHsCaseAltDoExp, genWildPat )
+import GHC.Rename.Utils ( wrapGenSpan, genHsExpApps, genHsApp, genHsLet, genLHsApp,
+                          genHsLamDoExp, genHsCaseAltDoExp )
 import GHC.Tc.Utils.Monad
 import GHC.Tc.Gen.Pat
 import GHC.Tc.Utils.TcMType
@@ -53,66 +53,56 @@ import Data.List ((\\))
 --   so that they can be typechecked.
 --   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 (LHsExpr GhcRn)
-expandDoStmts doFlav stmts = do expanded_expr <- expand_do_stmts doFlav stmts
-                                case expanded_expr of
-                                         L _ (XExpr (PopErrCtxt e)) -> return 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 expanded_expr
+expandDoStmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (HsExpr GhcRn)
+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 _ (stmt@(L _ (XStmtLR ApplicativeStmt{})): _) =
-  pprPanic "expand_do_stmts: Applicative Stmt" $ ppr stmt
-  -- Handeled by tcSyntaxOp see `GHC.Tc.Gen.Match.tcStmtsAndThen`
-
-
-expand_do_stmts _ [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
-   = do traceTc "expand_do_stmts last" (ppr ret_expr)
-        return $ mkExpandedStmtPopAt loc stmt body
+   = return $ if addPop then mkExpandedStmtPopAt loc stmt flav TcExpr body
+                        else mkExpandedStmtAt loc stmt flav TcExpr 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)
-        return $ mkExpandedStmtPopAt loc stmt expansion
+   = do let expansion = genHsApp ret (L body_loc body)
+        return $ if addPop then mkExpandedStmtPopAt loc stmt flav TcExpr expansion
+                           else mkExpandedStmtAt loc stmt flav TcExpr expansion
 
-expand_do_stmts do_or_lc (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 do_or_lc lstmts
+  do expand_stmts <- expand_do_stmts True doFlavour lstmts
      let expansion = genHsLet bs expand_stmts
-     return $ mkExpandedStmtPopAt loc stmt expansion
+     return $ if addPop then mkExpandedStmtPopAt loc stmt doFlavour TcExpr expansion
+                        else mkExpandedStmtAt loc stmt doFlavour TcExpr expansion
 
-expand_do_stmts do_or_lc (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
@@ -121,29 +111,31 @@ expand_do_stmts do_or_lc (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
 --                                   _   -> fail "Pattern match failure .."
 --    -------------------------------------------------------
 --       pat <- e ; stmts   ~~> (>>=) e f
-  = do expand_stmts <- expand_do_stmts do_or_lc lstmts
-       failable_expr <- mk_failable_expr do_or_lc pat expand_stmts fail_op
+  = 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 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 do_or_lc (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 do_or_lc lstmts
+  do expand_stmts_expr <- expand_do_stmts True doFlavour lstmts
      let expansion = genHsExpApps then_op  -- (>>)
                                   [ e
                                   , expand_stmts_expr ]
-     return $ mkExpandedStmtPopAt loc stmt expansion
+     return $ if addPop then mkExpandedStmtPopAt loc stmt doFlavour TcApp expansion
+                        else mkExpandedStmtAt loc stmt doFlavour TcApp expansion
 
-expand_do_stmts do_or_lc
+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
@@ -163,12 +155,12 @@ expand_do_stmts do_or_lc
 --                                           -> do { rec_stmts
 --                                                 ; return (local_only_ids ++ later_ids) } ))
 --                              (\ [ local_only_ids ++ later_ids ] -> stmts')
-  do expand_stmts <- expand_do_stmts do_or_lc 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)                                           -- (>>=)
                       [ (wrapGenSpan mfix_fun) `mkHsApp` mfix_expr           -- (mfix (do block))
-                      , genHsLamDoExp do_or_lc [ mkBigLHsVarPatTup all_ids ] --        (\ x ->
+                      , genHsLamDoExp doFlavour [ mkBigLHsVarPatTup all_ids ] --        (\ x ->
                                        expand_stmts                          --               stmts')
                       ]
   where
@@ -184,33 +176,112 @@ expand_do_stmts do_or_lc
     do_stmts     :: XRec GhcRn [ExprLStmt GhcRn]
     do_stmts     = L stmts_loc $ rec_stmts ++ [return_stmt]
     do_block     :: LHsExpr GhcRn
-    do_block     = L loc $ HsDo noExtField do_or_lc do_stmts
+    do_block     = L loc $ HsDo noExtField doFlavour do_stmts
     mfix_expr    :: LHsExpr GhcRn
-    mfix_expr    = genHsLamDoExp do_or_lc [ wrapGenSpan (LazyPat noExtField $ mkBigLHsVarPatTup all_ids) ]
+    mfix_expr    = genHsLamDoExp doFlavour [ wrapGenSpan (LazyPat noExtField $ mkBigLHsVarPatTup all_ids) ]
                                           $ do_block
                              -- NB: LazyPat because we do not want to eagerly evaluate the pattern
                              -- and potentially loop forever
 
-expand_do_stmts _ stmts = pprPanic "expand_do_stmts: impossible happened" $ (ppr stmts)
+expand_do_stmts addPop doFlavour ((L _ (XStmtLR (ApplicativeStmt _ args mb_join))): lstmts) =
+-- See Note [Applicative BodyStmt]
+--
+--                  stmts ~~> stmts'
+--   -------------------------------------------------------------------------
+--     [(fmap, \ x -> e1), (<*>, e2), (<*>, e3), .. ] ; stmts  ~~> (\ x -> stmts') <$> e1 <*> e2 ...
+--
+-- Very similar to HsToCore.Expr.dsDo
+
+-- args are [(<$>, e1), (<*>, e2), .., ]
+  do { xexpr <- expand_do_stmts False doFlavour lstmts
+     -- extracts pats and arg bodies (rhss) from args
+
+     ; (pats_can_fail, rhss) <- unzip <$> mapM (do_arg . snd) args
+
+     -- add blocks for failable patterns
+     ; 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)
+
+     -- wrap the expanded expression with a `join` if needed
+     ; let final_expr = case mb_join of
+                          Just (SyntaxExprRn join_op)
+                            -> genLHsApp join_op expand_ado_expr
+                          _ -> expand_ado_expr
+     ; traceTc "expand_do_stmts AppStmt" (vcat [ text "args:" <+> ppr args
+                                               , text "lstmts:" <+> ppr lstmts
+                                               , text "mb_join:" <+> ppr mb_join
+                                               , text "expansion:" <+> ppr final_expr])
+     ; return $ final_expr
+
+     }
+  where
+    do_arg :: ApplicativeArg GhcRn -> TcM ((LPat GhcRn, FailOperator GhcRn), LHsExpr GhcRn)
+    do_arg (ApplicativeArgOne
+            { xarg_app_arg_one = mb_fail_op
+            , app_arg_pattern = pat
+            , arg_expr        = (L rhs_loc rhs)
+            , is_body_stmt    = is_body_stmt
+            }) =
+      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)
+        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 { 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)
+                  , 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
+      where stmt_ctxt = case unLoc stmt_expr of
+                          XExpr (ExpandedThingRn (OrigStmt s _) _ _) -> Just (doFlavour, s)
+                          _ -> Nothing
+
+    mk_apps :: LHsExpr GhcRn -> (SyntaxExprRn, LHsExpr GhcRn) -> LHsExpr GhcRn
+    mk_apps l_expr (op, r_expr) =
+      case op of
+        SyntaxExprRn op -> wrapGenSpan $ genHsExpApps op [ l_expr, r_expr ]
+        NoSyntaxExprRn -> pprPanic "expand_do_stmts applicative op:" (ppr op)
+
+    xbsn :: XBindStmtRn
+    xbsn = XBindStmtRn NoSyntaxExprRn Nothing
+
+
+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 -> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn)
-mk_failable_expr doFlav pat@(L loc _) expr fail_op =
+mk_failable_expr :: HsDoFlavour -> Maybe (HsDoFlavour, ExprLStmt GhcRn)
+                 -> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn)
+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 pat expr fail_op
+       then case pat of
+              (WildPat{}) -> return $ genHsLamDoExp doFlav [L noSrcSpanA pat] expr
+              _ -> return $ case mb_stmt_info of
+                              Nothing -> genHsLamDoExp doFlav [lpat] expr
+                              Just (f, s) -> wrapGenSpan (mkExpandedStmt s f TcExpr
+                                                           (unLoc $ (genHsLamDoExp f [lpat]
+                                                                      $ wrapGenSpan (mkPopErrCtxtExpr expr))))
+       else L loc <$> mk_fail_block doFlav mb_stmt_info lpat expr fail_op
      }
 
 -- makes the fail block with a given fail_op
-mk_fail_block :: HsDoFlavour -> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (HsExpr GhcRn)
-mk_fail_block doFlav pat@(L ploc _) e (Just (SyntaxExprRn fail_op)) =
+mk_fail_block :: HsDoFlavour -> Maybe (HsDoFlavour, ExprLStmt GhcRn)
+              -> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (HsExpr GhcRn)
+mk_fail_block doFlav mb_stmt_info pat@(L ploc _) e (Just (SyntaxExprRn fail_op)) =
   do  dflags <- getDynFlags
       return $ HsLam noAnn LamCases $ mkMatchGroup (doExpansionOrigin doFlav) -- \
                 (wrapGenSpan [ genHsCaseAltDoExp doFlav pat e                 --  pat -> expr
@@ -218,22 +289,22 @@ mk_fail_block doFlav 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
           fail_op_expr dflags pat fail_op
-            = mkExpandedPatRn pat $
+            = mkExpandedPatRn pat mb_stmt_info $
                     genHsApp fail_op (mk_fail_msg_expr dflags 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 (DoExpr Nothing)
+              text "Pattern match failure in" <+> pprHsDoFlavour doFlav
                    <+> text "at" <+> ppr (getLocA pat)
 
 
-mk_fail_block _ _ _ _ = pprPanic "mk_fail_block: impossible happened" empty
+mk_fail_block _ _ _ _ _ = pprPanic "mk_fail_block: impossible happened" empty
 
 
 {- Note [Expanding HsDo with XXExprGhcRn]


=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -710,27 +710,25 @@ tcXExpr (PopErrCtxt (L loc e)) res_ty
       setSrcSpanA loc $
       tcExpr e res_ty
 
-tcXExpr xe@(ExpandedThingRn o e') res_ty
-  | OrigStmt ls@(L loc s at LetStmt{}) <- o
+tcXExpr xe@(ExpandedThingRn o e' tc_info) res_ty
+  | OrigStmt ls@(L loc s at LetStmt{}) flav <- o
   , HsLet x binds e <- e'
   =  do { (binds', wrapper, e') <-  setSrcSpanA loc $
-                            addStmtCtxt s $
+                            addStmtCtxt s flav $
                             tcLocalBinds binds $
                             tcMonoExprNC e res_ty -- NB: Do not call tcMonoExpr here as it adds
                                                   -- a duplicate error context
-        ; return $ mkExpandedStmtTc ls (HsLet x binds' (mkLHsWrap wrapper e'))
+        ; return $ mkExpandedStmtTc ls flav (HsLet x binds' (mkLHsWrap wrapper e'))
         }
-  | OrigStmt ls@(L loc s at LastStmt{}) <- o
-  =  setSrcSpanA loc $
-          addStmtCtxt s $
-          mkExpandedStmtTc ls <$> tcExpr e' res_ty
-                -- It is important that we call tcExpr (and not tcApp) here as
-                -- `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 _) <- o
+  | OrigStmt ls@(L loc s) flav <- o
+  , TcExpr <- tc_info
   = setSrcSpanA loc $
-       mkExpandedStmtTc ls <$> tcApp (XExpr xe) res_ty
+    addStmtCtxt s flav $
+    mkExpandedStmtTc ls flav <$> tcExpr e' res_ty
+  | OrigStmt ls@(L loc _) flav <- o
+  , TcApp <- tc_info
+  = setSrcSpanA loc $
+    mkExpandedStmtTc ls flav <$> tcApp (XExpr xe) res_ty
 
 tcXExpr xe res_ty = tcApp (XExpr xe) res_ty
 


=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -240,7 +240,8 @@ appCtxtLoc (VACall _ _ l)    = l
 
 insideExpansion :: AppCtxt -> Bool
 insideExpansion (VAExpansion {}) = True
-insideExpansion (VACall {})      = False -- but what if the VACall has a generated context?
+insideExpansion (VACall _ _ src)   = isGeneratedSrcSpan src
+-- insideExpansion (VACall {})      = False -- but what if the VACall has a generated context?
 
 instance Outputable AppCtxt where
   ppr (VAExpansion e l _) = text "VAExpansion" <+> ppr e <+> ppr l
@@ -292,7 +293,7 @@ splitHsApps e = go e (top_ctxt 0 e) []
     top_ctxt n (HsPragE _ _ fun)           = top_lctxt n fun
     top_ctxt n (HsAppType _ fun _)         = top_lctxt (n+1) fun
     top_ctxt n (HsApp _ fun _)             = top_lctxt (n+1) fun
-    top_ctxt n (XExpr (ExpandedThingRn o _))
+    top_ctxt n (XExpr (ExpandedThingRn o _ _))
       | OrigExpr fun <- o                  = VACall fun  n noSrcSpan
     top_ctxt n other_fun                   = VACall other_fun n noSrcSpan
 
@@ -317,19 +318,19 @@ splitHsApps e = go e (top_ctxt 0 e) []
             HsQuasiQuote _ _ (L l _)      -> set l ctxt -- l :: SrcAnn NoEpAnns
 
     -- See Note [Looking through ExpandedThingRn]
-    go (XExpr (ExpandedThingRn o e)) ctxt args
+    go (XExpr (ExpandedThingRn o e _)) ctxt args
       | isHsThingRnExpr o
       = 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]
                (EWrap (EExpand o) : args)       -- in `GHC.Tc.Gen.Do`
 
 
-      | OrigPat (L loc _) <- o                              -- so that we set the compiler generated fail context
+      | OrigPat (L loc _) _ <- o                            -- so that we set the compiler generated fail context
       = go e (VAExpansion o (locA loc) (locA loc))          -- to be originating from a failable pattern
                                                             -- See Part 1. Wrinkle 2. of
                (EWrap (EExpand o) : args)                   -- Note [Expanding HsDo with XXExprGhcRn]
@@ -893,17 +894,20 @@ tcInferAppHead_maybe fun
       _                         -> return Nothing
 
 addHeadCtxt :: AppCtxt -> TcM a -> TcM a
-addHeadCtxt (VAExpansion (OrigStmt (L loc stmt)) _ _) thing_inside =
-  do setSrcSpanA loc $
-       addStmtCtxt stmt
+addHeadCtxt (VAExpansion (OrigStmt (L loc stmt) flav) _ _) thing_inside =
+  do traceTc "addHeadCtxt stmt" (ppr stmt)
+     setSrcSpanA loc $
+       addStmtCtxt stmt flav $
          thing_inside
 addHeadCtxt fun_ctxt thing_inside
   | not (isGoodSrcSpan fun_loc)   -- noSrcSpan => no arguments
   = thing_inside                  -- => context is already set
   | otherwise
   = setSrcSpan fun_loc $
-    do case fun_ctxt of
+    do traceTc "addHeadCtxt fun_loc" (ppr fun_ctxt)
+       case fun_ctxt of
          VAExpansion (OrigExpr orig) _ _ -> addExprCtxt orig thing_inside
+         VAExpansion (OrigPat _ (Just (flav, stmt))) _ _ -> addStmtCtxt (unLoc stmt) flav $ thing_inside
          _                               -> thing_inside
   where
     fun_loc = appCtxtLoc fun_ctxt
@@ -1587,9 +1591,9 @@ mis-match in the number of value arguments.
 *                                                                      *
 ********************************************************************* -}
 
-addStmtCtxt :: ExprStmt GhcRn -> TcRn a -> TcRn a
-addStmtCtxt stmt thing_inside
-  = do let err_doc = pprStmtInCtxt (HsDoStmt (DoExpr Nothing)) stmt
+addStmtCtxt :: ExprStmt GhcRn -> HsDoFlavour -> TcRn a -> TcRn a
+addStmtCtxt stmt flav thing_inside
+  = do let err_doc = pprStmtInCtxt (HsDoStmt flav) stmt
        addErrCtxt err_doc thing_inside
   where
     pprStmtInCtxt :: HsStmtContextRn -> StmtLR GhcRn GhcRn (LHsExpr GhcRn) -> SDoc
@@ -1602,6 +1606,7 @@ addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a
 addExprCtxt e thing_inside
   = case e of
       HsUnboundVar {} -> thing_inside
+      XExpr (ExpandedThingRn (OrigStmt stmt flav) _ _) -> addStmtCtxt (unLoc stmt) flav thing_inside
       _ -> addErrCtxt (exprCtxt e) thing_inside
    -- The HsUnboundVar special case addresses situations like
    --    f x = _


=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -78,13 +78,9 @@ import GHC.Types.SrcLoc
 import GHC.Types.Basic( VisArity, isDoExpansionGenerated )
 
 import Control.Monad
-import Control.Arrow ( second )
 import qualified Data.List.NonEmpty as NE
 import Data.Maybe (mapMaybe)
 
-import qualified GHC.LanguageExtensions as LangExt
-
-
 {-
 ************************************************************************
 *                                                                      *
@@ -353,20 +349,16 @@ tcDoStmts ListComp (L l stmts) res_ty
                             (mkCheckExpType elt_ty)
         ; return $ mkHsWrapCo co (HsDo list_ty ListComp (L l stmts')) }
 
-tcDoStmts doExpr@(DoExpr _) ss@(L l stmts) res_ty
-  = do  { isApplicativeDo <- xoptM LangExt.ApplicativeDo
-        ; if isApplicativeDo
-          then do { stmts' <- tcStmts (HsDoStmt doExpr) tcDoStmt stmts res_ty
-                  ; res_ty <- readExpType res_ty
-                  ; return (HsDo res_ty doExpr (L l stmts')) }
-          else do { expanded_expr <- expandDoStmts doExpr stmts
-                                               -- Do expansion on the fly
-                  ; mkExpandedExprTc (HsDo noExtField doExpr ss) <$> tcExpr (unLoc expanded_expr) res_ty }
+tcDoStmts doExpr@(DoExpr _) ss@(L _ stmts) res_ty
+  = do  { traceTc "tcDoStmts" $ text "original:" <+> ppr ss
+        ; expanded_expr <- expandDoStmts doExpr stmts -- Do expansion on the fly
+        ; traceTc "tcDoStmts" $ text "expansion:" <+> ppr expanded_expr
+        ; mkExpandedExprTc (HsDo noExtField doExpr ss) <$> tcExpr expanded_expr res_ty
         }
 
 tcDoStmts mDoExpr@(MDoExpr _) ss@(L _ stmts) res_ty
   = do  { expanded_expr <- expandDoStmts mDoExpr stmts -- Do expansion on the fly
-        ; mkExpandedExprTc (HsDo noExtField mDoExpr ss) <$> tcExpr (unLoc expanded_expr) res_ty  }
+        ; mkExpandedExprTc (HsDo noExtField mDoExpr ss) <$> tcExpr expanded_expr res_ty  }
 
 tcDoStmts MonadComp (L l stmts) res_ty
   = do  { stmts' <- tcStmts (HsDoStmt MonadComp) tcMcStmt stmts res_ty
@@ -997,18 +989,6 @@ tcDoStmt ctxt (RecStmt { recS_stmts = L l stmts, recS_later_ids = later_names
                             , recS_ret_ty = stmts_ty} }, thing)
         }}
 
-tcDoStmt ctxt (XStmtLR (ApplicativeStmt _ pairs mb_join)) res_ty thing_inside
-  = do  { let tc_app_stmts ty = tcApplicativeStmts ctxt pairs ty $
-                                thing_inside . mkCheckExpType
-        ; ((pairs', body_ty, thing), mb_join') <- case mb_join of
-            Nothing -> (, Nothing) <$> tc_app_stmts res_ty
-            Just join_op ->
-              second Just <$>
-              (tcSyntaxOp DoOrigin join_op [SynRho] res_ty $
-               \ [rhs_ty] [rhs_mult] -> tcScalingUsage rhs_mult $ tc_app_stmts (mkCheckExpType rhs_ty))
-
-        ; return (XStmtLR $ ApplicativeStmt body_ty pairs' mb_join', thing) }
-
 tcDoStmt _ stmt _ _
   = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
 
@@ -1084,87 +1064,6 @@ To achieve this we:
     all branches. This step is done with bindLocalNames.
 -}
 
-tcApplicativeStmts
-  :: HsStmtContextRn
-  -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
-  -> ExpRhoType                         -- rhs_ty
-  -> (TcRhoType -> TcM t)               -- thing_inside
-  -> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Type, t)
-
-tcApplicativeStmts ctxt pairs rhs_ty thing_inside
- = do { body_ty <- newFlexiTyVarTy liftedTypeKind
-      ; let arity = length pairs
-      ; ts <- replicateM (arity-1) $ newInferExpType
-      ; exp_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind
-      ; pat_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind
-      ; let fun_ty = mkVisFunTysMany pat_tys body_ty
-
-       -- NB. do the <$>,<*> operators first, we don't want type errors here
-       --     i.e. goOps before goArgs
-       -- See Note [Treat rebindable syntax first]
-      ; let (ops, args) = unzip pairs
-      ; ops' <- goOps fun_ty (zip3 ops (ts ++ [rhs_ty]) exp_tys)
-
-      -- Typecheck each ApplicativeArg separately
-      -- See Note [ApplicativeDo and constraints]
-      ; args' <- mapM (goArg body_ty) (zip3 args pat_tys exp_tys)
-
-      -- Bring into scope all the things bound by the args,
-      -- and typecheck the thing_inside
-      -- See Note [ApplicativeDo and constraints]
-      ; res <- tcExtendIdEnv (concatMap get_arg_bndrs args') $
-               thing_inside body_ty
-
-      ; return (zip ops' args', body_ty, res) }
-  where
-    goOps _ [] = return []
-    goOps t_left ((op,t_i,exp_ty) : ops)
-      = do { (_, op')
-               <- tcSyntaxOp DoOrigin op
-                             [synKnownType t_left, synKnownType exp_ty] t_i $
-                   \ _ _ -> return ()
-           ; t_i <- readExpType t_i
-           ; ops' <- goOps t_i ops
-           ; return (op' : ops') }
-
-    goArg :: Type -> (ApplicativeArg GhcRn, Type, Type)
-          -> TcM (ApplicativeArg GhcTc)
-
-    goArg body_ty (ApplicativeArgOne
-                    { xarg_app_arg_one = fail_op
-                    , app_arg_pattern = pat
-                    , arg_expr = rhs
-                    , ..
-                    }, pat_ty, exp_ty)
-      = setSrcSpan (combineSrcSpans (getLocA pat) (getLocA rhs)) $
-        addErrCtxt (pprStmtInCtxt ctxt (mkRnBindStmt pat rhs))   $
-        do { rhs'      <- tcCheckMonoExprNC rhs exp_ty
-           ; (pat', _) <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $
-                          return ()
-           ; fail_op' <- fmap join . forM fail_op $ \fail ->
-               tcMonadFailOp (DoPatOrigin pat) pat' fail body_ty
-
-           ; return (ApplicativeArgOne
-                      { xarg_app_arg_one = fail_op'
-                      , app_arg_pattern = pat'
-                      , arg_expr        = rhs'
-                      , .. }
-                    ) }
-
-    goArg _body_ty (ApplicativeArgMany x stmts ret pat ctxt, pat_ty, exp_ty)
-      = do { (stmts', (ret',pat')) <-
-                tcStmtsAndThen (HsDoStmt ctxt) tcDoStmt stmts (mkCheckExpType exp_ty) $
-                \res_ty  -> do
-                  { ret'      <- tcExpr ret res_ty
-                  ; (pat', _) <- tcCheckPat (StmtCtxt (HsDoStmt ctxt)) pat (unrestricted pat_ty) $
-                                 return ()
-                  ; return (ret', pat')
-                  }
-           ; return (ApplicativeArgMany x stmts' ret' pat' ctxt) }
-
-    get_arg_bndrs :: ApplicativeArg GhcTc -> [Id]
-    get_arg_bndrs (ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders CollNoDictBinders pat
-    get_arg_bndrs (ApplicativeArgMany { bv_pattern =  pat })    = collectPatBinders CollNoDictBinders pat
 
 {- Note [ApplicativeDo and constraints]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~


=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -751,9 +751,9 @@ exprCtOrigin (HsUntypedSplice {})  = Shouldn'tHappenOrigin "TH untyped splice"
 exprCtOrigin (HsProc {})         = Shouldn'tHappenOrigin "proc"
 exprCtOrigin (HsStatic {})       = Shouldn'tHappenOrigin "static expression"
 exprCtOrigin (HsEmbTy {})        = Shouldn'tHappenOrigin "type expression"
-exprCtOrigin (XExpr (ExpandedThingRn thing _)) | OrigExpr a <- thing = exprCtOrigin a
-                                               | OrigStmt _ <- thing = DoOrigin
-                                               | OrigPat p  <- thing = DoPatOrigin p
+exprCtOrigin (XExpr (ExpandedThingRn thing _ _)) | OrigExpr a <- thing = exprCtOrigin a
+                                                 | OrigStmt _ _ <- thing = DoOrigin
+                                                 | OrigPat p _ <- thing = DoPatOrigin p
 exprCtOrigin (XExpr (PopErrCtxt {})) = Shouldn'tHappenOrigin "PopErrCtxt"
 
 -- | Extract a suitable CtOrigin from a MatchGroup


=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -68,6 +68,7 @@ module GHC.Tc.Utils.Monad(
   checkErr, checkErrAt,
   addMessages,
   discardWarnings, mkDetailedMessage,
+  dbgErrCtxt,
 
   -- * Usage environment
   tcCollectingUsage, tcScalingUsage, tcEmitBindingUsage,
@@ -1230,7 +1231,7 @@ setErrCtxt ctxt = updLclEnv (setLclEnvErrCtxt ctxt)
 -- do any tidying.
 addErrCtxt :: SDoc -> TcM a -> TcM a
 {-# INLINE addErrCtxt #-}   -- Note [Inlining addErrCtxt]
-addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
+addErrCtxt msg thing_inside = dbgErrCtxt msg (addErrCtxtM (\env -> return (env, msg)) thing_inside)
 
 -- | Add a message to the error context. This message may do tidying.
 addErrCtxtM :: (TidyEnv -> ZonkM (TidyEnv, SDoc)) -> TcM a -> TcM a
@@ -1255,6 +1256,13 @@ pushCtxt :: ErrCtxt -> TcM a -> TcM a
 {-# INLINE pushCtxt #-} -- Note [Inlining addErrCtxt]
 pushCtxt ctxt = updLclEnv (updCtxt ctxt)
 
+dbgErrCtxt :: SDoc -> TcM a -> TcM a
+dbgErrCtxt msg thing_inside =
+  do errCtxt <- getErrCtxt
+     info <- mkErrInfo emptyTidyEnv errCtxt
+     traceTc "--Debug Error Context--" (vcat [ppr msg, text "----", ppr info, text "----"])
+     thing_inside
+
 updCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv
 -- Do not update the context if we are in generated code
 -- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr
@@ -1263,8 +1271,8 @@ updCtxt ctxt env
   | otherwise = addLclEnvErrCtxt ctxt env
 
 popErrCtxt :: TcM a -> TcM a
-popErrCtxt thing_inside = updLclEnv (\env -> setLclEnvErrCtxt (pop $ getLclEnvErrCtxt env) env) $
-                          thing_inside
+popErrCtxt thing_inside = dbgErrCtxt (text "PopErrCtxt") $ updLclEnv (\env -> setLclEnvErrCtxt (pop $ getLclEnvErrCtxt env) env) $
+                                       thing_inside
            where
              pop []       = []
              pop (_:msgs) = msgs


=====================================
compiler/GHC/Tc/Utils/Unify.hs
=====================================
@@ -134,7 +134,7 @@ matchActualFunTy
 
 matchActualFunTy herald mb_thing err_info fun_ty
   = assertPpr (isRhoTy fun_ty) (ppr fun_ty) $
-    go 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,


=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -97,7 +97,6 @@ import GHC.Tc.Types.BasicTypes
 import GHC.Data.Maybe
 import GHC.Data.Bag
 
-import Control.Monad
 import Control.Monad.Trans.Class ( lift )
 import Data.Semigroup
 
@@ -1408,54 +1407,6 @@ zonkStmt zBody (BindStmt xbs pat body)
               })
             new_pat new_body }
 
--- Scopes: join > ops (in reverse order) > pats (in forward order)
---              > rest of stmts
-zonkStmt _zBody (XStmtLR (ApplicativeStmt body_ty args mb_join))
-  = do  { new_mb_join   <- zonk_join mb_join
-        ; new_args      <- zonk_args args
-        ; new_body_ty   <- noBinders $ zonkTcTypeToTypeX body_ty
-        ; return $ XStmtLR $ ApplicativeStmt new_body_ty new_args new_mb_join }
-  where
-    zonk_join Nothing  = return Nothing
-    zonk_join (Just j) = Just <$> zonkSyntaxExpr j
-
-    get_pat :: (SyntaxExpr GhcTc, ApplicativeArg GhcTc) -> LPat GhcTc
-    get_pat (_, ApplicativeArgOne _ pat _ _) = pat
-    get_pat (_, ApplicativeArgMany _ _ _ pat _) = pat
-
-    replace_pat :: LPat GhcTc
-                -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
-                -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
-    replace_pat pat (op, ApplicativeArgOne fail_op _ a isBody)
-      = (op, ApplicativeArgOne fail_op pat a isBody)
-    replace_pat pat (op, ApplicativeArgMany x a b _ c)
-      = (op, ApplicativeArgMany x a b pat c)
-
-    zonk_args args
-      = do { new_args_rev <- zonk_args_rev (reverse args)
-           ; new_pats     <- zonkPats (map get_pat args)
-           ; return $ zipWithEqual "zonkStmt" replace_pat
-                        new_pats (reverse new_args_rev) }
-
-     -- these need to go backward, because if any operators are higher-rank,
-     -- later operators may introduce skolems that are in scope for earlier
-     -- arguments
-    zonk_args_rev ((op, arg) : args)
-      = do { new_op   <- zonkSyntaxExpr op
-           ; new_arg  <- noBinders $ zonk_arg arg
-           ; new_args <- zonk_args_rev args
-           ; return $ (new_op, new_arg) : new_args }
-    zonk_args_rev [] = return []
-
-    zonk_arg (ApplicativeArgOne fail_op pat expr isBody)
-      = do { new_expr <- zonkLExpr expr
-           ; new_fail <- forM fail_op $ don'tBind . zonkSyntaxExpr
-           ; return (ApplicativeArgOne new_fail pat new_expr isBody) }
-    zonk_arg (ApplicativeArgMany x stmts ret pat ctxt)
-      = runZonkBndrT (zonkStmts zonkLExpr stmts) $ \ new_stmts ->
-        do { new_ret <- zonkExpr ret
-           ; return (ApplicativeArgMany x new_stmts new_ret pat ctxt) }
-
 -------------------------------------------------------------------------
 zonkRecFields :: HsRecordBinds GhcTc -> ZonkTcM (HsRecordBinds GhcTc)
 zonkRecFields (HsRecFields flds dd)


=====================================
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)
+


=====================================
testsuite/tests/ado/T16135.stderr deleted
=====================================
@@ -1,19 +0,0 @@
-T16135.hs:11:18: error: [GHC-83865]
-    • Couldn't match type ‘a0’ with ‘a’
-      Expected: f a0
-        Actual: f a
-      ‘a0’ is untouchable
-        inside the constraints: Functor f
-        bound by the type signature for:
-                   runf :: forall (f :: * -> *). Functor f => IO (T f)
-        at T16135.hs:7:1-39
-      ‘a’ is a rigid type variable bound by
-        a pattern with constructor:
-          MkT :: forall {k} (f :: k -> *) (a :: k). f a -> T f,
-        in a pattern binding in
-             a 'do' block
-        at T16135.hs:10:5-10
-    • In the first argument of ‘MkT’, namely ‘fa’
-      In the second argument of ‘($)’, namely ‘MkT fa’
-      In a stmt of a 'do' block: return $ MkT fa
-    • Relevant bindings include fa :: f a (bound at T16135.hs:10:9)


=====================================
testsuite/tests/ado/T24406.hs
=====================================
@@ -0,0 +1,14 @@
+{-# LANGUAGE ImpredicativeTypes, ApplicativeDo #-}
+module T where
+
+t :: IO (forall a. a -> a)
+t = return id
+
+p :: (forall a. a -> a) -> (Bool, Int)
+p f = (f True, f 3)
+
+-- This typechecks (with QL)
+foo1 = t >>= \x -> return (p x)
+
+-- But this did not not type check:
+foo2 = do { x <- t ; return (p x) }


=====================================
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
@@ -24,30 +23,39 @@ ado002.hs:9:3: error: [GHC-83865]
                  y <- getChar 'a'
                  print (x, y)
 
-ado002.hs:15:11: error: [GHC-83865]
-    • Couldn't match expected type ‘Int’ with actual type ‘Char’
-    • In the expression: y
-      In a stmt of a 'do' block: return (y, x)
+ado002.hs:13:8: error: [GHC-83865]
+    • Couldn't match type ‘Char’ with ‘Int’
+      Expected: IO Int
+        Actual: IO Char
+    • In a stmt of a 'do' block: x <- getChar
       In the expression:
         do x <- getChar
            y <- getChar
            return (y, x)
+      In an equation for ‘g’:
+          g = do x <- getChar
+                 y <- getChar
+                 return (y, x)
 
-ado002.hs:15:13: error: [GHC-83865]
-    • Couldn't match expected type ‘Int’ with actual type ‘Char’
-    • In the expression: x
-      In a stmt of a 'do' block: return (y, x)
+ado002.hs:14:8: error: [GHC-83865]
+    • Couldn't match type ‘Char’ with ‘Int’
+      Expected: IO Int
+        Actual: IO Char
+    • In a stmt of a 'do' block: y <- getChar
       In the expression:
         do x <- getChar
            y <- getChar
            return (y, x)
+      In an equation for ‘g’:
+          g = do x <- getChar
+                 y <- getChar
+                 return (y, x)
 
-ado002.hs:23:9: error: [GHC-83865]
-    • Couldn't match expected type: Char -> IO a0
-                  with actual type: IO Char
-    • 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
+ado002.hs:20:9: error: [GHC-83865]
+    • Couldn't match type ‘Char’ with ‘Int’
+      Expected: IO Int
+        Actual: IO Char
+    • In a stmt of a 'do' block: x2 <- getChar
       In the expression:
         do x1 <- getChar
            x2 <- getChar
@@ -55,11 +63,17 @@ ado002.hs:23:9: error: [GHC-83865]
            x4 <- getChar
            x5 <- getChar x4
            return (x2, x4)
+      In an equation for ‘h’:
+          h = do x1 <- getChar
+                 x2 <- getChar
+                 x3 <- const (return ()) x1
+                 x4 <- getChar
+                 x5 <- getChar x4
+                 return (x2, x4)
 
-ado002.hs:24:11: error: [GHC-83865]
+ado002.hs:23:3: error: [GHC-83865]
     • Couldn't match expected type ‘Int’ with actual type ‘Char’
-    • In the expression: x2
-      In a stmt of a 'do' block: return (x2, x4)
+    • In a stmt of a 'do' block: x4 <- getChar
       In the expression:
         do x1 <- getChar
            x2 <- getChar
@@ -67,11 +81,20 @@ ado002.hs:24:11: error: [GHC-83865]
            x4 <- getChar
            x5 <- getChar x4
            return (x2, x4)
+      In an equation for ‘h’:
+          h = do x1 <- getChar
+                 x2 <- getChar
+                 x3 <- const (return ()) x1
+                 x4 <- getChar
+                 x5 <- getChar x4
+                 return (x2, x4)
 
-ado002.hs:24:14: error: [GHC-83865]
-    • Couldn't match expected type ‘Int’ with actual type ‘Char’
-    • In the expression: x4
-      In a stmt of a 'do' block: return (x2, x4)
+ado002.hs:23:9: error: [GHC-83865]
+    • Couldn't match expected type: Char -> IO a0
+                  with actual type: IO Char
+    • 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
@@ -79,3 +102,4 @@ ado002.hs:24:14: error: [GHC-83865]
            x4 <- getChar
            x5 <- getChar x4
            return (x2, x4)
+


=====================================
testsuite/tests/ado/ado003.stderr
=====================================
@@ -1,7 +1,7 @@
 
-ado003.hs:7:3: error: [GHC-83865]
-    • Couldn't match expected type ‘Int’ with actual type ‘Char’
-    • In the pattern: 'a'
+ado003.hs:7:18: error: [GHC-83865]
+    • Couldn't match expected type ‘Char’ with actual type ‘Int’
+    • In the first argument of ‘return’, namely ‘(3 :: Int)’
       In a stmt of a 'do' block: 'a' <- return (3 :: Int)
       In the expression:
         do x <- getChar


=====================================
testsuite/tests/ado/ado004.stderr
=====================================
@@ -8,24 +8,24 @@ TYPE SIGNATURES
   test1c ::
     forall (f :: * -> *). Applicative f => (Int -> f Int) -> f Int
   test2 ::
-    forall {f :: * -> *} {t} {b}.
-    (Applicative f, Num t, Num b) =>
+    forall {f :: * -> *} {b} {t}.
+    (Applicative f, Num b, Num t) =>
     (t -> f b) -> f b
   test2a ::
-    forall {f :: * -> *} {t} {b}.
-    (Functor f, Num t, Num b) =>
+    forall {f :: * -> *} {b} {t}.
+    (Functor f, Num b, Num t) =>
     (t -> f b) -> f b
   test2b ::
     forall {f :: * -> *} {t} {a}.
     (Applicative f, Num t) =>
     (t -> a) -> f a
   test2c ::
-    forall {f :: * -> *} {t} {b}.
-    (Functor f, Num t, Num b) =>
+    forall {f :: * -> *} {b} {t}.
+    (Functor f, Num b, Num t) =>
     (t -> f b) -> f b
   test2d ::
-    forall {f :: * -> *} {t} {b} {a}.
-    (Functor f, Num t, Num b) =>
+    forall {f :: * -> *} {b} {t} {a}.
+    (Functor f, Num b, Num t) =>
     (t -> f a) -> f b
   test3 ::
     forall {m :: * -> *} {t1} {t2} {a}.
@@ -44,4 +44,4 @@ TYPE SIGNATURES
     (Monad m, Num (m a)) =>
     (m a -> m (m a)) -> p -> m a
 Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [base-4.20.0.0]


=====================================
testsuite/tests/ado/all.T
=====================================
@@ -20,5 +20,6 @@ test('T15344', normal, compile_and_run, [''])
 test('T16628', normal, compile_fail, [''])
 test('T17835', normal, compile, [''])
 test('T20540', normal, compile, [''])
-test('T16135', [when(compiler_debugged(),expect_broken(16135))], compile_fail, [''])
+test('T16135', [when(compiler_debugged(),expect_broken(16135))], compile, [''])
 test('T22483', normal, compile, ['-Wall'])
+test('T24406', normal, compile, [''])
\ No newline at end of file


=====================================
testsuite/tests/determinism/determ021/determ021.stdout
=====================================
@@ -1,16 +1,16 @@
 [1 of 1] Compiling A                ( A.hs, A.o )
 TYPE SIGNATURES
   test2 ::
-    forall {f :: * -> *} {t} {b}.
-    (Applicative f, Num t, Num b) =>
+    forall {f :: * -> *} {b} {t}.
+    (Applicative f, Num b, Num t) =>
     (t -> f b) -> f b
 Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [base-4.20.0.0]
 [1 of 1] Compiling A                ( A.hs, A.o )
 TYPE SIGNATURES
   test2 ::
-    forall {f :: * -> *} {t} {b}.
-    (Applicative f, Num t, Num b) =>
+    forall {f :: * -> *} {b} {t}.
+    (Applicative f, Num b, Num t) =>
     (t -> f b) -> f b
 Dependent modules: []
-Dependent packages: [base-4.16.0.0]
+Dependent packages: [base-4.20.0.0]


=====================================
testsuite/tests/ghci.debugger/scripts/break029.stdout
=====================================
@@ -1,9 +1,9 @@
 Stopped in Main.f, break029.hs:(4,7)-(6,16)
 _result :: IO Int = _
 x :: Int = 3
-Stopped in Main.f, break029.hs:5:8-21
-_result :: IO Int = _
-x :: Int = 3
+Stopped in Main.f, break029.hs:6:3-16
+_result :: Int = _
+y :: Int = _
 Stopped in Main.f, break029.hs:6:11-15
 _result :: Int = _
 y :: Int = _


=====================================
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/-/commit/0dd8fb6b8ed90ca35e8fc9f3b1f9d1b186e18d7e

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0dd8fb6b8ed90ca35e8fc9f3b1f9d1b186e18d7e
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/20240529/59c4bafb/attachment-0001.html>


More information about the ghc-commits mailing list