[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