X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnExpr.lhs;h=e78e942bf20b7e9da8417a65cde530f6142a5f71;hb=72e37dedee9e8a109ebda4b13e49b7133b530591;hp=99d0767a8e786e6f167922a2eda08f251096c933;hpb=70f6cbd1695128f2685085d423c09e4cb889d91e;p=ghc-hetmet.git diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 99d0767..e78e942 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -23,7 +23,7 @@ import HsSyn import RnHsSyn import TcRnMonad import RnEnv -import OccName ( plusOccEnv ) +import HscTypes ( availNames ) import RnNames ( getLocalDeclBinders, extendRdrEnvRn ) import RnTypes ( rnHsTypeFVs, rnLPat, rnOverLit, rnPatsAndThen, rnLit, mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec, @@ -34,16 +34,10 @@ import SrcLoc ( SrcSpan ) import PrelNames ( thFAKE, hasKey, assertIdKey, assertErrorName, loopAName, choiceAName, appAName, arrAName, composeAName, firstAName, negateName, thenMName, bindMName, failMName ) -#if defined(GHCI) && defined(BREAKPOINT) -import PrelNames ( breakpointJumpName, breakpointCondJumpName - , undefined_RDR, breakpointIdKey, breakpointCondIdKey ) -import UniqFM ( eltsUFM ) -import DynFlags ( GhcMode(..) ) -import Name ( isTyVarName ) -#endif + import Name ( Name, nameOccName, nameIsLocalOrFrom ) import NameSet -import RdrName ( RdrName, emptyGlobalRdrEnv, extendLocalRdrEnv, lookupLocalRdrEnv ) +import RdrName ( RdrName, extendLocalRdrEnv, lookupLocalRdrEnv, hideSomeUnquals ) import LoadIface ( loadInterfaceForName ) import UniqFM ( isNullUFM ) import UniqSet ( emptyUniqSet ) @@ -96,40 +90,30 @@ rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars) rnExpr (HsVar v) = do name <- lookupOccRn v - localRdrEnv <- getLocalRdrEnv - lclEnv <- getLclEnv ignore_asserts <- doptM Opt_IgnoreAsserts - ignore_breakpoints <- doptM Opt_IgnoreBreakpoints - ghcMode <- getGhcMode - let conds = [ (name `hasKey` assertIdKey - && not ignore_asserts, - do (e, fvs) <- mkAssertErrorExpr - return (e, fvs `addOneFV` name)) -#if defined(GHCI) && defined(BREAKPOINT) - , (name `hasKey` breakpointIdKey - && not ignore_breakpoints - && ghcMode == Interactive, - do let isWantedName = not.isTyVarName - (e, fvs) <- mkBreakpointExpr (filter isWantedName (eltsUFM localRdrEnv)) - return (e, fvs `addOneFV` name) - ) - , (name `hasKey` breakpointCondIdKey - && not ignore_breakpoints - && ghcMode == Interactive, - do let isWantedName = not.isTyVarName - (e, fvs) <- mkBreakpointCondExpr (filter isWantedName (eltsUFM localRdrEnv)) - return (e, fvs `addOneFV` name) - ) -#endif - ] - case lookup True conds of - Just action -> action - Nothing -> return (HsVar name, unitFV name) + finish_var ignore_asserts name + where + finish_var ignore_asserts name + | ignore_asserts || not (name `hasKey` assertIdKey) + = return (HsVar name, unitFV name) + | otherwise + = do { (e, fvs) <- mkAssertErrorExpr + ; return (e, fvs `addOneFV` name) } rnExpr (HsIPVar v) = newIPNameRn v `thenM` \ name -> returnM (HsIPVar name, emptyFVs) +rnExpr (HsLit lit@(HsString s)) + = do { + opt_OverloadedStrings <- doptM Opt_OverloadedStrings + ; if opt_OverloadedStrings then + rnExpr (HsOverLit (mkHsIsString s)) + else -- Same as below + rnLit lit `thenM_` + returnM (HsLit lit, emptyFVs) + } + rnExpr (HsLit lit) = rnLit lit `thenM_` returnM (HsLit lit, emptyFVs) @@ -200,6 +184,9 @@ rnExpr (HsCoreAnn ann expr) rnExpr (HsSCC lbl expr) = rnLExpr expr `thenM` \ (expr', fvs_expr) -> returnM (HsSCC lbl expr', fvs_expr) +rnExpr (HsTickPragma info expr) + = rnLExpr expr `thenM` \ (expr', fvs_expr) -> + returnM (HsTickPragma info expr', fvs_expr) rnExpr (HsLam matches) = rnMatchGroup LambdaExpr matches `thenM` \ (matches', fvMatch) -> @@ -236,22 +223,23 @@ rnExpr e@(ExplicitTuple exps boxity) tup_size = length exps tycon_name = tupleTyCon_name boxity tup_size -rnExpr (RecordCon con_id _ rbinds) +rnExpr (RecordCon con_id _ (HsRecordBinds rbinds)) = lookupLocatedOccRn con_id `thenM` \ conname -> rnRbinds "construction" rbinds `thenM` \ (rbinds', fvRbinds) -> - returnM (RecordCon conname noPostTcExpr rbinds', + returnM (RecordCon conname noPostTcExpr (HsRecordBinds rbinds'), fvRbinds `addOneFV` unLoc conname) -rnExpr (RecordUpd expr rbinds _ _) +rnExpr (RecordUpd expr (HsRecordBinds rbinds) _ _) = rnLExpr expr `thenM` \ (expr', fvExpr) -> rnRbinds "update" rbinds `thenM` \ (rbinds', fvRbinds) -> - returnM (RecordUpd expr' rbinds' placeHolderType placeHolderType, + returnM (RecordUpd expr' (HsRecordBinds rbinds') placeHolderType placeHolderType, fvExpr `plusFV` fvRbinds) rnExpr (ExprWithTySig expr pty) - = rnLExpr expr `thenM` \ (expr', fvExpr) -> - rnHsTypeFVs doc pty `thenM` \ (pty', fvTy) -> - returnM (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) + = do { (pty', fvTy) <- rnHsTypeFVs doc pty + ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $ + rnLExpr expr + ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) } where doc = text "In an expression type signature" @@ -330,7 +318,7 @@ rnExpr (HsArrForm op fixity cmds) returnM (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds) rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other) - -- DictApp, DictLam, TyApp, TyLam + -- HsWrap \end{code} @@ -573,25 +561,27 @@ rnBracket (DecBr group) -- confuse the Names for the current module. -- By using a pretend module, thFAKE, we keep them safely out of the way. - ; names <- getLocalDeclBinders gbl_env1 group - ; rdr_env' <- extendRdrEnvRn emptyGlobalRdrEnv names - -- Furthermore, the names in the bracket shouldn't conflict with - -- existing top-level names E.g. + ; avails <- getLocalDeclBinders gbl_env1 group + ; let names = concatMap availNames avails + + ; let new_occs = map nameOccName names + trimmed_rdr_env = hideSomeUnquals (tcg_rdr_env gbl_env) new_occs + + ; rdr_env' <- extendRdrEnvRn trimmed_rdr_env avails + -- In this situation we want to *shadow* top-level bindings. -- foo = 1 -- bar = [d| foo = 1|] - -- But both 'foo's get a LocalDef provenance, so we'd get a complaint unless - -- we start with an emptyGlobalRdrEnv - - ; setGblEnv (gbl_env { tcg_rdr_env = tcg_rdr_env gbl_env1 `plusOccEnv` rdr_env', + -- If we don't shadow, we'll get an ambiguity complaint when we do + -- a lookupTopBndrRn (which uses lookupGreLocalRn) on the binder of the 'foo' + -- + -- Furthermore, arguably if the splice does define foo, that should hide + -- any foo's further out + -- + -- The shadowing is acheived by the call to hideSomeUnquals, which removes + -- the unqualified bindings of things defined by the bracket + + ; setGblEnv (gbl_env { tcg_rdr_env = rdr_env', tcg_dus = emptyDUs }) $ do - -- Notice plusOccEnv, not plusGlobalRdrEnv. In this situation we want - -- to *shadow* top-level bindings. (See the 'foo' example above.) - -- If we don't shadow, we'll get an ambiguity complaint when we do - -- a lookupTopBndrRn (which uses lookupGreLocalRn) on the binder of the 'foo' - -- - -- Furthermore, arguably if the splice does define foo, that should hide - -- any foo's further out - -- -- The emptyDUs is so that we just collect uses for this group alone { (tcg_env, group') <- rnSrcDecls group @@ -941,48 +931,14 @@ segsToStmts ((defs, uses, fwds, ss) : segs) fvs_later %************************************************************************ %* * -\subsubsection{breakpoint utils} +\subsubsection{Assertion utils} %* * %************************************************************************ \begin{code} -#if defined(GHCI) && defined(BREAKPOINT) -mkBreakpointExpr :: [Name] -> RnM (HsExpr Name, FreeVars) -mkBreakpointExpr = mkBreakpointExpr' breakpointJumpName - -mkBreakpointCondExpr :: [Name] -> RnM (HsExpr Name, FreeVars) -mkBreakpointCondExpr = mkBreakpointExpr' breakpointCondJumpName - -mkBreakpointExpr' :: Name -> [Name] -> RnM (HsExpr Name, FreeVars) -mkBreakpointExpr' breakpointFunc scope - = do sloc <- getSrcSpanM - undef <- lookupOccRn undefined_RDR - let inLoc = L sloc - lHsApp x y = inLoc (HsApp x y) - mkExpr fnName args = mkExpr' fnName (reverse args) - mkExpr' fnName [] = inLoc (HsVar fnName) - mkExpr' fnName (arg:args) - = lHsApp (mkExpr' fnName args) (inLoc arg) - expr = unLoc $ mkExpr breakpointFunc [mkScopeArg scope, HsVar undef, msg] - mkScopeArg args = unLoc $ mkExpr undef (map HsVar args) - msg = srcSpanLit sloc - return (expr, emptyFVs) -#endif - -srcSpanLit :: SrcSpan -> HsExpr Name -srcSpanLit span = HsLit (HsString (mkFastString (showSDoc (ppr span)))) - srcSpanPrimLit :: SrcSpan -> HsExpr Name srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDoc (ppr span)))) -\end{code} - -%************************************************************************ -%* * -\subsubsection{Assertion utils} -%* * -%************************************************************************ -\begin{code} mkAssertErrorExpr :: RnM (HsExpr Name, FreeVars) -- Return an expression for (assertError "Foo.hs:27") mkAssertErrorExpr @@ -1011,3 +967,5 @@ badIpBinds what binds = hang (ptext SLIT("Implicit-parameter bindings illegal in") <+> what) 2 (ppr binds) \end{code} + +