[Git][ghc/ghc][wip/expansions-appdo] 2 commits: add testcase T24406.hs
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Tue May 28 20:11:43 UTC 2024
Apoorv Ingle pushed to branch wip/expansions-appdo at Glasgow Haskell Compiler / GHC
Commits:
d8867b5c by Apoorv Ingle at 2024-05-28T14:25:44-05:00
add testcase T24406.hs
- - - - -
4f0ab3ed by Apoorv Ingle at 2024-05-28T15:11:00-05:00
Remove `XStmtLR GhcTc` as `XStmtLR GhcRn` is now compiled to `HsExpr GhcTc`
- - - - -
12 changed files:
- compiler/GHC/Hs/Expr.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/Tc/Gen/Match.hs
- compiler/GHC/Tc/Zonk/Type.hs
- + testsuite/tests/ado/T24406.hs
- testsuite/tests/ado/all.T
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -1702,7 +1702,7 @@ type instance XRecStmt (GhcPass _) GhcTc b = RecStmtTc
type instance XXStmtLR (GhcPass _) GhcPs b = DataConCantHappen
type instance XXStmtLR (GhcPass x) GhcRn b = ApplicativeStmt (GhcPass x) GhcRn
-type instance XXStmtLR (GhcPass x) GhcTc b = ApplicativeStmt (GhcPass x) GhcTc
+type instance XXStmtLR (GhcPass x) GhcTc b = DataConCantHappen
-- | 'ApplicativeStmt' represents an applicative expression built with
-- '<$>' and '<*>'. It is generated by the renamer, and is desugared into the
@@ -1808,7 +1808,6 @@ pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids
pprStmt (XStmtLR x) = case ghcPass :: GhcPass idR of
GhcRn -> pprApplicativeStmt x
- GhcTc -> pprApplicativeStmt x
where
pprApplicativeStmt :: (OutputableBndrId idL, OutputableBndrId idR) => ApplicativeStmt (GhcPass idL) (GhcPass idR) -> SDoc
@@ -1829,7 +1828,6 @@ pprStmt (XStmtLR x) = case ghcPass :: GhcPass idR of
flattenStmt :: ExprLStmt (GhcPass idL) -> [SDoc]
flattenStmt (L _ (XStmtLR x)) = case ghcPass :: GhcPass idL of
GhcRn | (ApplicativeStmt _ args _) <- x -> concatMap flattenArg args
- GhcTc | (ApplicativeStmt _ args _) <- x -> concatMap flattenArg args
flattenStmt stmt = [ppr stmt]
flattenArg :: (a, ApplicativeArg (GhcPass idL)) -> [SDoc]
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -1188,7 +1188,6 @@ collectStmtBinders flag = \case
RecStmt { recS_stmts = L _ ss } -> collectLStmtsBinders flag ss
XStmtLR x -> case ghcPass :: GhcPass idR of
GhcRn -> collectApplicativeStmtBndrs x
- GhcTc -> collectApplicativeStmtBndrs x
where
collectApplicativeStmtBndrs :: ApplicativeStmt (GhcPass idL) a -> [IdP (GhcPass idL)]
collectApplicativeStmtBndrs (ApplicativeStmt _ args _) = concatMap (collectArgBinders . snd) args
@@ -1777,7 +1776,6 @@ lStmtsImplicits = hs_lstmts
hs_stmt (BindStmt _ pat _) = lPatImplicits pat
hs_stmt (XStmtLR x) = case ghcPass :: GhcPass idR of
GhcRn -> hs_applicative_stmt x
- GhcTc -> hs_applicative_stmt x
hs_stmt (LetStmt _ binds) = hs_local_binds binds
hs_stmt (BodyStmt {}) = []
hs_stmt (LastStmt {}) = []
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -463,10 +463,10 @@ dsExpr (HsLet _ binds body) = do
-- because the interpretation of `stmts' depends on what sort of thing it is.
--
dsExpr (HsDo res_ty ListComp (L _ stmts)) = dsListComp stmts res_ty
-dsExpr (HsDo _ ctx at DoExpr{} (L _ stmts)) = dsDo ctx stmts
-dsExpr (HsDo _ ctx at GhciStmtCtxt (L _ stmts)) = dsDo ctx stmts
-dsExpr (HsDo _ ctx at MDoExpr{} (L _ stmts)) = dsDo ctx stmts
dsExpr (HsDo _ MonadComp (L _ stmts)) = dsMonadComp stmts
+dsExpr (HsDo _ ctx at GhciStmtCtxt (L _ stmts)) = dsDo ctx stmts
+dsExpr (HsDo _ DoExpr{} (L _ stmts)) = pprPanic "shouldn't happen dsDo DoExpr" (ppr stmts)
+dsExpr (HsDo _ MDoExpr{} (L _ stmts)) = pprPanic "shouldn't happen dsDo MDoExpr" (ppr stmts)
dsExpr (HsIf _ guard_expr then_expr else_expr)
= do { pred <- dsLExpr guard_expr
@@ -815,38 +815,6 @@ dsDo ctx stmts
-- This LastStmt will be desugared with dsDo,
-- which ignores the return_op in the LastStmt,
-- so we must apply the return_op explicitly
-
- go _ (XStmtLR (ApplicativeStmt body_ty args mb_join)) stmts
- = do {
- let
- (pats, rhss) = unzip (map (do_arg . snd) args)
-
- do_arg (ApplicativeArgOne fail_op pat expr _) =
- ((pat, fail_op), dsLExpr expr)
- do_arg (ApplicativeArgMany _ stmts ret pat _) =
- ((pat, Nothing), dsDo ctx (stmts ++ [noLocA $ mkLastStmt ret]))
-
- ; rhss' <- sequence rhss
-
- ; body' <- dsLExpr $ noLocA $ HsDo body_ty ctx (noLocA stmts)
-
- ; let match_args (pat, fail_op) (vs,body)
- = putSrcSpanDs (getLocA pat) $
- do { var <- selectSimpleMatchVarL ManyTy pat
- ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt ctx)) pat
- body_ty (cantFailMatchResult body)
- ; match_code <- dsHandleMonadicFailure ctx pat match fail_op
- ; return (var:vs, match_code)
- }
-
- ; (vars, body) <- foldrM match_args ([],body') pats
- ; let fun' = mkLams vars body
- ; let mk_ap_call l (op,r) = dsSyntaxExpr op [l,r]
- ; expr <- foldlM mk_ap_call fun' (zip (map fst args) rhss')
- ; case mb_join of
- Nothing -> return expr
- Just join_op -> dsSyntaxExpr join_op [expr] }
-
go _ (ParStmt {}) _ = panic "dsDo ParStmt"
go _ (TransStmt {}) _ = panic "dsDo TransStmt"
=====================================
compiler/GHC/HsToCore/GuardedRHSs.hs
=====================================
@@ -144,8 +144,6 @@ matchGuards (LastStmt {} : _) _ _ _ _ = panic "matchGuards LastStmt"
matchGuards (ParStmt {} : _) _ _ _ _ = panic "matchGuards ParStmt"
matchGuards (TransStmt {} : _) _ _ _ _ = panic "matchGuards TransStmt"
matchGuards (RecStmt {} : _) _ _ _ _ = panic "matchGuards RecStmt"
-matchGuards (XStmtLR ApplicativeStmt {} : _) _ _ _ _ =
- panic "matchGuards ApplicativeLastStmt"
{-
Should {\em fail} if @e@ returns @D@
=====================================
compiler/GHC/HsToCore/ListComp.hs
=====================================
@@ -257,9 +257,6 @@ deListComp (ParStmt _ stmtss_w_bndrs _ _ : quals) list
deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt"
-deListComp (XStmtLR ApplicativeStmt {} : _) _ =
- panic "deListComp ApplicativeStmt"
-
deBindComp :: LPat GhcTc
-> CoreExpr
-> [ExprStmt GhcTc]
@@ -352,8 +349,6 @@ dfListComp c_id n_id (BindStmt _ pat list1 : quals) = do
dfListComp _ _ (ParStmt {} : _) = panic "dfListComp ParStmt"
dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt"
-dfListComp _ _ (XStmtLR ApplicativeStmt {} : _) =
- panic "dfListComp ApplicativeStmt"
dfBindComp :: Id -> Id -- 'c' and 'n'
-> (LPat GhcTc, CoreExpr)
@@ -580,7 +575,6 @@ dsMcStmt (ParStmt bind_ty blocks mzip_op bind_op) stmts_rest
= do { exp <- dsInnerMonadComp stmts bndrs return_op
; return (exp, mkBigCoreVarTupTy bndrs) }
-dsMcStmt stmt@(XStmtLR ApplicativeStmt {}) _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)
dsMcStmt stmt@(RecStmt {}) _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)
matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr
=====================================
compiler/GHC/HsToCore/Pmc/Desugar.hs
=====================================
@@ -377,7 +377,6 @@ desugarGuard guard = case guard of
ParStmt {} -> panic "desugarGuard ParStmt"
TransStmt {} -> panic "desugarGuard TransStmt"
RecStmt {} -> panic "desugarGuard RecStmt"
- XStmtLR ApplicativeStmt{} -> panic "desugarGuard ApplicativeLastStmt"
-- | Desugar local bindings to a bunch of 'PmLet' guards.
-- Deals only with simple @let@ or @where@ bindings without any polymorphism,
=====================================
compiler/GHC/HsToCore/Ticks.hs
=====================================
@@ -752,33 +752,10 @@ addTickStmt isGuard stmt@(RecStmt {})
; return (stmt { recS_stmts = noLocA stmts', recS_ret_fn = ret'
, recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
-addTickStmt isGuard (XStmtLR (ApplicativeStmt body_ty args mb_join)) = do
- args' <- mapM (addTickApplicativeArg isGuard) args
- return (XStmtLR (ApplicativeStmt body_ty args' mb_join))
-
addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
| otherwise = addTickLHsExprRHS e
-addTickApplicativeArg
- :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
- -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
-addTickApplicativeArg isGuard (op, arg) =
- liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)
- where
- addTickArg (ApplicativeArgOne m_fail pat expr isBody) =
- ApplicativeArgOne
- <$> mapM (addTickSyntaxExpr hpcSrcSpan) m_fail
- <*> addTickLPat pat
- <*> addTickLHsExpr expr
- <*> pure isBody
- addTickArg (ApplicativeArgMany x stmts ret pat ctxt) =
- (ApplicativeArgMany x)
- <$> addTickLStmts isGuard stmts
- <*> addTickLHsExpr ret
- <*> addTickLPat pat
- <*> pure ctxt
-
addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc
-> TM (ParStmtBlock GhcTc GhcTc)
addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) =
@@ -967,8 +944,6 @@ addTickCmdStmt stmt@(RecStmt {})
; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
; return (stmt { recS_stmts = noLocA stmts', recS_ret_fn = ret'
, recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
-addTickCmdStmt (XStmtLR (ApplicativeStmt{})) =
- panic "ToDo: addTickCmdStmt ApplicativeLastStmt"
-- Others should never happen in a command context.
addTickCmdStmt stmt = pprPanic "addTickHsCmd" (ppr stmt)
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -1370,7 +1370,6 @@ instance ( ToHie (LocatedA (body (GhcPass p)))
]
XStmtLR x -> case hiePass @p of
HieRn -> extApplicativeStmt x
- HieTc -> extApplicativeStmt x
where
node = case hiePass @p of
HieTc -> makeNodeA stmt span
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -78,7 +78,6 @@ import GHC.Types.SrcLoc
import GHC.Types.Basic( VisArity, isDoExpansionGenerated )
import Control.Monad
-import Control.Arrow ( second )
import qualified Data.List.NonEmpty as NE
import Data.Maybe (mapMaybe)
@@ -990,18 +989,6 @@ tcDoStmt ctxt (RecStmt { recS_stmts = L l stmts, recS_later_ids = later_names
, recS_ret_ty = stmts_ty} }, thing)
}}
-tcDoStmt ctxt (XStmtLR (ApplicativeStmt _ pairs mb_join)) res_ty thing_inside
- = do { let tc_app_stmts ty = tcApplicativeStmts ctxt pairs ty $
- thing_inside . mkCheckExpType
- ; ((pairs', body_ty, thing), mb_join') <- case mb_join of
- Nothing -> (, Nothing) <$> tc_app_stmts res_ty
- Just join_op ->
- second Just <$>
- (tcSyntaxOp DoOrigin join_op [SynRho] res_ty $
- \ [rhs_ty] [rhs_mult] -> tcScalingUsage rhs_mult $ tc_app_stmts (mkCheckExpType rhs_ty))
-
- ; return (XStmtLR $ ApplicativeStmt body_ty pairs' mb_join', thing) }
-
tcDoStmt _ stmt _ _
= pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
@@ -1077,87 +1064,6 @@ To achieve this we:
all branches. This step is done with bindLocalNames.
-}
-tcApplicativeStmts
- :: HsStmtContextRn
- -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
- -> ExpRhoType -- rhs_ty
- -> (TcRhoType -> TcM t) -- thing_inside
- -> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Type, t)
-
-tcApplicativeStmts ctxt pairs rhs_ty thing_inside
- = do { body_ty <- newFlexiTyVarTy liftedTypeKind
- ; let arity = length pairs
- ; ts <- replicateM (arity-1) $ newInferExpType
- ; exp_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind
- ; pat_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind
- ; let fun_ty = mkVisFunTysMany pat_tys body_ty
-
- -- NB. do the <$>,<*> operators first, we don't want type errors here
- -- i.e. goOps before goArgs
- -- See Note [Treat rebindable syntax first]
- ; let (ops, args) = unzip pairs
- ; ops' <- goOps fun_ty (zip3 ops (ts ++ [rhs_ty]) exp_tys)
-
- -- Typecheck each ApplicativeArg separately
- -- See Note [ApplicativeDo and constraints]
- ; args' <- mapM (goArg body_ty) (zip3 args pat_tys exp_tys)
-
- -- Bring into scope all the things bound by the args,
- -- and typecheck the thing_inside
- -- See Note [ApplicativeDo and constraints]
- ; res <- tcExtendIdEnv (concatMap get_arg_bndrs args') $
- thing_inside body_ty
-
- ; return (zip ops' args', body_ty, res) }
- where
- goOps _ [] = return []
- goOps t_left ((op,t_i,exp_ty) : ops)
- = do { (_, op')
- <- tcSyntaxOp DoOrigin op
- [synKnownType t_left, synKnownType exp_ty] t_i $
- \ _ _ -> return ()
- ; t_i <- readExpType t_i
- ; ops' <- goOps t_i ops
- ; return (op' : ops') }
-
- goArg :: Type -> (ApplicativeArg GhcRn, Type, Type)
- -> TcM (ApplicativeArg GhcTc)
-
- goArg body_ty (ApplicativeArgOne
- { xarg_app_arg_one = fail_op
- , app_arg_pattern = pat
- , arg_expr = rhs
- , ..
- }, pat_ty, exp_ty)
- = setSrcSpan (combineSrcSpans (getLocA pat) (getLocA rhs)) $
- addErrCtxt (pprStmtInCtxt ctxt (mkRnBindStmt pat rhs)) $
- do { rhs' <- tcCheckMonoExprNC rhs exp_ty
- ; (pat', _) <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $
- return ()
- ; fail_op' <- fmap join . forM fail_op $ \fail ->
- tcMonadFailOp (DoPatOrigin pat) pat' fail body_ty
-
- ; return (ApplicativeArgOne
- { xarg_app_arg_one = fail_op'
- , app_arg_pattern = pat'
- , arg_expr = rhs'
- , .. }
- ) }
-
- goArg _body_ty (ApplicativeArgMany x stmts ret pat ctxt, pat_ty, exp_ty)
- = do { (stmts', (ret',pat')) <-
- tcStmtsAndThen (HsDoStmt ctxt) tcDoStmt stmts (mkCheckExpType exp_ty) $
- \res_ty -> do
- { ret' <- tcMonoExprNC ret res_ty
- ; (pat', _) <- tcCheckPat (StmtCtxt (HsDoStmt ctxt)) pat (unrestricted pat_ty) $
- return ()
- ; return (ret', pat')
- }
- ; return (ApplicativeArgMany x stmts' ret' pat' ctxt) }
-
- get_arg_bndrs :: ApplicativeArg GhcTc -> [Id]
- get_arg_bndrs (ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders CollNoDictBinders pat
- get_arg_bndrs (ApplicativeArgMany { bv_pattern = pat }) = collectPatBinders CollNoDictBinders pat
{- Note [ApplicativeDo and constraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -97,7 +97,6 @@ import GHC.Tc.Types.BasicTypes
import GHC.Data.Maybe
import GHC.Data.Bag
-import Control.Monad
import Control.Monad.Trans.Class ( lift )
import Data.Semigroup
@@ -1408,54 +1407,6 @@ zonkStmt zBody (BindStmt xbs pat body)
})
new_pat new_body }
--- Scopes: join > ops (in reverse order) > pats (in forward order)
--- > rest of stmts
-zonkStmt _zBody (XStmtLR (ApplicativeStmt body_ty args mb_join))
- = do { new_mb_join <- zonk_join mb_join
- ; new_args <- zonk_args args
- ; new_body_ty <- noBinders $ zonkTcTypeToTypeX body_ty
- ; return $ XStmtLR $ ApplicativeStmt new_body_ty new_args new_mb_join }
- where
- zonk_join Nothing = return Nothing
- zonk_join (Just j) = Just <$> zonkSyntaxExpr j
-
- get_pat :: (SyntaxExpr GhcTc, ApplicativeArg GhcTc) -> LPat GhcTc
- get_pat (_, ApplicativeArgOne _ pat _ _) = pat
- get_pat (_, ApplicativeArgMany _ _ _ pat _) = pat
-
- replace_pat :: LPat GhcTc
- -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
- -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
- replace_pat pat (op, ApplicativeArgOne fail_op _ a isBody)
- = (op, ApplicativeArgOne fail_op pat a isBody)
- replace_pat pat (op, ApplicativeArgMany x a b _ c)
- = (op, ApplicativeArgMany x a b pat c)
-
- zonk_args args
- = do { new_args_rev <- zonk_args_rev (reverse args)
- ; new_pats <- zonkPats (map get_pat args)
- ; return $ zipWithEqual "zonkStmt" replace_pat
- new_pats (reverse new_args_rev) }
-
- -- these need to go backward, because if any operators are higher-rank,
- -- later operators may introduce skolems that are in scope for earlier
- -- arguments
- zonk_args_rev ((op, arg) : args)
- = do { new_op <- zonkSyntaxExpr op
- ; new_arg <- noBinders $ zonk_arg arg
- ; new_args <- zonk_args_rev args
- ; return $ (new_op, new_arg) : new_args }
- zonk_args_rev [] = return []
-
- zonk_arg (ApplicativeArgOne fail_op pat expr isBody)
- = do { new_expr <- zonkLExpr expr
- ; new_fail <- forM fail_op $ don'tBind . zonkSyntaxExpr
- ; return (ApplicativeArgOne new_fail pat new_expr isBody) }
- zonk_arg (ApplicativeArgMany x stmts ret pat ctxt)
- = runZonkBndrT (zonkStmts zonkLExpr stmts) $ \ new_stmts ->
- do { new_ret <- zonkLExpr ret
- ; return (ApplicativeArgMany x new_stmts new_ret pat ctxt) }
-
-------------------------------------------------------------------------
zonkRecFields :: HsRecordBinds GhcTc -> ZonkTcM (HsRecordBinds GhcTc)
zonkRecFields (HsRecFields flds dd)
=====================================
testsuite/tests/ado/T24406.hs
=====================================
@@ -0,0 +1,14 @@
+{-# LANGUAGE ImpredicativeTypes, ApplicativeDo #-}
+module T where
+
+t :: IO (forall a. a -> a)
+t = return id
+
+p :: (forall a. a -> a) -> (Bool, Int)
+p f = (f True, f 3)
+
+-- This typechecks (with QL)
+foo1 = t >>= \x -> return (p x)
+
+-- But this did not not type check:
+foo2 = do { x <- t ; return (p x) }
=====================================
testsuite/tests/ado/all.T
=====================================
@@ -22,3 +22,4 @@ test('T17835', normal, compile, [''])
test('T20540', normal, compile, [''])
test('T16135', [when(compiler_debugged(),expect_broken(16135))], compile, [''])
test('T22483', normal, compile, ['-Wall'])
+test('T24406', normal, compile, [''])
\ No newline at end of file
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5775afabeab4d1180a88cd161905c40115ca95bb...4f0ab3eddd973a86be1b44f46d02da5ea4f62168
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5775afabeab4d1180a88cd161905c40115ca95bb...4f0ab3eddd973a86be1b44f46d02da5ea4f62168
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/20240528/2d6fd76b/attachment-0001.html>
More information about the ghc-commits
mailing list