[Git][ghc/ghc][master] TTG: ApplicativeStatement exist only in Rn and Tc

Marge Bot (@marge-bot) gitlab at gitlab.haskell.org
Wed May 15 21:15:53 UTC 2024



Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
639d742b by M Farkas-Dyck at 2024-05-15T17:14:49-04:00
TTG: ApplicativeStatement exist only in Rn and Tc

Co-Authored-By: romes <rodrigo.m.mesquita at gmail.com>

- - - - -


16 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/Ticks.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Zonk/Type.hs
- compiler/Language/Haskell/Syntax/Expr.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- utils/check-exact/ExactPrint.hs


Changes:

=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -1666,9 +1666,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
@@ -1688,7 +1688,62 @@ type instance XRecStmt         (GhcPass _) GhcPs b = 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
@@ -1739,40 +1794,48 @@ 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 :: 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 :: 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]
+        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]
@@ -2247,7 +2310,7 @@ pprStmtContext (TransStmtCtxt c) =
   ifPprDebug (sep [text "transformed branch of", pprAStmtContext c])
              (pprStmtContext c)
 
-pprStmtCat :: Stmt (GhcPass p) body -> SDoc
+pprStmtCat :: forall p body . IsPass p => Stmt (GhcPass p) body -> SDoc
 pprStmtCat (TransStmt {})       = text "transform"
 pprStmtCat (LastStmt {})        = text "return expression"
 pprStmtCat (BodyStmt {})        = text "body"
@@ -2255,7 +2318,7 @@ pprStmtCat (BindStmt {})        = text "binding"
 pprStmtCat (LetStmt {})         = text "let"
 pprStmtCat (RecStmt {})         = text "rec"
 pprStmtCat (ParStmt {})         = text "parallel"
-pprStmtCat (ApplicativeStmt {}) = text "applicative"
+pprStmtCat (XStmtLR _)          = text "applicative"
 
 pprAHsDoFlavour, pprHsDoFlavour :: HsDoFlavour -> SDoc
 pprAHsDoFlavour flavour = article <+> pprHsDoFlavour flavour


=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -377,6 +377,17 @@ deriving instance Data (ParStmtBlock GhcPs GhcRn)
 deriving instance Data (ParStmtBlock GhcRn GhcRn)
 deriving instance Data (ParStmtBlock GhcTc GhcTc)
 
+-- deriving instance (DataIdLR p p) => Data (ApplicativeStmt p p)
+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)


=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -1152,28 +1152,28 @@ collectMethodBinders binds = foldr (get . unXRec @idL) [] binds
 ----------------- Statements --------------------------
 --
 collectLStmtsBinders
-  :: CollectPass (GhcPass idL)
+  :: (IsPass idL, IsPass idR, CollectPass (GhcPass idL))
   => CollectFlag (GhcPass idL)
   -> [LStmtLR (GhcPass idL) (GhcPass idR) body]
   -> [IdP (GhcPass idL)]
 collectLStmtsBinders flag = concatMap (collectLStmtBinders flag)
 
 collectStmtsBinders
-  :: CollectPass (GhcPass idL)
+  :: (IsPass idL, IsPass idR, CollectPass (GhcPass idL))
   => CollectFlag (GhcPass idL)
   -> [StmtLR (GhcPass idL) (GhcPass idR) body]
   -> [IdP (GhcPass idL)]
 collectStmtsBinders flag = concatMap (collectStmtBinders flag)
 
 collectLStmtBinders
-  :: CollectPass (GhcPass idL)
+  :: (IsPass idL, IsPass idR, CollectPass (GhcPass idL))
   => CollectFlag (GhcPass idL)
   -> LStmtLR (GhcPass idL) (GhcPass idR) body
   -> [IdP (GhcPass idL)]
 collectLStmtBinders flag = collectStmtBinders flag . unLoc
 
 collectStmtBinders
-  :: CollectPass (GhcPass idL)
+  :: forall idL idR body . (IsPass idL, IsPass idR, CollectPass (GhcPass idL))
   => CollectFlag (GhcPass idL)
   -> StmtLR (GhcPass idL) (GhcPass idR) body
   -> [IdP (GhcPass idL)]
@@ -1186,12 +1186,16 @@ 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
+    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
 
+    collectArgBinders = \case
+        ApplicativeArgOne { app_arg_pattern = pat } -> collectPatBinders flag pat
+        ApplicativeArgMany { bv_pattern = pat }     -> collectPatBinders flag pat
 
 ----------------- Patterns --------------------------
 
@@ -1760,25 +1764,24 @@ data ImplicitFieldBinders
                              -- (in practice, always a singleton: see Note [Collecting implicit binders])
                          }
 
-lStmtsImplicits :: [LStmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))]
+lStmtsImplicits :: forall idR body . IsPass idR => [LStmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))]
                 -> [(SrcSpan, [ImplicitFieldBinders])]
 lStmtsImplicits = hs_lstmts
   where
-    hs_lstmts :: [LStmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))]
+    hs_lstmts :: forall idR body . IsPass idR => [LStmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))]
               -> [(SrcSpan, [ImplicitFieldBinders])]
     hs_lstmts = concatMap (hs_stmt . unLoc)
 
-    hs_stmt :: StmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))
+    hs_stmt :: forall idR body . IsPass idR => StmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))
             -> [(SrcSpan, [ImplicitFieldBinders])]
     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 (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 {})         = []
-    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
 
@@ -1786,6 +1789,10 @@ lStmtsImplicits = hs_lstmts
     hs_local_binds (HsIPBinds {})           = []
     hs_local_binds (EmptyLocalBinds _)      = []
 
+    hs_applicative_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
+
 hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR)
                     -> [(SrcSpan, [ImplicitFieldBinders])]
 hsValBindsImplicits (XValBindsLR (NValBinds binds _))


=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -775,37 +775,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)
-                   = 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 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
@@ -847,6 +816,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)
+                   = 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,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"
 
 {-


=====================================
compiler/GHC/HsToCore/ListComp.hs
=====================================
@@ -257,7 +257,7 @@ deListComp (ParStmt _ stmtss_w_bndrs _ _ : quals) list
 
 deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt"
 
-deListComp (ApplicativeStmt {} : _) _ =
+deListComp (XStmtLR ApplicativeStmt {} : _) _ =
   panic "deListComp ApplicativeStmt"
 
 deBindComp :: LPat GhcTc
@@ -352,7 +352,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'
@@ -580,7 +580,7 @@ dsMcStmt (ParStmt bind_ty blocks mzip_op bind_op) stmts_rest
        = do { exp <- dsInnerMonadComp stmts bndrs return_op
             ; return (exp, mkBigCoreVarTupTy bndrs) }
 
-dsMcStmt stmt@(ApplicativeStmt {}) _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)
+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,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,


=====================================
compiler/GHC/HsToCore/Ticks.hs
=====================================
@@ -730,9 +730,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
@@ -755,6 +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
@@ -966,7 +967,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.


=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -810,6 +810,7 @@ class ( HiePass (NoGhcTcPass p)
       , Data (IPBind (GhcPass p))
       , ToHie (Context (Located (IdGhcP p)))
       , Anno (IdGhcP p) ~ SrcSpanAnnN
+      , Typeable p
       )
       => HiePass p where
   hiePass :: HiePassEv p
@@ -1346,12 +1347,6 @@ instance ( ToHie (LocatedA (body (GhcPass p)))
         , whenPostTcGen @p $
             toHieSyntax $ L span (xbstc_bindOp monad)
         ]
-      ApplicativeStmt _ stmts _ ->
-        [ concatMapM (toHie . RS scope . snd) stmts
-        , let applicative_or_functor = map fst stmts
-           in whenPostTcGen @p $
-                concatMapM (toHieSyntax . L span) applicative_or_functor
-        ]
       BodyStmt _ body monad alternative ->
         [ toHie body
         , whenPostTc @p $
@@ -1373,10 +1368,20 @@ instance ( ToHie (LocatedA (body (GhcPass p)))
       RecStmt {recS_stmts = L _ stmts} ->
         [ toHie $ map (RS $ combineScopes scope (mkScope (locA span))) stmts
         ]
+      XStmtLR x -> case hiePass @p of
+        HieRn -> extApplicativeStmt x
+        HieTc -> extApplicativeStmt x
     where
       node = case hiePass @p of
         HieTc -> makeNodeA stmt span
         HieRn -> makeNodeA stmt span
+      extApplicativeStmt :: ApplicativeStmt (GhcPass p) (GhcPass p) -> [ReaderT NodeOrigin (State HieState) [HieAST Type]]
+      extApplicativeStmt (ApplicativeStmt _ stmts _) =
+        [ concatMapM (toHie . RS scope . snd) stmts
+        , let applicative_or_functor = map fst stmts
+           in whenPostTcGen @p $
+                concatMapM (toHieSyntax . L span) applicative_or_functor
+        ]
 
 instance HiePass p => ToHie (RScoped (HsLocalBinds (GhcPass p))) where
   toHie (RS scope binds) = concatM $ makeNode binds (spanHsLocaLBinds binds) : case binds of


=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -1032,7 +1032,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
 
@@ -1349,9 +1349,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. HsStmtContextRn
                 -> SyntaxExpr GhcRn
                 -> [ParStmtBlock GhcPs GhcPs]
@@ -1555,9 +1552,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"
 
@@ -1632,9 +1626,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
              => HsStmtContextRn
              -> (body GhcPs -> RnM (body GhcRn, FreeVars))
@@ -2229,7 +2220,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
@@ -2459,7 +2450,7 @@ mkApplicativeStmt ctxt args need_join body_stmts
        -- than the span of the do-block, but it is better than nothing for IDE info
        -- See Note [Source locations for implicit function calls]
        ; loc <- getSrcSpanM
-       ; let applicative_stmt = L (noAnnSrcSpan loc) $ ApplicativeStmt noExtField
+       ; let applicative_stmt = L (noAnnSrcSpan loc) $ XStmtLR $ ApplicativeStmt noExtField
                (zip (fmap_op : repeat ap_op) args)
                mb_join
        ; return ( applicative_stmt : body_stmts
@@ -2655,7 +2646,6 @@ okCompStmt dflags _ stmt
          | otherwise -> NotValid (Just LangExt.TransformListComp)
        RecStmt {}  -> emptyInvalid
        LastStmt {} -> emptyInvalid  -- Should not happen (dealt with by checkLastStmt)
-       ApplicativeStmt {} -> emptyInvalid
 
 ---------
 checkTupleSection :: [HsTupArg GhcPs] -> RnM ()


=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -80,7 +80,7 @@ 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 _ (ApplicativeStmt{})): _) =
+expand_do_stmts _ (stmt@(L _ (XStmtLR ApplicativeStmt{})): _) =
   pprPanic "expand_do_stmts: Applicative Stmt" $ ppr stmt
   -- Handeled by tcSyntaxOp see `GHC.Tc.Gen.Match.tcStmtsAndThen`
 


=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -439,7 +439,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'  $
@@ -933,17 +933,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
@@ -1008,6 +997,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)
 


=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -1410,11 +1410,11 @@ zonkStmt zBody (BindStmt xbs pat body)
 
 -- Scopes: join > ops (in reverse order) > pats (in forward order)
 --              > rest of stmts
-zonkStmt _zBody (ApplicativeStmt body_ty args mb_join)
+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 $ ApplicativeStmt new_body_ty new_args new_mb_join }
+        ; return $ XStmtLR $ ApplicativeStmt new_body_ty new_args new_mb_join }
   where
     zonk_join Nothing  = return Nothing
     zonk_join (Just j) = Just <$> zonkSyntaxExpr j


=====================================
compiler/Language/Haskell/Syntax/Expr.hs
=====================================
@@ -1129,20 +1129,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]
@@ -1247,37 +1233,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]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~


=====================================
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
 
@@ -704,7 +692,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


=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -3563,9 +3563,6 @@ instance (
     body' <- markAnnotated body
     return (BindStmt an0 pat' body')
 
-  exact (ApplicativeStmt _ _body _) = do
-    error $ "ApplicativeStmt is introduced in the renamer"
-
   exact (BodyStmt a body b c) = do
     debugM $ "BodyStmt"
     body' <- markAnnotated body



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/639d742b15e255a96f424bb636c5fd65efdc34f7

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/639d742b15e255a96f424bb636c5fd65efdc34f7
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/20240515/82ed1851/attachment-0001.html>


More information about the ghc-commits mailing list