X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnExpr.lhs;h=3992a6495d38a0368dedf5e2b07597d52adc129f;hb=2ddea0a849e8873f7943d9b32e501f6324e2e18b;hp=009facdb55c771619732e5987855c66d04469996;hpb=4166dff80e8ec94022a040318ff2759913fbbe06;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 009facd..3992a64 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -11,44 +11,49 @@ free variables. \begin{code} module RnExpr ( - rnMatch, rnGRHSs, rnPat, rnExpr, rnExprs, + rnMatch, rnGRHSs, rnPat, rnExpr, rnExprs, rnStmt, checkPrecMatch ) where #include "HsVersions.h" import {-# SOURCE #-} RnBinds ( rnBinds ) -import {-# SOURCE #-} RnSource ( rnHsTypeFVs ) import HsSyn import RdrHsSyn import RnHsSyn import RnMonad import RnEnv -import RnHiFiles ( lookupFixityRn ) +import RnTypes ( rnHsTypeFVs, precParseErr, sectionPrecErr ) import CmdLineOpts ( DynFlag(..), opt_IgnoreAsserts ) -import Literal ( inIntRange ) -import BasicTypes ( Fixity(..), FixityDirection(..), defaultFixity, negateFixity ) -import PrelNames ( hasKey, assertIdKey, - 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 - ) +import Literal ( inIntRange, inCharRange ) +import BasicTypes ( Fixity(..), FixityDirection(..), IPName(..), + defaultFixity, negateFixity, compareFixity ) +import PrelNames ( hasKey, assertIdKey, + eqClassName, foldrName, buildName, eqStringName, + cCallableClassName, cReturnableClassName, + monadClassName, enumClassName, ordClassName, + ratioDataConName, splitName, fstName, sndName, + ioDataConName, plusIntegerName, timesIntegerName, + assertErr_RDR, + replicatePName, mapPName, filterPName, + falseDataConName, trueDataConName, crossPName, + zipPName, lengthPName, indexPName, toPName, + enumFromToPName, enumFromThenToPName, + fromIntegerName, fromRationalName, minusName, negateName, + monadNames ) import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, - floatPrimTyCon, doublePrimTyCon - ) + floatPrimTyCon, doublePrimTyCon ) import TysWiredIn ( intTyCon ) -import Name ( NamedThing(..), mkSysLocalName, nameSrcLoc ) +import Name ( NamedThing(..), mkSystemName, nameSrcLoc ) import NameSet +import UnicodeUtil ( stringToUtf8 ) import UniqFM ( isNullUFM ) -import FiniteMap ( elemFM ) import UniqSet ( emptyUniqSet ) import List ( intersectBy ) -import ListSetOps ( unionLists, removeDups ) -import Maybes ( maybeToBool ) +import ListSetOps ( removeDups ) import Outputable +import FastString \end{code} @@ -81,24 +86,29 @@ rnPat (SigPatIn pat ty) doc = text "a pattern type-signature" rnPat (LitPatIn s@(HsString _)) - = lookupOrigName eqString_RDR `thenRn` \ eq -> - returnRn (LitPatIn s, unitFV eq) + = returnRn (LitPatIn s, unitFV eqStringName) rnPat (LitPatIn lit) = litFVs lit `thenRn` \ fvs -> returnRn (LitPatIn lit, fvs) -rnPat (NPatIn lit) +rnPat (NPatIn lit mb_neg) + = rnOverLit lit `thenRn` \ (lit', fvs1) -> + (case mb_neg of + Nothing -> returnRn (Nothing, emptyFVs) + Just _ -> lookupSyntaxName negateName `thenRn` \ (neg, fvs) -> + returnRn (Just neg, fvs) + ) `thenRn` \ (mb_neg', fvs2) -> + returnRn (NPatIn lit' mb_neg', + fvs1 `plusFV` fvs2 `addOneFV` eqClassName) + -- Needed to find equality on pattern + +rnPat (NPlusKPatIn name lit _) = rnOverLit lit `thenRn` \ (lit', fvs1) -> - lookupOrigName eqClass_RDR `thenRn` \ eq -> -- Needed to find equality on pattern - returnRn (NPatIn lit', fvs1 `addOneFV` eq) - -rnPat (NPlusKPatIn name lit minus) - = 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') + lookupSyntaxName minusName `thenRn` \ (minus, fvs2) -> + returnRn (NPlusKPatIn name' lit' minus, + fvs1 `plusFV` fvs2 `addOneFV` ordClassName) rnPat (LazyPatIn pat) = rnPat pat `thenRn` \ (pat', fvs) -> @@ -121,10 +131,10 @@ rnPat (ConOpPatIn pat1 con _ pat2) getModeRn `thenRn` \ mode -> -- See comments with rnExpr (OpApp ...) - (case mode of - InterfaceMode -> returnRn (ConOpPatIn pat1' con' defaultFixity pat2') - SourceMode -> lookupFixityRn con' `thenRn` \ fixity -> - mkConOpPatRn pat1' con' fixity pat2' + (if isInterfaceMode mode + then returnRn (ConOpPatIn pat1' con' defaultFixity pat2') + else lookupFixityRn con' `thenRn` \ fixity -> + mkConOpPatRn pat1' con' fixity pat2' ) `thenRn` \ pat' -> returnRn (pat', fvs1 `plusFV` fvs2 `addOneFV` con') @@ -136,6 +146,13 @@ rnPat (ListPatIn pats) = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) -> returnRn (ListPatIn patslist, fvs `addOneFV` listTyCon_name) +rnPat (PArrPatIn pats) + = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) -> + returnRn (PArrPatIn patslist, + fvs `plusFV` implicit_fvs `addOneFV` parrTyCon_name) + where + implicit_fvs = mkFVs [lengthPName, indexPName] + rnPat (TuplePatIn pats boxed) = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) -> returnRn (TuplePatIn patslist boxed, fvs `addOneFV` tycon_name) @@ -146,8 +163,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) -> + +rnPat (TypePatIn name) + = rnHsTypeFVs (text "type pattern") name `thenRn` \ (name', fvs) -> returnRn (TypePatIn name', fvs) \end{code} @@ -158,30 +176,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 "in 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) $ -- 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) -> @@ -201,10 +215,11 @@ rnMatch match@(Match _ pats maybe_rhs_sig grhss) in warnUnusedMatches unused_binders `thenRn_` - returnRn (Match sig_tyvars pats' maybe_rhs_sig' grhss', all_fvs) + returnRn (Match pats' maybe_rhs_sig' grhss', all_fvs) -- The bindLocals and bindTyVars will remove the bound FVs \end{code} + %************************************************************************ %* * \subsubsection{Guarded right-hand sides (GRHSs)} @@ -214,11 +229,10 @@ rnMatch match@(Match _ pats maybe_rhs_sig grhss) \begin{code} rnGRHSs :: RdrNameGRHSs -> RnMS (RenamedGRHSs, FreeVars) -rnGRHSs (GRHSs grhss binds maybe_ty) - = ASSERT( not (maybeToBool maybe_ty) ) - rnBinds binds $ \ binds' -> +rnGRHSs (GRHSs grhss binds _) + = rnBinds binds $ \ binds' -> mapFvRn rnGRHS grhss `thenRn` \ (grhss', fvGRHSs) -> - returnRn (GRHSs grhss' binds' Nothing, fvGRHSs) + returnRn (GRHSs grhss' binds' placeHolderType, fvGRHSs) rnGRHS (GRHS guarded locn) = doptRn Opt_GlasgowExts `thenRn` \ opt_GlasgowExts -> @@ -229,15 +243,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} %************************************************************************ @@ -283,7 +297,12 @@ rnExpr (HsVar v) rnExpr (HsIPVar v) = newIPName v `thenRn` \ name -> - returnRn (HsIPVar name, emptyFVs) + let + fvs = case name of + Linear _ -> mkFVs [splitName, fstName, sndName] + Dupable _ -> emptyFVs + in + returnRn (HsIPVar name, fvs) rnExpr (HsLit lit) = litFVs lit `thenRn` \ fvs -> @@ -294,7 +313,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) @@ -313,20 +332,20 @@ rnExpr (OpApp e1 op _ e2) -- that the deriving code generator got the association correct -- Don't even look up the fixity when in interface mode getModeRn `thenRn` \ mode -> - (case mode of - SourceMode -> lookupFixityRn op_name `thenRn` \ fixity -> - mkOpAppRn e1' op' fixity e2' - InterfaceMode -> returnRn (OpApp e1' op' defaultFixity e2') + (if isInterfaceMode mode + then returnRn (OpApp e1' op' defaultFixity e2') + else lookupFixityRn op_name `thenRn` \ fixity -> + mkOpAppRn e1' op' fixity e2' ) `thenRn` \ final_e -> 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) + lookupSyntaxName negateName `thenRn` \ (neg_name, fv_neg) -> + mkNegAppRn e' neg_name `thenRn` \ final_e -> + returnRn (final_e, fv_e `plusFV` fv_neg) rnExpr (HsPar e) = rnExpr e `thenRn` \ (e', fvs_e) -> @@ -335,23 +354,23 @@ rnExpr (HsPar e) rnExpr section@(SectionL expr op) = rnExpr expr `thenRn` \ (expr', fvs_expr) -> rnExpr op `thenRn` \ (op', fvs_op) -> - checkSectionPrec "left" section op' expr' `thenRn_` + checkSectionPrec InfixL section op' expr' `thenRn_` returnRn (SectionL expr' op', fvs_op `plusFV` fvs_expr) rnExpr section@(SectionR op expr) = rnExpr op `thenRn` \ (op', fvs_op) -> rnExpr expr `thenRn` \ (expr', fvs_expr) -> - checkSectionPrec "right" section op' expr' `thenRn_` + checkSectionPrec InfixR section op' expr' `thenRn_` returnRn (SectionR op' expr', fvs_op `plusFV` fvs_expr) -rnExpr (HsCCall fun args may_gc is_casm fake_result_ty) +rnExpr (HsCCall fun args may_gc is_casm _) -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls - = lookupOrigNames [cCallableClass_RDR, - cReturnableClass_RDR, - ioDataCon_RDR] `thenRn` \ implicit_fvs -> + = lookupOrigNames [] `thenRn` \ implicit_fvs -> rnExprs args `thenRn` \ (args', fvs_args) -> - returnRn (HsCCall fun args' may_gc is_casm fake_result_ty, - fvs_args `plusFV` implicit_fvs) + returnRn (HsCCall fun args' may_gc is_casm placeHolderType, + fvs_args `plusFV` mkFVs [cCallableClassName, + cReturnableClassName, + ioDataConName]) rnExpr (HsSCC lbl expr) = rnExpr expr `thenRn` \ (expr', fvs_expr) -> @@ -359,8 +378,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) @@ -368,32 +387,50 @@ rnExpr (HsLet binds expr) rnExpr expr `thenRn` \ (expr',fvExpr) -> returnRn (HsLet binds' expr', fvExpr) -rnExpr (HsWith expr binds) - = rnExpr expr `thenRn` \ (expr',fvExpr) -> +rnExpr (HsWith expr binds is_with) + = warnCheckRn (not is_with) withWarning `thenRn_` + rnExpr expr `thenRn` \ (expr',fvExpr) -> rnIPBinds binds `thenRn` \ (binds',fvBinds) -> - returnRn (HsWith expr' binds', fvExpr `plusFV` fvBinds) + returnRn (HsWith expr' binds' is_with, fvExpr `plusFV` fvBinds) -rnExpr e@(HsDo do_or_lc stmts src_loc) +rnExpr e@(HsDo do_or_lc stmts _ ty src_loc) = pushSrcLocRn src_loc $ - lookupOrigNames implicit_rdr_names `thenRn` \ implicit_fvs -> - rnStmts rnExpr stmts `thenRn` \ ((_, stmts'), fvs) -> - -- check the statement list ends in an expression + 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) + + -- Generate the rebindable syntax for the monad + (case do_or_lc of + DoExpr -> mapAndUnzipRn lookupSyntaxName monadNames + other -> returnRn ([], []) + ) `thenRn` \ (monad_names', monad_fvs) -> + + returnRn (HsDo do_or_lc stmts' monad_names' placeHolderType src_loc, + fvs `plusFV` implicit_fvs `plusFV` plusFVs monad_fvs) where - implicit_rdr_names = [foldr_RDR, build_RDR, monadClass_RDR] + implicit_fvs = case do_or_lc of + PArrComp -> mkFVs [replicatePName, mapPName, filterPName, + falseDataConName, trueDataConName, crossPName, + zipPName] + ListComp -> mkFVs [foldrName, buildName] + other -> emptyFVs + -- monadClassName pulls in the standard names -- Monad stuff should not be necessary for a list comprehension -- but the typechecker looks up the bind and return Ids anyway -- Oh well. +rnExpr (ExplicitList _ exps) + = rnExprs exps `thenRn` \ (exps', fvs) -> + returnRn (ExplicitList placeHolderType exps', fvs `addOneFV` listTyCon_name) -rnExpr (ExplicitList exps) +rnExpr (ExplicitPArr _ exps) = rnExprs exps `thenRn` \ (exps', fvs) -> - returnRn (ExplicitList exps', fvs `addOneFV` listTyCon_name) + returnRn (ExplicitPArr placeHolderType exps', + fvs `addOneFV` toPName `addOneFV` parrTyCon_name) rnExpr (ExplicitTuple exps boxity) = rnExprs exps `thenRn` \ (exps', fvs) -> @@ -427,12 +464,11 @@ rnExpr (HsType a) = rnHsTypeFVs doc a `thenRn` \ (t, fvT) -> returnRn (HsType t, fvT) where - doc = text "renaming a type pattern" + doc = text "in a type argument" rnExpr (ArithSeqIn seq) - = lookupOrigName enumClass_RDR `thenRn` \ enum -> - rn_seq seq `thenRn` \ (new_seq, fvs) -> - returnRn (ArithSeqIn new_seq, fvs `addOneFV` enum) + = rn_seq seq `thenRn` \ (new_seq, fvs) -> + returnRn (ArithSeqIn new_seq, fvs `addOneFV` enumClassName) where rn_seq (From expr) = rnExpr expr `thenRn` \ (expr', fvExpr) -> @@ -454,6 +490,28 @@ rnExpr (ArithSeqIn seq) rnExpr expr3 `thenRn` \ (expr3', fvExpr3) -> returnRn (FromThenTo expr1' expr2' expr3', plusFVs [fvExpr1, fvExpr2, fvExpr3]) + +rnExpr (PArrSeqIn seq) + = rn_seq seq `thenRn` \ (new_seq, fvs) -> + returnRn (PArrSeqIn new_seq, + fvs `plusFV` mkFVs [enumFromToPName, enumFromThenToPName]) + where + + -- the parser shouldn't generate these two + -- + rn_seq (From _ ) = panic "RnExpr.rnExpr: Infinite parallel array!" + rn_seq (FromThen _ _) = panic "RnExpr.rnExpr: Infinite parallel array!" + + rn_seq (FromTo expr1 expr2) + = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) -> + rnExpr expr2 `thenRn` \ (expr2', fvExpr2) -> + returnRn (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) + rn_seq (FromThenTo expr1 expr2 expr3) + = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) -> + rnExpr expr2 `thenRn` \ (expr2', fvExpr2) -> + rnExpr expr3 `thenRn` \ (expr3', fvExpr3) -> + returnRn (FromThenTo expr1' expr2' expr3', + plusFVs [fvExpr1, fvExpr2, fvExpr3]) \end{code} These three are pattern syntax appearing in expressions. @@ -540,28 +598,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 +627,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) $ + 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) -> - thing_inside (ExprStmt expr' src_loc) `thenRn` \ (result, fvs) -> + rnExpr expr `thenRn` \ (expr', fv_expr) -> + thing_inside (ExprStmt expr' placeHolderType 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) -> + rnExpr expr `thenRn` \ (expr', fv_expr) -> + thing_inside (ResultStmt 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) -> - 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,21 +701,21 @@ 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 neg_name) 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 neg_name) 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 - | not associate_right -- We *want* right association +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) where @@ -687,13 +740,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 neg_name = #ifdef DEBUG getModeRn `thenRn` \ mode -> ASSERT( not_op_app mode neg_arg ) #endif - returnRn (NegApp neg_arg neg_op) + returnRn (NegApp neg_arg neg_name) not_op_app SourceMode (OpApp _ _ _ _) = False not_op_app mode other = True @@ -730,14 +783,14 @@ checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnMS () checkPrecMatch False fn match = returnRn () -checkPrecMatch True op (Match _ (p1:p2:_) _ _) +checkPrecMatch True op (Match (p1:p2:_) _ _) -- True indicates an infix lhs = getModeRn `thenRn` \ mode -> -- See comments with rnExpr (OpApp ...) - case mode of - InterfaceMode -> returnRn () - SourceMode -> checkPrec op p1 False `thenRn_` - checkPrec op p2 True + if isInterfaceMode mode + then returnRn () + else checkPrec op p1 False `thenRn_` + checkPrec op p2 True checkPrecMatch True op _ = panic "checkPrecMatch" @@ -760,45 +813,24 @@ checkPrec op pat right = returnRn () -- Check precedence of (arg op) or (op arg) respectively --- If arg is itself an operator application, its precedence should --- be higher than that of op -checkSectionPrec left_or_right section op arg +-- If arg is itself an operator application, then either +-- (a) its precedence must be higher than that of op +-- (b) its precedency & associativity must be the same as that of op +checkSectionPrec direction section op arg = case arg of OpApp _ op fix _ -> go_for_it (ppr_op op) fix NegApp _ _ -> go_for_it pp_prefix_minus negateFixity other -> returnRn () where HsVar op_name = op - go_for_it pp_arg_op arg_fix@(Fixity arg_prec _) + go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc) = lookupFixityRn op_name `thenRn` \ op_fix@(Fixity op_prec _) -> - checkRn (op_prec < arg_prec) - (sectionPrecErr (ppr_op op_name, op_fix) (pp_arg_op, arg_fix) section) + checkRn (op_prec < arg_prec + || op_prec == arg_prec && direction == assoc) + (sectionPrecErr (ppr_op op_name, op_fix) + (pp_arg_op, arg_fix) section) \end{code} -Consider -\begin{verbatim} - a `op1` b `op2` c -\end{verbatim} -@(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 `compare` 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} %************************************************************************ %* * @@ -811,7 +843,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)) @@ -819,31 +854,37 @@ litFVs (HsInt i) = returnRn (unitFV (getName intTyCon)) litFVs (HsIntPrim i) = returnRn (unitFV (getName intPrimTyCon)) litFVs (HsFloatPrim f) = returnRn (unitFV (getName floatPrimTyCon)) litFVs (HsDoublePrim d) = returnRn (unitFV (getName doublePrimTyCon)) -litFVs (HsLitLit l bogus_ty) = lookupOrigName cCallableClass_RDR `thenRn` \ cc -> - returnRn (unitFV cc) +litFVs (HsLitLit l bogus_ty) = returnRn (unitFV cCallableClassName) 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 (HsIntegral i _) + = lookupSyntaxName fromIntegerName `thenRn` \ (from_integer_name, fvs) -> + if inIntRange i then + returnRn (HsIntegral i from_integer_name, fvs) + else let + extra_fvs = mkFVs [plusIntegerName, timesIntegerName] + -- Big integer literals are built, using + and *, + -- out of small integers (DsUtils.mkIntegerLit) + -- [NB: plusInteger, timesInteger aren't rebindable... + -- they are used to construct the argument to fromInteger, + -- which is the rebindable one.] + in + returnRn (HsIntegral i from_integer_name, fvs `plusFV` extra_fvs) -rnOverLit (HsFractional i n) - = lookupOccRn n `thenRn` \ n' -> - lookupOrigNames [ratioDataCon_RDR, plusInteger_RDR, timesInteger_RDR] `thenRn` \ ns' -> +rnOverLit (HsFractional i _) + = lookupSyntaxName fromRationalName `thenRn` \ (from_rat_name, fvs) -> + let + extra_fvs = mkFVs [ratioDataConName, plusIntegerName, timesIntegerName] -- 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. -- The Rational type is needed too, but that will come in - -- when fractionalClass does. + -- as part of the type for fromRational. -- The plus/times integer operations may be needed to construct the numerator -- and denominator (see DsUtils.mkIntegerLit) - returnRn (HsFractional i n', ns' `addOneFV` n') + in + returnRn (HsFractional i from_rat_name, fvs `plusFV` extra_fvs) \end{code} %************************************************************************ @@ -864,23 +905,19 @@ mkAssertExpr = if opt_IgnoreAsserts then getUniqRn `thenRn` \ uniq -> let - vname = mkSysLocalName uniq SLIT("v") + vname = mkSystemName uniq FSLIT("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) placeHolderType loc in returnRn (expr, unitFV name) else let expr = HsApp (HsVar name) - (HsLit (HsString (_PK_ (showSDoc (ppr sloc))))) - + (HsLit (HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc)))))) in returnRn (expr, unitFV name) - \end{code} %************************************************************************ @@ -891,7 +928,6 @@ mkAssertExpr = \begin{code} ppr_op op = quotes (ppr op) -- Here, op can be a Name or a (Var n), where n is a Name -ppr_opfix (pp_op, fixity) = pp_op <+> brackets (ppr fixity) pp_prefix_minus = ptext SLIT("prefix `-'") dupFieldErr str (dup:rest) @@ -899,17 +935,6 @@ dupFieldErr str (dup:rest) quotes (ppr dup), ptext SLIT("in record"), text str] -precParseErr op1 op2 - = hang (ptext SLIT("precedence parsing error")) - 4 (hsep [ptext SLIT("cannot mix"), ppr_opfix op1, ptext SLIT("and"), - ppr_opfix op2, - ptext SLIT("in the same infix expression")]) - -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))] - nonStdGuardErr guard = hang (ptext SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)") @@ -926,4 +951,13 @@ 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 '\'' + +withWarning + = sep [quotes (ptext SLIT("with")), + ptext SLIT("is deprecated, use"), + quotes (ptext SLIT("let")), + ptext SLIT("instead")] \end{code}