[commit: ghc] master: Add hook for splicing in renamer (df2dd64)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/df2dd64dca0796f01356f5fb2ec41edf9762c349/ghc

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

commit df2dd64dca0796f01356f5fb2ec41edf9762c349
Author: Edsko de Vries <edsko at well-typed.com>
Date:   Tue Dec 17 17:28:44 2013 +0000

    Add hook for splicing in renamer
    
    With the recent modifications to the TH infrastructure, many splices are now
    expanded in the renamer rather than the typechecker. This means that tools
    which inspect the renamed tree don't get to see the original splices. Added a
    new hook which gets called before such a splice gets expanded, analogous to the
    runQuasiQuoteHook.


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

df2dd64dca0796f01356f5fb2ec41edf9762c349
 compiler/main/Hooks.lhs      |    5 ++++-
 compiler/rename/RnSplice.lhs |   15 +++++++++++----
 2 files changed, 15 insertions(+), 5 deletions(-)

diff --git a/compiler/main/Hooks.lhs b/compiler/main/Hooks.lhs
index 24bfb10..326b140 100644
--- a/compiler/main/Hooks.lhs
+++ b/compiler/main/Hooks.lhs
@@ -16,6 +16,7 @@ module Hooks ( Hooks
              , runPhaseHook
              , linkHook
              , runQuasiQuoteHook
+             , runRnSpliceHook
              , getValueSafelyHook
              ) where
 
@@ -26,6 +27,7 @@ import PipelineMonad
 import HscTypes
 import HsDecls
 import HsBinds
+import HsExpr
 import {-# SOURCE #-} DsMonad
 import OrdList
 import Id
@@ -54,7 +56,7 @@ import Data.Maybe
 
 emptyHooks :: Hooks
 emptyHooks = Hooks Nothing Nothing Nothing Nothing Nothing Nothing
-                   Nothing Nothing Nothing Nothing Nothing
+                   Nothing Nothing Nothing Nothing Nothing Nothing
 
 data Hooks = Hooks
   { dsForeignsHook         :: Maybe ([LForeignDecl Id] -> DsM (ForeignStubs, OrdList (Id, CoreExpr)))
@@ -67,6 +69,7 @@ data Hooks = Hooks
   , runPhaseHook           :: Maybe (PhasePlus -> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath))
   , linkHook               :: Maybe (GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag)
   , runQuasiQuoteHook      :: Maybe (HsQuasiQuote Name -> RnM (HsQuasiQuote Name))
+  , runRnSpliceHook        :: Maybe (HsSplice Name -> RnM (HsSplice Name))
   , getValueSafelyHook     :: Maybe (HscEnv -> Name -> Type -> IO (Maybe HValue))
   }
 
diff --git a/compiler/rename/RnSplice.lhs b/compiler/rename/RnSplice.lhs
index b744313..bc47fe8 100644
--- a/compiler/rename/RnSplice.lhs
+++ b/compiler/rename/RnSplice.lhs
@@ -28,6 +28,7 @@ import TcEnv            ( checkWellStaged, tcMetaTy )
 import Outputable
 import BasicTypes       ( TopLevelFlag, isTopLevel )
 import FastString
+import Hooks
 
 import {-# SOURCE #-} RnExpr   ( rnLExpr )
 import {-# SOURCE #-} TcExpr   ( tcMonoExpr )
@@ -136,7 +137,7 @@ rnSpliceExpr is_typed splice
         = (PendingRnExpSplice rn_splice, HsSpliceE is_typed rn_splice)
 
     run_expr_splice :: HsSplice Name -> RnM (HsExpr Name, FreeVars)
-    run_expr_splice rn_splice@(HsSplice _ expr)
+    run_expr_splice rn_splice
       | is_typed   -- Run it later, in the type checker
       = do {  -- Ugh!  See Note [Splices] above
               lcl_rdr <- getLocalRdrEnv
@@ -148,7 +149,9 @@ rnSpliceExpr is_typed splice
            ; return (HsSpliceE is_typed rn_splice, lcl_names `plusFV` gbl_names) }
 
       | otherwise  -- Run it here
-      = do { -- The splice must have type ExpQ
+      = do { HsSplice _ expr <- getHooked runRnSpliceHook return >>= ($ rn_splice)
+      
+             -- The splice must have type ExpQ
            ; meta_exp_ty <- tcMetaTy expQTyConName
 
              -- Typecheck the expression
@@ -171,8 +174,10 @@ rnSpliceType splice k
     pend_type_splice rn_splice
        = (PendingRnTypeSplice rn_splice, HsSpliceTy rn_splice k)
 
-    run_type_splice (HsSplice _ expr)
-       = do { meta_exp_ty <- tcMetaTy typeQTyConName
+    run_type_splice rn_splice 
+       = do { HsSplice _ expr <- getHooked runRnSpliceHook return >>= ($ rn_splice)
+              
+            ; meta_exp_ty <- tcMetaTy typeQTyConName
 
               -- Typecheck the expression
             ; zonked_q_expr <- tcTopSpliceExpr False $
@@ -190,6 +195,7 @@ rnSpliceType splice k
 
 ----------------------
 rnSplicePat :: HsSplice RdrName -> RnM (Pat Name, FreeVars)
+-- TODO: Run runHsSpliceHook (see runSpliceExpr)
 rnSplicePat splice
   = rnSpliceGen False run_pat_splice pend_pat_splice splice
   where
@@ -226,6 +232,7 @@ rnSpliceDecl (SpliceDecl (L loc splice) flg)
 \begin{code}
 rnTopSpliceDecls :: HsSplice RdrName -> RnM ([LHsDecl RdrName], FreeVars)
 -- Declaration splice at the very top level of the module
+-- TODO: Run runHsSpliceHook (see runSpliceExpr)
 rnTopSpliceDecls (HsSplice _ expr)
    = do  { (expr', fvs) <- setStage (Splice False) $
                            rnLExpr expr