X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsExpr.lhs;h=419cb3161a58b65c5135b9aeec00d83703dd3861;hb=10fcd78ccde892feccda3f5eacd221c1de75feea;hp=93aa0e3c12be66cbff0d098722433770cb66262d;hpb=2f51f1402e6869c0f049ffbe7b019bf6ab80558f;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 93aa0e3..419cb31 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -1,32 +1,32 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[HsExpr]{Abstract Haskell syntax: expressions} \begin{code} -#include "HsVersions.h" - module HsExpr where -import Ubiq{-uitous-} -import HsLoop -- for paranoia checking +#include "HsVersions.h" -- friends: -import HsBinds ( HsBinds ) -import HsLit ( HsLit ) -import HsMatches ( pprMatches, pprMatch, Match ) -import HsTypes ( PolyType ) +import HsBinds ( HsBinds(..), nullBinds ) +import HsTypes ( PostTcType ) +import HsLit ( HsLit, HsOverLit ) +import BasicTypes ( Fixity(..) ) +import HsTypes ( HsType ) +import HsImpExp ( isOperator ) -- others: -import Id ( DictVar(..), GenId, Id(..) ) -import Name ( isSymLexeme, pprSym ) -import Outputable ( interppSP, interpp'SP, ifnotPprForUser ) -import PprType ( pprGenType, pprParendGenType, GenType{-instance-} ) -import Pretty -import PprStyle ( PprStyle(..) ) +import Name ( Name ) +import ForeignCall ( Safety ) +import Outputable +import PprType ( pprParendType ) +import Type ( Type ) +import Var ( TyVar ) +import DataCon ( DataCon ) +import CStrings ( CLabelString, pprCLabelString ) +import BasicTypes ( IPName, Boxity, tupleParens ) import SrcLoc ( SrcLoc ) -import Usage ( GenUsage{-instance-} ) -import Util ( panic{-ToDo:rm eventually-} ) \end{code} %************************************************************************ @@ -36,15 +36,15 @@ import Util ( panic{-ToDo:rm eventually-} ) %************************************************************************ \begin{code} -data HsExpr tyvar uvar id pat - = HsVar id -- variable - | HsLit HsLit -- literal - | HsLitOut HsLit -- TRANSLATION - (GenType tyvar uvar) -- (with its type) +data HsExpr id pat + = HsVar id -- variable + | HsIPVar (IPName id) -- implicit parameter + | HsOverLit HsOverLit -- Overloaded literals; eliminated by type checker + | HsLit HsLit -- Simple (non-overloaded) literals - | HsLam (Match tyvar uvar id pat) -- lambda - | HsApp (HsExpr tyvar uvar id pat) -- application - (HsExpr tyvar uvar id pat) + | HsLam (Match id pat) -- lambda + | HsApp (HsExpr id pat) -- application + (HsExpr id pat) -- Operator applications: -- NB Bracketed ops such as (+) come out as Vars. @@ -52,130 +52,153 @@ data HsExpr tyvar uvar id pat -- NB We need an expr for the operator in an OpApp/Section since -- the typechecker may need to apply the operator to a few types. - | OpApp (HsExpr tyvar uvar id pat) -- left operand - (HsExpr tyvar uvar id pat) -- operator - (HsExpr tyvar uvar id pat) -- right operand + | OpApp (HsExpr id pat) -- left operand + (HsExpr id pat) -- operator + Fixity -- Renamer adds fixity; bottom until then + (HsExpr id pat) -- right operand -- We preserve prefix negation and parenthesis for the precedence parser. + -- They are eventually removed by the type checker. + + | NegApp (HsExpr id pat) -- negated expr + Name -- Name of 'negate' (see RnEnv.lookupSyntaxName) - | NegApp (HsExpr tyvar uvar id pat) -- negated expr - | HsPar (HsExpr tyvar uvar id pat) -- parenthesised expr + | HsPar (HsExpr id pat) -- parenthesised expr - | SectionL (HsExpr tyvar uvar id pat) -- operand - (HsExpr tyvar uvar id pat) -- operator - | SectionR (HsExpr tyvar uvar id pat) -- operator - (HsExpr tyvar uvar id pat) -- operand + | SectionL (HsExpr id pat) -- operand + (HsExpr id pat) -- operator + | SectionR (HsExpr id pat) -- operator + (HsExpr id pat) -- operand - | HsCase (HsExpr tyvar uvar id pat) - [Match tyvar uvar id pat] -- must have at least one Match + | HsCase (HsExpr id pat) + [Match id pat] SrcLoc - | HsIf (HsExpr tyvar uvar id pat) -- predicate - (HsExpr tyvar uvar id pat) -- then part - (HsExpr tyvar uvar id pat) -- else part + | HsIf (HsExpr id pat) -- predicate + (HsExpr id pat) -- then part + (HsExpr id pat) -- else part SrcLoc - | HsLet (HsBinds tyvar uvar id pat) -- let(rec) - (HsExpr tyvar uvar id pat) + | HsLet (HsBinds id pat) -- let(rec) + (HsExpr id pat) - | HsDo [Stmt tyvar uvar id pat] -- "do":one or more stmts - SrcLoc + | HsWith (HsExpr id pat) -- implicit parameter binding + [(IPName id, HsExpr id pat)] - | HsDoOut [Stmt tyvar uvar id pat] -- "do":one or more stmts - id id -- Monad and MonadZero dicts + | HsDo HsDoContext + [Stmt id pat] -- "do":one or more stmts SrcLoc - | ListComp (HsExpr tyvar uvar id pat) -- list comprehension - [Qual tyvar uvar id pat] -- at least one Qual(ifier) + | HsDoOut HsDoContext + [Stmt id pat] -- "do":one or more stmts + id -- id for return + id -- id for >>= + id -- id for fail + Type -- Type of the whole expression + SrcLoc | ExplicitList -- syntactic list - [HsExpr tyvar uvar id pat] - | ExplicitListOut -- TRANSLATION - (GenType tyvar uvar) -- Gives type of components of list - [HsExpr tyvar uvar id pat] + PostTcType -- Gives type of components of list + [HsExpr id pat] + + | ExplicitPArr -- syntactic parallel array: [:e1, ..., en:] + PostTcType -- type of elements of the parallel array + [HsExpr id pat] | ExplicitTuple -- tuple - [HsExpr tyvar uvar id pat] + [HsExpr id pat] -- NB: Unit is ExplicitTuple [] -- for tuples, we can get the types -- direct from the components + Boxity + -- Record construction - | RecordCon (HsExpr tyvar uvar id pat) -- Always (HsVar id) until type checker, - -- but the latter adds its type args too - (HsRecordBinds tyvar uvar id pat) + | RecordCon id -- The constructor + (HsRecordBinds id pat) + + | RecordConOut DataCon + (HsExpr id pat) -- Data con Id applied to type args + (HsRecordBinds id pat) + -- Record update - | RecordUpd (HsExpr tyvar uvar id pat) - (HsRecordBinds tyvar uvar id pat) - - | RecordUpdOut (HsExpr tyvar uvar id pat) -- TRANSLATION - [id] -- Dicts needed for construction - (HsRecordBinds tyvar uvar id pat) - - | ExprWithTySig -- signature binding - (HsExpr tyvar uvar id pat) - (PolyType id) - | ArithSeqIn -- arithmetic sequence - (ArithSeqInfo tyvar uvar id pat) + | RecordUpd (HsExpr id pat) + (HsRecordBinds id pat) + + | RecordUpdOut (HsExpr id pat) -- TRANSLATION + Type -- Type of *input* record + Type -- Type of *result* record (may differ from + -- type of input record) + [id] -- Dicts needed for construction + (HsRecordBinds id pat) + + | ExprWithTySig -- signature binding + (HsExpr id pat) + (HsType id) + | ArithSeqIn -- arithmetic sequence + (ArithSeqInfo id pat) | ArithSeqOut - (HsExpr tyvar uvar id pat) -- (typechecked, of course) - (ArithSeqInfo tyvar uvar id pat) - - | CCall FAST_STRING -- call into the C world; string is - [HsExpr tyvar uvar id pat] -- the C function; exprs are the + (HsExpr id pat) -- (typechecked, of course) + (ArithSeqInfo id pat) + | PArrSeqIn -- arith. sequence for parallel array + (ArithSeqInfo id pat) -- [:e1..e2:] or [:e1, e2..e3:] + | PArrSeqOut + (HsExpr id pat) -- (typechecked, of course) + (ArithSeqInfo id pat) + + | HsCCall CLabelString -- call into the C world; string is + [HsExpr id pat] -- the C function; exprs are the -- arguments to pass. - Bool -- True <=> might cause Haskell + Safety -- True <=> might cause Haskell -- garbage-collection (must generate -- more paranoid code) Bool -- True <=> it's really a "casm" -- NOTE: this CCall is the *boxed* -- version; the desugarer will convert -- it into the unboxed "ccall#". - (GenType tyvar uvar) -- The result type; will be *bottom* + PostTcType -- The result type; will be *bottom* -- until the typechecker gets ahold of it | HsSCC FAST_STRING -- "set cost centre" (_scc_) annotation - (HsExpr tyvar uvar id pat) -- expr whose cost is to be measured + (HsExpr id pat) -- expr whose cost is to be measured + +\end{code} + +These constructors only appear temporarily in the parser. +The renamer translates them into the Right Thing. + +\begin{code} + | EWildPat -- wildcard + + | EAsPat id -- as pattern + (HsExpr id pat) + + | ELazyPat (HsExpr id pat) -- ~ pattern + + | HsType (HsType id) -- Explicit type argument; e.g f {| Int |} x y \end{code} Everything from here on appears only in typechecker output. \begin{code} | TyLam -- TRANSLATION - [tyvar] - (HsExpr tyvar uvar id pat) + [TyVar] + (HsExpr id pat) | TyApp -- TRANSLATION - (HsExpr tyvar uvar id pat) -- generated by Spec - [GenType tyvar uvar] + (HsExpr id pat) -- generated by Spec + [Type] -- DictLam and DictApp are "inverses" | DictLam [id] - (HsExpr tyvar uvar id pat) + (HsExpr id pat) | DictApp - (HsExpr tyvar uvar id pat) + (HsExpr id pat) [id] - -- ClassDictLam and Dictionary are "inverses" (see note below) - | ClassDictLam - [id] -- superclass dicts - [id] -- methods - (HsExpr tyvar uvar id pat) - | Dictionary - [id] -- superclass dicts - [id] -- methods - - | SingleDict -- a simple special case of Dictionary - id -- local dictionary name - - | HsCon -- TRANSLATION; a constructor application - Id -- used only in the RHS of constructor definitions - [GenType tyvar uvar] - [HsExpr tyvar uvar id pat] - -type HsRecordBinds tyvar uvar id pat - = [(id, HsExpr tyvar uvar id pat, Bool)] +type HsRecordBinds id pat + = [(id, HsExpr id pat, Bool)] -- True <=> source code used "punning", -- i.e. {op1, op2} rather than {op1=e1, op2=e2} \end{code} @@ -187,202 +210,204 @@ A @Dictionary@, unless of length 0 or 1, becomes a tuple. A \end{verbatim} \begin{code} -instance (NamedThing id, Outputable id, Outputable pat, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => - Outputable (HsExpr tyvar uvar id pat) where - ppr = pprExpr +instance (Outputable id, Outputable pat) => + Outputable (HsExpr id pat) where + ppr expr = pprExpr expr \end{code} \begin{code} -pprExpr sty (HsVar v) - = (if (isSymLexeme v) then ppParens else id) (ppr sty v) +pprExpr :: (Outputable id, Outputable pat) + => HsExpr id pat -> SDoc -pprExpr sty (HsLit lit) = ppr sty lit -pprExpr sty (HsLitOut lit _) = ppr sty lit +pprExpr e = pprDeeper (ppr_expr e) +pprBinds b = pprDeeper (ppr b) -pprExpr sty (HsLam match) - = ppCat [ppStr "\\", ppNest 2 (pprMatch sty True match)] +ppr_expr (HsVar v) + -- Put it in parens if it's an operator + | isOperator v = parens (ppr v) + | otherwise = ppr v -pprExpr sty expr@(HsApp e1 e2) +ppr_expr (HsIPVar v) = ppr v +ppr_expr (HsLit lit) = ppr lit +ppr_expr (HsOverLit lit) = ppr lit + +ppr_expr (HsLam match) + = hsep [char '\\', nest 2 (pprMatch LambdaExpr match)] + +ppr_expr expr@(HsApp e1 e2) = let (fun, args) = collect_args expr [] in - ppHang (pprParendExpr sty fun) 4 (ppSep (map (pprParendExpr sty) args)) + (ppr_expr fun) <+> (sep (map ppr_expr args)) where collect_args (HsApp fun arg) args = collect_args fun (arg:args) collect_args fun args = (fun, args) -pprExpr sty (OpApp e1 op e2) +ppr_expr (OpApp e1 op fixity e2) = case op of HsVar v -> pp_infixly v _ -> pp_prefixly where - pp_e1 = pprParendExpr sty e1 - pp_e2 = pprParendExpr sty e2 + pp_e1 = pprParendExpr e1 -- Add parens to make precedence clear + pp_e2 = pprParendExpr e2 pp_prefixly - = ppHang (pprParendExpr sty op) 4 (ppSep [pp_e1, pp_e2]) + = hang (pprExpr op) 4 (sep [pp_e1, pp_e2]) pp_infixly v - = ppSep [pp_e1, ppCat [pprSym sty v, pp_e2]] + = sep [pp_e1, hsep [pp_v_op, pp_e2]] + where + pp_v_op | isOperator v = ppr v + | otherwise = char '`' <> ppr v <> char '`' + -- Put it in backquotes if it's not an operator already -pprExpr sty (NegApp e) - = ppBeside (ppChar '-') (pprParendExpr sty e) +ppr_expr (NegApp e _) = char '-' <+> pprParendExpr e -pprExpr sty (HsPar e) - = ppParens (pprExpr sty e) +ppr_expr (HsPar e) = parens (ppr_expr e) -pprExpr sty (SectionL expr op) +ppr_expr (SectionL expr op) = case op of HsVar v -> pp_infixly v _ -> pp_prefixly where - pp_expr = pprParendExpr sty expr + pp_expr = pprParendExpr expr - pp_prefixly = ppHang (ppCat [ppStr "( \\ _x ->", ppr sty op]) - 4 (ppCat [pp_expr, ppStr "_x )"]) - pp_infixly v - = ppSep [ ppBeside ppLparen pp_expr, - ppBeside (pprSym sty v) ppRparen ] + pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op]) + 4 (hsep [pp_expr, ptext SLIT("x_ )")]) + pp_infixly v = parens (sep [pp_expr, ppr v]) -pprExpr sty (SectionR op expr) +ppr_expr (SectionR op expr) = case op of HsVar v -> pp_infixly v _ -> pp_prefixly where - pp_expr = pprParendExpr sty expr + pp_expr = pprParendExpr expr - pp_prefixly = ppHang (ppCat [ppStr "( \\ _x ->", ppr sty op, ppPStr SLIT("_x")]) - 4 (ppBeside pp_expr ppRparen) + pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, ptext SLIT("x_")]) + 4 ((<>) pp_expr rparen) pp_infixly v - = ppSep [ ppBeside ppLparen (pprSym sty v), - ppBeside pp_expr ppRparen ] + = parens (sep [ppr v, pp_expr]) -pprExpr sty (HsCase expr matches _) - = ppSep [ ppSep [ppPStr SLIT("case"), ppNest 4 (pprExpr sty expr), ppPStr SLIT("of")], - ppNest 2 (pprMatches sty (True, ppNil) matches) ] +ppr_expr (HsCase expr matches _) + = sep [ sep [ptext SLIT("case"), nest 4 (pprExpr expr), ptext SLIT("of")], + nest 2 (pprMatches CaseAlt matches) ] -pprExpr sty (HsIf e1 e2 e3 _) - = ppSep [ppCat [ppPStr SLIT("if"), ppNest 2 (pprExpr sty e1), ppPStr SLIT("then")], - ppNest 4 (pprExpr sty e2), - ppPStr SLIT("else"), - ppNest 4 (pprExpr sty e3)] +ppr_expr (HsIf e1 e2 e3 _) + = sep [hsep [ptext SLIT("if"), nest 2 (pprExpr e1), ptext SLIT("then")], + nest 4 (pprExpr e2), + ptext SLIT("else"), + nest 4 (pprExpr e3)] -- special case: let ... in let ... -pprExpr sty (HsLet binds expr@(HsLet _ _)) - = ppSep [ppHang (ppPStr SLIT("let")) 2 (ppCat [ppr sty binds, ppPStr SLIT("in")]), - ppr sty expr] - -pprExpr sty (HsLet binds expr) - = ppSep [ppHang (ppPStr SLIT("let")) 2 (ppr sty binds), - ppHang (ppPStr SLIT("in")) 2 (ppr sty expr)] - -pprExpr sty (HsDo stmts _) - = ppCat [ppPStr SLIT("do"), ppAboves (map (ppr sty) stmts)] -pprExpr sty (HsDoOut stmts _ _ _) - = ppCat [ppPStr SLIT("do"), ppAboves (map (ppr sty) stmts)] - -pprExpr sty (ListComp expr quals) - = ppHang (ppCat [ppLbrack, pprExpr sty expr, ppChar '|']) - 4 (ppSep [interpp'SP sty quals, ppRbrack]) - -pprExpr sty (ExplicitList exprs) - = ppBracket (ppInterleave ppComma (map (pprExpr sty) exprs)) -pprExpr sty (ExplicitListOut ty exprs) - = ppBesides [ ppBracket (ppInterleave ppComma (map (pprExpr sty) exprs)), - ifnotPprForUser sty (ppBeside ppSP (ppParens (pprGenType sty ty))) ] - -pprExpr sty (ExplicitTuple exprs) - = ppParens (ppInterleave ppComma (map (pprExpr sty) exprs)) - -pprExpr sty (RecordCon con rbinds) - = pp_rbinds sty (ppr sty con) rbinds - -pprExpr sty (RecordUpd aexp rbinds) - = pp_rbinds sty (pprParendExpr sty aexp) rbinds -pprExpr sty (RecordUpdOut aexp _ rbinds) - = pp_rbinds sty (pprParendExpr sty aexp) rbinds - -pprExpr sty (ExprWithTySig expr sig) - = ppHang (ppBesides [ppLparen, ppNest 2 (pprExpr sty expr), ppPStr SLIT(" ::")]) - 4 (ppBeside (ppr sty sig) ppRparen) - -pprExpr sty (ArithSeqIn info) - = ppBracket (ppr sty info) -pprExpr sty (ArithSeqOut expr info) - = case sty of - PprForUser -> - ppBracket (ppr sty info) - _ -> - ppBesides [ppLbrack, ppParens (ppr sty expr), ppr sty info, ppRbrack] - -pprExpr sty (CCall fun args _ is_asm result_ty) - = ppHang (if is_asm - then ppBesides [ppStr "_casm_ ``", ppPStr fun, ppStr "''"] - else ppBeside (ppPStr SLIT("_ccall_ ")) (ppPStr fun)) - 4 (ppSep (map (pprParendExpr sty) args)) - -pprExpr sty (HsSCC label expr) - = ppSep [ ppBeside (ppPStr SLIT("_scc_ ")) (ppBesides [ppChar '"', ppPStr label, ppChar '"']), - pprParendExpr sty expr ] - -pprExpr sty (TyLam tyvars expr) - = ppHang (ppCat [ppStr "/\\", interppSP sty tyvars, ppStr "->"]) - 4 (pprExpr sty expr) - -pprExpr sty (TyApp expr [ty]) - = ppHang (pprExpr sty expr) 4 (pprParendGenType sty ty) - -pprExpr sty (TyApp expr tys) - = ppHang (pprExpr sty expr) - 4 (ppBracket (interpp'SP sty tys)) - -pprExpr sty (DictLam dictvars expr) - = ppHang (ppCat [ppStr "\\{-dict-}", interppSP sty dictvars, ppStr "->"]) - 4 (pprExpr sty expr) - -pprExpr sty (DictApp expr [dname]) - = ppHang (pprExpr sty expr) 4 (ppr sty dname) - -pprExpr sty (DictApp expr dnames) - = ppHang (pprExpr sty expr) - 4 (ppBracket (interpp'SP sty dnames)) - -pprExpr sty (ClassDictLam dicts methods expr) - = ppHang (ppCat [ppStr "\\{-classdict-}", - ppBracket (interppSP sty dicts), - ppBracket (interppSP sty methods), - ppStr "->"]) - 4 (pprExpr sty expr) - -pprExpr sty (Dictionary dicts methods) - = ppSep [ppBesides [ppLparen, ppPStr SLIT("{-dict-}")], - ppBracket (interpp'SP sty dicts), - ppBesides [ppBracket (interpp'SP sty methods), ppRparen]] - -pprExpr sty (SingleDict dname) - = ppCat [ppPStr SLIT("{-singleDict-}"), ppr sty dname] - -pprExpr sty (HsCon con tys exprs) - = ppCat [ppPStr SLIT("{-HsCon-}"), ppr sty con, interppSP sty tys, interppSP sty exprs] +ppr_expr (HsLet binds expr@(HsLet _ _)) + = sep [hang (ptext SLIT("let")) 2 (hsep [pprBinds binds, ptext SLIT("in")]), + pprExpr expr] + +ppr_expr (HsLet binds expr) + = sep [hang (ptext SLIT("let")) 2 (pprBinds binds), + hang (ptext SLIT("in")) 2 (ppr expr)] + +ppr_expr (HsWith expr binds) + = hsep [ppr expr, ptext SLIT("with"), pp_ipbinds binds] + +ppr_expr (HsDo do_or_list_comp stmts _) = pprDo do_or_list_comp stmts +ppr_expr (HsDoOut do_or_list_comp stmts _ _ _ _ _) = pprDo do_or_list_comp stmts + +ppr_expr (ExplicitList _ exprs) + = brackets (fsep (punctuate comma (map ppr_expr exprs))) + +ppr_expr (ExplicitPArr _ exprs) + = pabrackets (fsep (punctuate comma (map ppr_expr exprs))) + +ppr_expr (ExplicitTuple exprs boxity) + = tupleParens boxity (sep (punctuate comma (map ppr_expr exprs))) + +ppr_expr (RecordCon con_id rbinds) + = pp_rbinds (ppr con_id) rbinds +ppr_expr (RecordConOut data_con con rbinds) + = pp_rbinds (ppr con) rbinds + +ppr_expr (RecordUpd aexp rbinds) + = pp_rbinds (pprParendExpr aexp) rbinds +ppr_expr (RecordUpdOut aexp _ _ _ rbinds) + = pp_rbinds (pprParendExpr aexp) rbinds + +ppr_expr (ExprWithTySig expr sig) + = hang (nest 2 (ppr_expr expr) <+> dcolon) + 4 (ppr sig) + +ppr_expr (ArithSeqIn info) + = brackets (ppr info) +ppr_expr (ArithSeqOut expr info) + = brackets (ppr info) + +ppr_expr (PArrSeqIn info) + = pabrackets (ppr info) +ppr_expr (PArrSeqOut expr info) + = pabrackets (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 (HsCCall fun args _ is_asm result_ty) + = hang (if is_asm + then ptext SLIT("_casm_ ``") <> pprCLabelString fun <> ptext SLIT("''") + else ptext SLIT("_ccall_") <+> pprCLabelString fun) + 4 (sep (map pprParendExpr args)) + +ppr_expr (HsSCC lbl expr) + = sep [ ptext SLIT("_scc_") <+> doubleQuotes (ptext lbl), pprParendExpr expr ] + +ppr_expr (TyLam tyvars expr) + = hang (hsep [ptext SLIT("/\\"), interppSP tyvars, ptext SLIT("->")]) + 4 (ppr_expr expr) + +ppr_expr (TyApp expr [ty]) + = hang (ppr_expr expr) 4 (pprParendType ty) + +ppr_expr (TyApp expr tys) + = hang (ppr_expr expr) + 4 (brackets (interpp'SP tys)) + +ppr_expr (DictLam dictvars expr) + = hang (hsep [ptext SLIT("\\{-dict-}"), interppSP dictvars, ptext SLIT("->")]) + 4 (ppr_expr expr) + +ppr_expr (DictApp expr [dname]) + = hang (ppr_expr expr) 4 (ppr dname) + +ppr_expr (DictApp expr dnames) + = hang (ppr_expr expr) + 4 (brackets (interpp'SP dnames)) + +ppr_expr (HsType id) = ppr id + +-- add parallel array brackets around a document +-- +pabrackets :: SDoc -> SDoc +pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]") \end{code} Parenthesize unless very simple: \begin{code} -pprParendExpr :: (NamedThing id, Outputable id, Outputable pat, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) - => PprStyle -> HsExpr tyvar uvar id pat -> Pretty +pprParendExpr :: (Outputable id, Outputable pat) + => HsExpr id pat -> SDoc -pprParendExpr sty expr +pprParendExpr expr = let - pp_as_was = pprExpr sty expr + pp_as_was = pprExpr expr in case expr of - HsLit l -> ppr sty l - HsLitOut l _ -> ppr sty l + HsLit l -> ppr l + HsOverLit l -> ppr l + HsVar _ -> pp_as_was - ExplicitList _ -> pp_as_was - ExplicitListOut _ _ -> pp_as_was - ExplicitTuple _ -> pp_as_was - _ -> ppParens pp_as_was + HsIPVar _ -> pp_as_was + ExplicitList _ _ -> pp_as_was + ExplicitPArr _ _ -> pp_as_was + ExplicitTuple _ _ -> pp_as_was + HsPar _ -> pp_as_was + + _ -> parens pp_as_was \end{code} %************************************************************************ @@ -392,45 +417,236 @@ pprParendExpr sty expr %************************************************************************ \begin{code} -pp_rbinds :: (NamedThing id, Outputable id, Outputable pat, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) - => PprStyle -> Pretty - -> HsRecordBinds tyvar uvar id pat -> Pretty - -pp_rbinds sty thing rbinds - = ppHang thing 4 - (ppBesides [ppChar '{', ppInterleave ppComma (map (pp_rbind sty) rbinds), ppChar '}']) +pp_rbinds :: (Outputable id, Outputable pat) + => SDoc + -> HsRecordBinds id pat -> SDoc + +pp_rbinds thing rbinds + = hang thing + 4 (braces (sep (punctuate comma (map (pp_rbind) rbinds)))) where - pp_rbind sty (v, _, True{-pun-}) = ppr sty v - pp_rbind sty (v, e, _) = ppCat [ppr sty v, ppStr "<-", ppr sty e] + pp_rbind (v, e, pun_flag) + = getPprStyle $ \ sty -> + if pun_flag && userStyle sty then + ppr v + else + hsep [ppr v, char '=', ppr e] +\end{code} + +\begin{code} +pp_ipbinds :: (Outputable id, Outputable pat) + => [(IPName id, HsExpr id pat)] -> SDoc +pp_ipbinds pairs = hsep (punctuate semi (map pp_item pairs)) + where + pp_item (id,rhs) = ppr id <+> equals <+> ppr_expr rhs \end{code} + %************************************************************************ %* * -\subsection{Do stmts} +\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes} %* * %************************************************************************ +@Match@es are sets of pattern bindings and right hand sides for +functions, patterns or case branches. For example, if a function @g@ +is defined as: +\begin{verbatim} +g (x,y) = y +g ((x:ys),y) = y+1, +\end{verbatim} +then \tr{g} has two @Match@es: @(x,y) = y@ and @((x:ys),y) = y+1@. + +It is always the case that each element of an @[Match]@ list has the +same number of @pats@s inside it. This corresponds to saying that +a function defined by pattern matching must have the same number of +patterns in each equation. + \begin{code} -data Stmt tyvar uvar id pat - = BindStmt pat - (HsExpr tyvar uvar id pat) - SrcLoc - | ExprStmt (HsExpr tyvar uvar id pat) - SrcLoc - | LetStmt (HsBinds tyvar uvar id pat) +data Match id pat + = Match + [pat] -- The patterns + (Maybe (HsType id)) -- A type signature for the result of the match + -- Nothing after typechecking + + (GRHSs id pat) + +-- GRHSs are used both for pattern bindings and for Matches +data GRHSs id pat + = GRHSs [GRHS id pat] -- Guarded RHSs + (HsBinds id pat) -- The where clause + PostTcType -- Type of RHS (after type checking) + +data GRHS id pat + = GRHS [Stmt id pat] -- The RHS is the final ResultStmt + -- I considered using a RetunStmt, but + -- it printed 'wrong' in error messages + SrcLoc + +mkSimpleMatch :: [pat] -> HsExpr id pat -> Type -> SrcLoc -> Match id pat +mkSimpleMatch pats rhs rhs_ty locn + = Match pats Nothing (GRHSs (unguardedRHS rhs locn) EmptyBinds rhs_ty) + +unguardedRHS :: HsExpr id pat -> SrcLoc -> [GRHS id pat] +unguardedRHS rhs loc = [GRHS [ResultStmt rhs loc] loc] \end{code} +@getMatchLoc@ takes a @Match@ and returns the +source-location gotten from the GRHS inside. +THis is something of a nuisance, but no more. + \begin{code} -instance (NamedThing id, Outputable id, Outputable pat, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => - Outputable (Stmt tyvar uvar id pat) where - ppr sty (BindStmt pat expr _) - = ppCat [ppr sty pat, ppStr "<-", ppr sty expr] - ppr sty (LetStmt binds) - = ppCat [ppPStr SLIT("let"), ppr sty binds] - ppr sty (ExprStmt expr _) - = ppr sty expr +getMatchLoc :: Match id pat -> SrcLoc +getMatchLoc (Match _ _ (GRHSs (GRHS _ loc : _) _ _)) = loc +\end{code} + +We know the list must have at least one @Match@ in it. + +\begin{code} +pprMatches :: (Outputable id, Outputable pat) + => HsMatchContext id -> [Match id pat] -> SDoc +pprMatches ctxt matches = vcat (map (pprMatch ctxt) matches) + +-- Exported to HsBinds, which can't see the defn of HsMatchContext +pprFunBind :: (Outputable id, Outputable pat) + => id -> [Match id pat] -> SDoc +pprFunBind fun matches = pprMatches (FunRhs fun) matches + +-- Exported to HsBinds, which can't see the defn of HsMatchContext +pprPatBind :: (Outputable id, Outputable pat) + => pat -> GRHSs id pat -> SDoc +pprPatBind pat grhss = sep [ppr pat, nest 4 (pprGRHSs PatBindRhs grhss)] + + +pprMatch :: (Outputable id, Outputable pat) + => HsMatchContext id -> Match id pat -> SDoc +pprMatch ctxt (Match pats maybe_ty grhss) + = pp_name ctxt <+> sep [sep (map ppr pats), + ppr_maybe_ty, + nest 2 (pprGRHSs ctxt grhss)] + where + pp_name (FunRhs fun) = ppr fun + pp_name other = empty + ppr_maybe_ty = case maybe_ty of + Just ty -> dcolon <+> ppr ty + Nothing -> empty + + +pprGRHSs :: (Outputable id, Outputable pat) + => HsMatchContext id -> GRHSs id pat -> SDoc +pprGRHSs ctxt (GRHSs grhss binds ty) + = vcat (map (pprGRHS ctxt) grhss) + $$ + (if nullBinds binds then empty + else text "where" $$ nest 4 (pprDeeper (ppr binds))) + + +pprGRHS :: (Outputable id, Outputable pat) + => HsMatchContext id -> GRHS id pat -> SDoc + +pprGRHS ctxt (GRHS [ResultStmt expr _] locn) + = pp_rhs ctxt expr + +pprGRHS ctxt (GRHS guarded locn) + = sep [char '|' <+> interpp'SP guards, pp_rhs ctxt expr] + where + ResultStmt expr _ = last guarded -- Last stmt should be a ResultStmt for guards + guards = init guarded + +pp_rhs ctxt rhs = ptext (matchSeparator ctxt) <+> pprDeeper (ppr rhs) +\end{code} + + + +%************************************************************************ +%* * +\subsection{Do stmts and list comprehensions} +%* * +%************************************************************************ + +\begin{code} +data Stmt id pat + = BindStmt pat (HsExpr id pat) SrcLoc + | LetStmt (HsBinds id pat) + | ResultStmt (HsExpr id pat) SrcLoc -- See notes that follow + | ExprStmt (HsExpr id pat) PostTcType SrcLoc -- See notes that follow + -- The type is the *element type* of the expression + | ParStmt [[Stmt id pat]] -- List comp only: parallel set of quals + | ParStmtOut [([id], [Stmt id pat])] -- PLC after renaming; the ids are the binders + -- bound by the stmts +\end{code} + +ExprStmts and ResultStmts are a bit tricky, because what they mean +depends on the context. Consider the following contexts: + + A do expression of type (m res_ty) + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * ExprStmt E any_ty: do { ....; E; ... } + E :: m any_ty + Translation: E >> ... + + * ResultStmt E: do { ....; E } + E :: m res_ty + Translation: E + + A list comprehensions of type [elt_ty] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * ExprStmt E Bool: [ .. | .... E ] + [ .. | ..., E, ... ] + [ .. | .... | ..., E | ... ] + E :: Bool + Translation: if E then fail else ... + + * ResultStmt E: [ E | ... ] + E :: elt_ty + Translation: return E + + A guard list, guarding a RHS of type rhs_ty + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * ExprStmt E Bool: f x | ..., E, ... = ...rhs... + E :: Bool + Translation: if E then fail else ... + + * ResultStmt E: f x | ...guards... = E + E :: rhs_ty + Translation: E + +Array comprehensions are handled like list comprehensions -=chak + +\begin{code} +consLetStmt :: HsBinds id pat -> [Stmt id pat] -> [Stmt id pat] +consLetStmt EmptyBinds stmts = stmts +consLetStmt binds stmts = LetStmt binds : stmts +\end{code} + +\begin{code} +instance (Outputable id, Outputable pat) => + Outputable (Stmt id pat) where + ppr stmt = pprStmt stmt + +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 (ResultStmt expr _) = ppr expr +pprStmt (ParStmt stmtss) + = hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss) +pprStmt (ParStmtOut stmtss) + = hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss) + +pprDo :: (Outputable id, Outputable pat) + => HsDoContext -> [Stmt id pat] -> SDoc +pprDo DoExpr stmts = hang (ptext SLIT("do")) 2 (vcat (map ppr stmts)) +pprDo ListComp stmts = pprComp brackets stmts +pprDo PArrComp stmts = pprComp pabrackets stmts + +pprComp :: (Outputable id, Outputable pat) + => (SDoc -> SDoc) -> [Stmt id pat] -> SDoc +pprComp brack stmts = brack $ + hang (pprExpr expr <+> char '|') + 4 (interpp'SP quals) + where + ResultStmt expr _ = last stmts -- Last stmt should + quals = init stmts -- be an ResultStmt \end{code} %************************************************************************ @@ -440,47 +656,84 @@ instance (NamedThing id, Outputable id, Outputable pat, %************************************************************************ \begin{code} -data ArithSeqInfo tyvar uvar id pat - = From (HsExpr tyvar uvar id pat) - | FromThen (HsExpr tyvar uvar id pat) - (HsExpr tyvar uvar id pat) - | FromTo (HsExpr tyvar uvar id pat) - (HsExpr tyvar uvar id pat) - | FromThenTo (HsExpr tyvar uvar id pat) - (HsExpr tyvar uvar id pat) - (HsExpr tyvar uvar id pat) +data ArithSeqInfo id pat + = From (HsExpr id pat) + | FromThen (HsExpr id pat) + (HsExpr id pat) + | FromTo (HsExpr id pat) + (HsExpr id pat) + | FromThenTo (HsExpr id pat) + (HsExpr id pat) + (HsExpr id pat) +\end{code} + +\begin{code} +instance (Outputable id, Outputable pat) => + Outputable (ArithSeqInfo id pat) where + ppr (From e1) = hcat [ppr e1, pp_dotdot] + ppr (FromThen e1 e2) = hcat [ppr e1, comma, space, ppr e2, pp_dotdot] + ppr (FromTo e1 e3) = hcat [ppr e1, pp_dotdot, ppr e3] + ppr (FromThenTo e1 e2 e3) + = hcat [ppr e1, comma, space, ppr e2, pp_dotdot, ppr e3] + +pp_dotdot = ptext SLIT(" .. ") +\end{code} + + +%************************************************************************ +%* * +\subsection{HsMatchCtxt} +%* * +%************************************************************************ + +\begin{code} +data HsMatchContext id -- Context of a Match or Stmt + = DoCtxt HsDoContext -- Do-stmt or list comprehension + | FunRhs id -- Function binding for f + | CaseAlt -- Guard on a case alternative + | LambdaExpr -- Lambda + | PatBindRhs -- Pattern binding + | RecUpd -- Record update + deriving () + +data HsDoContext = ListComp + | DoExpr + | PArrComp -- parallel array comprehension \end{code} \begin{code} -instance (NamedThing id, Outputable id, Outputable pat, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => - Outputable (ArithSeqInfo tyvar uvar id pat) where - ppr sty (From e1) = ppBesides [ppr sty e1, pp_dotdot] - ppr sty (FromThen e1 e2) = ppBesides [ppr sty e1, pp'SP, ppr sty e2, pp_dotdot] - ppr sty (FromTo e1 e3) = ppBesides [ppr sty e1, pp_dotdot, ppr sty e3] - ppr sty (FromThenTo e1 e2 e3) - = ppBesides [ppr sty e1, pp'SP, ppr sty e2, pp_dotdot, ppr sty e3] - -pp_dotdot = ppPStr SLIT(" .. ") +isDoExpr (DoCtxt DoExpr) = True +isDoExpr other = False \end{code} -``Qualifiers'' in list comprehensions: \begin{code} -data Qual tyvar uvar id pat - = GeneratorQual pat - (HsExpr tyvar uvar id pat) - | LetQual (HsBinds tyvar uvar id pat) - | FilterQual (HsExpr tyvar uvar id pat) +matchSeparator (FunRhs _) = SLIT("=") +matchSeparator CaseAlt = SLIT("->") +matchSeparator LambdaExpr = SLIT("->") +matchSeparator PatBindRhs = SLIT("=") +matchSeparator (DoCtxt _) = SLIT("<-") +matchSeparator RecUpd = panic "When is this used?" \end{code} \begin{code} -instance (NamedThing id, Outputable id, Outputable pat, - Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => - Outputable (Qual tyvar uvar id pat) where - ppr sty (GeneratorQual pat expr) - = ppCat [ppr sty pat, ppStr "<-", ppr sty expr] - ppr sty (LetQual binds) - = ppCat [ppPStr SLIT("let"), ppr sty binds] - ppr sty (FilterQual expr) - = ppr sty expr +pprMatchContext (FunRhs fun) = ptext SLIT("In the definition of") <+> quotes (ppr fun) +pprMatchContext CaseAlt = ptext SLIT("In a case alternative") +pprMatchContext RecUpd = ptext SLIT("In a record-update construct") +pprMatchContext PatBindRhs = ptext SLIT("In a pattern binding") +pprMatchContext LambdaExpr = ptext SLIT("In a lambda abstraction") +pprMatchContext (DoCtxt DoExpr) = ptext SLIT("In a 'do' expression pattern binding") +pprMatchContext (DoCtxt ListComp) = + ptext SLIT("In a 'list comprehension' pattern binding") +pprMatchContext (DoCtxt PArrComp) = + ptext SLIT("In an 'array comprehension' pattern binding") + +-- Used to generate the string for a *runtime* error message +matchContextErrString (FunRhs fun) = "function " ++ showSDoc (ppr fun) +matchContextErrString CaseAlt = "case" +matchContextErrString PatBindRhs = "pattern binding" +matchContextErrString RecUpd = "record update" +matchContextErrString LambdaExpr = "lambda" +matchContextErrString (DoCtxt DoExpr) = "'do' expression" +matchContextErrString (DoCtxt ListComp) = "list comprehension" +matchContextErrString (DoCtxt PArrComp) = "array comprehension" \end{code}