X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnExpr.lhs;h=2df8e950e6e1e64e4d21ba7cf0acf064924d9f4e;hp=716a85a3b3ad4ad094c8ecc0b11d58211e9b99bb;hb=9da4639011348fb6c318e3cba4b08622f811d9c4;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 716a85a..2df8e95 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -23,27 +23,27 @@ import HsSyn import RnHsSyn import TcRnMonad import RnEnv -import OccName ( plusOccEnv ) import RnNames ( getLocalDeclBinders, extendRdrEnvRn ) import RnTypes ( rnHsTypeFVs, rnLPat, rnOverLit, rnPatsAndThen, rnLit, mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec, dupFieldErr, checkTupSize ) import DynFlags ( DynFlag(..) ) import BasicTypes ( FixityDirection(..) ) +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, undefined_RDR, breakpointIdKey ) +import PrelNames ( breakpointJumpName, breakpointCondJumpName + , undefined_RDR, breakpointIdKey, breakpointCondIdKey ) import UniqFM ( eltsUFM ) import DynFlags ( GhcMode(..) ) -import SrcLoc ( srcSpanFile, srcSpanStartLine ) import Name ( isTyVarName ) #endif import Name ( Name, nameOccName, nameIsLocalOrFrom ) import NameSet -import RdrName ( RdrName, emptyGlobalRdrEnv, extendLocalRdrEnv, lookupLocalRdrEnv ) -import LoadIface ( loadHomeInterface ) +import RdrName ( RdrName, extendLocalRdrEnv, lookupLocalRdrEnv, hideSomeUnquals ) +import LoadIface ( loadInterfaceForName ) import UniqFM ( isNullUFM ) import UniqSet ( emptyUniqSet ) import List ( nub ) @@ -99,20 +99,25 @@ rnExpr (HsVar v) 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, - do ghcMode <- getGhcMode - case ghcMode of - Interactive - -> do let isWantedName = not.isTyVarName - (e, fvs) <- mkBreakPointExpr (filter isWantedName (eltsUFM localRdrEnv)) - return (e, fvs `addOneFV` name) - _ -> return (HsVar name, unitFV name) + && 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 ] @@ -243,9 +248,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" @@ -324,7 +330,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} @@ -453,7 +459,7 @@ methodNamesCmd other = emptyFVs -- The type checker will complain later --------------------------------------------------- -methodNamesMatch (MatchGroup ms ty) +methodNamesMatch (MatchGroup ms _) = plusFVs (map do_one ms) where do_one (L _ (Match pats sig_ty grhss)) = methodNamesGRHSs grhss @@ -544,7 +550,7 @@ rnRbinds str rbinds rnBracket (VarBr n) = do { name <- lookupOccRn n ; this_mod <- getModule ; checkM (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking asumes the - do { loadHomeInterface msg name -- home interface is loaded, and this is the + do { loadInterfaceForName msg name -- home interface is loaded, and this is the ; return () } -- only way that is going to happen ; returnM (VarBr name, unitFV name) } where @@ -567,25 +573,26 @@ 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. + ; names <- getLocalDeclBinders gbl_env1 group + + ; let new_occs = map nameOccName names + trimmed_rdr_env = hideSomeUnquals (tcg_rdr_env gbl_env) new_occs + + ; rdr_env' <- extendRdrEnvRn trimmed_rdr_env names + -- 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,8 +948,14 @@ segsToStmts ((defs, uses, fwds, ss) : segs) fvs_later \begin{code} #if defined(GHCI) && defined(BREAKPOINT) -mkBreakPointExpr :: [Name] -> RnM (HsExpr Name, FreeVars) -mkBreakPointExpr scope +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 @@ -951,12 +964,17 @@ mkBreakPointExpr scope mkExpr' fnName [] = inLoc (HsVar fnName) mkExpr' fnName (arg:args) = lHsApp (mkExpr' fnName args) (inLoc arg) - expr = unLoc $ mkExpr breakpointJumpName [mkScopeArg scope, HsVar undef, HsLit msg] - mkScopeArg args - = unLoc $ mkExpr undef (map HsVar args) - msg = HsString (mkFastString (unpackFS (srcSpanFile sloc) ++ ":" ++ show (srcSpanStartLine sloc))) + 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} %************************************************************************ @@ -971,8 +989,8 @@ mkAssertErrorExpr :: RnM (HsExpr Name, FreeVars) mkAssertErrorExpr = getSrcSpanM `thenM` \ sloc -> let - expr = HsApp (L sloc (HsVar assertErrorName)) (L sloc (HsLit msg)) - msg = HsStringPrim (mkFastString (showSDoc (ppr sloc))) + expr = HsApp (L sloc (HsVar assertErrorName)) + (L sloc (srcSpanPrimLit sloc)) in returnM (expr, emptyFVs) \end{code}