X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsExpr.lhs;h=40c97ffb01ef61b428e42a13bd7c100bb4685edc;hb=94c5c5a2f6e296125940af1946d888e53b8c82f0;hp=620f060bb01a367126e75787363a47706773370d;hpb=9579283cadf4ac68a6f4252244041b5127e16811;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 620f060..40c97ff 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -9,21 +9,23 @@ module HsExpr where #include "HsVersions.h" -- friends: -import {-# SOURCE #-} HsMatches ( pprMatches, pprMatch, Match ) - -import HsBinds ( HsBinds(..) ) -import HsBasic ( HsLit ) -import BasicTypes ( Fixity(..), FixityDirection(..) ) +import HsBinds ( HsBinds(..), nullBinds ) +import HsTypes ( PostTcType ) +import HsLit ( HsLit, HsOverLit ) +import BasicTypes ( Fixity(..) ) import HsTypes ( HsType ) +import HsImpExp ( isOperator ) -- others: -import Name ( Name, isLexId ) +import Name ( Name ) +import ForeignCall ( Safety ) import Outputable -import PprType ( pprType, pprParendType ) -import Type ( Type ) -import Var ( TyVar, Id ) +import PprType ( pprParendType ) +import Type ( Type ) +import Var ( TyVar ) import DataCon ( DataCon ) import CStrings ( CLabelString, pprCLabelString ) +import BasicTypes ( IPName, Boxity, tupleParens ) import SrcLoc ( SrcLoc ) \end{code} @@ -35,11 +37,10 @@ import SrcLoc ( SrcLoc ) \begin{code} data HsExpr id pat - = HsVar id -- variable - | HsIPVar id -- implicit parameter - | HsLit HsLit -- literal - | HsLitOut HsLit -- TRANSLATION - Type -- (with its type) + = HsVar id -- variable + | HsIPVar (IPName id) -- implicit parameter + | HsOverLit HsOverLit -- Overloaded literals; eliminated by type checker + | HsLit HsLit -- Simple (non-overloaded) literals | HsLam (Match id pat) -- lambda | HsApp (HsExpr id pat) -- application @@ -60,7 +61,7 @@ data HsExpr id pat -- They are eventually removed by the type checker. | NegApp (HsExpr id pat) -- negated expr - (HsExpr id pat) -- the negate id (in a HsVar) + Name -- Name of 'negate' (see RnEnv.lookupSyntaxName) | HsPar (HsExpr id pat) -- parenthesised expr @@ -82,24 +83,28 @@ data HsExpr id pat (HsExpr id pat) | HsWith (HsExpr id pat) -- implicit parameter binding - [(id, HsExpr id pat)] + [(IPName id, HsExpr id pat)] + Bool -- True <=> this was a 'with' binding + -- (tmp, until 'with' is removed) - | HsDo StmtCtxt + | HsDo HsDoContext [Stmt id pat] -- "do":one or more stmts SrcLoc - | HsDoOut StmtCtxt + | HsDoOut HsDoContext [Stmt id pat] -- "do":one or more stmts id -- id for return id -- id for >>= - id -- id for zero + id -- id for fail Type -- Type of the whole expression SrcLoc | ExplicitList -- syntactic list + PostTcType -- Gives type of components of list [HsExpr id pat] - | ExplicitListOut -- TRANSLATION - Type -- Gives type of components of list + + | ExplicitPArr -- syntactic parallel array: [:e1, ..., en:] + PostTcType -- type of elements of the parallel array [HsExpr id pat] | ExplicitTuple -- tuple @@ -107,7 +112,7 @@ data HsExpr id pat -- NB: Unit is ExplicitTuple [] -- for tuples, we can get the types -- direct from the components - Bool -- boxed? + Boxity -- Record construction @@ -124,9 +129,9 @@ data 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 + -- type of input record) (HsRecordBinds id pat) | ExprWithTySig -- signature binding @@ -137,22 +142,28 @@ data HsExpr id pat | ArithSeqOut (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#". - Type -- 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 id pat) -- expr whose cost is to be measured + \end{code} These constructors only appear temporarily in the parser. @@ -165,6 +176,8 @@ The renamer translates them into the Right Thing. (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. @@ -210,14 +223,17 @@ pprExpr :: (Outputable id, Outputable pat) pprExpr e = pprDeeper (ppr_expr e) pprBinds b = pprDeeper (ppr b) -ppr_expr (HsVar v) = ppr v -ppr_expr (HsIPVar v) = {- char '?' <> -} ppr v +ppr_expr (HsVar v) + -- Put it in parens if it's an operator + | isOperator v = parens (ppr v) + | otherwise = ppr v -ppr_expr (HsLit lit) = ppr lit -ppr_expr (HsLitOut lit _) = ppr lit +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 (True,empty) match)] + = hsep [char '\\', nest 2 (pprMatch LambdaExpr match)] ppr_expr expr@(HsApp e1 e2) = let (fun, args) = collect_args expr [] in @@ -240,16 +256,11 @@ ppr_expr (OpApp e1 op fixity e2) pp_infixly v = sep [pp_e1, hsep [pp_v_op, pp_e2]] where - pp_v = ppr v - pp_v_op | isLexId (_PK_ (showSDoc pp_v)) = char '`' <> pp_v <> char '`' - | otherwise = pp_v - -- Put it in backquotes if it's not an operator already - -- We use (showSDoc pp_v), rather than isSymOcc (getOccName v) simply so - -- that we don't need NamedThing in the context of all these funcions. - -- Gruesome, but simple. + pp_v_op | isOperator v = ppr v + | otherwise = char '`' <> ppr v <> char '`' + -- Put it in backquotes if it's not an operator already -ppr_expr (NegApp e _) - = char '-' <+> pprParendExpr e +ppr_expr (NegApp e _) = char '-' <+> pprParendExpr e ppr_expr (HsPar e) = parens (ppr_expr e) @@ -278,7 +289,7 @@ ppr_expr (SectionR op expr) ppr_expr (HsCase expr matches _) = sep [ sep [ptext SLIT("case"), nest 4 (pprExpr expr), ptext SLIT("of")], - nest 2 (pprMatches (True, empty) matches) ] + nest 2 (pprMatches CaseAlt matches) ] ppr_expr (HsIf e1 e2 e3 _) = sep [hsep [ptext SLIT("if"), nest 2 (pprExpr e1), ptext SLIT("then")], @@ -295,23 +306,21 @@ 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"), ppr binds] +ppr_expr (HsWith expr binds is_with) + = sep [hang (ptext SLIT("let")) 2 (pp_ipbinds binds), + hang (ptext SLIT("in")) 2 (ppr expr)] 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) +ppr_expr (ExplicitList _ exprs) = brackets (fsep (punctuate comma (map ppr_expr exprs))) -ppr_expr (ExplicitListOut ty exprs) - = hcat [ brackets (fsep (punctuate comma (map ppr_expr exprs))), - ifNotPprForUser ((<>) space (parens (pprType ty))) ] -ppr_expr (ExplicitTuple exprs True) - = parens (sep (punctuate comma (map ppr_expr exprs))) +ppr_expr (ExplicitPArr _ exprs) + = pabrackets (fsep (punctuate comma (map ppr_expr exprs))) -ppr_expr (ExplicitTuple exprs False) - = ptext SLIT("(#") <> sep (punctuate comma (map ppr_expr exprs)) <> ptext SLIT("#)") +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 @@ -332,6 +341,11 @@ ppr_expr (ArithSeqIn 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 @@ -367,6 +381,12 @@ 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: @@ -380,12 +400,12 @@ pprParendExpr expr in case expr of HsLit l -> ppr l - HsLitOut l _ -> ppr l + HsOverLit l -> ppr l HsVar _ -> pp_as_was HsIPVar _ -> pp_as_was - ExplicitList _ -> pp_as_was - ExplicitListOut _ _ -> pp_as_was + ExplicitList _ _ -> pp_as_was + ExplicitPArr _ _ -> pp_as_was ExplicitTuple _ _ -> pp_as_was HsPar _ -> pp_as_was @@ -415,48 +435,187 @@ pp_rbinds thing rbinds 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 and list comprehensions} +\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 StmtCtxt -- Context of a Stmt - = DoStmt -- Do Statment - | ListComp -- List comprehension - | CaseAlt -- Guard on a case alternative - | PatBindRhs -- Guard on a pattern binding - | FunRhs Name -- Guard on a function defn for f - | LambdaBody -- Body of a lambda abstraction - -pprDo DoStmt stmts - = hang (ptext SLIT("do")) 2 (vcat (map ppr stmts)) -pprDo ListComp stmts - = brackets $ - hang (pprExpr expr <+> char '|') - 4 (interpp'SP quals) - where - ReturnStmt expr = last stmts -- Last stmt should be a ReturnStmt for list comps - quals = init stmts +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} -data Stmt id pat - = BindStmt pat - (HsExpr id pat) - SrcLoc +getMatchLoc :: Match id pat -> SrcLoc +getMatchLoc (Match _ _ (GRHSs (GRHS _ loc : _) _ _)) = loc +\end{code} - | LetStmt (HsBinds id pat) +We know the list must have at least one @Match@ in it. - | GuardStmt (HsExpr id pat) -- List comps only - SrcLoc +\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 - | ExprStmt (HsExpr id pat) -- Do stmts; and guarded things at the end - SrcLoc - | ReturnStmt (HsExpr id pat) -- List comps only, at the end +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 @@ -467,16 +626,29 @@ 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 (GuardStmt expr _) - = ppr expr -pprStmt (ReturnStmt expr) - = hsep [ptext SLIT("return"), ppr expr] +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} %************************************************************************ @@ -508,3 +680,62 @@ instance (Outputable id, Outputable pat) => 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} +isDoExpr (DoCtxt DoExpr) = True +isDoExpr other = False +\end{code} + +\begin{code} +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} +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}