X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnExpr.lhs;h=17c7f97001d9dde681477e900e057b84e5a941d2;hb=90dc9026b091be5cca5da4c6cbd3713ecc493361;hp=049123e77770717879ae614fd7360706ab5ae4fd;hpb=e6d057711f4d6d6ff6342c39fa2b9e44d25447f1;p=ghc-hetmet.git diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 049123e..17c7f97 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -23,6 +23,8 @@ import HsSyn import RnHsSyn import TcRnMonad import RnEnv +import HscTypes ( availNames ) +import OccName ( plusOccEnv ) import RnNames ( getLocalDeclBinders, extendRdrEnvRn ) import RnTypes ( rnHsTypeFVs, rnLPat, rnOverLit, rnPatsAndThen, rnLit, mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec, @@ -33,13 +35,7 @@ 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, extendLocalRdrEnv, lookupLocalRdrEnv, hideSomeUnquals ) @@ -104,22 +100,6 @@ rnExpr (HsVar v) && 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 @@ -129,6 +109,16 @@ 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) @@ -199,6 +189,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) -> @@ -248,9 +241,10 @@ rnExpr (RecordUpd expr rbinds _ _) 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" @@ -572,12 +566,13 @@ 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 + ; 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 names + ; rdr_env' <- extendRdrEnvRn trimmed_rdr_env avails -- In this situation we want to *shadow* top-level bindings. -- foo = 1 -- bar = [d| foo = 1|] @@ -941,48 +936,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) - -srcSpanLit :: SrcSpan -> HsExpr Name -srcSpanLit span = HsLit (HsString (mkFastString (showSDoc (ppr span)))) -#endif - 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 +972,5 @@ badIpBinds what binds = hang (ptext SLIT("Implicit-parameter bindings illegal in") <+> what) 2 (ppr binds) \end{code} + +