X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FHsExpr.lhs;h=b7fe6fc1331324faab65b036fd36d9d2d5342da8;hp=7930caa00d2a10c13ec3085c6b4015919b51cc9c;hb=34c8d0312071f7d0f4d221a997d3408c653ef9e5;hpb=f278f0676579f67075033a4f9857715909c4b71e diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 7930caa..b7fe6fc 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -48,7 +48,7 @@ type LHsExpr id = Located (HsExpr id) type PostTcExpr = HsExpr Id -- | We use a PostTcTable where there are a bunch of pieces of evidence, more -- than is convenient to keep individually. -type PostTcTable = [(Name, Id)] +type PostTcTable = [(Name, PostTcExpr)] noPostTcExpr :: PostTcExpr noPostTcExpr = HsLit (HsString (fsLit "noPostTcExpr")) @@ -62,7 +62,7 @@ noPostTcTable = [] -- -- E.g. @(>>=)@ is filled in before the renamer by the appropriate 'Name' for -- @(>>=)@, and then instantiated by the type checker with its type args --- tec +-- etc type SyntaxExpr id = HsExpr id @@ -132,7 +132,10 @@ data HsExpr id | HsCase (LHsExpr id) (MatchGroup id) - | HsIf (LHsExpr id) -- predicate + | HsIf (Maybe (SyntaxExpr id)) -- cond function + -- Nothing => use the built-in 'if' + -- See Note [Rebindable if] + (LHsExpr id) -- predicate (LHsExpr id) -- then part (LHsExpr id) -- else part @@ -220,6 +223,13 @@ data HsExpr id (LHsCmdTop id) -- body of the abstraction -- always has an empty stack + ----------------------------------------------------------- + -- Heterogeneous Metaprogramming extension + + | HsHetMetBrak PostTcType (LHsExpr id) -- code type brackets + | HsHetMetEsc PostTcType PostTcType (LHsExpr id) -- code type escape + | HsHetMetCSP PostTcType (LHsExpr id) -- code type cross-stage persistence + --------------------------------------- -- The following are commands, not expressions proper @@ -297,11 +307,18 @@ type PendingSplice = (Name, LHsExpr Id) -- Typechecked splices, waiting to be -- pasted back in by the desugarer \end{code} -A @Dictionary@, unless of length 0 or 1, becomes a tuple. A -@ClassDictLam dictvars methods expr@ is, therefore: -\begin{verbatim} -\ x -> case x of ( dictvars-and-methods-tuple ) -> expr -\end{verbatim} +Note [Rebindable if] +~~~~~~~~~~~~~~~~~~~~ +The rebindable syntax for 'if' is a bit special, because when +rebindable syntax is *off* we do not want to treat + (if c then t else e) +as if it was an application (ifThenElse c t e). Why not? +Because we allow an 'if' to return *unboxed* results, thus + if blah then 3# else 4# +whereas that would not be possible using a all to a polymorphic function +(because you can't call a polymorphic function at an unboxed type). + +So we use Nothing to mean "use the old built-in typing rule". \begin{code} instance OutputableBndr id => Outputable (HsExpr id) where @@ -343,6 +360,9 @@ 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 (HsHetMetBrak _ e) = ptext (sLit "<[") <> (ppr_lexpr e) <> ptext (sLit "]>") +ppr_expr (HsHetMetEsc _ _ e) = ptext (sLit "~~") <> (ppr_lexpr e) +ppr_expr (HsHetMetCSP _ e) = ptext (sLit "%%") <> (ppr_lexpr e) ppr_expr (HsCoreAnn s e) = vcat [ptext (sLit "HsCoreAnn") <+> ftext s, ppr_lexpr e] @@ -414,7 +434,7 @@ ppr_expr exprType@(HsCase expr matches) nest 2 (pprMatches (CaseAlt `asTypeOf` idType exprType) matches <+> char '}') ] where idType :: HsExpr id -> HsMatchContext id; idType = undefined -ppr_expr (HsIf e1 e2 e3) +ppr_expr (HsIf _ e1 e2 e3) = sep [hsep [ptext (sLit "if"), nest 2 (ppr e1), ptext (sLit "then")], nest 4 (ppr e2), ptext (sLit "else"), @@ -619,7 +639,8 @@ The legal constructors for commands are: [Match id] -- bodies are HsCmd's SrcLoc - | HsIf (HsExpr id) -- predicate + | HsIf (Maybe (SyntaxExpr id)) -- cond function + (HsExpr id) -- predicate (HsCmd id) -- then part (HsCmd id) -- else part SrcLoc @@ -748,16 +769,16 @@ pprFunBind fun inf matches = pprMatches (FunRhs fun inf) matches pprPatBind :: (OutputableBndr bndr, OutputableBndr id) => LPat bndr -> GRHSs id -> SDoc pprPatBind pat ty@(grhss) - = sep [ppr pat, nest 4 (pprGRHSs (PatBindRhs `asTypeOf` idType ty) grhss)] + = sep [ppr pat, nest 2 (pprGRHSs (PatBindRhs `asTypeOf` idType ty) grhss)] --avoid using PatternSignatures for stage1 code portability where idType :: GRHSs id -> HsMatchContext id; idType = undefined pprMatch :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> Match idR -> SDoc pprMatch ctxt (Match pats maybe_ty grhss) - = herald <+> sep [sep (map pprParendLPat other_pats), - ppr_maybe_ty, - nest 2 (pprGRHSs ctxt grhss)] + = sep [ sep (herald : map (nest 2 . pprParendLPat) other_pats) + , nest 2 ppr_maybe_ty + , nest 2 (pprGRHSs ctxt grhss) ] where (herald, other_pats) = case ctxt of @@ -894,9 +915,6 @@ data StmtLR idL idR -- because the Id may be *polymorphic*, but -- the returned thing has to be *monomorphic*, -- so they may be type applications - - , recS_dicts :: DictBinds idR -- Method bindings of Ids bound by the - -- RecStmt, and used afterwards } deriving (Data, Typeable) \end{code} @@ -997,8 +1015,8 @@ pprStmt (ExprStmt expr _ _) = ppr expr pprStmt (ParStmt stmtss) = hsep (map doStmts stmtss) where doStmts stmts = ptext (sLit "| ") <> ppr stmts -pprStmt (TransformStmt stmts _ using by) - = sep (ppr_lc_stmts stmts ++ [pprTransformStmt using by]) +pprStmt (TransformStmt stmts bndrs using by) + = sep (ppr_lc_stmts stmts ++ [pprTransformStmt bndrs using by]) pprStmt (GroupStmt stmts _ by using) = sep (ppr_lc_stmts stmts ++ [pprGroupStmt by using]) @@ -1010,8 +1028,11 @@ 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])] -pprTransformStmt :: OutputableBndr id => LHsExpr id -> Maybe (LHsExpr id) -> SDoc -pprTransformStmt using by = sep [ ptext (sLit "then"), nest 2 (ppr using), nest 2 (pprBy by)] +pprTransformStmt :: OutputableBndr id => [id] -> LHsExpr id -> Maybe (LHsExpr id) -> SDoc +pprTransformStmt bndrs using by + = sep [ ptext (sLit "then") <+> ifPprDebug (braces (ppr bndrs)) + , nest 2 (ppr using) + , nest 2 (pprBy by)] pprGroupStmt :: OutputableBndr id => Maybe (LHsExpr id) -> Either (LHsExpr id) (SyntaxExpr is) @@ -1029,7 +1050,7 @@ pprBy (Just e) = ptext (sLit "by") <+> ppr e pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> LHsExpr id -> SDoc pprDo DoExpr stmts body = ptext (sLit "do") <+> ppr_do_stmts stmts body pprDo GhciStmt stmts body = ptext (sLit "do") <+> ppr_do_stmts stmts body -pprDo (MDoExpr _) stmts body = ptext (sLit "mdo") <+> ppr_do_stmts stmts body +pprDo MDoExpr stmts body = ptext (sLit "mdo") <+> ppr_do_stmts stmts body pprDo ListComp stmts body = brackets $ pprComp stmts body pprDo PArrComp stmts body = pa_brackets $ pprComp stmts body pprDo _ _ _ = panic "pprDo" -- PatGuard, ParStmtCxt @@ -1066,8 +1087,16 @@ instance OutputableBndr id => Outputable (HsSplice id) where pprSplice :: OutputableBndr id => HsSplice id -> SDoc pprSplice (HsSplice n e) - = char '$' <> ifPprDebug (brackets (ppr n)) <> pprParendExpr e - + = char '$' <> ifPprDebug (brackets (ppr n)) <> eDoc + where + -- We use pprLExpr to match pprParendExpr: + -- Using pprLExpr makes sure that we go 'deeper' + -- I think that is usually (always?) right + pp_as_was = pprLExpr e + eDoc = case unLoc e of + HsPar _ -> pp_as_was + HsVar _ -> pp_as_was + _ -> parens pp_as_was data HsBracket id = ExpBr (LHsExpr id) -- [| expr |] | PatBr (LPat id) -- [p| pat |] @@ -1139,14 +1168,18 @@ pp_dotdot = ptext (sLit " .. ") \begin{code} data HsMatchContext id -- Context of a Match = FunRhs id Bool -- Function binding for f; True <=> written infix - | CaseAlt -- Patterns and guards on a case alternative | LambdaExpr -- Patterns of a lambda + | CaseAlt -- Patterns and guards on a case alternative | ProcExpr -- Patterns of a proc - | PatBindRhs -- Patterns in the *guards* of a pattern binding + | PatBindRhs -- A pattern binding eg [y] <- e = e + | RecUpd -- Record update [used only in DsExpr to -- tell matchWrapper what sort of -- runtime error message to generate] - | StmtCtxt (HsStmtContext id) -- Pattern of a do-stmt or list comprehension + + | StmtCtxt (HsStmtContext id) -- Pattern of a do-stmt, list comprehension, + -- pattern guard, etc + | ThPatQuote -- A Template Haskell pattern quotation [p| (a,b) |] deriving (Data, Typeable) @@ -1154,9 +1187,7 @@ data HsStmtContext id = ListComp | DoExpr | GhciStmt -- A command-line Stmt in GHCi pat <- rhs - | MDoExpr PostTcTable -- Recursive do-expression - -- (tiresomely, it needs table - -- of its return/bind ops) + | MDoExpr -- Recursive do-expression | PArrComp -- Parallel array comprehension | PatGuard (HsMatchContext id) -- Pattern guard for specified thing | ParStmtCtxt (HsStmtContext id) -- A branch of a parallel stmt @@ -1166,9 +1197,9 @@ data HsStmtContext id \begin{code} isDoExpr :: HsStmtContext id -> Bool -isDoExpr DoExpr = True -isDoExpr (MDoExpr _) = True -isDoExpr _ = False +isDoExpr DoExpr = True +isDoExpr MDoExpr = True +isDoExpr _ = False isListCompExpr :: HsStmtContext id -> Bool isListCompExpr ListComp = True @@ -1190,16 +1221,25 @@ matchSeparator ThPatQuote = panic "unused" \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") -pprMatchContext ThPatQuote = ptext (sLit "a Template Haskell pattern quotation") -pprMatchContext PatBindRhs = ptext (sLit "a pattern binding") -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 +pprMatchContext ctxt + | want_an ctxt = ptext (sLit "an") <+> pprMatchContextNoun ctxt + | otherwise = ptext (sLit "a") <+> pprMatchContextNoun ctxt + where + want_an (FunRhs {}) = True -- Use "an" in front + want_an ProcExpr = True + want_an _ = False + +pprMatchContextNoun :: Outputable id => HsMatchContext id -> SDoc +pprMatchContextNoun (FunRhs fun _) = ptext (sLit "equation for") + <+> quotes (ppr fun) +pprMatchContextNoun CaseAlt = ptext (sLit "case alternative") +pprMatchContextNoun RecUpd = ptext (sLit "record-update construct") +pprMatchContextNoun ThPatQuote = ptext (sLit "Template Haskell pattern quotation") +pprMatchContextNoun PatBindRhs = ptext (sLit "pattern binding") +pprMatchContextNoun LambdaExpr = ptext (sLit "lambda abstraction") +pprMatchContextNoun ProcExpr = ptext (sLit "arrow abstraction") +pprMatchContextNoun (StmtCtxt ctxt) = ptext (sLit "pattern binding in") + $$ pprStmtContext ctxt pprStmtContext :: Outputable id => HsStmtContext id -> SDoc pprStmtContext (ParStmtCtxt c) @@ -1210,7 +1250,7 @@ pprStmtContext (PatGuard ctxt) = ptext (sLit "a pattern guard for") $$ pprMatchContext ctxt pprStmtContext GhciStmt = ptext (sLit "an interactive GHCi command") pprStmtContext DoExpr = ptext (sLit "a 'do' expression") -pprStmtContext (MDoExpr _) = ptext (sLit "an 'mdo' expression") +pprStmtContext MDoExpr = ptext (sLit "an 'mdo' expression") pprStmtContext ListComp = ptext (sLit "a list comprehension") pprStmtContext PArrComp = ptext (sLit "an array comprehension") @@ -1243,7 +1283,7 @@ matchContextErrString (StmtCtxt (TransformStmtCtxt c)) = matchContextErrString ( matchContextErrString (StmtCtxt (PatGuard _)) = ptext (sLit "pattern guard") matchContextErrString (StmtCtxt GhciStmt) = ptext (sLit "interactive GHCi command") matchContextErrString (StmtCtxt DoExpr) = ptext (sLit "'do' expression") -matchContextErrString (StmtCtxt (MDoExpr _)) = ptext (sLit "'mdo' expression") +matchContextErrString (StmtCtxt MDoExpr) = ptext (sLit "'mdo' expression") matchContextErrString (StmtCtxt ListComp) = ptext (sLit "list comprehension") matchContextErrString (StmtCtxt PArrComp) = ptext (sLit "array comprehension") \end{code} @@ -1260,7 +1300,7 @@ pprStmtInCtxt ctxt stmt = hang (ptext (sLit "In a stmt of") <+> pprStmtContext c 4 (ppr_stmt stmt) where -- For Group and Transform Stmts, don't print the nested stmts! - ppr_stmt (GroupStmt _ _ by using) = pprGroupStmt by using - ppr_stmt (TransformStmt _ _ using by) = pprTransformStmt using by - ppr_stmt stmt = pprStmt stmt + ppr_stmt (GroupStmt _ _ by using) = pprGroupStmt by using + ppr_stmt (TransformStmt _ bndrs using by) = pprTransformStmt bndrs using by + ppr_stmt stmt = pprStmt stmt \end{code}