diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 82717a03c0b..2b910ccf351 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -168,19 +168,9 @@ rnExpr (NegApp e _) -- Template Haskell extensions -- 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) - = do - thEnabled <- xoptM Opt_TemplateHaskell - unless thEnabled $ - failWith ( vcat [ ptext (sLit "Syntax error on") <+> ppr e - , ptext (sLit "Perhaps you intended to use -XTemplateHaskell") ] ) - checkTH e "bracket" - (body', fvs_e) <- rnBracket br_body - return (HsBracket body', fvs_e) - -rnExpr (HsSpliceE splice) - = rnSplice splice `thenM` \ (splice', fvs) -> - return (HsSpliceE splice', fvs) +rnExpr e@(HsBracket br_body) = rnBracket e br_body + +rnExpr (HsSpliceE splice) = rnSpliceExpr splice #ifndef GHCI rnExpr e@(HsQuasiQuoteE _) = pprPanic "Cant do quasiquotation without GHCi" (ppr e) diff --git a/compiler/rename/RnSplice.lhs b/compiler/rename/RnSplice.lhs index 09ab9defdf0..afa16821e49 100644 --- a/compiler/rename/RnSplice.lhs +++ b/compiler/rename/RnSplice.lhs @@ -1,9 +1,11 @@ \begin{code} module RnSplice ( - rnSplice, rnBracket, checkTH + rnSpliceType, rnSpliceExpr, + rnBracket, checkTH ) where import Control.Monad ( unless ) +import DynFlags import FastString import Name import NameSet @@ -64,7 +66,24 @@ rnSplice (HsSplice n expr) lcl_names = mkNameSet (localRdrEnvElts lcl_rdr) ; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) } +\end{code} + +\begin{code} +rnSpliceType :: HsSplice RdrName -> PostTcKind -> RnM (HsType Name, FreeVars) +rnSpliceType splice k + = do { (splice', fvs) <- rnSplice splice -- ToDo: deal with fvs + ; return (HsSpliceTy splice' fvs k, fvs) + } +\end{code} +\begin{code} +rnSpliceExpr :: HsSplice RdrName -> RnM (HsExpr Name, FreeVars) +rnSpliceExpr splice = do + (splice', fvs) <- rnSplice splice + return (HsSpliceE splice', fvs) +\end{code} + +\begin{code} checkTH :: Outputable a => a -> String -> RnM () #ifdef GHCI checkTH _ _ = return () -- OK @@ -84,8 +103,19 @@ checkTH e what -- Raise an error in a stage-1 compiler %************************************************************************ \begin{code} -rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars) -rnBracket (VarBr flg n) +rnBracket :: HsExpr RdrName -> HsBracket RdrName -> RnM (HsExpr Name, FreeVars) +rnBracket e br_body + = do { thEnabled <- xoptM Opt_TemplateHaskell + ; unless thEnabled $ + failWith ( vcat [ ptext (sLit "Syntax error on") <+> ppr e + , ptext (sLit "Perhaps you intended to use -XTemplateHaskell") ] ) + ; checkTH e "bracket" + ; (body', fvs_e) <- rn_bracket br_body + ; return (HsBracket body', fvs_e) + } + +rn_bracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars) +rn_bracket (VarBr flg n) = do { name <- lookupOccRn n ; this_mod <- getModule ; unless (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking assumes @@ -96,15 +126,15 @@ rnBracket (VarBr flg n) where msg = ptext (sLit "Need interface for Template Haskell quoted Name") -rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e - ; return (ExpBr e', fvs) } +rn_bracket (ExpBr e) = do { (e', fvs) <- rnLExpr e + ; return (ExpBr e', fvs) } -rnBracket (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs) +rn_bracket (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs) -rnBracket (TypBr t) = do { (t', fvs) <- rnLHsType TypBrCtx t - ; return (TypBr t', fvs) } +rn_bracket (TypBr t) = do { (t', fvs) <- rnLHsType TypBrCtx t + ; return (TypBr t', fvs) } -rnBracket (DecBrL decls) +rn_bracket (DecBrL decls) = do { (group, mb_splice) <- findSplice decls ; case mb_splice of Nothing -> return () @@ -124,9 +154,9 @@ rnBracket (DecBrL decls) -- See Note [Extra dependencies from .hs-boot files] in RnSource -- Discard the tcg_env; it contains only extra info about fixity - ; traceRn (text "rnBracket dec" <+> (ppr (tcg_dus tcg_env) $$ + ; traceRn (text "rn_bracket dec" <+> (ppr (tcg_dus tcg_env) $$ ppr (duUses (tcg_dus tcg_env)))) ; return (DecBrG group', duUses (tcg_dus tcg_env)) } -rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG" +rn_bracket (DecBrG _) = panic "rn_bracket: unexpected DecBrG" \end{code} diff --git a/compiler/rename/RnSplice.lhs-boot b/compiler/rename/RnSplice.lhs-boot index b656cec5a9e..dbb876cee14 100644 --- a/compiler/rename/RnSplice.lhs-boot +++ b/compiler/rename/RnSplice.lhs-boot @@ -9,8 +9,10 @@ import NameSet import Outputable -rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars) -rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars) +rnBracket :: HsExpr RdrName -> HsBracket RdrName -> RnM (HsExpr Name, FreeVars) + +rnSpliceType :: HsSplice RdrName -> PostTcKind -> RnM (HsType Name, FreeVars) +rnSpliceExpr :: HsSplice RdrName -> RnM (HsExpr Name, FreeVars) checkTH :: Outputable a => a -> String -> RnM () \end{code} diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index 3944b9e5150..08d2017947b 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -24,7 +24,7 @@ module RnTypes ( #ifdef GHCI import {-# SOURCE #-} TcSplice( runQuasiQuoteType ) #endif /* GHCI */ -import {-# SOURCE #-} RnSplice( rnSplice ) +import {-# SOURCE #-} RnSplice( rnSpliceType ) import DynFlags import HsSyn @@ -247,8 +247,7 @@ rnHsTyKi isType doc (HsEqTy ty1 ty2) rnHsTyKi isType _ (HsSpliceTy sp _ k) = ASSERT ( isType ) - do { (sp', fvs) <- rnSplice sp -- ToDo: deal with fvs - ; return (HsSpliceTy sp' fvs k, fvs) } + rnSpliceType sp k rnHsTyKi isType doc (HsDocTy ty haddock_doc) = ASSERT ( isType )