[commit: ghc] th-new-7.6: Consolidate TH renaming. (ec95d23)
Geoffrey Mainland
gmainlan at microsoft.com
Wed Jun 12 12:03:08 CEST 2013
Repository : http://darcs.haskell.org/ghc.git/
On branch : th-new-7.6
https://github.com/ghc/ghc/commit/ec95d23e39525b50dd4dff4abb8e0bda7ee3f3ff
>---------------------------------------------------------------
commit ec95d23e39525b50dd4dff4abb8e0bda7ee3f3ff
Author: Geoffrey Mainland <mainland at apeiron.net>
Date: Wed Apr 24 08:41:50 2013 +0100
Consolidate TH renaming.
>---------------------------------------------------------------
compiler/rename/RnExpr.lhs | 16 +++---------
compiler/rename/RnSplice.lhs | 52 ++++++++++++++++++++++++++++++---------
compiler/rename/RnSplice.lhs-boot | 6 +++--
compiler/rename/RnTypes.lhs | 5 ++--
4 files changed, 50 insertions(+), 29 deletions(-)
diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index a06af4f..62f0709 100644
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -157,19 +157,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 09ab9de..afa1682 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 b656cec..dbb876c 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 315f77c..37f6cba 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 )
More information about the ghc-commits
mailing list