TTG: ApplicativeStatement exist only in Rn and Tcwip/romes/ttg-applicative-statement

14 files changed, 197 insertions, 178 deletions

diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 405b772199..1ee2edd7f1 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -1478,9 +1478,9 @@ data XBindStmtTc = XBindStmtTc
   , xbstc_failOp :: FailOperator GhcTc
   }
 
-type instance XApplicativeStmt (GhcPass _) GhcPs b = NoExtField
-type instance XApplicativeStmt (GhcPass _) GhcRn b = NoExtField
-type instance XApplicativeStmt (GhcPass _) GhcTc b = Type
+type instance XApplicativeStmt (GhcPass _) GhcPs = NoExtField
+type instance XApplicativeStmt (GhcPass _) GhcRn = NoExtField
+type instance XApplicativeStmt (GhcPass _) GhcTc = Type
 
 type instance XBodyStmt        (GhcPass _) GhcPs b = NoExtField
 type instance XBodyStmt        (GhcPass _) GhcRn b = NoExtField
@@ -1500,7 +1500,62 @@ type instance XRecStmt         (GhcPass _) GhcPs b = EpAnn AnnList
 type instance XRecStmt         (GhcPass _) GhcRn b = NoExtField
 type instance XRecStmt         (GhcPass _) GhcTc b = RecStmtTc
 
-type instance XXStmtLR         (GhcPass _) (GhcPass _) b = DataConCantHappen
+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
+
+-- | 'ApplicativeStmt' represents an applicative expression built with
+-- '<$>' and '<*>'.  It is generated by the renamer, and is desugared into the
+-- appropriate applicative expression by the desugarer, but it is intended
+-- to be invisible in error messages.
+--
+-- For full details, see Note [ApplicativeDo] in "GHC.Rename.Expr"
+--
+data ApplicativeStmt idL idR
+  = ApplicativeStmt
+             (XApplicativeStmt idL idR) -- Post typecheck, Type of the body
+             [ ( SyntaxExpr idR
+               , ApplicativeArg idL) ]
+                      -- [(<$>, e1), (<*>, e2), ..., (<*>, en)]
+             (Maybe (SyntaxExpr idR))  -- 'join', if necessary
+
+-- | Applicative Argument
+data ApplicativeArg idL
+  = ApplicativeArgOne      -- A single statement (BindStmt or BodyStmt)
+    { xarg_app_arg_one  :: XApplicativeArgOne idL
+      -- ^ The fail operator, after renaming
+      --
+      -- The fail operator is needed if this is a BindStmt
+      -- where the pattern can fail. E.g.:
+      -- (Just a) <- stmt
+      -- The fail operator will be invoked if the pattern
+      -- match fails.
+      -- It is also used for guards in MonadComprehensions.
+      -- The fail operator is Nothing
+      -- if the pattern match can't fail
+    , app_arg_pattern   :: LPat idL -- WildPat if it was a BodyStmt (see below)
+    , arg_expr          :: LHsExpr idL
+    , is_body_stmt      :: Bool
+      -- ^ True <=> was a BodyStmt,
+      -- False <=> was a BindStmt.
+      -- See Note [Applicative BodyStmt]
+    }
+  | 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)
+    , bv_pattern        :: LPat idL      -- (v1,...,vn)
+    , stmt_context      :: HsDoFlavour
+      -- ^ context of the do expression, used in pprArg
+    }
+  | XApplicativeArg !(XXApplicativeArg idL)
+
+type family XApplicativeStmt x x'
+
+-- ApplicativeArg type families
+type family XApplicativeArgOne   x
+type family XApplicativeArgMany  x
+type family XXApplicativeArg     x
 
 type instance XParStmtBlock  (GhcPass pL) (GhcPass pR) = NoExtField
 type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = DataConCantHappen
@@ -1551,41 +1606,49 @@ pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids
          , whenPprDebug (vcat [ text "rec_ids=" <> ppr rec_ids
                             , text "later_ids=" <> ppr later_ids])]
 
-pprStmt (ApplicativeStmt _ args mb_join)
-  = getPprStyle $ \style ->
-      if userStyle style
-         then pp_for_user
-         else pp_debug
+pprStmt (XStmtLR x)
+  = case ghcPass @idR of
+      GhcRn -> pprApplicativeStmt x
+      GhcTc -> pprApplicativeStmt x
   where
-  -- make all the Applicative stuff invisible in error messages by
-  -- flattening the whole ApplicativeStmt nest back to a sequence
-  -- of statements.
-   pp_for_user = vcat $ concatMap flattenArg args
-
-   -- ppr directly rather than transforming here, because we need to
-   -- inject a "return" which is hard when we're polymorphic in the id
-   -- type.
-   flattenStmt :: ExprLStmt (GhcPass idL) -> [SDoc]
-   flattenStmt (L _ (ApplicativeStmt _ args _)) = concatMap flattenArg args
-   flattenStmt stmt = [ppr stmt]
-
-   flattenArg :: forall a . (a, ApplicativeArg (GhcPass idL)) -> [SDoc]
-   flattenArg (_, ApplicativeArgOne _ pat expr isBody)
-     | isBody =  [ppr expr] -- See Note [Applicative BodyStmt]
-     | otherwise = [pprBindStmt pat expr]
-   flattenArg (_, ApplicativeArgMany _ stmts _ _ _) =
-     concatMap flattenStmt stmts
-
-   pp_debug =
-     let
-         ap_expr = sep (punctuate (text " |") (map pp_arg args))
-     in
-       whenPprDebug (if isJust mb_join then text "[join]" else empty) <+>
-       (if lengthAtLeast args 2 then parens else id) ap_expr
-
-   pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc
-   pp_arg (_, applicativeArg) = ppr applicativeArg
-
+    pprApplicativeStmt :: (OutputableBndrId idL, OutputableBndrId idR) => ApplicativeStmt (GhcPass idL) (GhcPass idR) -> SDoc
+    pprApplicativeStmt (ApplicativeStmt _ args mb_join) = 
+      getPprStyle $ \style ->
+          if userStyle style
+             then pp_for_user
+             else pp_debug
+      where
+        -- make all the Applicative stuff invisible in error messages by
+        -- flattening the whole ApplicativeStmt nest back to a sequence
+        -- of statements.
+        pp_for_user = vcat $ concatMap flattenArg args
+  
+        -- ppr directly rather than transforming here, because we need to
+        -- inject a "return" which is hard when we're polymorphic in the id
+        -- type.
+        flattenStmt :: ExprLStmt (GhcPass idL) -> [SDoc]
+        flattenStmt (L _ (XStmtLR x)) = case ghcPass @idL of
+            GhcRn | (ApplicativeStmt _ args _) <- x -> concatMap flattenArg args
+            GhcTc | (ApplicativeStmt _ args _) <- x -> concatMap flattenArg args
+        flattenStmt stmt = [ppr stmt]
+  
+        flattenArg :: forall a . (a, ApplicativeArg (GhcPass idL)) -> [SDoc]
+        flattenArg (_, ApplicativeArgOne _ pat expr isBody)
+          | isBody =  [ppr expr] -- See Note [Applicative BodyStmt]
+          | otherwise = [pprBindStmt pat expr]
+        flattenArg (_, ApplicativeArgMany _ stmts _ _ _) =
+          concatMap flattenStmt stmts
+  
+        pp_debug =
+          let
+              ap_expr = sep (punctuate (text " |") (map pp_arg args))
+          in
+            whenPprDebug (if isJust mb_join then text "[join]" else empty) <+>
+            (if lengthAtLeast args 2 then parens else id) ap_expr
+  
+        pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc
+        pp_arg (_, applicativeArg) = ppr applicativeArg
+  
 pprBindStmt :: (Outputable pat, Outputable expr) => pat -> expr -> SDoc
 pprBindStmt pat expr = hsep [ppr pat, larrow, ppr expr]
 
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index a0c588413b..11343503c8 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -366,6 +366,17 @@ deriving instance Data (ParStmtBlock GhcPs GhcRn)
 deriving instance Data (ParStmtBlock GhcRn GhcRn)
 deriving instance Data (ParStmtBlock GhcTc GhcTc)
 
+-- ROMES:TODO: Can we get rid of one of the parameters? What is applicativestmt?
+deriving instance Data (ApplicativeStmt GhcPs GhcPs)
+deriving instance Data (ApplicativeStmt GhcPs GhcRn)
+deriving instance Data (ApplicativeStmt GhcPs GhcTc)
+deriving instance Data (ApplicativeStmt GhcRn GhcPs)
+deriving instance Data (ApplicativeStmt GhcRn GhcRn)
+deriving instance Data (ApplicativeStmt GhcRn GhcTc)
+deriving instance Data (ApplicativeStmt GhcTc GhcPs)
+deriving instance Data (ApplicativeStmt GhcTc GhcRn)
+deriving instance Data (ApplicativeStmt GhcTc GhcTc)
+
 -- deriving instance (DataIdLR p p) => Data (ApplicativeArg p)
 deriving instance Data (ApplicativeArg GhcPs)
 deriving instance Data (ApplicativeArg GhcRn)
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 3e74eea3db..b3d0781f07 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -1119,7 +1119,7 @@ collectLStmtBinders
 collectLStmtBinders flag = collectStmtBinders flag . unLoc
 
 collectStmtBinders
-  :: CollectPass (GhcPass idL)
+  :: forall idL idR body. CollectPass (GhcPass idL)
   => CollectFlag (GhcPass idL)
   -> StmtLR (GhcPass idL) (GhcPass idR) body
   -> [IdP (GhcPass idL)]
@@ -1132,11 +1132,15 @@ collectStmtBinders flag = \case
     ParStmt _ xs _ _ -> collectLStmtsBinders flag [s | ParStmtBlock _ ss _ _ <- xs, s <- ss]
     TransStmt { trS_stmts = stmts } -> collectLStmtsBinders flag stmts
     RecStmt { recS_stmts = L _ ss } -> collectLStmtsBinders flag ss
-    ApplicativeStmt _ args _        -> concatMap collectArgBinders args
-        where
-         collectArgBinders = \case
-            (_, ApplicativeArgOne { app_arg_pattern = pat }) -> collectPatBinders flag pat
-            (_, ApplicativeArgMany { bv_pattern = pat })     -> collectPatBinders flag pat
+    -- ROMES:TODO:
+    -- XStmtLR x -> case ghcPass @idR of
+    --     GhcRn | ApplicativeStmt _ args _ <- x -> concatMap collectArgBinders args
+    --     GhcTc | ApplicativeStmt _ args _ <- x -> concatMap collectArgBinders args
+    --     where
+    --      collectArgBinders :: (a, ApplicativeArg (GhcPass idL)) -> [IdP (GhcPass idL)]
+    --      collectArgBinders = \case
+    --         (_, ApplicativeArgOne { app_arg_pattern = pat }) -> collectPatBinders flag pat
+    --         (_, ApplicativeArgMany { bv_pattern = pat })     -> collectPatBinders flag pat
 
 
 ----------------- Patterns --------------------------
@@ -1548,16 +1552,18 @@ lStmtsImplicits = hs_lstmts
     hs_stmt :: StmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))
             -> [(SrcSpan, [Name])]
     hs_stmt (BindStmt _ pat _) = lPatImplicits pat
-    hs_stmt (ApplicativeStmt _ args _) = concatMap do_arg args
-      where do_arg (_, ApplicativeArgOne { app_arg_pattern = pat }) = lPatImplicits pat
-            do_arg (_, ApplicativeArgMany { app_stmts = stmts }) = hs_lstmts stmts
     hs_stmt (LetStmt _ binds)     = hs_local_binds binds
     hs_stmt (BodyStmt {})         = []
     hs_stmt (LastStmt {})         = []
-    hs_stmt (ParStmt _ xs _ _)    = hs_lstmts [s | ParStmtBlock _ ss _ _ <- xs
-                                                , s <- ss]
+    hs_stmt (ParStmt _ xs _ _)    = hs_lstmts [s | ParStmtBlock _ ss _ _ <- xs , s <- ss]
     hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts
     hs_stmt (RecStmt { recS_stmts = L _ ss }) = hs_lstmts ss
+    -- ROMES:TODO
+    -- hs_stmt (XStmtLR x) = case ghcPass @idR of
+    --     GhcRn | (ApplicativeStmt _ args _) <- x -> concatMap do_arg args
+    --     GhcTc | (ApplicativeStmt _ args _) <- x -> concatMap do_arg args
+    --   where do_arg (_, ApplicativeArgOne { app_arg_pattern = pat }) = lPatImplicits pat
+    --         do_arg (_, ApplicativeArgMany { app_stmts = stmts }) = hs_lstmts stmts
 
     hs_local_binds (HsValBinds _ val_binds) = hsValBindsImplicits val_binds
     hs_local_binds (HsIPBinds {})           = []
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index 1acc52fad0..7153c62473 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -700,36 +700,6 @@ dsDo ctx stmts
             ; match_code <- dsHandleMonadicFailure ctx pat match (xbstc_failOp xbs)
             ; dsSyntaxExpr (xbstc_bindOp xbs) [rhs', Lam var match_code] }
 
-    go _ (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)
-                   = do { var   <- selectSimpleMatchVarL Many 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 loc (RecStmt { recS_stmts = L _ rec_stmts, recS_later_ids = later_ids
                     , recS_rec_ids = rec_ids, recS_ret_fn = return_op
                     , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
@@ -770,6 +740,37 @@ dsDo ctx stmts
                      -- 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)
+                   = do { var   <- selectSimpleMatchVarL Many 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"
 
diff --git a/compiler/GHC/HsToCore/GuardedRHSs.hs b/compiler/GHC/HsToCore/GuardedRHSs.hs
index 8ecf6c84ed..14803818b3 100644
--- a/compiler/GHC/HsToCore/GuardedRHSs.hs
+++ b/compiler/GHC/HsToCore/GuardedRHSs.hs
@@ -144,7 +144,7 @@ matchGuards (LastStmt  {} : _) _ _ _ _ = panic "matchGuards LastStmt"
 matchGuards (ParStmt   {} : _) _ _ _ _ = panic "matchGuards ParStmt"
 matchGuards (TransStmt {} : _) _ _ _ _ = panic "matchGuards TransStmt"
 matchGuards (RecStmt   {} : _) _ _ _ _ = panic "matchGuards RecStmt"
-matchGuards (ApplicativeStmt {} : _) _ _ _ _ =
+matchGuards (XStmtLR ApplicativeStmt {} : _) _ _ _ _ =
   panic "matchGuards ApplicativeLastStmt"
 
 {-
diff --git a/compiler/GHC/HsToCore/ListComp.hs b/compiler/GHC/HsToCore/ListComp.hs
index 12a40e6c90..4365abeb65 100644
--- a/compiler/GHC/HsToCore/ListComp.hs
+++ b/compiler/GHC/HsToCore/ListComp.hs
@@ -258,7 +258,7 @@ deListComp (ParStmt _ stmtss_w_bndrs _ _ : quals) list
 
 deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt"
 
-deListComp (ApplicativeStmt {} : _) _ =
+deListComp (XStmtLR ApplicativeStmt {} : _) _ =
   panic "deListComp ApplicativeStmt"
 
 deBindComp :: LPat GhcTc
@@ -353,7 +353,7 @@ dfListComp c_id n_id (BindStmt _ pat list1 : quals) = do
 
 dfListComp _ _ (ParStmt {} : _) = panic "dfListComp ParStmt"
 dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt"
-dfListComp _ _ (ApplicativeStmt {} : _) =
+dfListComp _ _ (XStmtLR ApplicativeStmt {} : _) =
   panic "dfListComp ApplicativeStmt"
 
 dfBindComp :: Id -> Id             -- 'c' and 'n'
diff --git a/compiler/GHC/HsToCore/Pmc/Desugar.hs b/compiler/GHC/HsToCore/Pmc/Desugar.hs
index c0d0d9f0e9..a783817221 100644
--- a/compiler/GHC/HsToCore/Pmc/Desugar.hs
+++ b/compiler/GHC/HsToCore/Pmc/Desugar.hs
@@ -370,7 +370,7 @@ desugarGuard guard = case guard of
   ParStmt         {} -> panic "desugarGuard ParStmt"
   TransStmt       {} -> panic "desugarGuard TransStmt"
   RecStmt         {} -> panic "desugarGuard RecStmt"
-  ApplicativeStmt {} -> panic "desugarGuard ApplicativeLastStmt"
+  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,
diff --git a/compiler/GHC/HsToCore/Ticks.hs b/compiler/GHC/HsToCore/Ticks.hs
index f47ee5689e..d56cba4ae8 100644
--- a/compiler/GHC/HsToCore/Ticks.hs
+++ b/compiler/GHC/HsToCore/Ticks.hs
@@ -700,9 +700,6 @@ addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) =
         (mapM (addTickStmtAndBinders isGuard) pairs)
         (unLoc <$> addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) mzipExpr))
         (addTickSyntaxExpr hpcSrcSpan bindExpr)
-addTickStmt isGuard (ApplicativeStmt body_ty args mb_join) = do
-    args' <- mapM (addTickApplicativeArg isGuard) args
-    return (ApplicativeStmt body_ty args' mb_join)
 
 addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts
                                     , trS_by = by, trS_using = using
@@ -725,6 +722,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
@@ -938,7 +939,7 @@ 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 ApplicativeStmt{} =
+addTickCmdStmt (XStmtLR (ApplicativeStmt{})) =
   panic "ToDo: addTickCmdStmt ApplicativeLastStmt"
 
 -- Others should never happen in a command context.
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 43cd29bc1c..552bd1d628 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -1255,9 +1255,6 @@ instance ( ToHie (LocatedA (body (GhcPass p)))
         [ toHie $ PS (getRealSpan $ getLocA body) scope NoScope pat
         , toHie body
         ]
-      ApplicativeStmt _ stmts _ ->
-        [ concatMapM (toHie . RS scope . snd) stmts
-        ]
       BodyStmt _ body _ _ ->
         [ toHie body
         ]
@@ -1277,10 +1274,15 @@ instance ( ToHie (LocatedA (body (GhcPass p)))
       RecStmt {recS_stmts = L _ stmts} ->
         [ toHie $ map (RS $ combineScopes scope (mkScope (locA span))) stmts
         ]
+      XStmtLR x -> ext x
+          where
     where
       node = case hiePass @p of
         HieTc -> makeNodeA stmt span
         HieRn -> makeNodeA stmt span
+      ext x = case hiePass @p of
+        HieRn | ApplicativeStmt _ stmts _ <- x -> [ concatMapM (toHie . RS scope . snd) stmts ]
+        HieTc | ApplicativeStmt _ stmts _ <- x -> [ concatMapM (toHie . RS scope . snd) stmts ]
 
 instance HiePass p => ToHie (RScoped (HsLocalBinds (GhcPass p))) where
   toHie (RS scope binds) = concatM $ makeNode binds (spanHsLocaLBinds binds) : case binds of
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index 6316ecea63..6b2551faf1 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -943,7 +943,7 @@ methodNamesStmt (RecStmt { recS_stmts = L _ stmts }) =
 methodNamesStmt (LetStmt {})                   = emptyFVs
 methodNamesStmt (ParStmt {})                   = emptyFVs
 methodNamesStmt (TransStmt {})                 = emptyFVs
-methodNamesStmt ApplicativeStmt{}              = emptyFVs
+methodNamesStmt (XStmtLR ApplicativeStmt{})    = emptyFVs
    -- ParStmt and TransStmt can't occur in commands, but it's not
    -- convenient to error here so we just do what's convenient
 
@@ -1265,9 +1265,6 @@ rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = for
                                     , trS_ret = return_op, trS_bind = bind_op
                                     , trS_fmap = fmap_op }), fvs2)], thing), all_fvs) }
 
-rnStmt _ _ (L _ ApplicativeStmt{}) _ =
-  panic "rnStmt: ApplicativeStmt"
-
 rnParallelStmts :: forall thing. HsStmtContext GhcRn
                 -> SyntaxExpr GhcRn
                 -> [ParStmtBlock GhcPs GhcPs]
@@ -1473,9 +1470,6 @@ rn_rec_stmt_lhs _ stmt@(L _ (ParStmt {}))       -- Syntactically illegal in mdo
 rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {}))     -- Syntactically illegal in mdo
   = pprPanic "rn_rec_stmt" (ppr stmt)
 
-rn_rec_stmt_lhs _ stmt@(L _ (ApplicativeStmt {})) -- Shouldn't appear yet
-  = pprPanic "rn_rec_stmt" (ppr stmt)
-
 rn_rec_stmt_lhs _ (L _ (LetStmt _ (EmptyLocalBinds _)))
   = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
 
@@ -1550,9 +1544,6 @@ rn_rec_stmt _ _ _ stmt@(L _ (TransStmt {}), _)     -- Syntactically illegal in m
 rn_rec_stmt _ _ _ (L _ (LetStmt _ (EmptyLocalBinds _)), _)
   = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
 
-rn_rec_stmt _ _ _ stmt@(L _ (ApplicativeStmt {}), _)
-  = pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt)
-
 rn_rec_stmts :: AnnoBody body =>
                 HsStmtContext GhcRn
              -> (body GhcPs -> RnM (body GhcRn, FreeVars))
@@ -2148,7 +2139,7 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
          tup = mkBigLHsVarTup pvars noExtField
      (stmts',fvs2) <- stmtTreeToStmts monad_names ctxt tree [] pvarset
      (mb_ret, fvs1) <-
-        if | L _ ApplicativeStmt{} <- last stmts' ->
+        if | L _ (XStmtLR ApplicativeStmt{}) <- last stmts' ->
              return (unLoc tup, emptyNameSet)
            | otherwise -> do
              -- Need 'pureAName' and not 'returnMName' here, so that it requires
@@ -2371,7 +2362,7 @@ mkApplicativeStmt ctxt args need_join body_stmts
                 ; return (Just join_op, fvs) }
            else
              return (Nothing, emptyNameSet)
-       ; let applicative_stmt = noLocA $ ApplicativeStmt noExtField
+       ; let applicative_stmt = noLocA $ XStmtLR $ ApplicativeStmt noExtField
                (zip (fmap_op : repeat ap_op) args)
                mb_join
        ; return ( applicative_stmt : body_stmts
@@ -2505,7 +2496,7 @@ checkStmt ctxt (L _ stmt)
    msg = sep [ text "Unexpected" <+> pprStmtCat stmt <+> text "statement"
              , text "in" <+> pprAStmtContext ctxt ]
 
-pprStmtCat :: Stmt (GhcPass a) body -> SDoc
+pprStmtCat :: forall a body. IsPass a => Stmt (GhcPass a) body -> SDoc
 pprStmtCat (TransStmt {})     = text "transform"
 pprStmtCat (LastStmt {})      = text "return expression"
 pprStmtCat (BodyStmt {})      = text "body"
@@ -2513,7 +2504,9 @@ pprStmtCat (BindStmt {})      = text "binding"
 pprStmtCat (LetStmt {})       = text "let"
 pprStmtCat (RecStmt {})       = text "rec"
 pprStmtCat (ParStmt {})       = text "parallel"
-pprStmtCat (ApplicativeStmt {}) = panic "pprStmtCat: ApplicativeStmt"
+pprStmtCat (XStmtLR _)        = case ghcPass @a of
+                                  GhcRn -> panic "pprStmtCat: ApplicativeStmt"
+                                  GhcTc -> panic "pprStmtCat: ApplicativeStmt"
 
 ------------
 emptyInvalid :: Validity  -- Payload is the empty document
@@ -2584,7 +2577,6 @@ okCompStmt dflags _ stmt
          | otherwise -> NotValid (text "Use TransformListComp")
        RecStmt {}  -> emptyInvalid
        LastStmt {} -> emptyInvalid  -- Should not happen (dealt with by checkLastStmt)
-       ApplicativeStmt {} -> emptyInvalid
 
 ---------
 checkTupleSection :: [HsTupArg GhcPs] -> RnM ()
diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs
index e1a0c2401b..d043b2a352 100644
--- a/compiler/GHC/Tc/Gen/Match.hs
+++ b/compiler/GHC/Tc/Gen/Match.hs
@@ -397,7 +397,7 @@ tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt x binds) : stmts)
 -- possible to do this with a popErrCtxt in the tcStmt case for
 -- ApplicativeStmt, but it did something strange and broke a test (ado002).
 tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
-  | ApplicativeStmt{} <- stmt
+  | XStmtLR ApplicativeStmt{} <- stmt
   = do  { (stmt', (stmts', thing)) <-
              stmt_chk ctxt stmt res_ty $ \ res_ty' ->
                tcStmtsAndThen ctxt stmt_chk stmts res_ty'  $
@@ -885,18 +885,6 @@ tcDoStmt ctxt (BindStmt xbsrn pat rhs) res_ty thing_inside
                 }
         ; return (BindStmt xbstc pat' rhs', thing) }
 
-tcDoStmt ctxt (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 (ApplicativeStmt body_ty pairs' mb_join', thing) }
-
 tcDoStmt _ (BodyStmt _ rhs then_op _) res_ty thing_inside
   = do  {       -- Deal with rebindable syntax;
                 --   (>>) :: rhs_ty -> new_res_ty -> res_ty
@@ -962,6 +950,18 @@ 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)
 
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index f11bc29000..36ad2a985d 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -1220,12 +1220,12 @@ zonkStmt env zBody (BindStmt xbs pat body)
 
 -- Scopes: join > ops (in reverse order) > pats (in forward order)
 --              > rest of stmts
-zonkStmt env _zBody (ApplicativeStmt body_ty args mb_join)
+zonkStmt env _zBody (XStmtLR (ApplicativeStmt body_ty args mb_join))
   = do  { (env1, new_mb_join)   <- zonk_join env mb_join
         ; (env2, new_args)      <- zonk_args env1 args
         ; new_body_ty           <- zonkTcTypeToTypeX env2 body_ty
         ; return ( env2
-                 , ApplicativeStmt new_body_ty new_args new_mb_join) }
+                 , XStmtLR $ ApplicativeStmt new_body_ty new_args new_mb_join) }
   where
     zonk_join env Nothing  = return (env, Nothing)
     zonk_join env (Just j) = second Just <$> zonkSyntaxExpr env j
diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs
index 326c9903dc..03596f1a77 100644
--- a/compiler/Language/Haskell/Syntax/Expr.hs
+++ b/compiler/Language/Haskell/Syntax/Expr.hs
@@ -1131,20 +1131,6 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
              (LPat idL)
              body
 
-  -- | 'ApplicativeStmt' represents an applicative expression built with
-  -- '<$>' and '<*>'.  It is generated by the renamer, and is desugared into the
-  -- appropriate applicative expression by the desugarer, but it is intended
-  -- to be invisible in error messages.
-  --
-  -- For full details, see Note [ApplicativeDo] in "GHC.Rename.Expr"
-  --
-  | ApplicativeStmt
-             (XApplicativeStmt idL idR body) -- Post typecheck, Type of the body
-             [ ( SyntaxExpr idR
-               , ApplicativeArg idL) ]
-                      -- [(<$>, e1), (<*>, e2), ..., (<*>, en)]
-             (Maybe (SyntaxExpr idR))  -- 'join', if necessary
-
   | BodyStmt (XBodyStmt idL idR body) -- Post typecheck, element type
                                       -- of the RHS (used for arrows)
              body              -- See Note [BodyStmt]
@@ -1249,37 +1235,6 @@ data ParStmtBlock idL idR
 -- '@BindStmt@'s should use the monadic fail and which shouldn't.
 type FailOperator id = Maybe (SyntaxExpr id)
 
--- | Applicative Argument
-data ApplicativeArg idL
-  = ApplicativeArgOne      -- A single statement (BindStmt or BodyStmt)
-    { xarg_app_arg_one  :: XApplicativeArgOne idL
-      -- ^ The fail operator, after renaming
-      --
-      -- The fail operator is needed if this is a BindStmt
-      -- where the pattern can fail. E.g.:
-      -- (Just a) <- stmt
-      -- The fail operator will be invoked if the pattern
-      -- match fails.
-      -- It is also used for guards in MonadComprehensions.
-      -- The fail operator is Nothing
-      -- if the pattern match can't fail
-    , app_arg_pattern   :: LPat idL -- WildPat if it was a BodyStmt (see below)
-    , arg_expr          :: LHsExpr idL
-    , is_body_stmt      :: Bool
-      -- ^ True <=> was a BodyStmt,
-      -- False <=> was a BindStmt.
-      -- See Note [Applicative BodyStmt]
-    }
-  | 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)
-    , bv_pattern        :: LPat idL      -- (v1,...,vn)
-    , stmt_context      :: HsDoFlavour
-      -- ^ context of the do expression, used in pprArg
-    }
-  | XApplicativeArg !(XXApplicativeArg idL)
-
 {-
 Note [The type of bind in Stmts]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/Language/Haskell/Syntax/Extension.hs b/compiler/Language/Haskell/Syntax/Extension.hs
index 4bdb3ce3cb..9bc79c3527 100644
--- a/compiler/Language/Haskell/Syntax/Extension.hs
+++ b/compiler/Language/Haskell/Syntax/Extension.hs
@@ -518,7 +518,6 @@ type family XXGRHS  x b
 -- StmtLR type families
 type family XLastStmt        x x' b
 type family XBindStmt        x x' b
-type family XApplicativeStmt x x' b
 type family XBodyStmt        x x' b
 type family XLetStmt         x x' b
 type family XParStmt         x x' b
@@ -546,17 +545,6 @@ type family XXCmd        x
 type family XParStmtBlock  x x'
 type family XXParStmtBlock x x'
 
--- -------------------------------------
--- ApplicativeArg type families
-type family XApplicativeArgOne   x
-type family XApplicativeArgMany  x
-type family XXApplicativeArg     x
-
--- =====================================================================
--- Type families for the HsImpExp extension points
-
--- TODO
-
 -- =====================================================================
 -- Type families for the HsLit extension points
 
@@ -691,7 +679,7 @@ type family XCFieldOcc x
 type family XXFieldOcc x
 
 -- =====================================================================
--- Type families for the HsImpExp type families
+-- Type families for the HsImpExp extension points
 
 -- -------------------------------------
 -- ImportDecl type families