[commit: ghc] wip/th-new: Consolidate TH renaming. (515dfd1)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/th-new
Link       : http://ghc.haskell.org/trac/ghc/changeset/515dfd180e2bd856b55610f4355fddec45a0b3c5/ghc

>---------------------------------------------------------------

commit 515dfd180e2bd856b55610f4355fddec45a0b3c5
Author: Geoffrey Mainland <mainland at apeiron.net>
Date:   Wed Apr 24 08:41:50 2013 +0100

    Consolidate TH renaming.


>---------------------------------------------------------------

515dfd180e2bd856b55610f4355fddec45a0b3c5
 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 9cf4c75..fc71686 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 TemplateHaskell") ] )
-    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..5440e58 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 TemplateHaskell") ] )
+       ; 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 33951bb..9c6ccf9 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
@@ -251,8 +251,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 )