import RnEnv
import RnNames ( importsFromLocalDecls )
import RnTypes ( rnHsTypeFVs, rnPat, litFVs, rnOverLit, rnPatsAndThen,
- dupFieldErr, precParseErr, sectionPrecErr, patSigErr )
+ dupFieldErr, precParseErr, sectionPrecErr, patSigErr, checkTupSize )
import CmdLineOpts ( DynFlag(..), opt_IgnoreAsserts )
import BasicTypes ( Fixity(..), FixityDirection(..), IPName(..),
defaultFixity, negateFixity, compareFixity )
crossPName, zipPName, toPName,
enumFromToPName, enumFromThenToPName, assertErrorName,
negateName, monadNames, mfixName )
-#ifdef GHCI
-import DsMeta ( qTyConName )
-#endif
import Name ( Name, nameOccName )
import NameSet
import UnicodeUtil ( stringToUtf8 )
returnM (HsPar e', fvs_e)
-- Template Haskell extensions
-#ifdef GHCI
-rnExpr (HsBracket br_body loc)
- = addSrcLoc loc $
- checkGHCI (thErr "bracket") `thenM_`
- rnBracket br_body `thenM` \ (body', fvs_e) ->
- 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
-
-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' loc, fvs_e `addOneFV` qTyConName)
- -- The qTyCon brutally pulls in all the meta stuff
-
-rnExpr (HsReify (Reify flavour name))
- = checkGHCI (thErr "reify") `thenM_`
- lookupGlobalOccRn name `thenM` \ name' ->
+-- Don't ifdef-GHCI them because we want to fail gracefully
+-- (not with an rnExpr crash) in a stage-1 compiler.
+rnExpr e@(HsBracket br_body loc)
+ = addSrcLoc loc $
+ checkTH e "bracket" `thenM_`
+ rnBracket br_body `thenM` \ (body', fvs_e) ->
+ returnM (HsBracket body' loc, fvs_e `plusFV` thProxyName)
+
+rnExpr e@(HsSplice n splice loc)
+ = addSrcLoc loc $
+ checkTH e "splice" `thenM_`
+ newLocalsRn [(n,loc)] `thenM` \ [n'] ->
+ rnExpr splice `thenM` \ (splice', fvs_e) ->
+ returnM (HsSplice n' splice' loc, fvs_e `plusFV` thProxyName)
+
+rnExpr e@(HsReify (Reify flavour name))
+ = checkTH e "reify" `thenM_`
+ lookupGlobalOccRn name `thenM` \ name' ->
-- For now, we can only reify top-level things
- returnM (HsReify (Reify flavour name'), mkFVs [name', qTyConName])
- -- The qTyCon brutally pulls in all the meta stuff
-#endif
+ returnM (HsReify (Reify flavour name'), unitFV name' `plusFV` thProxyName)
rnExpr section@(SectionL expr op)
= rnExpr expr `thenM` \ (expr', fvs_expr) ->
returnM (ExplicitPArr placeHolderType exps',
fvs `addOneFV` toPName `addOneFV` parrTyCon_name)
-rnExpr (ExplicitTuple exps boxity)
- = rnExprs exps `thenM` \ (exps', fvs) ->
+rnExpr e@(ExplicitTuple exps boxity)
+ = checkTupSize tup_size `thenM_`
+ rnExprs exps `thenM` \ (exps', fvs) ->
returnM (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name)
where
- tycon_name = tupleTyCon_name boxity (length exps)
+ tup_size = length exps
+ tycon_name = tupleTyCon_name boxity tup_size
rnExpr (RecordCon con_id rbinds)
= lookupOccRn con_id `thenM` \ conname ->
MDoExpr -> "mdo"
other -> "do"
-thErr what
- = ptext SLIT("Template Haskell") <+> text what <+>
- ptext SLIT("illegal in a stage-1 compiler")
+#ifdef GHCI
+checkTH e what = returnM () -- OK
+#else
+checkTH e what -- Raise an error in a stage-1 compiler
+ = addErr (vcat [ptext SLIT("Template Haskell") <+> text what <+>
+ ptext SLIT("illegal in a stage-1 compiler"),
+ nest 2 (ppr e)])
+#endif
badIpBinds binds
= hang (ptext SLIT("Implicit-parameter bindings illegal in a parallel list comprehension:")) 4