diff options
Diffstat (limited to 'compiler/hsSyn/HsExpr.hs')
| -rw-r--r-- | compiler/hsSyn/HsExpr.hs | 91 |
1 files changed, 81 insertions, 10 deletions
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index 8b8b9df255..a3c1f6ce5b 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -39,6 +39,7 @@ import Type -- libraries: import Data.Data hiding (Fixity) +import Data.Maybe (isNothing) {- ************************************************************************ @@ -1266,12 +1267,15 @@ data StmtLR idL idR body -- body should always be (LHs**** idR) = LastStmt -- Always the last Stmt in ListComp, MonadComp, PArrComp, -- and (after the renamer) DoExpr, MDoExpr -- Not used for GhciStmtCtxt, PatGuard, which scope over other stuff - body - (SyntaxExpr idR) -- The return operator, used only for MonadComp - -- For ListComp, PArrComp, we use the baked-in 'return' - -- For DoExpr, MDoExpr, we don't apply a 'return' at all - -- See Note [Monad Comprehensions] - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLarrow' + body + Bool -- True <=> return was stripped by ApplicativeDo + (SyntaxExpr idR) -- The return operator, used only for + -- MonadComp For ListComp, PArrComp, we + -- use the baked-in 'return' For DoExpr, + -- MDoExpr, we don't apply a 'return' at + -- all See Note [Monad Comprehensions] | + -- - 'ApiAnnotation.AnnKeywordId' : + -- 'ApiAnnotation.AnnLarrow' -- For details on above see note [Api annotations] in ApiAnnotation | BindStmt (LPat idL) @@ -1281,6 +1285,20 @@ data StmtLR idL idR body -- body should always be (LHs**** idR) -- The fail operator is noSyntaxExpr -- if the pattern match can't fail + -- | '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 RnExpr + -- + | ApplicativeStmt + [ ( SyntaxExpr idR + , ApplicativeArg idL idR) ] + -- [(<$>, e1), (<*>, e2), ..., (<*>, en)] + (Maybe (SyntaxExpr idR)) -- 'join', if necessary + (PostTc idR Type) -- Type of the body + | BodyStmt body -- See Note [BodyStmt] (SyntaxExpr idR) -- The (>>) operator (SyntaxExpr idR) -- The `guard` operator; used only in MonadComp @@ -1375,6 +1393,17 @@ data ParStmtBlock idL idR deriving( Typeable ) deriving instance (DataId idL, DataId idR) => Data (ParStmtBlock idL idR) +data ApplicativeArg idL idR + = ApplicativeArgOne -- pat <- expr (pat must be irrefutable) + (LPat idL) + (LHsExpr idL) + | ApplicativeArgMany -- do { stmts; return vars } + [ExprLStmt idL] -- stmts + (SyntaxExpr idL) -- return (v1,..,vn), or just (v1,..,vn) + (LPat idL) -- (v1,...,vn) + deriving( Typeable ) +deriving instance (DataId idL, DataId idR) => Data (ApplicativeArg idL idR) + {- Note [The type of bind in Stmts] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1520,9 +1549,12 @@ instance (OutputableBndr idL, OutputableBndr idR, Outputable body) => Outputable (StmtLR idL idR body) where ppr stmt = pprStmt stmt -pprStmt :: (OutputableBndr idL, OutputableBndr idR, Outputable body) +pprStmt :: forall idL idR body . (OutputableBndr idL, OutputableBndr idR, Outputable body) => (StmtLR idL idR body) -> SDoc -pprStmt (LastStmt expr _) = ifPprDebug (ptext (sLit "[last]")) <+> ppr expr +pprStmt (LastStmt expr ret_stripped _) + = ifPprDebug (ptext (sLit "[last]")) <+> + (if ret_stripped then ptext (sLit "return") else empty) <+> + ppr expr pprStmt (BindStmt pat expr _ _) = hsep [ppr pat, larrow, ppr expr] pprStmt (LetStmt binds) = hsep [ptext (sLit "let"), pprBinds binds] pprStmt (BodyStmt expr _ _ _) = ppr expr @@ -1538,6 +1570,45 @@ pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids , ifPprDebug (vcat [ ptext (sLit "rec_ids=") <> ppr rec_ids , ptext (sLit "later_ids=") <> ppr later_ids])] +pprStmt (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 $ punctuate semi $ concatMap flattenArg args + + -- ppr directly rather than transforming here, becuase we need to + -- inject a "return" which is hard when we're polymorphic in the id + -- type. + flattenStmt :: ExprLStmt idL -> [SDoc] + flattenStmt (L _ (ApplicativeStmt args _ _)) = concatMap flattenArg args + flattenStmt stmt = [ppr stmt] + + flattenArg (_, ApplicativeArgOne pat expr) = + [ppr (BindStmt pat expr noSyntaxExpr noSyntaxExpr :: ExprStmt idL)] + flattenArg (_, ApplicativeArgMany stmts _ _) = + concatMap flattenStmt stmts + + pp_debug = + let + ap_expr = sep (punctuate (ptext (sLit " |")) (map pp_arg args)) + in + if isNothing mb_join + then ap_expr + else ptext (sLit "join") <+> parens ap_expr + + pp_arg (_, ApplicativeArgOne pat expr) = + ppr (BindStmt pat expr noSyntaxExpr noSyntaxExpr :: ExprStmt idL) + pp_arg (_, ApplicativeArgMany stmts return pat) = + ppr pat <+> + ptext (sLit "<-") <+> + ppr (HsDo DoExpr (stmts ++ [noLoc (LastStmt (noLoc return) False noSyntaxExpr)]) + (error "pprStmt")) + pprTransformStmt :: OutputableBndr id => [id] -> LHsExpr id -> Maybe (LHsExpr id) -> SDoc pprTransformStmt bndrs using by = sep [ ptext (sLit "then") <+> ifPprDebug (braces (ppr bndrs)) @@ -1577,7 +1648,7 @@ pprComp :: (OutputableBndr id, Outputable body) => [LStmt id body] -> SDoc pprComp quals -- Prints: body | qual1, ..., qualn | not (null quals) - , L _ (LastStmt body _) <- last quals + , L _ (LastStmt body _ _) <- last quals = hang (ppr body <+> char '|') 2 (pprQuals (dropTail 1 quals)) | otherwise = pprPanic "pprComp" (pprQuals quals) @@ -1962,7 +2033,7 @@ pprMatchInCtxt ctxt match = hang (ptext (sLit "In") <+> pprMatchContext ctxt <> pprStmtInCtxt :: (OutputableBndr idL, OutputableBndr idR, Outputable body) => HsStmtContext idL -> StmtLR idL idR body -> SDoc -pprStmtInCtxt ctxt (LastStmt e _) +pprStmtInCtxt ctxt (LastStmt e _ _) | isListCompExpr ctxt -- For [ e | .. ], do not mutter about "stmts" = hang (ptext (sLit "In the expression:")) 2 (ppr e) |