diff options
Diffstat (limited to 'compiler/rename')
| -rw-r--r-- | compiler/rename/RnExpr.hs | 97 |
1 files changed, 85 insertions, 12 deletions
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index 42d38c23e9..d3f72fff47 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -1492,12 +1492,45 @@ dsDo {(arg_1 | ... | arg_n); stmts} expr = <*> ... <*> argexpr(arg_n) += Relevant modules in the rest of the compiler = + +ApplicativeDo touches a few phases in the compiler: + +* Renamer: The journey begins here in the renamer, where do-blocks are + scheduled as outlined above and transformed into applicative + combinators. However, the code is still represented as a do-block + with special forms of applicative statements. This allows us to + recover the original do-block when e.g. printing type errors, where + we don't want to show any of the applicative combinators since they + don't exist in the source code. + See ApplicativeStmt and ApplicativeArg in HsExpr. + +* Typechecker: ApplicativeDo passes through the typechecker much like any + other form of expression. The only crux is that the typechecker has to + be aware of the special ApplicativeDo statements in the do-notation, and + typecheck them appropriately. + Relevant module: TcMatches + +* Desugarer: Any do-block which contains applicative statements is desugared + as outlined above, to use the Applicative combinators. + Relevant module: DsExpr + -} -- | The 'Name's of @return@ and @pure@. These may not be 'returnName' and -- 'pureName' due to @RebindableSyntax@. data MonadNames = MonadNames { return_name, pure_name :: Name } +instance Outputable MonadNames where + ppr (MonadNames {return_name=return_name,pure_name=pure_name}) = + hcat + [text "MonadNames { return_name = " + ,ppr return_name + ,text ", pure_name = " + ,ppr pure_name + ,text "}" + ] + -- | rearrange a list of statements using ApplicativeDoStmt. See -- Note [ApplicativeDo]. rearrangeForApplicativeDo @@ -1640,16 +1673,27 @@ stmtTreeToStmts -- In the spec, but we do it here rather than in the desugarer, -- because we need the typechecker to typecheck the <$> form rather than -- the bind form, which would give rise to a Monad constraint. -stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt _ pat rhs _ _), _)) +stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt _ pat rhs _ fail_op), _)) tail _tail_fvs | not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail -- See Note [ApplicativeDo and strict patterns] - = mkApplicativeStmt ctxt [ApplicativeArgOne noExtField pat rhs False] False tail' -stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ _),_)) + = mkApplicativeStmt ctxt [ApplicativeArgOne + { xarg_app_arg_one = noExtField + , app_arg_pattern = pat + , arg_expr = rhs + , is_body_stmt = False + , fail_operator = fail_op}] + False tail' +stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ fail_op),_)) tail _tail_fvs | (False,tail') <- needJoin monad_names tail = mkApplicativeStmt ctxt - [ApplicativeArgOne noExtField nlWildPatName rhs True] False tail' + [ApplicativeArgOne + { xarg_app_arg_one = noExtField + , app_arg_pattern = nlWildPatName + , arg_expr = rhs + , is_body_stmt = True + , fail_operator = fail_op}] False tail' stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs = return (s : tail, emptyNameSet) @@ -1663,14 +1707,30 @@ stmtTreeToStmts monad_names ctxt (StmtTreeBind before after) tail tail_fvs = do stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do pairs <- mapM (stmtTreeArg ctxt tail_fvs) trees let (stmts', fvss) = unzip pairs - let (need_join, tail') = needJoin monad_names tail + let (need_join, tail') = + if any hasStrictPattern trees + then (True, tail) + else needJoin monad_names tail + (stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail' return (stmts, unionNameSets (fvs:fvss)) where - stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt _ pat exp _ _), _)) - = return (ApplicativeArgOne noExtField pat exp False, emptyFVs) - stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ _), _)) = - return (ApplicativeArgOne noExtField nlWildPatName exp True, emptyFVs) + stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt _ pat exp _ fail_op), _)) + = return (ApplicativeArgOne + { xarg_app_arg_one = noExtField + , app_arg_pattern = pat + , arg_expr = exp + , is_body_stmt = False + , fail_operator = fail_op + }, emptyFVs) + stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ fail_op), _)) = + return (ApplicativeArgOne + { xarg_app_arg_one = noExtField + , app_arg_pattern = nlWildPatName + , arg_expr = exp + , is_body_stmt = True + , fail_operator = fail_op + }, emptyFVs) stmtTreeArg ctxt tail_fvs tree = do let stmts = flattenStmtTree tree pvarset = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts) @@ -1684,9 +1744,15 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do if | L _ ApplicativeStmt{} <- last stmts' -> return (unLoc tup, emptyNameSet) | otherwise -> do - (ret,fvs) <- lookupStmtNamePoly ctxt returnMName - return (HsApp noExtField (noLoc ret) tup, fvs) - return ( ApplicativeArgMany noExtField stmts' mb_ret pat + ret <- lookupSyntaxName' returnMName + let expr = HsApp noExtField (noLoc (HsVar noExtField (noLoc ret))) tup + return (expr, emptyFVs) + return ( ApplicativeArgMany + { xarg_app_arg_many = noExtField + , app_stmts = stmts' + , final_expr = mb_ret + , bv_pattern = pat + } , fvs1 `plusFV` fvs2) @@ -1790,6 +1856,13 @@ isStrictPattern lpat = SplicePat{} -> True _otherwise -> panic "isStrictPattern" +hasStrictPattern :: ExprStmtTree -> Bool +hasStrictPattern (StmtTreeOne (L _ (BindStmt _ pat _ _ _), _)) = isStrictPattern pat +hasStrictPattern (StmtTreeOne _) = False +hasStrictPattern (StmtTreeBind a b) = hasStrictPattern a || hasStrictPattern b +hasStrictPattern (StmtTreeApplicative trees) = any hasStrictPattern trees + + isLetStmt :: LStmt a b -> Bool isLetStmt (L _ LetStmt{}) = True isLetStmt _ = False |