import RnHsSyn
import TcRnMonad
import RnEnv
+import HscTypes ( availNames )
import OccName ( plusOccEnv )
import RnNames ( getLocalDeclBinders, extendRdrEnvRn )
import RnTypes ( rnHsTypeFVs, rnLPat, rnOverLit, rnPatsAndThen, rnLit,
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 )
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
]
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"
returnM (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds)
rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
- -- DictApp, DictLam, TyApp, TyLam
+ -- HsWrap
\end{code}
-- 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
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
-- 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 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
\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
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}
%************************************************************************
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}
projects / ghc-hetmet.git / blobdiff