X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FhsSyn%2FHsExpr.lhs;h=514606787ebb6a6589c6ebf12cd2faeee4ac35c2;hb=ed1ec7cf0cf4c18547cfc87f68a0dce1d3da2bae;hp=5b552c6385bd7dc5a3d813a646f2701bf7559c50;hpb=ce43dfc719eda4752d8de67cefb61d03b05b8e3c;p=ghc-hetmet.git diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 5b552c6..5146067 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -6,13 +6,6 @@ HsExpr: Abstract Haskell syntax: expressions \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module HsExpr where #include "HsVersions.h" @@ -94,7 +87,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 +253,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 +302,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 @@ -328,7 +326,7 @@ ppr_expr (HsApp e1 e2) collect_args (L _ (HsApp fun arg)) args = collect_args fun (arg:args) collect_args fun args = (fun, args) -ppr_expr (OpApp e1 op fixity e2) +ppr_expr (OpApp e1 op _ e2) = case unLoc op of HsVar v -> pp_infixly v _ -> pp_prefixly @@ -353,7 +351,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 +363,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")], @@ -400,7 +398,7 @@ ppr_expr (ExplicitPArr _ exprs) ppr_expr (ExplicitTuple exprs boxity) = tupleParens boxity (sep (punctuate comma (map ppr_lexpr exprs))) -ppr_expr (RecordCon con_id con_expr rbinds) +ppr_expr (RecordCon con_id _ rbinds) = hang (ppr con_id) 2 (ppr rbinds) ppr_expr (RecordUpd aexp rbinds _ _ _) @@ -413,12 +411,13 @@ ppr_expr (ExprWithTySigOut expr sig) = hang (nest 2 (ppr_lexpr expr) <+> dcolon) 4 (ppr sig) -ppr_expr (ArithSeq expr info) = brackets (ppr info) -ppr_expr (PArrSeq expr info) = pa_brackets (ppr info) +ppr_expr (ArithSeq _ info) = brackets (ppr info) +ppr_expr (PArrSeq _ info) = pa_brackets (ppr info) -ppr_expr EWildPat = char '_' -ppr_expr (ELazyPat e) = char '~' <> pprParendExpr e -ppr_expr (EAsPat v e) = ppr v <> char '@' <> pprParendExpr e +ppr_expr EWildPat = char '_' +ppr_expr (ELazyPat e) = char '~' <> pprParendExpr e +ppr_expr (EAsPat v e) = ppr v <> char '@' <> pprParendExpr e +ppr_expr (EViewPat p e) = ppr p <+> ptext SLIT("->") <+> ppr e ppr_expr (HsSCC lbl expr) = sep [ ptext SLIT("_scc_") <+> doubleQuotes (ftext lbl), pprParendExpr expr ] @@ -505,8 +504,8 @@ pprParendExpr expr -- I think that is usually (always?) right in case unLoc expr of - HsLit l -> pp_as_was - HsOverLit l -> pp_as_was + HsLit _ -> pp_as_was + HsOverLit _ -> pp_as_was HsVar _ -> pp_as_was HsIPVar _ -> pp_as_was ExplicitList _ _ -> pp_as_was @@ -519,14 +518,14 @@ pprParendExpr expr | isListCompExpr sc -> pp_as_was _ -> parens pp_as_was -isAtomicHsExpr :: HsExpr id -> Bool -- A single token +isAtomicHsExpr :: HsExpr id -> Bool -- A single token isAtomicHsExpr (HsVar {}) = True isAtomicHsExpr (HsLit {}) = True isAtomicHsExpr (HsOverLit {}) = True isAtomicHsExpr (HsIPVar {}) = True isAtomicHsExpr (HsWrap _ e) = isAtomicHsExpr e isAtomicHsExpr (HsPar e) = isAtomicHsExpr (unLoc e) -isAtomicHsExpr e = False +isAtomicHsExpr _ = False \end{code} %************************************************************************ @@ -675,22 +674,23 @@ 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 ctxt (MatchGroup matches ty) = vcat (map (pprMatch ctxt) (map unLoc matches)) +pprMatches :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> MatchGroup idR -> SDoc +pprMatches ctxt (MatchGroup matches _) + = 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, @@ -714,20 +714,20 @@ pprMatch ctxt (Match pats maybe_ty grhss) pp_infix = ppr pat1 <+> ppr fun <+> ppr pat2 LambdaExpr -> (char '\\', pats) - other -> (empty, pats) + _ -> (empty, pats) ppr_maybe_ty = case maybe_ty of Just ty -> dcolon <+> ppr ty 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 @@ -735,6 +735,7 @@ pprGRHS ctxt (GRHS [] expr) pprGRHS ctxt (GRHS guards expr) = sep [char '|' <+> interpp'SP guards, pp_rhs ctxt expr] +pp_rhs :: OutputableBndr idR => HsMatchContext idL -> LHsExpr idR -> SDoc pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs) \end{code} @@ -745,35 +746,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 +802,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,21 +856,33 @@ 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, _) 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, _) 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]) pprDo ListComp stmts body = pprComp brackets stmts body pprDo PArrComp stmts body = pprComp pa_brackets stmts body -pprDo other stmts body = panic "pprDo" -- PatGuard, ParStmtCxt +pprDo _ _ _ = panic "pprDo" -- PatGuard, ParStmtCxt pprComp :: OutputableBndr id => (SDoc -> SDoc) -> [LStmt id] -> LHsExpr id -> SDoc pprComp brack quals body @@ -888,6 +919,7 @@ instance OutputableBndr id => Outputable (HsBracket id) where ppr = pprHsBracket +pprHsBracket :: OutputableBndr id => HsBracket id -> SDoc pprHsBracket (ExpBr e) = thBrackets empty (ppr e) pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p) pprHsBracket (DecBr d) = thBrackets (char 'd') (ppr d) @@ -898,6 +930,7 @@ pprHsBracket (VarBr n) = char '\'' <> ppr n -- pretty-printer for HsExpr doesn't ask for NamedThings -- But the pretty-printer for names will show the OccName class +thBrackets :: SDoc -> SDoc -> SDoc thBrackets pp_kind pp_body = char '[' <> pp_kind <> char '|' <+> pp_body <+> ptext SLIT("|]") \end{code} @@ -928,6 +961,7 @@ instance OutputableBndr id => Outputable (ArithSeqInfo id) where ppr (FromThenTo e1 e2 e3) = hcat [ppr e1, comma, space, ppr e2, pp_dotdot, ppr e3] +pp_dotdot :: SDoc pp_dotdot = ptext SLIT(" .. ") \end{code} @@ -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} @@ -974,6 +1009,7 @@ isListCompExpr _ = False \end{code} \begin{code} +matchSeparator :: HsMatchContext id -> SDoc matchSeparator (FunRhs {}) = ptext SLIT("=") matchSeparator CaseAlt = ptext SLIT("->") matchSeparator LambdaExpr = ptext SLIT("->") @@ -984,6 +1020,7 @@ matchSeparator RecUpd = panic "unused" \end{code} \begin{code} +pprMatchContext :: Outputable id => HsMatchContext id -> SDoc pprMatchContext (FunRhs fun _) = ptext SLIT("the definition of") <+> quotes (ppr fun) pprMatchContext CaseAlt = ptext SLIT("a case alternative") pprMatchContext RecUpd = ptext SLIT("a record-update construct") @@ -992,7 +1029,9 @@ pprMatchContext LambdaExpr = ptext SLIT("a lambda abstraction") pprMatchContext ProcExpr = ptext SLIT("an arrow abstraction") pprMatchContext (StmtCtxt ctxt) = ptext SLIT("a pattern binding in") $$ pprStmtContext ctxt +pprStmtContext :: Outputable id => HsStmtContext id -> SDoc 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") @@ -1015,6 +1054,7 @@ pprStmtResultContext other = ptext SLIT("the result of") <+> pprStmtContext -} -- Used to generate the string for a *runtime* error message +matchContextErrString :: Outputable id => HsMatchContext id -> String matchContextErrString (FunRhs fun _) = "function " ++ showSDoc (ppr fun) matchContextErrString CaseAlt = "case" matchContextErrString PatBindRhs = "pattern binding" @@ -1022,6 +1062,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"