X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FhsSyn%2FHsExpr.lhs;h=9bcd06e47f74d57bf0abeeea36324bfea08e439c;hb=1b1e5a46082b74cb7ce05c14def21416375a9545;hp=dbdd24c3c5b75e2e5cf19bddded19d5fc061d17f;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index dbdd24c..9bcd06e 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -1,7 +1,9 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[HsExpr]{Abstract Haskell syntax: expressions} + +HsExpr: Abstract Haskell syntax: expressions \begin{code} module HsExpr where @@ -9,19 +11,18 @@ module HsExpr where #include "HsVersions.h" -- friends: -import HsDecls ( HsGroup ) -import HsPat ( LPat ) -import HsLit ( HsLit(..), HsOverLit ) -import HsTypes ( LHsType, PostTcType ) -import HsImpExp ( isOperator, pprHsVar ) -import HsBinds ( HsLocalBinds, DictBinds, ExprCoFn, isEmptyLocalBinds ) +import HsDecls +import HsPat +import HsLit +import HsTypes +import HsImpExp +import HsBinds -- others: -import Type ( Type, pprParendType ) -import Var ( TyVar, Id ) -import Name ( Name ) -import BasicTypes ( IPName, Boxity, tupleParens, Arity, Fixity(..) ) -import SrcLoc ( Located(..), unLoc ) +import Var +import Name +import BasicTypes +import SrcLoc import Outputable import FastString \end{code} @@ -201,6 +202,18 @@ data HsExpr id -- always has an empty stack --------------------------------------- + -- Hpc Support + + | HsTick + Int -- module-local tick number + (LHsExpr id) -- sub-expression + + | HsBinTick + Int -- module-local tick number for True + Int -- module-local tick number for False + (LHsExpr id) -- sub-expression + + --------------------------------------- -- The following are commands, not expressions proper | HsArrApp -- Arrow tail, or arrow application (f -< arg) @@ -239,22 +252,7 @@ The renamer translates them into the Right Thing. Everything from here on appears only in typechecker output. \begin{code} - | TyLam -- TRANSLATION - [TyVar] - (LHsExpr id) - | TyApp -- TRANSLATION - (LHsExpr id) -- generated by Spec - [Type] - - -- DictLam and DictApp are "inverses" - | DictLam - [id] - (LHsExpr id) - | DictApp - (LHsExpr id) - [id] - - | HsCoerce ExprCoFn -- TRANSLATION + | HsWrap HsWrapper -- TRANSLATION (HsExpr id) type PendingSplice = (Name, LHsExpr Id) -- Typechecked splices, waiting to be @@ -287,10 +285,14 @@ ppr_expr (HsVar v) = pprHsVar v ppr_expr (HsIPVar v) = ppr v ppr_expr (HsLit lit) = ppr lit ppr_expr (HsOverLit lit) = ppr lit +ppr_expr (HsPar e) = parens (ppr_lexpr e) + +ppr_expr (HsCoreAnn s e) + = vcat [ptext SLIT("HsCoreAnn") <+> ftext s, ppr_lexpr e] ppr_expr (HsApp e1 e2) = let (fun, args) = collect_args e1 [e2] in - (ppr_lexpr fun) <+> (sep (map pprParendExpr args)) + hang (ppr_lexpr fun) 2 (sep (map pprParendExpr args)) where collect_args (L _ (HsApp fun arg)) args = collect_args fun (arg:args) collect_args fun args = (fun, args) @@ -304,15 +306,13 @@ ppr_expr (OpApp e1 op fixity e2) pp_e2 = pprParendExpr e2 pp_prefixly - = hang (ppr op) 4 (sep [pp_e1, pp_e2]) + = hang (ppr op) 2 (sep [pp_e1, pp_e2]) pp_infixly v - = sep [pp_e1, hsep [pprInfix v, pp_e2]] + = sep [nest 2 pp_e1, pprInfix v, nest 2 pp_e2] ppr_expr (NegApp e _) = char '-' <+> pprParendExpr e -ppr_expr (HsPar e) = parens (ppr_lexpr e) - ppr_expr (SectionL expr op) = case unLoc op of HsVar v -> pp_infixly v @@ -392,35 +392,8 @@ ppr_expr (EAsPat v e) = ppr v <> char '@' <> pprParendExpr e ppr_expr (HsSCC lbl expr) = sep [ ptext SLIT("_scc_") <+> doubleQuotes (ftext lbl), pprParendExpr expr ] -ppr_expr (TyLam tyvars expr) - = hang (hsep [ptext SLIT("/\\"), - hsep (map (pprBndr LambdaBind) tyvars), - ptext SLIT("->")]) - 4 (ppr_lexpr expr) - -ppr_expr (TyApp expr [ty]) - = hang (ppr_lexpr expr) 4 (pprParendType ty) - -ppr_expr (TyApp expr tys) - = hang (ppr_lexpr expr) - 4 (brackets (interpp'SP tys)) - -ppr_expr (DictLam dictvars expr) - = hang (hsep [ptext SLIT("\\{-dict-}"), - hsep (map (pprBndr LambdaBind) dictvars), - ptext SLIT("->")]) - 4 (ppr_lexpr expr) - -ppr_expr (DictApp expr [dname]) - = hang (ppr_lexpr expr) 4 (ppr dname) - -ppr_expr (DictApp expr dnames) - = hang (ppr_lexpr expr) - 4 (brackets (interpp'SP dnames)) - -ppr_expr (HsCoerce co_fn e) = ppr_expr e - -ppr_expr (HsType id) = ppr id +ppr_expr (HsWrap co_fn e) = pprHsWrapper (ppr_expr e) co_fn +ppr_expr (HsType id) = ppr id ppr_expr (HsSpliceE s) = pprSplice s ppr_expr (HsBracket b) = pprHsBracket b @@ -430,6 +403,16 @@ ppr_expr (HsBracketOut e ps) = ppr e $$ ptext SLIT("pending") <+> ppr ps ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _))) = hsep [ptext SLIT("proc"), ppr pat, ptext SLIT("->"), ppr cmd] +ppr_expr (HsTick tickId exp) + = hcat [ptext SLIT("tick<"), ppr tickId,ptext SLIT(">("), ppr exp,ptext SLIT(")")] +ppr_expr (HsBinTick tickIdTrue tickIdFalse exp) + = hcat [ptext SLIT("bintick<"), + ppr tickIdTrue, + ptext SLIT(","), + ppr tickIdFalse, + ptext SLIT(">("), + ppr exp,ptext SLIT(")")] + ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp True) = hsep [ppr_lexpr arrow, ptext SLIT("-<"), ppr_lexpr arg] ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp False) @@ -619,6 +602,8 @@ data Match id (GRHSs id) matchGroupArity :: MatchGroup id -> Arity +matchGroupArity (MatchGroup [] _) + = panic "matchGroupArity" -- MatchGroup is never empty matchGroupArity (MatchGroup (match:matches) _) = ASSERT( all ((== n_pats) . length . hsLMatchPats) matches ) -- Assertion just checks that all the matches have the same number of pats @@ -644,7 +629,9 @@ 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 _) = vcat (map (pprMatch ctxt) (map unLoc matches)) +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 -> MatchGroup id -> SDoc @@ -799,10 +786,11 @@ pprStmt (ParStmt stmtss) = hsep (map (\stmts -> ptext SLIT("| ") <> ppr pprStmt (RecStmt segment _ _ _ _) = ptext SLIT("rec") <+> braces (vcat (map ppr segment)) pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> LHsExpr id -> SDoc -pprDo DoExpr stmts body = hang (ptext SLIT("do")) 2 (vcat (map ppr stmts) $$ ppr body) -pprDo (MDoExpr _) stmts body = hang (ptext SLIT("mdo")) 3 (vcat (map ppr stmts) $$ ppr body) +pprDo DoExpr stmts body = ptext SLIT("do") <+> (vcat (map ppr stmts) $$ ppr body) +pprDo (MDoExpr _) stmts body = ptext SLIT("mdo") <+> (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 pprComp :: OutputableBndr id => (SDoc -> SDoc) -> [LStmt id] -> LHsExpr id -> SDoc pprComp brack quals body @@ -938,13 +926,6 @@ 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 -pprMatchRhsContext (FunRhs fun) = ptext SLIT("a right-hand side of function") <+> quotes (ppr fun) -pprMatchRhsContext CaseAlt = ptext SLIT("the body of a case alternative") -pprMatchRhsContext PatBindRhs = ptext SLIT("the right-hand side of a pattern binding") -pprMatchRhsContext LambdaExpr = ptext SLIT("the body of a lambda") -pprMatchRhsContext ProcExpr = ptext SLIT("the body of a proc") -pprMatchRhsContext RecUpd = panic "pprMatchRhsContext" - pprStmtContext (ParStmtCtxt c) = sep [ptext SLIT("a parallel branch of"), pprStmtContext c] pprStmtContext (PatGuard ctxt) = ptext SLIT("a pattern guard for") $$ pprMatchContext ctxt pprStmtContext DoExpr = ptext SLIT("a 'do' expression") @@ -952,12 +933,20 @@ pprStmtContext (MDoExpr _) = ptext SLIT("an 'mdo' expression") pprStmtContext ListComp = ptext SLIT("a list comprehension") pprStmtContext PArrComp = ptext SLIT("an array comprehension") +{- +pprMatchRhsContext (FunRhs fun) = ptext SLIT("a right-hand side of function") <+> quotes (ppr fun) +pprMatchRhsContext CaseAlt = ptext SLIT("the body of a case alternative") +pprMatchRhsContext PatBindRhs = ptext SLIT("the right-hand side of a pattern binding") +pprMatchRhsContext LambdaExpr = ptext SLIT("the body of a lambda") +pprMatchRhsContext ProcExpr = ptext SLIT("the body of a proc") +pprMatchRhsContext other = panic "pprMatchRhsContext" -- RecUpd, StmtCtxt + -- Used for the result statement of comprehension -- e.g. the 'e' in [ e | ... ] -- or the 'r' in f x = r pprStmtResultContext (PatGuard ctxt) = pprMatchRhsContext ctxt pprStmtResultContext other = ptext SLIT("the result of") <+> pprStmtContext other - +-} -- Used to generate the string for a *runtime* error message matchContextErrString (FunRhs fun) = "function " ++ showSDoc (ppr fun)