X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnExpr.lhs;h=e1e6fe23db7a244455482bc78f26f5b8d2c229a2;hb=1fb1ab5d53a09607e7f6d2450806760688396387;hp=613b37be92d35e2bac91607d54ae28d5c8fde047;hpb=7a3bd641457666e10d0a47be9f22762e03defbf0;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 613b37b..e1e6fe2 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -26,22 +26,25 @@ import RnHsSyn import RnMonad import RnEnv import PrelInfo ( numClass_RDR, fractionalClass_RDR, eqClass_RDR, ccallableClass_RDR, - creturnableClass_RDR, monadZeroClass_RDR, enumClass_RDR, + creturnableClass_RDR, monadZeroClass_RDR, enumClass_RDR, ordClass_RDR, negate_RDR ) import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, floatPrimTyCon, doublePrimTyCon ) import TyCon ( TyCon ) +import Id ( GenId ) import ErrUtils ( addErrLoc, addShortErrLocLine ) import Name import Pretty +import Unique ( Unique, otherwiseIdKey ) import UniqFM ( lookupUFM{-, ufmToList ToDo:rm-} ) import UniqSet ( emptyUniqSet, unitUniqSet, unionUniqSets, unionManyUniqSets, SYN_IE(UniqSet) ) -import Util ( Ord3(..), removeDups, panic ) +import PprStyle ( PprStyle(..) ) +import Util ( Ord3(..), removeDups, panic, pprPanic, assertPanic ) \end{code} @@ -57,7 +60,7 @@ rnPat :: RdrNamePat -> RnMS s RenamedPat rnPat WildPatIn = returnRn WildPatIn rnPat (VarPatIn name) - = lookupRn name `thenRn` \ vname -> + = lookupBndrRn name `thenRn` \ vname -> returnRn (VarPatIn vname) rnPat (LitPatIn lit) @@ -71,16 +74,20 @@ rnPat (LazyPatIn pat) rnPat (AsPatIn name pat) = rnPat pat `thenRn` \ pat' -> - lookupRn name `thenRn` \ vname -> + lookupBndrRn name `thenRn` \ vname -> returnRn (AsPatIn vname pat') rnPat (ConPatIn con pats) - = lookupRn con `thenRn` \ con' -> + = lookupOccRn con `thenRn` \ con' -> mapRn rnPat pats `thenRn` \ patslist -> returnRn (ConPatIn con' patslist) -rnPat (ConOpPatIn pat1 con pat2) - = rnOpPat pat1 con pat2 +rnPat (ConOpPatIn pat1 con _ pat2) + = rnPat pat1 `thenRn` \ pat1' -> + lookupOccRn con `thenRn` \ con' -> + lookupFixity con `thenRn` \ fixity -> + rnPat pat2 `thenRn` \ pat2' -> + mkConOpPatRn pat1' con' fixity pat2' -- Negated patters can only be literals, and they are dealt with -- by negating the literal at compile time, not by using the negation @@ -100,6 +107,12 @@ rnPat (ParPatIn pat) = rnPat pat `thenRn` \ pat' -> returnRn (ParPatIn pat') +rnPat (NPlusKPatIn name lit) + = litOccurrence lit `thenRn_` + lookupImplicitOccRn ordClass_RDR `thenRn_` + lookupBndrRn name `thenRn` \ name' -> + returnRn (NPlusKPatIn name' lit) + rnPat (ListPatIn pats) = addImplicitOccRn listType_name `thenRn_` mapRn rnPat pats `thenRn` \ patslist -> @@ -111,7 +124,7 @@ rnPat (TuplePatIn pats) returnRn (TuplePatIn patslist) rnPat (RecPatIn con rpats) - = lookupRn con `thenRn` \ con' -> + = lookupOccRn con `thenRn` \ con' -> rnRpats rpats `thenRn` \ rpats' -> returnRn (RecPatIn con' rpats') \end{code} @@ -163,7 +176,15 @@ rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds) = pushSrcLocRn locn $ rnExpr guard `thenRn` \ (guard', fvsg) -> rnExpr expr `thenRn` \ (expr', fvse) -> - returnRn (GRHS guard' expr' locn, fvsg `unionNameSets` fvse) + + -- Turn an "otherwise" guard into an OtherwiseGRHS. + -- This is the first moment that we can be sure we havn't got a shadowed binding + -- of "otherwise". + let grhs' = case guard' of + HsVar v | uniqueOf v == otherwiseIdKey -> OtherwiseGRHS expr' locn + other -> GRHS guard' expr' locn + in + returnRn (grhs', fvsg `unionNameSets` fvse) rnGRHS (OtherwiseGRHS expr locn) = pushSrcLocRn locn $ @@ -179,13 +200,15 @@ rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds) \begin{code} rnExprs :: [RdrNameHsExpr] -> RnMS s ([RenamedHsExpr], FreeVars) - -rnExprs [] = returnRn ([], emptyNameSet) - -rnExprs (expr:exprs) - = rnExpr expr `thenRn` \ (expr', fvExpr) -> - rnExprs exprs `thenRn` \ (exprs', fvExprs) -> - returnRn (expr':exprs', fvExpr `unionNameSets` fvExprs) +rnExprs ls = + rnExprs' ls [] `thenRn` \ (exprs, fvExprs) -> + returnRn (exprs, unionManyNameSets fvExprs) + +rnExprs' [] acc = returnRn ([], acc) +rnExprs' (expr:exprs) acc + = rnExpr expr `thenRn` \ (expr', fvExpr) -> + rnExprs' exprs (fvExpr:acc) `thenRn` \ (exprs', fvExprs) -> + returnRn (expr':exprs', fvExprs) \end{code} Variables. We look up the variable and return the resulting name. The @@ -217,9 +240,28 @@ rnExpr (HsApp fun arg) rnExpr arg `thenRn` \ (arg',fvArg) -> returnRn (HsApp fun' arg', fvFun `unionNameSets` fvArg) -rnExpr (OpApp e1 (HsVar op) e2) = rnOpApp e1 op e2 +rnExpr (OpApp e1 op@(HsVar op_name) _ e2) + = rnExpr e1 `thenRn` \ (e1', fv_e1) -> + rnExpr e2 `thenRn` \ (e2', fv_e2) -> + rnExpr op `thenRn` \ (op', fv_op) -> + + -- Deal wth fixity + lookupFixity op_name `thenRn` \ fixity -> + getModeRn `thenRn` \ mode -> + (case mode of + SourceMode -> mkOpAppRn e1' op' fixity e2' + InterfaceMode -> returnRn (OpApp e1' op' fixity e2') + ) `thenRn` \ final_e -> + + returnRn (final_e, + fv_e1 `unionNameSets` fv_op `unionNameSets` fv_e2) -rnExpr (NegApp e n) = completeNegApp (rnExpr e) +rnExpr (NegApp e n) + = rnExpr e `thenRn` \ (e', fv_e) -> + lookupImplicitOccRn negate_RDR `thenRn` \ neg -> + getModeRn `thenRn` \ mode -> + mkNegAppRn mode e' (HsVar neg) `thenRn` \ final_e -> + returnRn (final_e, fv_e) rnExpr (HsPar e) = rnExpr e `thenRn` \ (e', fvs_e) -> @@ -256,16 +298,11 @@ rnExpr (HsLet binds expr) rnExpr expr `thenRn` \ (expr',fvExpr) -> returnRn (HsLet binds' expr', fvExpr) -rnExpr (HsDo stmts src_loc) +rnExpr (HsDo do_or_lc stmts src_loc) = pushSrcLocRn src_loc $ lookupImplicitOccRn monadZeroClass_RDR `thenRn_` -- Forces Monad to come too rnStmts stmts `thenRn` \ (stmts', fvStmts) -> - returnRn (HsDo stmts' src_loc, fvStmts) - -rnExpr (ListComp expr quals) - = addImplicitOccRn listType_name `thenRn_` - rnQuals expr quals `thenRn` \ ((expr', quals'), fvs) -> - returnRn (ListComp expr' quals', fvs) + returnRn (HsDo do_or_lc stmts' src_loc, fvStmts) rnExpr (ExplicitList exps) = addImplicitOccRn listType_name `thenRn_` @@ -343,7 +380,7 @@ rnRbinds str rbinds field_dup_err dups = addErrRn (dupFieldErr str dups) rn_rbind (field, expr, pun) - = lookupOccRn field `thenRn` \ fieldname -> + = lookupGlobalOccRn field `thenRn` \ fieldname -> rnExpr expr `thenRn` \ (expr', fvExpr) -> returnRn ((fieldname, expr', pun), fvExpr) @@ -356,14 +393,14 @@ rnRpats rpats field_dup_err dups = addErrRn (dupFieldErr "pattern" dups) rn_rpat (field, pat, pun) - = lookupOccRn field `thenRn` \ fieldname -> + = lookupGlobalOccRn field `thenRn` \ fieldname -> rnPat pat `thenRn` \ pat' -> returnRn (fieldname, pat', pun) \end{code} %************************************************************************ %* * -\subsubsection{@Qualifier@s: in list comprehensions} +\subsubsection{@Stmt@s: in @do@ expressions} %* * %************************************************************************ @@ -376,59 +413,9 @@ be @{r}@, and the free var set for the entire Quals will be @{r}@. This Quals. \begin{code} -rnQuals :: RdrNameHsExpr -> [RdrNameQual] - -> RnMS s ((RenamedHsExpr, [RenamedQual]), FreeVars) - -rnQuals expr [qual] -- must be at least one qual - = rnQual qual $ \ new_qual -> - rnExpr expr `thenRn` \ (expr', fvs) -> - returnRn ((expr', [new_qual]), fvs) - -rnQuals expr (qual: quals) - = rnQual qual $ \ qual' -> - rnQuals expr quals `thenRn` \ ((expr', quals'), fv_quals) -> - returnRn ((expr', qual' : quals'), fv_quals) - - --- rnQual :: RdrNameQual --- -> (RenamedQual -> RnMS s (a,FreeVars)) --- -> RnMS s (a,FreeVars) --- Because of mutual recursion the actual type is a bit less general than this [Haskell 1.2] - -rnQual (GeneratorQual pat expr) thing_inside - = rnExpr expr `thenRn` \ (expr', fv_expr) -> - bindLocalsRn "pattern in list comprehension" binders $ \ new_binders -> - rnPat pat `thenRn` \ pat' -> - - thing_inside (GeneratorQual pat' expr') `thenRn` \ (result, fvs) -> - returnRn (result, fv_expr `unionNameSets` (fvs `minusNameSet` mkNameSet new_binders)) - where - binders = collectPatBinders pat - -rnQual (FilterQual expr) thing_inside - = rnExpr expr `thenRn` \ (expr', fv_expr) -> - thing_inside (FilterQual expr') `thenRn` \ (result, fvs) -> - returnRn (result, fv_expr `unionNameSets` fvs) - -rnQual (LetQual binds) thing_inside - = rnBinds binds $ \ binds' -> - thing_inside (LetQual binds') -\end{code} - - -%************************************************************************ -%* * -\subsubsection{@Stmt@s: in @do@ expressions} -%* * -%************************************************************************ - -\begin{code} rnStmts :: [RdrNameStmt] -> RnMS s ([RenamedStmt], FreeVars) -rnStmts [stmt@(ExprStmt expr src_loc)] -- last stmt must be ExprStmt - = pushSrcLocRn src_loc $ - rnExpr expr `thenRn` \ (expr', fv_expr) -> - returnRn ([ExprStmt expr' src_loc], fv_expr) +rnStmts [] = returnRn ([], emptyNameSet) rnStmts (stmt:stmts) = rnStmt stmt $ \ stmt' -> @@ -456,6 +443,17 @@ rnStmt (ExprStmt expr src_loc) thing_inside thing_inside (ExprStmt expr' src_loc) `thenRn` \ (result, fvs) -> returnRn (result, fv_expr `unionNameSets` fvs) +rnStmt (GuardStmt expr src_loc) thing_inside + = pushSrcLocRn src_loc $ + rnExpr expr `thenRn` \ (expr', fv_expr) -> + thing_inside (GuardStmt expr' src_loc) `thenRn` \ (result, fvs) -> + returnRn (result, fv_expr `unionNameSets` fvs) + +rnStmt (ReturnStmt expr) thing_inside + = rnExpr expr `thenRn` \ (expr', fv_expr) -> + thing_inside (ReturnStmt expr') `thenRn` \ (result, fvs) -> + returnRn (result, fv_expr `unionNameSets` fvs) + rnStmt (LetStmt binds) thing_inside = rnBinds binds $ \ binds' -> thing_inside (LetStmt binds') @@ -467,85 +465,94 @@ rnStmt (LetStmt binds) thing_inside %* * %************************************************************************ -@rnOpApp@ deals with operator applications. It does some rearrangement of -the expression so that the precedences are right. This must be done on the -expression *before* renaming, because fixity info applies to the things -the programmer actually wrote. +@mkOpAppRn@ deals with operator fixities. The argument expressions +are assumed to be already correctly arranged. It needs the fixities +recorded in the OpApp nodes, because fixity info applies to the things +the programmer actually wrote, so you can't find it out from the Name. + +Furthermore, the second argument is guaranteed not to be another +operator application. Why? Because the parser parses all +operator appications left-associatively. \begin{code} -rnOpApp (NegApp e11 n) op e2 - = lookupFixity op `thenRn` \ (Fixity op_prec op_dir) -> - if op_prec > 6 then - -- negate precedence 6 wired in - -- (-x)*y ==> -(x*y) - completeNegApp (rnOpApp e11 op e2) - else - completeOpApp (completeNegApp (rnExpr e11)) op (rnExpr e2) - -rnOpApp (OpApp e11 (HsVar op1) e12) op e2 - = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) -> - lookupFixity op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) -> - -- pprTrace "rnOpApp:" (ppCat [ppr PprDebug op, ppInt op_prec, ppr PprDebug op1, ppInt op1_prec]) $ - case (op1_prec `cmp` op_prec) of - LT_ -> rearrange - EQ_ -> case (op1_dir, op_dir) of - (InfixR, InfixR) -> rearrange - (InfixL, InfixL) -> dont_rearrange - _ -> addErrRn (precParseErr (op1,op1_fix) (op,op_fix)) `thenRn_` - dont_rearrange - GT__ -> dont_rearrange +mkOpAppRn :: RenamedHsExpr -> RenamedHsExpr -> Fixity -> RenamedHsExpr + -> RnMS s RenamedHsExpr + +mkOpAppRn e1@(OpApp e11 op1 fix1 e12) + op2 fix2 e2 + | nofix_error + = addErrRn (precParseErr (get op1,fix1) (get op2,fix2)) `thenRn_` + returnRn (OpApp e1 op2 fix2 e2) + + | rearrange_me + = mkOpAppRn e12 op2 fix2 e2 `thenRn` \ new_e -> + returnRn (OpApp e11 op1 fix1 new_e) where - rearrange = rnOpApp e11 op1 (OpApp e12 (HsVar op) e2) - dont_rearrange = completeOpApp (rnOpApp e11 op1 e12) op (rnExpr e2) - -rnOpApp e1 op e2 = completeOpApp (rnExpr e1) op (rnExpr e2) + (nofix_error, rearrange_me) = compareFixity fix1 fix2 + get (HsVar n) = n + +mkOpAppRn e1@(NegApp neg_arg neg_id) + op2 + fix2@(Fixity prec2 dir2) + e2 + | prec2 > 6 -- Precedence of unary - is wired in as 6! + = mkOpAppRn neg_arg op2 fix2 e2 `thenRn` \ new_e -> + returnRn (NegApp new_e neg_id) + +mkOpAppRn e1 op fix e2 -- Default case, no rearrangment + = ASSERT( right_op_ok fix e2 ) + returnRn (OpApp e1 op fix e2) + +-- Parser left-associates everything, but +-- derived instances may have correctly-associated things to +-- in the right operarand. So we just check that the right operand is OK +right_op_ok fix1 (OpApp _ _ fix2 _) + = not error_please && associate_right + where + (error_please, associate_right) = compareFixity fix1 fix2 +right_op_ok fix1 other + = True -completeOpApp rn_e1 op rn_e2 - = rn_e1 `thenRn` \ (e1', fvs1) -> - rn_e2 `thenRn` \ (e2', fvs2) -> - rnExpr (HsVar op) `thenRn` \ (op', fvs3) -> - returnRn (OpApp e1' op' e2', fvs1 `unionNameSets` fvs2 `unionNameSets` fvs3) +-- Parser initially makes negation bind more tightly than any other operator +mkNegAppRn mode neg_arg neg_id + = ASSERT( not_op_app mode neg_arg ) + returnRn (NegApp neg_arg neg_id) -completeNegApp rn_expr - = rn_expr `thenRn` \ (e', fvs_e) -> - lookupImplicitOccRn negate_RDR `thenRn` \ neg -> - returnRn (NegApp e' (HsVar neg), fvs_e) +not_op_app SourceMode (OpApp _ _ _ _) = False +not_op_app mode other = True \end{code} \begin{code} -rnOpPat p1@(NegPatIn p11) op p2 - = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) -> - if op_prec > 6 then - -- negate precedence 6 wired in - addErrRn (precParseNegPatErr (op,op_fix)) `thenRn_` - rnOpPat p11 op p2 `thenRn` \ op_pat -> - returnRn (NegPatIn op_pat) - else - completeOpPat (rnPat p1) op (rnPat p2) - -rnOpPat (ConOpPatIn p11 op1 p12) op p2 - = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) -> - lookupFixity op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) -> - case (op1_prec `cmp` op_prec) of - LT_ -> rearrange - EQ_ -> case (op1_dir, op_dir) of - (InfixR, InfixR) -> rearrange - (InfixL, InfixL) -> dont_rearrange - _ -> addErrRn (precParseErr (op1,op1_fix) (op,op_fix)) `thenRn_` - dont_rearrange - GT__ -> dont_rearrange - where - rearrange = rnOpPat p11 op1 (ConOpPatIn p12 op p2) - dont_rearrange = completeOpPat (rnOpPat p11 op1 p12) op (rnPat p2) +mkConOpPatRn :: RenamedPat -> Name -> Fixity -> RenamedPat + -> RnMS s RenamedPat +mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12) + op2 fix2 p2 + | nofix_error + = addErrRn (precParseErr (op1,fix1) (op2,fix2)) `thenRn_` + returnRn (ConOpPatIn p1 op2 fix2 p2) -rnOpPat p1 op p2 = completeOpPat (rnPat p1) op (rnPat p2) + | rearrange_me + = mkConOpPatRn p12 op2 fix2 p2 `thenRn` \ new_p -> + returnRn (ConOpPatIn p11 op1 fix1 new_p) -completeOpPat rn_p1 op rn_p2 - = rn_p1 `thenRn` \ p1' -> - rn_p2 `thenRn` \ p2' -> - lookupRn op `thenRn` \ op' -> - returnRn (ConOpPatIn p1' op' p2') + where + (nofix_error, rearrange_me) = compareFixity fix1 fix2 + +mkConOpPatRn p1@(NegPatIn neg_arg) + op2 + fix2@(Fixity prec2 dir2) + p2 + | prec2 > 6 -- Precedence of unary - is wired in as 6! + = addErrRn (precParseNegPatErr (op2,fix2)) `thenRn_` + returnRn (ConOpPatIn p1 op2 fix2 p2) + +mkConOpPatRn p1 op fix p2 -- Default case, no rearrangment + = ASSERT( not_op_pat p2 ) + returnRn (ConOpPatIn p1 op fix p2) + +not_op_pat (ConOpPatIn _ _ _ _) = False +not_op_pat other = True \end{code} \begin{code} @@ -559,7 +566,7 @@ checkPrecMatch True op (PatMatch p1 (PatMatch p2 (GRHSMatch _))) checkPrecMatch True op _ = panic "checkPrecMatch" -checkPrec op (ConOpPatIn _ op1 _) right +checkPrec op (ConOpPatIn _ op1 _ _) right = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) -> lookupFixity op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) -> let @@ -582,6 +589,30 @@ checkPrec op pat right = returnRn () \end{code} +Consider + a `op1` b `op2` c + +(compareFixity op1 op2) tells which way to arrange appication, or +whether there's an error. + +\begin{code} +compareFixity :: Fixity -> Fixity + -> (Bool, -- Error please + Bool) -- Associate to the right: a op1 (b op2 c) +compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2) + = case prec1 `cmp` prec2 of + GT_ -> left + LT_ -> right + EQ_ -> case (dir1, dir2) of + (InfixR, InfixR) -> right + (InfixL, InfixL) -> left + _ -> error_please + where + right = (False, True) + left = (False, False) + error_please = (True, False) +\end{code} + %************************************************************************ %* * \subsubsection{Literals} @@ -606,12 +637,10 @@ litOccurrence (HsStringPrim _) = addImplicitOccRn (getName addrPrimTyCon) litOccurrence (HsInt _) - = lookupImplicitOccRn numClass_RDR `thenRn_` -- Int and Integer are forced in by Num - returnRn () + = lookupImplicitOccRn numClass_RDR -- Int and Integer are forced in by Num litOccurrence (HsFrac _) - = lookupImplicitOccRn fractionalClass_RDR `thenRn_` -- ... similarly Rational - returnRn () + = lookupImplicitOccRn fractionalClass_RDR -- ... similarly Rational litOccurrence (HsIntPrim _) = addImplicitOccRn (getName intPrimTyCon) @@ -623,8 +652,7 @@ litOccurrence (HsDoublePrim _) = addImplicitOccRn (getName doublePrimTyCon) litOccurrence (HsLitLit _) - = lookupImplicitOccRn ccallableClass_RDR `thenRn_` - returnRn () + = lookupImplicitOccRn ccallableClass_RDR \end{code} @@ -636,19 +664,23 @@ litOccurrence (HsLitLit _) \begin{code} dupFieldErr str (dup:rest) sty - = ppBesides [ppStr "duplicate field name `", ppr sty dup, ppStr "' in record ", ppStr str] + = ppBesides [ppPStr SLIT("duplicate field name `"), + ppr sty dup, + ppPStr SLIT("' in record "), ppStr str] negPatErr pat sty - = ppSep [ppStr "prefix `-' not applied to literal in pattern", ppr sty pat] + = ppSep [ppPStr SLIT("prefix `-' not applied to literal in pattern"), ppr sty pat] precParseNegPatErr op sty - = ppHang (ppStr "precedence parsing error") - 4 (ppBesides [ppStr "prefix `-' has lower precedence than ", pp_op sty op, ppStr " in pattern"]) + = ppHang (ppPStr SLIT("precedence parsing error")) + 4 (ppBesides [ppPStr SLIT("prefix `-' has lower precedence than "), + pp_op sty op, + ppPStr SLIT(" in pattern")]) precParseErr op1 op2 sty - = ppHang (ppStr "precedence parsing error") - 4 (ppBesides [ppStr "cannot mix ", pp_op sty op1, ppStr " and ", pp_op sty op2, - ppStr " in the same infix expression"]) + = ppHang (ppPStr SLIT("precedence parsing error")) + 4 (ppBesides [ppPStr SLIT("cannot mix "), pp_op sty op1, ppPStr SLIT(" and "), pp_op sty op2, + ppPStr SLIT(" in the same infix expression")]) pp_op sty (op, fix) = ppBesides [pprSym sty op, ppLparen, ppr sty fix, ppRparen] \end{code}