X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FHsExpr.lhs;h=b3e78ac47d9130b10f5dc04ebae279dfa992ec60;hp=4995d525a49b6328a05a015a05b87b8cddc2b5de;hb=67cb409159fa9136dff942b8baaec25909416022;hpb=7fc749a43b4b6b85d234fa95d4928648259584f4 diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 4995d52..b3e78ac 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -94,7 +94,8 @@ noSyntaxTable = [] data HsExpr id = HsVar id -- variable | HsIPVar (IPName id) -- implicit parameter - | HsOverLit (HsOverLit id) -- Overloaded literals + | HsOverLit (HsOverLit id) -- Overloaded literals + | HsLit HsLit -- Simple (non-overloaded) literals | HsLam (MatchGroup id) -- Currently always a single match @@ -259,6 +260,9 @@ data HsExpr id | EAsPat (Located id) -- as pattern (LHsExpr id) + | EViewPat (LHsExpr id) -- view pattern + (LHsExpr id) + | ELazyPat (LHsExpr id) -- ~ pattern | HsType (LHsType id) -- Explicit type argument; e.g f {| Int |} x y @@ -305,13 +309,14 @@ isQuietHsExpr (HsApp _ _) = True isQuietHsExpr (OpApp _ _ _ _) = True isQuietHsExpr _ = False -pprBinds :: OutputableBndr id => HsLocalBinds id -> SDoc +pprBinds :: (OutputableBndr idL, OutputableBndr idR) => HsLocalBindsLR idL idR -> SDoc pprBinds b = pprDeeper (ppr b) ----------------------- ppr_lexpr :: OutputableBndr id => LHsExpr id -> SDoc ppr_lexpr e = ppr_expr (unLoc e) +ppr_expr :: OutputableBndr id => HsExpr id -> SDoc ppr_expr (HsVar v) = pprHsVar v ppr_expr (HsIPVar v) = ppr v ppr_expr (HsLit lit) = ppr lit @@ -353,7 +358,7 @@ ppr_expr (SectionL expr op) pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op]) 4 (hsep [pp_expr, ptext SLIT("x_ )")]) - pp_infixly v = parens (sep [pp_expr, pprInfix v]) + pp_infixly v = (sep [pp_expr, pprInfix v]) ppr_expr (SectionR op expr) = case unLoc op of @@ -365,14 +370,14 @@ ppr_expr (SectionR op expr) pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, ptext SLIT("x_")]) 4 ((<>) pp_expr rparen) pp_infixly v - = parens (sep [pprInfix v, pp_expr]) + = (sep [pprInfix v, pp_expr]) -ppr_expr (HsLam matches) - = pprMatches LambdaExpr matches +ppr_expr (HsLam matches :: HsExpr id) + = pprMatches (LambdaExpr :: HsMatchContext id) matches -ppr_expr (HsCase expr matches) +ppr_expr (HsCase expr matches :: HsExpr id) = sep [ sep [ptext SLIT("case"), nest 4 (ppr expr), ptext SLIT("of")], - nest 2 (pprMatches CaseAlt matches) ] + nest 2 (pprMatches (CaseAlt :: HsMatchContext id) matches) ] ppr_expr (HsIf e1 e2 e3) = sep [hsep [ptext SLIT("if"), nest 2 (ppr e1), ptext SLIT("then")], @@ -675,22 +680,22 @@ data GRHS id = GRHS [LStmt id] -- Guards We know the list must have at least one @Match@ in it. \begin{code} -pprMatches :: (OutputableBndr id) => HsMatchContext id -> MatchGroup id -> SDoc +pprMatches :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> MatchGroup idR -> SDoc pprMatches ctxt (MatchGroup matches ty) = vcat (map (pprMatch ctxt) (map unLoc matches)) -- Don't print the type; it's only -- a place-holder before typechecking -- Exported to HsBinds, which can't see the defn of HsMatchContext -pprFunBind :: (OutputableBndr id) => id -> Bool -> MatchGroup id -> SDoc +pprFunBind :: (OutputableBndr idL, OutputableBndr idR) => idL -> Bool -> MatchGroup idR -> SDoc pprFunBind fun inf matches = pprMatches (FunRhs fun inf) matches -- Exported to HsBinds, which can't see the defn of HsMatchContext pprPatBind :: (OutputableBndr bndr, OutputableBndr id) => LPat bndr -> GRHSs id -> SDoc -pprPatBind pat grhss = sep [ppr pat, nest 4 (pprGRHSs PatBindRhs grhss)] +pprPatBind pat (grhss :: GRHSs id) = sep [ppr pat, nest 4 (pprGRHSs (PatBindRhs :: HsMatchContext id) grhss)] -pprMatch :: OutputableBndr id => HsMatchContext id -> Match id -> SDoc +pprMatch :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> Match idR -> SDoc pprMatch ctxt (Match pats maybe_ty grhss) = herald <+> sep [sep (map ppr other_pats), ppr_maybe_ty, @@ -721,13 +726,13 @@ pprMatch ctxt (Match pats maybe_ty grhss) Nothing -> empty -pprGRHSs :: OutputableBndr id => HsMatchContext id -> GRHSs id -> SDoc +pprGRHSs :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> GRHSs idR -> SDoc pprGRHSs ctxt (GRHSs grhss binds) = vcat (map (pprGRHS ctxt . unLoc) grhss) $$ if isEmptyLocalBinds binds then empty else text "where" $$ nest 4 (pprBinds binds) -pprGRHS :: OutputableBndr id => HsMatchContext id -> GRHS id -> SDoc +pprGRHS :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> GRHS idR -> SDoc pprGRHS ctxt (GRHS [] expr) = pp_rhs ctxt expr @@ -745,35 +750,53 @@ pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs) %************************************************************************ \begin{code} -type LStmt id = Located (Stmt id) +type LStmt id = Located (StmtLR id id) +type LStmtLR idL idR = Located (StmtLR idL idR) + +type Stmt id = StmtLR id id + +data GroupByClause id = GroupByNothing (LHsExpr id) -- Using expression, i.e. "then group using f" ==> GroupByNothing f + | GroupBySomething (Either (LHsExpr id) (SyntaxExpr id)) + (LHsExpr id) + -- "then group using f by e" ==> GroupBySomething (Left f) e + -- "then group by e" ==> GroupBySomething (Right _) e: in this case the expression is filled in by the renamer -- The SyntaxExprs in here are used *only* for do-notation, which -- has rebindable syntax. Otherwise they are unused. -data Stmt id - = BindStmt (LPat id) - (LHsExpr id) - (SyntaxExpr id) -- The (>>=) operator - (SyntaxExpr id) -- The fail operator +data StmtLR idL idR + = BindStmt (LPat idL) + (LHsExpr idR) + (SyntaxExpr idR) -- The (>>=) operator + (SyntaxExpr idR) -- The fail operator -- The fail operator is noSyntaxExpr -- if the pattern match can't fail - | ExprStmt (LHsExpr id) - (SyntaxExpr id) -- The (>>) operator + | ExprStmt (LHsExpr idR) + (SyntaxExpr idR) -- The (>>) operator PostTcType -- Element type of the RHS (used for arrows) - | LetStmt (HsLocalBinds id) + | LetStmt (HsLocalBindsLR idL idR) -- ParStmts only occur in a list comprehension - | ParStmt [([LStmt id], [id])] -- After renaming, the ids are the binders - -- bound by the stmts and used subsequently + | ParStmt [([LStmt idL], [idR])] + -- After renaming, the ids are the binders bound by the stmts and used after them + + | TransformStmt ([LStmt idL], [idR]) (LHsExpr idR) (Maybe (LHsExpr idR)) + -- After renaming, the IDs are the binders occurring within this transform statement that are used after it + -- "qs, then f by e" ==> TransformStmt (qs, binders) f (Just e) + -- "qs, then f" ==> TransformStmt (qs, binders) f Nothing + + | GroupStmt ([LStmt idL], [(idR, idR)]) (GroupByClause idR) + -- After renaming, the IDs are the binders occurring within this transform statement that are used after it + -- which are paired with the names which they group over in statements -- Recursive statement (see Note [RecStmt] below) - | RecStmt [LStmt id] + | RecStmt [LStmtLR idL idR] --- The next two fields are only valid after renaming - [id] -- The ids are a subset of the variables bound by the stmts + [idR] -- The ids are a subset of the variables bound by the stmts -- that are used in stmts that follow the RecStmt - [id] -- Ditto, but these variables are the "recursive" ones, that + [idR] -- Ditto, but these variables are the "recursive" ones, that -- are used before they are bound in the stmts of the RecStmt -- From a type-checking point of view, these ones have to be monomorphic @@ -783,7 +806,7 @@ data Stmt id -- should be returned by the recursion. They may not quite be the -- Ids themselves, because the Id may be *polymorphic*, but -- the returned thing has to be *monomorphic*. - (DictBinds id) -- Method bindings of Ids bound by the RecStmt, + (DictBinds idR) -- Method bindings of Ids bound by the RecStmt, -- and used afterwards \end{code} @@ -837,15 +860,26 @@ have the same Name. \begin{code} -instance OutputableBndr id => Outputable (Stmt id) where +instance (OutputableBndr idL, OutputableBndr idR) => Outputable (StmtLR idL idR) where ppr stmt = pprStmt stmt +pprStmt :: (OutputableBndr idL, OutputableBndr idR) => (StmtLR idL idR) -> SDoc pprStmt (BindStmt pat expr _ _) = hsep [ppr pat, ptext SLIT("<-"), ppr expr] pprStmt (LetStmt binds) = hsep [ptext SLIT("let"), pprBinds binds] pprStmt (ExprStmt expr _ _) = ppr expr pprStmt (ParStmt stmtss) = hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss) +pprStmt (TransformStmt (stmts, bndrs) usingExpr maybeByExpr) = (hsep [stmtsDoc, ptext SLIT("then"), ppr usingExpr, byExprDoc]) + where stmtsDoc = interpp'SP stmts + byExprDoc = maybe empty (\byExpr -> hsep [ptext SLIT("by"), ppr byExpr]) maybeByExpr +pprStmt (GroupStmt (stmts, bndrs) groupByClause) = (hsep [stmtsDoc, ptext SLIT("then group"), pprGroupByClause groupByClause]) + where stmtsDoc = interpp'SP stmts pprStmt (RecStmt segment _ _ _ _) = ptext SLIT("rec") <+> braces (vcat (map ppr segment)) +pprGroupByClause :: (OutputableBndr id) => GroupByClause id -> SDoc +pprGroupByClause (GroupByNothing usingExpr) = hsep [ptext SLIT("using"), ppr usingExpr] +pprGroupByClause (GroupBySomething eitherUsingExpr byExpr) = hsep [ptext SLIT("by"), ppr byExpr, usingExprDoc] + where usingExprDoc = either (\usingExpr -> hsep [ptext SLIT("using"), ppr usingExpr]) (const empty) eitherUsingExpr + pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> LHsExpr id -> SDoc pprDo DoExpr stmts body = ptext SLIT("do") <+> pprDeeperList vcat (map ppr stmts ++ [ppr body]) pprDo (MDoExpr _) stmts body = ptext SLIT("mdo") <+> pprDeeperList vcat (map ppr stmts ++ [ppr body]) @@ -875,7 +909,7 @@ instance OutputableBndr id => Outputable (HsSplice id) where ppr = pprSplice pprSplice :: OutputableBndr id => HsSplice id -> SDoc -pprSplice (HsSplice n e) = char '$' <> brackets (ppr n) <> pprParendExpr e +pprSplice (HsSplice n e) = char '$' <> ifPprDebug (brackets (ppr n)) <> pprParendExpr e data HsBracket id = ExpBr (LHsExpr id) -- [| expr |] @@ -959,6 +993,7 @@ data HsStmtContext id | PArrComp -- Parallel array comprehension | PatGuard (HsMatchContext id) -- Pattern guard for specified thing | ParStmtCtxt (HsStmtContext id) -- A branch of a parallel stmt + | TransformStmtCtxt (HsStmtContext id) -- A branch of a transform stmt \end{code} \begin{code} @@ -993,6 +1028,7 @@ pprMatchContext ProcExpr = ptext SLIT("an arrow abstraction") pprMatchContext (StmtCtxt ctxt) = ptext SLIT("a pattern binding in") $$ pprStmtContext ctxt pprStmtContext (ParStmtCtxt c) = sep [ptext SLIT("a parallel branch of"), pprStmtContext c] +pprStmtContext (TransformStmtCtxt c) = sep [ptext SLIT("a transformed branch of"), pprStmtContext c] pprStmtContext (PatGuard ctxt) = ptext SLIT("a pattern guard for") $$ pprMatchContext ctxt pprStmtContext DoExpr = ptext SLIT("a 'do' expression") pprStmtContext (MDoExpr _) = ptext SLIT("an 'mdo' expression") @@ -1022,6 +1058,7 @@ matchContextErrString RecUpd = "record update" matchContextErrString LambdaExpr = "lambda" matchContextErrString ProcExpr = "proc" matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c) +matchContextErrString (StmtCtxt (TransformStmtCtxt c)) = matchContextErrString (StmtCtxt c) matchContextErrString (StmtCtxt (PatGuard _)) = "pattern guard" matchContextErrString (StmtCtxt DoExpr) = "'do' expression" matchContextErrString (StmtCtxt (MDoExpr _)) = "'mdo' expression"