[Git][ghc/ghc][wip/expand-do] remove applicative do expansion
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Mon Jun 26 14:35:09 UTC 2023
Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC
Commits:
3fa99e62 by Apoorv Ingle at 2023-06-26T09:34:47-05:00
remove applicative do expansion
- - - - -
3 changed files:
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Types/SrcLoc.hs
Changes:
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -1222,6 +1222,9 @@ expand_do_stmts _ (stmt@(L _ (ParStmt {})):_) =
-- See See Note [Monad Comprehensions]
pprPanic "expand_do_stmts: ParStmt" $ ppr stmt
+expand_do_stmts do_or_lc (stmt@(L _ (ApplicativeStmt _ _ _)): lstmts) =
+ pprPanic "expand_do_stmts: Applicative Stmt" $ ppr stmt
+
expand_do_stmts _ [stmt@(L _ (LastStmt _ body _ ret_expr))]
-- last statement of a list comprehension, needs to explicitly return it
-- See `checkLastStmt` and `Syntax.Expr.StmtLR.LastStmt`
@@ -1324,61 +1327,6 @@ expand_do_stmts do_or_lc
-- LazyPat becuase we do not want to eagerly evaluate the pattern
-- and potentially loop forever
-expand_do_stmts do_or_lc ((L _ (ApplicativeStmt _ args mb_join)): lstmts) =
--- See Note [Applicative BodyStmt]
---
--- stmts ~~> stmts'
--- -------------------------------------------------------------------------
--- [(<$>, \ x -> e1), (<*>, e2)] ; stmts ~~> (\ x -> stmts') <$> e1 <*> e2 ...
---
--- Very similar to HsToCore.Expr.dsDo
-
--- args are [(<$>, e1), (<*>, e2), .., ]
- do { expr' <- expand_do_stmts do_or_lc lstmts
- -- extracts pats and arg bodies (rhss) from args
- ; (pats_can_fail, rhss) <- unzip <$> mapM (do_arg . snd) args
-
- -- add blocks for failable patterns
- ; body_with_fails <- foldrM match_args expr' pats_can_fail
-
- -- builds (body <$> e1 <*> e2 ...)
- ; let expand_ado_expr = foldl mk_apps body_with_fails (zip (map fst args) rhss)
-
- -- wrap the expanded expression with a `join` if needed
- ; final_expr <- case mb_join of
- Nothing -> return $ expand_ado_expr
- Just NoSyntaxExprRn -> return $ expand_ado_expr -- why can this happen?
- Just (SyntaxExprRn join_op) ->
- return $ genHsApp (wrapGenSpan join_op) (expand_ado_expr)
- ; traceTc "expand_do_stmts AppStmt" (ppr final_expr)
- ; return final_expr
- }
- where
- do_arg :: ApplicativeArg GhcRn -> TcM ((LPat GhcRn, FailOperator GhcRn), LHsExpr GhcRn)
- do_arg (ApplicativeArgOne
- { xarg_app_arg_one = mb_fail_op
- , app_arg_pattern = pat@(L loc _)
- , arg_expr = rhs
- }) =
- return ((pat, mb_fail_op), L loc (mkExpandedStmt (L loc (BindStmt xbsn pat rhs)) rhs))
- do_arg (ApplicativeArgMany _ stmts ret pat ctxt) =
- do { expr <- expand_do_stmts ctxt $ stmts ++ [wrapGenSpan $ mkLastStmt (wrapGenSpan ret)]
- ; return ((pat, Nothing)
- , {- wrapGenSpan $ mkExpandedExpr (HsDo noExtField ctxt (wrapGenSpan stmts)) (unLoc expr)-} expr) }
-
- match_args :: (LPat GhcRn, FailOperator GhcRn) -> LHsExpr GhcRn -> TcM (LHsExpr GhcRn)
- match_args (pat, fail_op) body = mk_failable_lexpr_tcm pat body fail_op
-
- mk_apps :: LHsExpr GhcRn -> (SyntaxExprRn, LHsExpr GhcRn) -> LHsExpr GhcRn
- mk_apps l_expr (op, r_expr) =
- case op of
- SyntaxExprRn op -> foldl genHsApp (wrapGenSpan op) [ l_expr
- , r_expr ]
- NoSyntaxExprRn -> pprPanic "expand_do_stmts op:" (ppr op)
-
- xbsn :: XBindStmtRn
- xbsn = XBindStmtRn NoSyntaxExprRn Nothing
-
expand_do_stmts _ stmts = pprPanic "expand_do_stmts: impossible happened" $ (ppr stmts)
=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -1332,10 +1332,12 @@ data ExpectedFunTyOrigin
--
-- Test cases for representation-polymorphism checks:
-- RepPolyApp
- | ExpectedFunTyArg
+ | forall (p :: Pass)
+ . (OutputableBndrId p)
+ => ExpectedFunTyArg
!TypedThing
-- ^ function
- !(HsExpr GhcRn)
+ !(HsExpr (GhcPass p))
-- ^ argument
-- | Ensure that a function defined by equations indeed has a function type
@@ -1378,19 +1380,11 @@ pprExpectedFunTyOrigin funTy_origin i =
ExpectedFunTyViewPat expr ->
vcat [ the_arg_of <+> text "the view pattern"
, nest 2 (ppr expr) ]
- ExpectedFunTyArg fun arg -> case arg of
- XExpr (PopSrcSpan (L _ (XExpr (ExpandedStmt (HsExpanded {}))))) ->
- -- likey an expanded statement
- vcat [ sep [ the_arg_of
- , text "the rebindable syntax operator"
- , quotes (ppr fun)
- ]
- , nest 2 (text "arising from a do statement")
- ]
- _ -> sep [ text "The argument"
- , quotes (ppr arg)
- , text "of"
- , quotes (ppr fun) ]
+ ExpectedFunTyArg fun arg ->
+ sep [ text "The argument"
+ , quotes (ppr arg)
+ , text "of"
+ , quotes (ppr fun) ]
ExpectedFunTyMatches fun (MG { mg_alts = L _ alts })
| null alts
-> the_arg_of <+> quotes (ppr fun)
=====================================
compiler/GHC/Types/SrcLoc.hs
=====================================
@@ -690,11 +690,11 @@ instance Outputable UnhelpfulSpanReason where
unhelpfulSpanFS :: UnhelpfulSpanReason -> FastString
unhelpfulSpanFS r = case r of
- UnhelpfulOther s -> s
- UnhelpfulNoLocationInfo -> fsLit "<no location info>"
- UnhelpfulWiredIn -> fsLit "<wired into compiler>"
- UnhelpfulInteractive -> fsLit "<interactive>"
- UnhelpfulGenerated -> fsLit "<generated>"
+ UnhelpfulOther s -> s
+ UnhelpfulNoLocationInfo -> fsLit "<no location info>"
+ UnhelpfulWiredIn -> fsLit "<wired into compiler>"
+ UnhelpfulInteractive -> fsLit "<interactive>"
+ UnhelpfulGenerated -> fsLit "<generated>"
pprUnhelpfulSpanReason :: UnhelpfulSpanReason -> SDoc
pprUnhelpfulSpanReason r = ftext (unhelpfulSpanFS r)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3fa99e6210c6bd43eadbc45b8a8e72dbc8d1b7f7
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3fa99e6210c6bd43eadbc45b8a8e72dbc8d1b7f7
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/20230626/fa186f06/attachment-0001.html>
More information about the ghc-commits
mailing list