import RnHsSyn
import TcRnMonad
import RnEnv
+import HscTypes ( availNames )
import OccName ( plusOccEnv )
import RnNames ( getLocalDeclBinders, extendRdrEnvRn )
import RnTypes ( rnHsTypeFVs, rnLPat, rnOverLit, rnPatsAndThen, rnLit,
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 )
&& 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
= 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)
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) ->
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"
returnM (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds)
rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
- -- DictApp, DictLam, TyApp, TyLam
+ -- HsWrap
\end{code}
-- 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
%************************************************************************
%* *
-\subsubsection{breakpoint 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))))
-\end{code}
-
-%************************************************************************
-%* *
\subsubsection{Assertion utils}
%* *
%************************************************************************
\begin{code}
+srcSpanPrimLit :: SrcSpan -> HsExpr Name
+srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDoc (ppr span))))
+
mkAssertErrorExpr :: RnM (HsExpr Name, FreeVars)
-- Return an expression for (assertError "Foo.hs:27")
mkAssertErrorExpr
= getSrcSpanM `thenM` \ sloc ->
let
expr = HsApp (L sloc (HsVar assertErrorName))
- (L sloc (srcSpanLit sloc))
+ (L sloc (srcSpanPrimLit sloc))
in
returnM (expr, emptyFVs)
\end{code}
= hang (ptext SLIT("Implicit-parameter bindings illegal in") <+> what)
2 (ppr binds)
\end{code}
+
+
projects / ghc-hetmet.git / blobdiff