dupFieldErr, checkTupSize )
import DynFlags ( DynFlag(..) )
import BasicTypes ( FixityDirection(..) )
-import PrelNames ( hasKey, assertIdKey, assertErrorName,
+import PrelNames ( thFAKE, hasKey, assertIdKey, assertErrorName,
loopAName, choiceAName, appAName, arrAName, composeAName, firstAName,
negateName, thenMName, bindMName, failMName )
-import Name ( Name, nameOccName )
+#if defined(GHCI) && defined(BREAKPOINT)
+import PrelNames ( breakpointJumpName, undefined_RDR, breakpointIdKey )
+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 UnicodeUtil ( stringToUtf8 )
import UniqFM ( isNullUFM )
import UniqSet ( emptyUniqSet )
import List ( nub )
import Util ( isSingleton )
import ListSetOps ( removeDups )
-import Maybes ( fromJust )
+import Maybes ( expectJust )
import Outputable
import SrcLoc ( Located(..), unLoc, getLoc, cmpLocated )
import FastString
rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
rnExpr (HsVar v)
- = lookupOccRn v `thenM` \ name ->
- doptM Opt_IgnoreAsserts `thenM` \ ignore_asserts ->
- if name `hasKey` assertIdKey && not ignore_asserts then
- -- We expand it to (GHC.Err.assertError location_string)
- mkAssertErrorExpr `thenM` \ (e, fvs) ->
- returnM (e, fvs `addOneFV` name)
- -- Keep 'assert' as a free var, to ensure it's not reported as unused!
- else
- -- The normal case. Even if the Id was 'assert', if we are
- -- ignoring assertions we leave it as GHC.Base.assert;
- -- this function just ignores its first arg.
- returnM (HsVar name, unitFV name)
+ = do name <- lookupOccRn v
+ localRdrEnv <- getLocalRdrEnv
+ lclEnv <- getLclEnv
+ ignore_asserts <- doptM Opt_IgnoreAsserts
+ ignore_breakpoints <- doptM Opt_IgnoreBreakpoints
+ 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)
+ )
+#endif
+ ]
+ case lookup True conds of
+ Just action -> action
+ Nothing -> return (HsVar name, unitFV name)
rnExpr (HsIPVar v)
= newIPNameRn v `thenM` \ name ->
We return a (bogus) EWildPat in each case.
\begin{code}
-rnExpr e@EWildPat = addErr (patSynErr e) `thenM_`
- returnM (EWildPat, emptyFVs)
-
-rnExpr e@(EAsPat _ _) = addErr (patSynErr e) `thenM_`
- returnM (EWildPat, emptyFVs)
-
-rnExpr e@(ELazyPat _) = addErr (patSynErr e) `thenM_`
- returnM (EWildPat, emptyFVs)
+rnExpr e@EWildPat = patSynErr e
+rnExpr e@(EAsPat {}) = patSynErr e
+rnExpr e@(ELazyPat {}) = patSynErr e
\end{code}
%************************************************************************
\begin{code}
rnBracket (VarBr n) = do { name <- lookupOccRn n
- ; loadHomeInterface msg name -- Reason: deprecation checking asumes the
- -- home interface is loaded, and this is the
- -- only way that is going to happen
+ ; 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
+ ; return () } -- only way that is going to happen
; returnM (VarBr name, unitFV name) }
where
msg = ptext SLIT("Need interface for Template Haskell quoted Name")
doc = ptext SLIT("In a Template-Haskell quoted type")
rnBracket (DecBr group)
= do { gbl_env <- getGblEnv
- ; names <- getLocalDeclBinders gbl_env group
- ; rdr_env' <- extendRdrEnvRn (tcg_mod gbl_env) emptyGlobalRdrEnv names
- ; setGblEnv (gbl_env { tcg_rdr_env = tcg_rdr_env gbl_env `plusOccEnv` rdr_env',
+ ; let gbl_env1 = gbl_env { tcg_mod = thFAKE }
+ -- Note the thFAKE. The top-level names from the bracketed
+ -- declarations will go into the name cache, and we don't want them to
+ -- 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.
+ -- 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',
tcg_dus = emptyDUs }) $ do
-- 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.)
- --
+ -- 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
{ -- Find the Names that are bound by stmts
lcl_env <- getLocalRdrEnv
; let { rdr_bndrs = collectLStmtsBinders stmts
- ; bndrs = map ( fromJust
+ ; bndrs = map ( expectJust "rnStmt"
. lookupLocalRdrEnv lcl_env
. unLoc) rdr_bndrs
; new_bndrs = nub bndrs ++ bndrs_so_far
%************************************************************************
%* *
+\subsubsection{breakpoint utils}
+%* *
+%************************************************************************
+
+\begin{code}
+#if defined(GHCI) && defined(BREAKPOINT)
+mkBreakPointExpr :: [Name] -> RnM (HsExpr Name, FreeVars)
+mkBreakPointExpr 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 breakpointJumpName [mkScopeArg scope, HsVar undef, HsLit msg]
+ mkScopeArg args
+ = unLoc $ mkExpr undef (map HsVar args)
+ msg = HsString (mkFastString (unpackFS (srcSpanFile sloc) ++ ":" ++ show (srcSpanStartLine sloc)))
+ return (expr, emptyFVs)
+#endif
+\end{code}
+
+%************************************************************************
+%* *
\subsubsection{Assertion utils}
%* *
%************************************************************************
= getSrcSpanM `thenM` \ sloc ->
let
expr = HsApp (L sloc (HsVar assertErrorName)) (L sloc (HsLit msg))
- msg = HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc))))
+ msg = HsStringPrim (mkFastString (showSDoc (ppr sloc)))
in
returnM (expr, emptyFVs)
\end{code}
%************************************************************************
\begin{code}
-patSynErr e
- = sep [ptext SLIT("Pattern syntax in expression context:"),
- nest 4 (ppr e)]
+patSynErr e = do { addErr (sep [ptext SLIT("Pattern syntax in expression context:"),
+ nest 4 (ppr e)])
+ ; return (EWildPat, emptyFVs) }
parStmtErr = addErr (ptext SLIT("Illegal parallel list comprehension: use -fglasgow-exts"))