add runMeta hook

Summary:
The runMeta hook can be used to override how metaprogramming expressions
are evaluated. It makes the metaprogramming request types explicit and
has access to the TcM monad. This makes it a much more convenient starting
point for implementing out of process Template Haskell than the existing
hscCompileCoreExpr hook.

Reviewers: hvr, edsko, austin, simonpj

Reviewed By: austin

Subscribers: thomie, carter

Differential Revision: https://phabricator.haskell.org/D501

2 files changed, 51 insertions, 0 deletions

diff --git a/compiler/main/Hooks.hs b/compiler/main/Hooks.hs
index 3e797cad2e..fd25e330b4 100644
--- a/compiler/main/Hooks.hs
+++ b/compiler/main/Hooks.hs
@@ -18,6 +18,7 @@ module Hooks ( Hooks
              , hscCompileCoreExprHook
              , ghcPrimIfaceHook
              , runPhaseHook
+             , runMetaHook
              , linkHook
              , runQuasiQuoteHook
              , runRnSpliceHook
@@ -59,6 +60,7 @@ import Data.Maybe
 emptyHooks :: Hooks
 emptyHooks = Hooks 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)))
@@ -69,6 +71,7 @@ data Hooks = Hooks
   , hscCompileCoreExprHook :: Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO HValue)
   , ghcPrimIfaceHook       :: Maybe ModIface
   , runPhaseHook           :: Maybe (PhasePlus -> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath))
+  , runMetaHook            :: Maybe (MetaHook TcM)
   , linkHook               :: Maybe (GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag)
   , runQuasiQuoteHook      :: Maybe (HsQuasiQuote Name -> RnM (HsQuasiQuote Name))
   , runRnSpliceHook        :: Maybe (LHsExpr Name -> RnM (LHsExpr Name))
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index c3879b6d58..909004e14d 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -46,6 +46,12 @@ module HscTypes (
 
         mkSOName, mkHsSOName, soExt,
 
+        -- * Metaprogramming
+        MetaRequest(..),
+        MetaResult, -- data constructors not exported to ensure correct response type
+        metaRequestE, metaRequestP, metaRequestT, metaRequestD, metaRequestAW,
+        MetaHook,
+
         -- * Annotations
         prepareAnnotations,
 
@@ -177,6 +183,7 @@ import Binary
 import ErrUtils
 import Platform
 import Util
+import Serialized       ( Serialized )
 
 import Control.Monad    ( guard, liftM, when, ap )
 import Data.Array       ( Array, array )
@@ -595,6 +602,47 @@ hptObjs hpt = concat (map (maybe [] linkableObjs . hm_linkable) (eltsUFM hpt))
 {-
 ************************************************************************
 *                                                                      *
+\subsection{Metaprogramming}
+*                                                                      *
+************************************************************************
+-}
+
+-- | The supported metaprogramming result types
+data MetaRequest
+  = MetaE  (LHsExpr RdrName   -> MetaResult)
+  | MetaP  (LPat RdrName      -> MetaResult)
+  | MetaT  (LHsType RdrName   -> MetaResult)
+  | MetaD  ([LHsDecl RdrName] -> MetaResult)
+  | MetaAW (Serialized        -> MetaResult)
+
+-- | data constructors not exported to ensure correct result type
+data MetaResult
+  = MetaResE  { unMetaResE  :: LHsExpr RdrName   }
+  | MetaResP  { unMetaResP  :: LPat RdrName      }
+  | MetaResT  { unMetaResT  :: LHsType RdrName   }
+  | MetaResD  { unMetaResD  :: [LHsDecl RdrName] }
+  | MetaResAW { unMetaResAW :: Serialized        }
+
+type MetaHook f = MetaRequest -> LHsExpr Id -> f MetaResult
+
+metaRequestE :: Functor f => MetaHook f -> LHsExpr Id -> f (LHsExpr RdrName)
+metaRequestE h = fmap unMetaResE . h (MetaE MetaResE)
+
+metaRequestP :: Functor f => MetaHook f -> LHsExpr Id -> f (LPat RdrName)
+metaRequestP h = fmap unMetaResP . h (MetaP MetaResP)
+
+metaRequestT :: Functor f => MetaHook f -> LHsExpr Id -> f (LHsType RdrName)
+metaRequestT h = fmap unMetaResT . h (MetaT MetaResT)
+
+metaRequestD :: Functor f => MetaHook f -> LHsExpr Id -> f [LHsDecl RdrName]
+metaRequestD h = fmap unMetaResD . h (MetaD MetaResD)
+
+metaRequestAW :: Functor f => MetaHook f -> LHsExpr Id -> f Serialized
+metaRequestAW h = fmap unMetaResAW . h (MetaAW MetaResAW)
+
+{-
+************************************************************************
+*                                                                      *
 \subsection{Dealing with Annotations}
 *                                                                      *
 ************************************************************************