From aadb64aa5644f2a3ad8a645e2c7a1e72c2f61e53 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Wed, 9 Oct 2002 16:53:13 +0000
Subject: [PATCH] [project @ 2002-10-09 16:53:10 by simonpj] Fix to mdo, plus
SrcLocs on splices and brackets
---
ghc/compiler/deSugar/DsExpr.lhs | 18 ++++++++++--------
ghc/compiler/deSugar/DsMeta.hs | 2 +-
ghc/compiler/hsSyn/HsDecls.lhs | 11 ++++++++---
ghc/compiler/hsSyn/HsExpr.lhs | 17 +++++++++++------
ghc/compiler/parser/Parser.y | 18 +++++++++---------
ghc/compiler/parser/RdrHsSyn.lhs | 6 +++---
ghc/compiler/rename/RnExpr.lhs | 17 +++++++++--------
ghc/compiler/typecheck/TcExpr.lhs | 7 ++++---
ghc/compiler/typecheck/TcHsSyn.lhs | 23 ++++++++++++++---------
ghc/compiler/typecheck/TcMatches.lhs | 13 +++++++++----
ghc/compiler/typecheck/TcRnDriver.lhs | 8 +++++---
11 files changed, 83 insertions(+), 57 deletions(-)
diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index 881822930dd4..c17a29296ce6 100644
--- a/ghc/compiler/deSugar/DsExpr.lhs
+++ b/ghc/compiler/deSugar/DsExpr.lhs
@@ -550,7 +550,7 @@ Here is where we desugar the Template Haskell brackets and escapes
#ifdef GHCI /* Only if bootstrapping */
dsExpr (HsBracketOut x ps) = dsBracket x ps
-dsExpr (HsSplice n e) = pprPanic "dsExpr:splice" (ppr e)
+dsExpr (HsSplice n e _) = pprPanic "dsExpr:splice" (ppr e)
#endif
\end{code}
@@ -636,10 +636,10 @@ dsDo do_or_lc stmts ids result_ty
returnDs (mkApps (Var bind_id) [Type a_ty, Type b_ty, expr2,
mkLams binders matching_code])
- go (RecStmt rec_vars rec_stmts : stmts)
+ go (RecStmt rec_vars rec_stmts rec_rets : stmts)
= go (bind_stmt : stmts)
where
- bind_stmt = dsRecStmt m_ty ids rec_vars rec_stmts
+ bind_stmt = dsRecStmt m_ty ids rec_vars rec_stmts rec_rets
in
go stmts
@@ -658,19 +658,21 @@ We turn (RecStmt [v1,..vn] stmts) into:
\begin{code}
dsRecStmt :: Type -- Monad type constructor :: * -> *
-> [Id] -- Ids for: [return,fail,>>=,>>,mfix]
- -> [Id] -> [TypecheckedStmt] -- Guts of the RecStmt
+ -> [Id] -> [TypecheckedStmt] -> [TypecheckedHsExpr] -- Guts of the RecStmt
-> TypecheckedStmt
-dsRecStmt m_ty ids@[return_id, _, _, _, mfix_id] vars stmts
- = BindStmt tup_pat mfix_app noSrcLoc
+dsRecStmt m_ty ids@[return_id, _, _, _, mfix_id] vars stmts rets
+ = ASSERT( length vars == length rets )
+ BindStmt tup_pat mfix_app noSrcLoc
where
(var1:rest) = vars -- Always at least one
+ (ret1:_) = rets
one_var = null rest
mfix_app = HsApp (TyApp (HsVar mfix_id) [tup_ty]) mfix_arg
mfix_arg = HsLam (mkSimpleMatch [tup_pat] body tup_ty noSrcLoc)
- tup_expr | one_var = HsVar var1
- | otherwise = ExplicitTuple (map HsVar vars) Boxed
+ tup_expr | one_var = ret1
+ | otherwise = ExplicitTuple rets Boxed
tup_ty | one_var = idType var1
| otherwise = mkTupleTy Boxed (length vars) (map idType vars)
tup_pat | one_var = VarPat var1
diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs
index 1899ff3e2cd7..8571e1efb7c8 100644
--- a/ghc/compiler/deSugar/DsMeta.hs
+++ b/ghc/compiler/deSugar/DsMeta.hs
@@ -284,7 +284,7 @@ repE (HsIPVar x) = panic "Can't represent implicit parameters"
repE (HsLit l) = do { a <- repLiteral l; repLit a }
repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
-repE (HsSplice n e)
+repE (HsSplice n e loc)
= do { mb_val <- dsLookupMetaEnv n
; case mb_val of
Just (Splice e) -> do { e' <- dsExpr e
diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs
index 4bda850ed6f1..5c806a6105fe 100644
--- a/ghc/compiler/hsSyn/HsDecls.lhs
+++ b/ghc/compiler/hsSyn/HsDecls.lhs
@@ -9,7 +9,7 @@ Definitions for: @TyDecl@ and @oCnDecl@, @ClassDecl@,
\begin{code}
module HsDecls (
HsDecl(..), TyClDecl(..), InstDecl(..), RuleDecl(..), RuleBndr(..),
- DefaultDecl(..), HsGroup(..),
+ DefaultDecl(..), HsGroup(..), SpliceDecl(..),
ForeignDecl(..), ForeignImport(..), ForeignExport(..),
CImportSpec(..), FoType(..),
ConDecl(..), CoreDecl(..),
@@ -74,7 +74,7 @@ data HsDecl id
| DeprecD (DeprecDecl id)
| RuleD (RuleDecl id)
| CoreD (CoreDecl id)
- | SpliceD (HsExpr id) -- Top level splice
+ | SpliceD (SpliceDecl id)
-- NB: all top-level fixity decls are contained EITHER
-- EITHER SigDs
@@ -125,7 +125,7 @@ instance OutputableBndr name => Outputable (HsDecl name) where
ppr (RuleD rd) = ppr rd
ppr (DeprecD dd) = ppr dd
ppr (CoreD dd) = ppr dd
- ppr (SpliceD e) = ptext SLIT("splice") <> parens (pprExpr e)
+ ppr (SpliceD dd) = ppr dd
instance OutputableBndr name => Outputable (HsGroup name) where
ppr (HsGroup { hs_valds = val_decls,
@@ -145,6 +145,11 @@ instance OutputableBndr name => Outputable (HsGroup name) where
where
ppr_ds [] = empty
ppr_ds ds = text "" $$ vcat (map ppr ds)
+
+data SpliceDecl id = SpliceDecl (HsExpr id) SrcLoc -- Top level splice
+
+instance OutputableBndr name => Outputable (SpliceDecl name) where
+ ppr (SpliceDecl e _) = ptext SLIT("$") <> parens (pprExpr e)
\end{code}
diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs
index e29590596168..0ff1823befc2 100644
--- a/ghc/compiler/hsSyn/HsExpr.lhs
+++ b/ghc/compiler/hsSyn/HsExpr.lhs
@@ -164,13 +164,13 @@ data HsExpr id
(HsExpr id) -- expr whose cost is to be measured
-- MetaHaskell Extensions
- | HsBracket (HsBracket id)
+ | HsBracket (HsBracket id) SrcLoc
| HsBracketOut (HsBracket Name) -- Output of the type checker is the *original*
[PendingSplice] -- renamed expression, plus *typechecked* splices
-- to be pasted back in by the desugarer
- | HsSplice id (HsExpr id ) -- $z or $(f 4)
+ | HsSplice id (HsExpr id) SrcLoc -- $z or $(f 4)
-- The id is just a unique name to
-- identify this splice point
\end{code}
@@ -389,8 +389,8 @@ ppr_expr (DictApp expr dnames)
ppr_expr (HsType id) = ppr id
-ppr_expr (HsSplice n e) = char '$' <> brackets (ppr n) <> pprParendExpr e
-ppr_expr (HsBracket b) = pprHsBracket b
+ppr_expr (HsSplice n e _) = char '$' <> brackets (ppr n) <> pprParendExpr e
+ppr_expr (HsBracket b _) = pprHsBracket b
ppr_expr (HsBracketOut e ps) = ppr e $$ ptext SLIT("where") <+> ppr ps
-- add parallel array brackets around a document
@@ -585,8 +585,13 @@ data Stmt id
-- The ids are a subset of the variables bound by the stmts that
-- either (a) are used before they are bound in the stmts
-- or (b) are used in stmts that follow the RecStmt
- | RecStmt [id]
+ | RecStmt [id]
[Stmt id]
+ [HsExpr id] -- Post type-checking only; these expressions correspond
+ -- 1-to-1 with the [id], and are the expresions that should
+ -- be returned by the recursion. They may not quite be the
+ -- Ids themselves, because the Id may be polymorphic, but
+ -- the returned thing has to be monomorphic.
\end{code}
ExprStmts and ResultStmts are a bit tricky, because what they mean
@@ -644,7 +649,7 @@ pprStmt (ParStmt stmtss)
= hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss)
pprStmt (ParStmtOut stmtss)
= hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss)
-pprStmt (RecStmt _ segment) = vcat (map ppr segment)
+pprStmt (RecStmt _ segment _) = vcat (map ppr segment)
pprDo :: OutputableBndr id => HsStmtContext any -> [Stmt id] -> SDoc
pprDo DoExpr stmts = hang (ptext SLIT("do")) 2 (vcat (map ppr stmts))
diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y
index f90e5959e1a6..ea68bb37eda5 100644
--- a/ghc/compiler/parser/Parser.y
+++ b/ghc/compiler/parser/Parser.y
@@ -1,6 +1,6 @@
{- -*-haskell-*-
-----------------------------------------------------------------------------
-$Id: Parser.y,v 1.106 2002/10/09 15:03:53 simonpj Exp $
+$Id: Parser.y,v 1.107 2002/10/09 16:53:11 simonpj Exp $
Haskell grammar.
@@ -415,7 +415,7 @@ topdecl :: { RdrBinding }
| 'foreign' fdecl { RdrHsDecl $2 }
| '{-# DEPRECATED' deprecations '#-}' { RdrBindings $2 }
| '{-# RULES' rules '#-}' { RdrBindings $2 }
- | '$(' exp ')' { RdrHsDecl (SpliceD $2) }
+ | srcloc '$(' exp ')' { RdrHsDecl (SpliceD (SpliceDecl $3 $1)) }
| decl { $1 }
tycl_decl :: { RdrNameTyClDecl }
@@ -1000,13 +1000,13 @@ aexp2 :: { RdrNameHsExpr }
| '_' { EWildPat }
-- MetaHaskell Extension
- | ID_SPLICE { mkHsSplice (HsVar (mkUnqual varName $1))} -- $x
- | '$(' exp ')' { mkHsSplice $2 } -- $( exp )
- | '[|' exp '|]' { HsBracket (ExpBr $2) }
- | '[t|' ctype '|]' { HsBracket (TypBr $2) }
- | '[p|' srcloc infixexp '|]' {% checkPattern $2 $3 `thenP` \p ->
- returnP (HsBracket (PatBr p)) }
- | '[d|' cvtopdecls '|]' { HsBracket (DecBr (mkGroup $2)) }
+ | srcloc ID_SPLICE { mkHsSplice (HsVar (mkUnqual varName $2)) $1 } -- $x
+ | srcloc '$(' exp ')' { mkHsSplice $3 $1 } -- $( exp )
+ | srcloc '[|' exp '|]' { HsBracket (ExpBr $3) $1 }
+ | srcloc '[t|' ctype '|]' { HsBracket (TypBr $3) $1 }
+ | srcloc '[p|' infixexp '|]' {% checkPattern $1 $3 `thenP` \p ->
+ returnP (HsBracket (PatBr p) $1) }
+ | srcloc '[d|' cvtopdecls '|]' { HsBracket (DecBr (mkGroup $3)) $1 }
texps :: { [RdrNameHsExpr] }
diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs
index 51bf7ddc5560..756dfc1f7169 100644
--- a/ghc/compiler/parser/RdrHsSyn.lhs
+++ b/ghc/compiler/parser/RdrHsSyn.lhs
@@ -281,7 +281,7 @@ mkHsDo ctxt stmts loc = HsDo ctxt stmts [] placeHolderType loc
\end{code}
\begin{code}
-mkHsSplice e = HsSplice unqualSplice e
+mkHsSplice e loc = HsSplice unqualSplice e loc
unqualSplice = mkRdrUnqual (mkVarOcc FSLIT("splice"))
-- A name (uniquified later) to
@@ -418,7 +418,7 @@ emptyGroup = HsGroup { hs_valds = MonoBind EmptyMonoBinds [] Recursive,
hs_fixds = [], hs_defds = [], hs_fords = [],
hs_depds = [] ,hs_ruleds = [], hs_coreds = [] }
-findSplice :: [HsDecl a] -> (HsGroup a, Maybe (HsExpr a, [HsDecl a]))
+findSplice :: [HsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [HsDecl a]))
findSplice ds = add emptyGroup ds
mkGroup :: [HsDecl a] -> HsGroup a
@@ -430,7 +430,7 @@ addImpDecls group decls = case add group decls of
(group', Nothing) -> group'
other -> panic "addImpDecls"
-add :: HsGroup a -> [HsDecl a] -> (HsGroup a, Maybe (HsExpr a, [HsDecl a]))
+add :: HsGroup a -> [HsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [HsDecl a]))
-- This stuff reverses the declarations (again) but it doesn't matter
-- Base cases
diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index 2b9ba9d0d74f..798c5689f5dc 100644
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -228,20 +228,21 @@ rnExpr (HsPar e)
-- Template Haskell extensions
#ifdef GHCI
-rnExpr (HsBracket br_body)
- = checkGHCI (thErr "bracket") `thenM_`
+rnExpr (HsBracket br_body loc)
+ = addSrcLoc loc $
+ checkGHCI (thErr "bracket") `thenM_`
rnBracket br_body `thenM` \ (body', fvs_e) ->
- returnM (HsBracket body', fvs_e `addOneFV` qTyConName)
+ returnM (HsBracket body' loc, fvs_e `addOneFV` qTyConName)
-- We use the Q tycon as a proxy to haul in all the smart
-- constructors; see the hack in RnIfaces
#endif
-rnExpr (HsSplice n e)
- = checkGHCI (thErr "splice") `thenM_`
- getSrcLocM `thenM` \ loc ->
+rnExpr (HsSplice n e loc)
+ = addSrcLoc loc $
+ checkGHCI (thErr "splice") `thenM_`
newLocalsRn [(n,loc)] `thenM` \ [n'] ->
rnExpr e `thenM` \ (e', fvs_e) ->
- returnM (HsSplice n' e', fvs_e)
+ returnM (HsSplice n' e' loc, fvs_e)
rnExpr section@(SectionL expr op)
= rnExpr expr `thenM` \ (expr', fvs_expr) ->
@@ -724,7 +725,7 @@ segsToStmts ((defs, uses, fwds, ss) : segs)
where
(later_stmts, later_uses) = segsToStmts segs
new_stmt | non_rec = head ss
- | otherwise = RecStmt rec_names ss
+ | otherwise = RecStmt rec_names ss []
where
non_rec = isSingleton ss && isEmptyNameSet fwds
rec_names = nameSetToList (fwds `plusFV` (defs `intersectNameSet` later_uses))
diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index c3dde2f1d6dc..b38d28baacd5 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -621,10 +621,11 @@ tcMonoExpr (PArrSeqIn _) _
#ifdef GHCI /* Only if bootstrapped */
-- Rename excludes these cases otherwise
-tcMonoExpr (HsSplice n expr) res_ty = tcSpliceExpr n expr res_ty
+tcMonoExpr (HsSplice n expr loc) res_ty = addSrcLoc loc (tcSpliceExpr n expr res_ty)
-tcMonoExpr (HsBracket brack) res_ty
- = getStage `thenM` \ level ->
+tcMonoExpr (HsBracket brack loc) res_ty
+ = addSrcLoc loc $
+ getStage `thenM` \ level ->
case bracketOK level of {
Nothing -> failWithTc (illegalBracket level) ;
Just next_level ->
diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index 251c7ad5624f..386f4eb593b1 100644
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -413,7 +413,11 @@ zonkGRHSs env (GRHSs grhss binds ty)
%************************************************************************
\begin{code}
-zonkExpr :: ZonkEnv -> TcExpr -> TcM TypecheckedHsExpr
+zonkExprs :: ZonkEnv -> [TcExpr] -> TcM [TypecheckedHsExpr]
+zonkExpr :: ZonkEnv -> TcExpr -> TcM TypecheckedHsExpr
+
+zonkExprs env exprs = mappM (zonkExpr env) exprs
+
zonkExpr env (HsVar id)
= returnM (HsVar (zonkIdOcc env id))
@@ -450,8 +454,8 @@ zonkExpr env (HsBracketOut body bs)
zonk_b (n,e) = zonkExpr env e `thenM` \ e' ->
returnM (n,e')
-zonkExpr env (HsSplice n e) = WARN( True, ppr e ) -- Should not happen
- returnM (HsSplice n e)
+zonkExpr env (HsSplice n e loc) = WARN( True, ppr e ) -- Should not happen
+ returnM (HsSplice n e loc)
zonkExpr env (OpApp e1 op fixity e2)
= zonkExpr env e1 `thenM` \ new_e1 ->
@@ -513,16 +517,16 @@ zonkExpr env (HsDo do_or_lc stmts ids ty src_loc)
zonkExpr env (ExplicitList ty exprs)
= zonkTcTypeToType env ty `thenM` \ new_ty ->
- mappM (zonkExpr env) exprs `thenM` \ new_exprs ->
+ zonkExprs env exprs `thenM` \ new_exprs ->
returnM (ExplicitList new_ty new_exprs)
zonkExpr env (ExplicitPArr ty exprs)
= zonkTcTypeToType env ty `thenM` \ new_ty ->
- mappM (zonkExpr env) exprs `thenM` \ new_exprs ->
+ zonkExprs env exprs `thenM` \ new_exprs ->
returnM (ExplicitPArr new_ty new_exprs)
zonkExpr env (ExplicitTuple exprs boxed)
- = mappM (zonkExpr env) exprs `thenM` \ new_exprs ->
+ = zonkExprs env exprs `thenM` \ new_exprs ->
returnM (ExplicitTuple new_exprs boxed)
zonkExpr env (RecordConOut data_con con_expr rbinds)
@@ -554,7 +558,7 @@ zonkExpr env (PArrSeqOut expr info)
returnM (PArrSeqOut new_expr new_info)
zonkExpr env (HsCCall fun args may_gc is_casm result_ty)
- = mappM (zonkExpr env) args `thenM` \ new_args ->
+ = zonkExprs env args `thenM` \ new_args ->
zonkTcTypeToType env result_ty `thenM` \ new_result_ty ->
returnM (HsCCall fun new_args may_gc is_casm new_result_ty)
@@ -629,14 +633,15 @@ zonkStmts env (ParStmtOut bndrstmtss : stmts)
where
(bndrss, stmtss) = unzip bndrstmtss
-zonkStmts env (RecStmt vs segStmts : stmts)
+zonkStmts env (RecStmt vs segStmts rets : stmts)
= mappM zonkId vs `thenM` \ new_vs ->
let
env1 = extendZonkEnv env new_vs
in
zonkStmts env1 segStmts `thenM` \ new_segStmts ->
+ zonkExprs env1 rets `thenM` \ new_rets ->
zonkStmts env1 stmts `thenM` \ new_stmts ->
- returnM (RecStmt new_vs new_segStmts : new_stmts)
+ returnM (RecStmt new_vs new_segStmts new_rets : new_stmts)
zonkStmts env (ResultStmt expr locn : stmts)
= zonkExpr env expr `thenM` \ new_expr ->
diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs
index 91d5aefff85b..a1a5758c5e4d 100644
--- a/ghc/compiler/typecheck/TcMatches.lhs
+++ b/ghc/compiler/typecheck/TcMatches.lhs
@@ -458,23 +458,28 @@ tcStmtAndThen combine do_or_lc m_ty (ParStmtOut bndr_stmts_s) thing_inside
combine_par stmt (stmts, thing) = (stmt:stmts, thing)
-- RecStmt
-tcStmtAndThen combine do_or_lc m_ty (RecStmt recNames stmts) thing_inside
+tcStmtAndThen combine do_or_lc m_ty (RecStmt recNames stmts _) thing_inside
= newTyVarTys (length recNames) liftedTypeKind `thenM` \ recTys ->
tcExtendLocalValEnv (zipWith mkLocalId recNames recTys) $
tcStmtsAndThen combine_rec do_or_lc m_ty stmts (
tcLookupLocalIds recNames `thenM` \ rn ->
returnM ([], rn)
- ) `thenM` \ (stmts', recNames') ->
+ ) `thenM` \ (stmts', recIds) ->
-- Unify the types of the "final" Ids with those of "knot-tied" Ids
- unifyTauTyLists recTys (map idType recNames') `thenM_`
+ mappM tc_ret (recIds `zip` recTys) `thenM` \ rets' ->
thing_inside `thenM` \ thing ->
- returnM (combine (RecStmt recNames' stmts') thing)
+ returnM (combine (RecStmt recIds stmts' rets') thing)
where
combine_rec stmt (stmts, thing) = (stmt:stmts, thing)
+ -- Unify the types of the "final" Ids with those of "knot-tied" Ids
+ tc_ret (rec_id, rec_ty)
+ = tcSubExp rec_ty (idType rec_id) `thenM` \ co_fn ->
+ returnM (co_fn <$> HsVar rec_id)
+
-- ExprStmt
tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ExprStmt exp _ locn) thing_inside
= addErrCtxt (stmtCtxt do_or_lc stmt) (
diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs
index ae5a12ed8455..6e146f400e80 100644
--- a/ghc/compiler/typecheck/TcRnDriver.lhs
+++ b/ghc/compiler/typecheck/TcRnDriver.lhs
@@ -22,7 +22,7 @@ import {-# SOURCE #-} TcSplice( tcSpliceDecls )
import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt )
import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..),
Stmt(..), Pat(VarPat), HsStmtContext(..), RuleDecl(..),
- HsGroup(..),
+ HsGroup(..), SpliceDecl(..),
mkSimpleMatch, placeHolderType, toHsType, andMonoBinds,
isSrcRule, collectStmtsBinders
)
@@ -597,7 +597,7 @@ tcRnSrcDecls ds
-- If there is no splice, we're done
case group_tail of
Nothing -> return (tcg_env, src_fvs1)
- Just (splice_expr, rest_ds) -> do {
+ Just (SpliceDecl splice_expr splice_loc, rest_ds) -> do {
setGblEnv tcg_env $ do {
@@ -605,7 +605,9 @@ tcRnSrcDecls ds
failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
#else
-- Rename the splice expression, and get its supporting decls
- (rn_splice_expr, fvs) <- initRn SourceMode (rnExpr splice_expr) ;
+ (rn_splice_expr, fvs) <- initRn SourceMode $
+ addSrcLoc splice_loc $
+ rnExpr splice_expr ;
tcg_env <- importSupportingDecls fvs ;
setGblEnv tcg_env $ do {
--
GitLab