X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnExpr.lhs;h=0b78b1a840e0110f793da244b7d5090197f884cd;hb=1f5e55804b97d2b9a77207d568d602ba88d8855d;hp=131a66c52ffd55d75cb2e46d3873203a71abaea1;hpb=abbc5a0be1df84a33015470319062ed7a3aa3153;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 131a66c..0b78b1a 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -28,28 +28,22 @@ import RdrHsSyn import RnHsSyn import TcRnMonad import RnEnv +import OccName ( plusOccEnv ) import RnNames ( importsFromLocalDecls ) import RnTypes ( rnHsTypeFVs, rnPat, litFVs, rnOverLit, rnPatsAndThen, dupFieldErr, precParseErr, sectionPrecErr, patSigErr, checkTupSize ) import CmdLineOpts ( DynFlag(..) ) -import BasicTypes ( Fixity(..), FixityDirection(..), IPName(..), - defaultFixity, negateFixity, compareFixity ) -import PrelNames ( hasKey, assertIdKey, - foldrName, buildName, - enumClassName, +import BasicTypes ( Fixity(..), FixityDirection(..), negateFixity, compareFixity ) +import PrelNames ( hasKey, assertIdKey, assertErrorName, loopAName, choiceAName, appAName, arrAName, composeAName, firstAName, - splitName, fstName, sndName, ioDataConName, - replicatePName, mapPName, filterPName, - crossPName, zipPName, toPName, - enumFromToPName, enumFromThenToPName, assertErrorName, negateName, monadNames, mfixName ) import Name ( Name, nameOccName ) import NameSet import UnicodeUtil ( stringToUtf8 ) import UniqFM ( isNullUFM ) import UniqSet ( emptyUniqSet ) -import Util ( isSingleton, mapAndUnzip ) -import List ( intersectBy, unzip4 ) +import Util ( isSingleton ) +import List ( unzip4 ) import ListSetOps ( removeDups ) import Outputable import SrcLoc ( noSrcLoc ) @@ -81,8 +75,8 @@ rnMatch ctxt match@(Match pats maybe_rhs_sig grhss) ) `thenM` \ (maybe_rhs_sig', ty_fvs) -> -- Now the main event - rnPatsAndThen ctxt pats $ \ pats' -> - rnGRHSs ctxt grhss `thenM` \ (grhss', grhss_fvs) -> + rnPatsAndThen ctxt True pats $ \ pats' -> + rnGRHSs ctxt grhss `thenM` \ (grhss', grhss_fvs) -> returnM (Match pats' maybe_rhs_sig' grhss', grhss_fvs `plusFV` ty_fvs) -- The bindPatSigTyVarsFV and rnPatsAndThen will remove the bound FVs @@ -172,13 +166,8 @@ rnExpr (HsVar v) returnM (HsVar name, unitFV name) rnExpr (HsIPVar v) - = newIPName v `thenM` \ name -> - let - fvs = case name of - Linear _ -> mkFVs [splitName, fstName, sndName] - Dupable _ -> emptyFVs - in - returnM (HsIPVar name, fvs) + = newIPNameRn v `thenM` \ name -> + returnM (HsIPVar name, emptyFVs) rnExpr (HsLit lit) = litFVs lit `thenM` \ fvs -> @@ -204,15 +193,11 @@ rnExpr (OpApp e1 op _ e2) -- Deal with fixity -- When renaming code synthesised from "deriving" declarations - -- we're in Interface mode, and we should ignore fixity; assume - -- that the deriving code generator got the association correct - -- Don't even look up the fixity when in interface mode - getModeRn `thenM` \ mode -> - (if isInterfaceMode mode - then returnM (OpApp e1' op' defaultFixity e2') - else lookupFixityRn op_name `thenM` \ fixity -> - mkOpAppRn e1' op' fixity e2' - ) `thenM` \ final_e -> + -- we used to avoid fixity stuff, but we can't easily tell any + -- more, so I've removed the test. Adding HsPars in TcGenDeriv + -- should prevent bad things happening. + lookupFixityRn op_name `thenM` \ fixity -> + mkOpAppRn e1' op' fixity e2' `thenM` \ final_e -> returnM (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) @@ -234,20 +219,14 @@ rnExpr e@(HsBracket br_body loc) = addSrcLoc loc $ checkTH e "bracket" `thenM_` rnBracket br_body `thenM` \ (body', fvs_e) -> - returnM (HsBracket body' loc, fvs_e `plusFV` thProxyName) + returnM (HsBracket body' loc, fvs_e) rnExpr e@(HsSplice n splice loc) = addSrcLoc loc $ checkTH e "splice" `thenM_` newLocalsRn [(n,loc)] `thenM` \ [n'] -> rnExpr splice `thenM` \ (splice', fvs_e) -> - returnM (HsSplice n' splice' loc, fvs_e `plusFV` thProxyName) - -rnExpr e@(HsReify (Reify flavour name)) - = checkTH e "reify" `thenM_` - lookupGlobalOccRn name `thenM` \ name' -> - -- For now, we can only reify top-level things - returnM (HsReify (Reify flavour name'), unitFV name' `plusFV` thProxyName) + returnM (HsSplice n' splice' loc, fvs_e) rnExpr section@(SectionL expr op) = rnExpr expr `thenM` \ (expr', fvs_expr) -> @@ -294,13 +273,8 @@ rnExpr e@(HsDo do_or_lc stmts _ _ src_loc) lookupSyntaxNames syntax_names `thenM` \ (syntax_names', monad_fvs) -> returnM (HsDo do_or_lc stmts' syntax_names' placeHolderType src_loc, - fvs `plusFV` implicit_fvs do_or_lc `plusFV` monad_fvs) + fvs `plusFV` monad_fvs) where - implicit_fvs PArrComp = mkFVs [replicatePName, mapPName, filterPName, crossPName, zipPName] - implicit_fvs ListComp = mkFVs [foldrName, buildName] - implicit_fvs DoExpr = emptyFVs - implicit_fvs MDoExpr = emptyFVs - syntax_names = case do_or_lc of DoExpr -> monadNames MDoExpr -> monadNames ++ [mfixName] @@ -312,8 +286,7 @@ rnExpr (ExplicitList _ exps) rnExpr (ExplicitPArr _ exps) = rnExprs exps `thenM` \ (exps', fvs) -> - returnM (ExplicitPArr placeHolderType exps', - fvs `addOneFV` toPName `addOneFV` parrTyCon_name) + returnM (ExplicitPArr placeHolderType exps', fvs) rnExpr e@(ExplicitTuple exps boxity) = checkTupSize tup_size `thenM_` @@ -355,12 +328,11 @@ rnExpr (HsType a) rnExpr (ArithSeqIn seq) = rnArithSeq seq `thenM` \ (new_seq, fvs) -> - returnM (ArithSeqIn new_seq, fvs `addOneFV` enumClassName) + returnM (ArithSeqIn new_seq, fvs) rnExpr (PArrSeqIn seq) = rnArithSeq seq `thenM` \ (new_seq, fvs) -> - returnM (PArrSeqIn new_seq, - fvs `plusFV` mkFVs [enumFromToPName, enumFromThenToPName]) + returnM (PArrSeqIn new_seq, fvs) \end{code} These three are pattern syntax appearing in expressions. @@ -387,8 +359,8 @@ rnExpr e@(ELazyPat _) = addErr (patSynErr e) `thenM_` \begin{code} rnExpr (HsProc pat body src_loc) = addSrcLoc src_loc $ - rnPatsAndThen ProcExpr [pat] $ \ [pat'] -> - rnCmdTop body `thenM` \ (body',fvBody) -> + rnPatsAndThen ProcExpr True [pat] $ \ [pat'] -> + rnCmdTop body `thenM` \ (body',fvBody) -> returnM (HsProc pat' body' src_loc, fvBody) rnExpr (HsArrApp arrow arg _ ho rtl srcloc) @@ -647,6 +619,8 @@ rnRbinds str rbinds %************************************************************************ \begin{code} +rnBracket (VarBr n) = lookupOccRn n `thenM` \ name -> + returnM (VarBr name, unitFV name) rnBracket (ExpBr e) = rnExpr e `thenM` \ (e', fvs) -> returnM (ExpBr e', fvs) rnBracket (PatBr p) = rnPat p `thenM` \ (p', fvs) -> @@ -659,12 +633,19 @@ rnBracket (DecBr group) = importsFromLocalDecls group `thenM` \ (rdr_env, avails) -> -- Discard avails (not useful here) - updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl }) $ + updGblEnv (\gbl -> gbl { tcg_rdr_env = tcg_rdr_env gbl `plusOccEnv` rdr_env}) $ + -- Notice plusOccEnv, not plusGlobalRdrEnv. In this situation we want + -- to *shadow* top-level bindings. E.g. + -- foo = 1 + -- bar = [d| foo = 1|] + -- So we drop down to plusOccEnv. (Perhaps there should be a fn in RdrName.) - rnSrcDecls group `thenM` \ (tcg_env, group', dus) -> + rnSrcDecls group `thenM` \ (tcg_env, group') -> -- Discard the tcg_env; it contains only extra info about fixity - - returnM (DecBr group', duUses dus `minusNameSet` duDefs dus) + let + dus = tcg_dus tcg_env + in + returnM (DecBr group', allUses dus) \end{code} %************************************************************************ @@ -687,8 +668,8 @@ rnNormalStmts ctxt [] = returnM ([], emptyFVs) -- Happens at the end of the sub-lists of a ParStmts rnNormalStmts ctxt (ExprStmt expr _ src_loc : stmts) - = addSrcLoc src_loc $ - rnExpr expr `thenM` \ (expr', fv_expr) -> + = addSrcLoc src_loc $ + rnExpr expr `thenM` \ (expr', fv_expr) -> rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) -> returnM (ExprStmt expr' placeHolderType src_loc : stmts', fv_expr `plusFV` fvs) @@ -703,8 +684,14 @@ rnNormalStmts ctxt (BindStmt pat expr src_loc : stmts) rnExpr expr `thenM` \ (expr', fv_expr) -> -- The binders do not scope over the expression - rnPatsAndThen (StmtCtxt ctxt) [pat] $ \ [pat'] -> - rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) -> + let + reportUnused = + case ctxt of + ParStmtCtxt{} -> False + _ -> True + in + rnPatsAndThen (StmtCtxt ctxt) reportUnused [pat] $ \ [pat'] -> + rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) -> returnM (BindStmt pat' expr' src_loc : stmts', fv_expr `plusFV` fvs) -- fv_expr shouldn't really be filtered by -- the rnPatsAndThen, but it does not matter @@ -717,8 +704,8 @@ rnNormalStmts ctxt (LetStmt binds : stmts) where -- We do not allow implicit-parameter bindings in a parallel -- list comprehension. I'm not sure what it might mean. - ok (ParStmtCtxt _) (IPBinds _ _) = False - ok _ _ = True + ok (ParStmtCtxt _) (IPBinds _) = False + ok _ _ = True rnNormalStmts ctxt (ParStmt stmtss : stmts) = doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts -> @@ -735,13 +722,16 @@ rnNormalStmts ctxt (ParStmt stmtss : stmts) -- shadow the next; e.g. x <- xs; x <- ys rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) -> - -- Cut down the exported binders to just the ones neede in the body + -- Cut down the exported binders to just the ones needed in the body let used_bndrs_s = map (filter (`elemNameSet` fvs)) bndrss + unused_bndrs = filter (not . (`elemNameSet` fvs)) bndrs in + -- With processing of the branches and the tail of comprehension done, + -- we can finally compute&report any unused ParStmt binders. + warnUnusedMatches unused_bndrs `thenM_` returnM (ParStmt (stmtss' `zip` used_bndrs_s) : stmts', fv_stmtss `plusFV` fvs) - where rn_branch (stmts, _) = rnNormalStmts (ParStmtCtxt ctxt) stmts @@ -1038,16 +1028,13 @@ right_op_ok fix1 other = True -- Parser initially makes negation bind more tightly than any other operator +-- And "deriving" code should respect this (use HsPar if not) mkNegAppRn neg_arg neg_name - = -#ifdef DEBUG - getModeRn `thenM` \ mode -> - ASSERT( not_op_app mode neg_arg ) -#endif + = ASSERT( not_op_app neg_arg ) returnM (NegApp neg_arg neg_name) -not_op_app SourceMode (OpApp _ _ _ _) = False -not_op_app mode other = True +not_op_app (OpApp _ _ _ _) = False +not_op_app other = True \end{code} \begin{code} @@ -1058,12 +1045,9 @@ checkPrecMatch False fn match checkPrecMatch True op (Match (p1:p2:_) _ _) -- True indicates an infix lhs - = getModeRn `thenM` \ mode -> - -- See comments with rnExpr (OpApp ...) - if isInterfaceMode mode - then returnM () - else checkPrec op p1 False `thenM_` - checkPrec op p2 True + = -- See comments with rnExpr (OpApp ...) about "deriving" + checkPrec op p1 False `thenM_` + checkPrec op p2 True checkPrecMatch True op _ = panic "checkPrecMatch" @@ -1120,7 +1104,7 @@ mkAssertErrorExpr expr = HsApp (HsVar assertErrorName) (HsLit msg) msg = HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc)))) in - returnM (expr, unitFV assertErrorName) + returnM (expr, emptyFVs) \end{code} %************************************************************************ @@ -1159,7 +1143,7 @@ checkTH e what -- Raise an error in a stage-1 compiler nest 2 (ppr e)]) #endif -parStmtErr = addErr (ptext SLIT("Illegal parallel list comprehension: use -fglagow-exts")) +parStmtErr = addErr (ptext SLIT("Illegal parallel list comprehension: use -fglasgow-exts")) badIpBinds binds = hang (ptext SLIT("Implicit-parameter bindings illegal in a parallel list comprehension:")) 4