diff options
-rw-r--r-- | compiler/GHC/Hs/Expr.hs | 139 | ||||
-rw-r--r-- | compiler/GHC/Hs/Instances.hs | 11 | ||||
-rw-r--r-- | compiler/GHC/Hs/Utils.hs | 28 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Expr.hs | 61 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/GuardedRHSs.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/ListComp.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Pmc/Desugar.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Ticks.hs | 9 | ||||
-rw-r--r-- | compiler/GHC/Iface/Ext/Ast.hs | 8 | ||||
-rw-r--r-- | compiler/GHC/Rename/Expr.hs | 22 | ||||
-rw-r--r-- | compiler/GHC/Tc/Gen/Match.hs | 26 | ||||
-rw-r--r-- | compiler/GHC/Tc/Utils/Zonk.hs | 4 | ||||
-rw-r--r-- | compiler/Language/Haskell/Syntax/Expr.hs | 45 | ||||
-rw-r--r-- | compiler/Language/Haskell/Syntax/Extension.hs | 14 |
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 |