X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnExpr.lhs;h=e7add898f9473d834bdb8728953ad5603f3c4f8c;hb=f8d8ea662828a295e27a2f5f52ce38d68fd3dee2;hp=62702334796afedd7f63c85554c538338fdda019;hpb=0ef29fb878dd6517d2716afb056bcf2536c2562e;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 6270233..e7add89 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -11,7 +11,7 @@ free variables. \begin{code} module RnExpr ( - rnMatch, rnGRHSs, rnPat, rnExpr, rnExprs, + rnMatch, rnGRHSs, rnPat, rnExpr, rnExprs, rnStmt, checkPrecMatch ) where @@ -27,14 +27,15 @@ import RnMonad import RnEnv import RnHiFiles ( lookupFixityRn ) import CmdLineOpts ( DynFlag(..), opt_IgnoreAsserts ) -import Literal ( inIntRange ) +import Literal ( inIntRange, inCharRange ) import BasicTypes ( Fixity(..), FixityDirection(..), defaultFixity, negateFixity ) -import PrelNames ( hasKey, assertIdKey, +import PrelNames ( hasKey, assertIdKey, minusName, negateName, fromIntegerName, eqClass_RDR, foldr_RDR, build_RDR, eqString_RDR, cCallableClass_RDR, cReturnableClass_RDR, monadClass_RDR, enumClass_RDR, ordClass_RDR, - ratioDataCon_RDR, negate_RDR, assertErr_RDR, - ioDataCon_RDR, plusInteger_RDR, timesInteger_RDR + ratioDataCon_RDR, assertErr_RDR, + ioDataCon_RDR, plusInteger_RDR, timesInteger_RDR, + fromInteger_RDR, fromRational_RDR, ) import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, floatPrimTyCon, doublePrimTyCon @@ -93,12 +94,11 @@ rnPat (NPatIn lit) lookupOrigName eqClass_RDR `thenRn` \ eq -> -- Needed to find equality on pattern returnRn (NPatIn lit', fvs1 `addOneFV` eq) -rnPat (NPlusKPatIn name lit minus) +rnPat (NPlusKPatIn name lit) = rnOverLit lit `thenRn` \ (lit', fvs) -> lookupOrigName ordClass_RDR `thenRn` \ ord -> lookupBndrRn name `thenRn` \ name' -> - lookupOccRn minus `thenRn` \ minus' -> - returnRn (NPlusKPatIn name' lit' minus', fvs `addOneFV` ord `addOneFV` minus') + returnRn (NPlusKPatIn name' lit', fvs `addOneFV` ord `addOneFV` minusName) rnPat (LazyPatIn pat) = rnPat pat `thenRn` \ (pat', fvs) -> @@ -146,8 +146,9 @@ rnPat (RecPatIn con rpats) = lookupOccRn con `thenRn` \ con' -> rnRpats rpats `thenRn` \ (rpats', fvs) -> returnRn (RecPatIn con' rpats', fvs `addOneFV` con') + rnPat (TypePatIn name) = - (rnHsTypeFVs (text "type pattern") name) `thenRn` \ (name', fvs) -> + rnHsTypeFVs (text "type pattern") name `thenRn` \ (name', fvs) -> returnRn (TypePatIn name', fvs) \end{code} @@ -158,30 +159,26 @@ rnPat (TypePatIn name) = ************************************************************************ \begin{code} -rnMatch :: RdrNameMatch -> RnMS (RenamedMatch, FreeVars) +rnMatch :: HsMatchContext RdrName -> RdrNameMatch -> RnMS (RenamedMatch, FreeVars) -rnMatch match@(Match _ pats maybe_rhs_sig grhss) +rnMatch ctxt match@(Match _ pats maybe_rhs_sig grhss) = pushSrcLocRn (getMatchLoc match) $ - -- Find the universally quantified type variables - -- in the pattern type signatures - getLocalNameEnv `thenRn` \ name_env -> + -- Bind pattern-bound type variables let - tyvars_in_sigs = rhs_sig_tyvars `unionLists` tyvars_in_pats - rhs_sig_tyvars = case maybe_rhs_sig of + rhs_sig_tys = case maybe_rhs_sig of Nothing -> [] - Just ty -> extractHsTyRdrTyVars ty - tyvars_in_pats = extractPatsTyVars pats - forall_tyvars = filter (not . (`elemFM` name_env)) tyvars_in_sigs - doc_sig = text "a pattern type-signature" - doc_pats = text "a pattern match" + Just ty -> [ty] + pat_sig_tys = collectSigTysFromPats pats + doc_sig = text "In a result type-signature" + doc_pat = pprMatchContext ctxt in - bindNakedTyVarsFVRn doc_sig forall_tyvars $ \ sig_tyvars -> + bindPatSigTyVars (rhs_sig_tys ++ pat_sig_tys) $ \ sig_tyvars -> -- Note that we do a single bindLocalsRn for all the -- matches together, so that we spot the repeated variable in -- f x x = 1 - bindLocalsFVRn doc_pats (collectPatsBinders pats) $ \ new_binders -> + bindLocalsFVRn doc_pat (collectPatsBinders pats) $ \ new_binders -> mapFvRn rnPat pats `thenRn` \ (pats', pat_fvs) -> rnGRHSs grhss `thenRn` \ (grhss', grhss_fvs) -> @@ -203,6 +200,21 @@ rnMatch match@(Match _ pats maybe_rhs_sig grhss) returnRn (Match sig_tyvars pats' maybe_rhs_sig' grhss', all_fvs) -- The bindLocals and bindTyVars will remove the bound FVs + + +bindPatSigTyVars :: [RdrNameHsType] + -> ([Name] -> RnMS (a, FreeVars)) + -> RnMS (a, FreeVars) + -- Find the type variables in the pattern type + -- signatures that must be brought into scope +bindPatSigTyVars tys thing_inside + = getLocalNameEnv `thenRn` \ name_env -> + let + tyvars_in_sigs = extractHsTysRdrTyVars tys + forall_tyvars = filter (not . (`elemFM` name_env)) tyvars_in_sigs + doc_sig = text "In a pattern type-signature" + in + bindNakedTyVarsFVRn doc_sig forall_tyvars thing_inside \end{code} %************************************************************************ @@ -229,15 +241,15 @@ rnGRHS (GRHS guarded locn) returnRn () ) `thenRn_` - rnStmts rnExpr guarded `thenRn` \ ((_, guarded'), fvs) -> + rnStmts guarded `thenRn` \ ((_, guarded'), fvs) -> returnRn (GRHS guarded' locn, fvs) where -- Standard Haskell 1.4 guards are just a single boolean -- expression, rather than a list of qualifiers as in the -- Glasgow extension - is_standard_guard [ExprStmt _ _] = True - is_standard_guard [GuardStmt _ _, ExprStmt _ _] = True - is_standard_guard other = False + is_standard_guard [ResultStmt _ _] = True + is_standard_guard [ExprStmt _ _, ResultStmt _ _] = True + is_standard_guard other = False \end{code} %************************************************************************ @@ -294,7 +306,7 @@ rnExpr (HsOverLit lit) returnRn (HsOverLit lit', fvs) rnExpr (HsLam match) - = rnMatch match `thenRn` \ (match', fvMatch) -> + = rnMatch LambdaExpr match `thenRn` \ (match', fvMatch) -> returnRn (HsLam match', fvMatch) rnExpr (HsApp fun arg) @@ -322,11 +334,10 @@ rnExpr (OpApp e1 op _ e2) returnRn (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) -rnExpr (NegApp e n) +rnExpr (NegApp e) = rnExpr e `thenRn` \ (e', fv_e) -> - lookupOrigName negate_RDR `thenRn` \ neg -> - mkNegAppRn e' neg `thenRn` \ final_e -> - returnRn (final_e, fv_e `addOneFV` neg) + mkNegAppRn e' `thenRn` \ final_e -> + returnRn (final_e, fv_e `addOneFV` negateName) rnExpr (HsPar e) = rnExpr e `thenRn` \ (e', fvs_e) -> @@ -359,8 +370,8 @@ rnExpr (HsSCC lbl expr) rnExpr (HsCase expr ms src_loc) = pushSrcLocRn src_loc $ - rnExpr expr `thenRn` \ (new_expr, e_fvs) -> - mapFvRn rnMatch ms `thenRn` \ (new_ms, ms_fvs) -> + rnExpr expr `thenRn` \ (new_expr, e_fvs) -> + mapFvRn (rnMatch CaseAlt) ms `thenRn` \ (new_ms, ms_fvs) -> returnRn (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs) rnExpr (HsLet binds expr) @@ -376,12 +387,11 @@ rnExpr (HsWith expr binds) rnExpr e@(HsDo do_or_lc stmts src_loc) = pushSrcLocRn src_loc $ lookupOrigNames implicit_rdr_names `thenRn` \ implicit_fvs -> - rnStmts rnExpr stmts `thenRn` \ ((_, stmts'), fvs) -> + rnStmts stmts `thenRn` \ ((_, stmts'), fvs) -> -- check the statement list ends in an expression case last stmts' of { - ExprStmt _ _ -> returnRn () ; - ReturnStmt _ -> returnRn () ; -- for list comprehensions - _ -> addErrRn (doStmtListErr e) + ResultStmt _ _ -> returnRn () ; + _ -> addErrRn (doStmtListErr e) } `thenRn_` returnRn (HsDo do_or_lc stmts' src_loc, fvs `plusFV` implicit_fvs) where @@ -540,28 +550,28 @@ be @{r}@, and the free var set for the entire Quals will be @{r}@. This Quals. \begin{code} -type RnExprTy = RdrNameHsExpr -> RnMS (RenamedHsExpr, FreeVars) - -rnStmts :: RnExprTy - -> [RdrNameStmt] +rnStmts :: [RdrNameStmt] -> RnMS (([Name], [RenamedStmt]), FreeVars) -rnStmts rn_expr [] +rnStmts [] = returnRn (([], []), emptyFVs) -rnStmts rn_expr (stmt:stmts) +rnStmts (stmt:stmts) = getLocalNameEnv `thenRn` \ name_env -> - rnStmt rn_expr stmt $ \ stmt' -> - rnStmts rn_expr stmts `thenRn` \ ((binders, stmts'), fvs) -> + rnStmt stmt $ \ stmt' -> + rnStmts stmts `thenRn` \ ((binders, stmts'), fvs) -> returnRn ((binders, stmt' : stmts'), fvs) -rnStmt :: RnExprTy -> RdrNameStmt +rnStmt :: RdrNameStmt -> (RenamedStmt -> RnMS (([Name], a), FreeVars)) -> RnMS (([Name], a), FreeVars) +-- The thing list of names returned is the list returned by the +-- thing_inside, plus the binders of the arguments stmt + -- Because of mutual recursion we have to pass in rnExpr. -rnStmt rn_expr (ParStmt stmtss) thing_inside - = mapFvRn (rnStmts rn_expr) stmtss `thenRn` \ (bndrstmtss, fv_stmtss) -> +rnStmt (ParStmt stmtss) thing_inside + = mapFvRn rnStmts stmtss `thenRn` \ (bndrstmtss, fv_stmtss) -> let binderss = map fst bndrstmtss checkBndrs all_bndrs bndrs = checkRn (null (intersectBy eqOcc all_bndrs bndrs)) err `thenRn_` @@ -569,45 +579,40 @@ rnStmt rn_expr (ParStmt stmtss) thing_inside eqOcc n1 n2 = nameOccName n1 == nameOccName n2 err = text "duplicate binding in parallel list comprehension" in - foldlRn checkBndrs [] binderss `thenRn` \ binders -> - bindLocalNamesFV binders $ + foldlRn checkBndrs [] binderss `thenRn` \ new_binders -> + bindLocalNamesFV new_binders $ thing_inside (ParStmtOut bndrstmtss)`thenRn` \ ((rest_bndrs, result), fv_rest) -> - returnRn ((rest_bndrs ++ binders, result), fv_stmtss `plusFV` fv_rest) + returnRn ((new_binders ++ rest_bndrs, result), fv_stmtss `plusFV` fv_rest) -rnStmt rn_expr (BindStmt pat expr src_loc) thing_inside +rnStmt (BindStmt pat expr src_loc) thing_inside = pushSrcLocRn src_loc $ - rn_expr expr `thenRn` \ (expr', fv_expr) -> - bindLocalsFVRn doc binders $ \ new_binders -> + rnExpr expr `thenRn` \ (expr', fv_expr) -> + bindPatSigTyVars (collectSigTysFromPat pat) $ \ sig_tyvars -> + bindLocalsFVRn doc (collectPatBinders pat) $ \ new_binders -> rnPat pat `thenRn` \ (pat', fv_pat) -> thing_inside (BindStmt pat' expr' src_loc) `thenRn` \ ((rest_binders, result), fvs) -> - -- ZZ is shadowing handled correctly? - returnRn ((rest_binders ++ new_binders, result), + returnRn ((new_binders ++ rest_binders, result), fv_expr `plusFV` fvs `plusFV` fv_pat) where - binders = collectPatBinders pat - doc = text "a pattern in do binding" + doc = text "In a pattern in 'do' binding" -rnStmt rn_expr (ExprStmt expr src_loc) thing_inside +rnStmt (ExprStmt expr src_loc) thing_inside = pushSrcLocRn src_loc $ - rn_expr expr `thenRn` \ (expr', fv_expr) -> + rnExpr expr `thenRn` \ (expr', fv_expr) -> thing_inside (ExprStmt expr' src_loc) `thenRn` \ (result, fvs) -> returnRn (result, fv_expr `plusFV` fvs) -rnStmt rn_expr (GuardStmt expr src_loc) thing_inside +rnStmt (ResultStmt expr src_loc) thing_inside = pushSrcLocRn src_loc $ - rn_expr expr `thenRn` \ (expr', fv_expr) -> - thing_inside (GuardStmt expr' src_loc) `thenRn` \ (result, fvs) -> - returnRn (result, fv_expr `plusFV` fvs) - -rnStmt rn_expr (ReturnStmt expr) thing_inside - = rn_expr expr `thenRn` \ (expr', fv_expr) -> - thing_inside (ReturnStmt expr') `thenRn` \ (result, fvs) -> + rnExpr expr `thenRn` \ (expr', fv_expr) -> + thing_inside (ResultStmt expr' src_loc) `thenRn` \ (result, fvs) -> returnRn (result, fv_expr `plusFV` fvs) -rnStmt rn_expr (LetStmt binds) thing_inside +rnStmt (LetStmt binds) thing_inside = rnBinds binds $ \ binds' -> - thing_inside (LetStmt binds') - + let new_binders = collectHsBinders binds' in + thing_inside (LetStmt binds') `thenRn` \ ((rest_binders, result), fvs) -> + returnRn ((new_binders ++ rest_binders, result), fvs ) \end{code} %************************************************************************ @@ -648,20 +653,20 @@ mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2 --------------------------- -- (- neg_arg) `op` e2 -mkOpAppRn e1@(NegApp neg_arg neg_op) op2 fix2 e2 +mkOpAppRn e1@(NegApp neg_arg) op2 fix2 e2 | nofix_error = addErrRn (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenRn_` returnRn (OpApp e1 op2 fix2 e2) | associate_right = mkOpAppRn neg_arg op2 fix2 e2 `thenRn` \ new_e -> - returnRn (NegApp new_e neg_op) + returnRn (NegApp new_e) where (nofix_error, associate_right) = compareFixity negateFixity fix2 --------------------------- -- e1 `op` - neg_arg -mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg neg_op) -- NegApp can occur on the right +mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg) -- NegApp can occur on the right | not associate_right -- We *want* right association = addErrRn (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenRn_` returnRn (OpApp e1 op1 fix1 e2) @@ -687,13 +692,13 @@ right_op_ok fix1 other = True -- Parser initially makes negation bind more tightly than any other operator -mkNegAppRn neg_arg neg_op +mkNegAppRn neg_arg = #ifdef DEBUG getModeRn `thenRn` \ mode -> ASSERT( not_op_app mode neg_arg ) #endif - returnRn (NegApp neg_arg neg_op) + returnRn (NegApp neg_arg) not_op_app SourceMode (OpApp _ _ _ _) = False not_op_app mode other = True @@ -765,7 +770,7 @@ checkPrec op pat right checkSectionPrec left_or_right section op arg = case arg of OpApp _ op fix _ -> go_for_it (ppr_op op) fix - NegApp _ _ -> go_for_it pp_prefix_minus negateFixity + NegApp _ -> go_for_it pp_prefix_minus negateFixity other -> returnRn () where HsVar op_name = op @@ -811,7 +816,10 @@ that the types and classes they involve are made available. \begin{code} -litFVs (HsChar c) = returnRn (unitFV charTyCon_name) +litFVs (HsChar c) + = checkRn (inCharRange c) (bogusCharError c) `thenRn_` + returnRn (unitFV charTyCon_name) + litFVs (HsCharPrim c) = returnRn (unitFV (getName charPrimTyCon)) litFVs (HsString s) = returnRn (mkFVs [listTyCon_name, charTyCon_name]) litFVs (HsStringPrim s) = returnRn (unitFV (getName addrPrimTyCon)) @@ -824,18 +832,20 @@ litFVs (HsLitLit l bogus_ty) = lookupOrigName cCallableClass_RDR `thenRn` \ cc litFVs lit = pprPanic "RnExpr.litFVs" (ppr lit) -- HsInteger and HsRat only appear -- in post-typechecker translations -rnOverLit (HsIntegral i from_integer) - = lookupOccRn from_integer `thenRn` \ from_integer' -> - (if inIntRange i then - returnRn emptyFVs - else - lookupOrigNames [plusInteger_RDR, timesInteger_RDR] - ) `thenRn` \ ns -> - returnRn (HsIntegral i from_integer', ns `addOneFV` from_integer') - -rnOverLit (HsFractional i n) - = lookupOccRn n `thenRn` \ n' -> - lookupOrigNames [ratioDataCon_RDR, plusInteger_RDR, timesInteger_RDR] `thenRn` \ ns' -> +rnOverLit (HsIntegral i) + | inIntRange i + = returnRn (HsIntegral i, unitFV fromIntegerName) + | otherwise + = lookupOrigNames [fromInteger_RDR, plusInteger_RDR, timesInteger_RDR] `thenRn` \ ns -> + -- Big integers are built, using + and *, out of small integers + -- [No particular reason why we use fromIntegerName in one case can + -- fromInteger_RDR in the other; but plusInteger_RDR means we + -- can get away without plusIntegerName altogether.] + returnRn (HsIntegral i, ns) + +rnOverLit (HsFractional i) + = lookupOrigNames [fromRational_RDR, ratioDataCon_RDR, + plusInteger_RDR, timesInteger_RDR] `thenRn` \ ns -> -- We have to make sure that the Ratio type is imported with -- its constructor, because literals of type Ratio t are -- built with that constructor. @@ -843,7 +853,7 @@ rnOverLit (HsFractional i n) -- when fractionalClass does. -- The plus/times integer operations may be needed to construct the numerator -- and denominator (see DsUtils.mkIntegerLit) - returnRn (HsFractional i n', ns' `addOneFV` n') + returnRn (HsFractional i, ns) \end{code} %************************************************************************ @@ -867,9 +877,7 @@ mkAssertExpr = vname = mkSysLocalName uniq SLIT("v") expr = HsLam ignorePredMatch loc = nameSrcLoc vname - ignorePredMatch = Match [] [WildPatIn, VarPatIn vname] Nothing - (GRHSs [GRHS [ExprStmt (HsVar vname) loc] loc] - EmptyBinds Nothing) + ignorePredMatch = mkSimpleMatch [WildPatIn, VarPatIn vname] (HsVar vname) Nothing loc in returnRn (expr, unitFV name) else @@ -908,7 +916,7 @@ precParseErr op1 op2 sectionPrecErr op arg_op section = vcat [ptext SLIT("The operator") <+> ppr_opfix op <+> ptext SLIT("of a section"), nest 4 (ptext SLIT("must have lower precedence than the operand") <+> ppr_opfix arg_op), - nest 4 (ptext SLIT("In the section:") <+> quotes (ppr section))] + nest 4 (ptext SLIT("in the section:") <+> quotes (ppr section))] nonStdGuardErr guard = hang (ptext @@ -926,4 +934,7 @@ patSynErr e doStmtListErr e = sep [ptext SLIT("`do' statements must end in expression:"), nest 4 (ppr e)] + +bogusCharError c + = ptext SLIT("character literal out of range: '\\") <> int c <> char '\'' \end{code}