Restructure compilation pipeline to allow hooks

This commit exposes GHC's internal compiler pipeline through a `Hooks`
module in the GHC API. It currently allows you to hook:

 * Foreign import/exports declarations
 * The frontend up to type checking
 * The one shot compilation mode
 * Core compilation, and the module iface
 * Linking and the phases in DriverPhases.hs
 * Quasiquotation
Authored-by: Luite Stegeman <stegeman@gmail.com>
Authored-by: Edsko de Vries <edsko@well-typed.com>
Signed-off-by: Austin Seipp <austin@well-typed.com>

compiler/basicTypes/BasicTypes.lhs

@@ -75,7 +75,9 @@ module BasicTypes(
 
         SuccessFlag(..), succeeded, failed, successIf,
 
-        FractionalLit(..), negateFractionalLit, integralFractionalLit
+        FractionalLit(..), negateFractionalLit, integralFractionalLit,
+
+        HValue(..)
    ) where
 
 import FastString
@@ -83,6 +85,7 @@ import Outputable
 
 import Data.Data hiding (Fixity)
 import Data.Function (on)
+import GHC.Exts (Any)
 \end{code}
 
 %************************************************************************
@@ -898,3 +901,9 @@ instance Ord FractionalLit where
 instance Outputable FractionalLit where
   ppr = text . fl_text
 \end{code}
+
+\begin{code}
+
+newtype HValue = HValue Any
+
+\end{code}

compiler/deSugar/DsForeign.lhs

@@ -6,7 +6,13 @@
 Desugaring foreign declarations (see also DsCCall).
 
 \begin{code}
-module DsForeign ( dsForeigns ) where
+module DsForeign ( dsForeigns
+                 , dsForeigns'
+                 , dsFImport, dsCImport, dsFCall, dsPrimCall
+                 , dsFExport, dsFExportDynamic, mkFExportCBits
+                 , toCType
+                 , foreignExportInitialiser
+                 ) where
 
 #include "HsVersions.h"
 import TcRnMonad        -- temp
@@ -48,6 +54,7 @@ import Config
 import OrdList
 import Pair
 import Util
+import Hooks
 
 import Data.Maybe
 import Data.List
@@ -72,9 +79,13 @@ type Binding = (Id, CoreExpr)   -- No rec/nonrec structure;
 
 dsForeigns :: [LForeignDecl Id]
            -> DsM (ForeignStubs, OrdList Binding)
-dsForeigns []
+dsForeigns fos = getHooked dsForeignsHook dsForeigns' >>= ($ fos)
+
+dsForeigns' :: [LForeignDecl Id]
+            -> DsM (ForeignStubs, OrdList Binding)
+dsForeigns' []
   = return (NoStubs, nilOL)
-dsForeigns fos = do
+dsForeigns' fos = do
     fives <- mapM do_ldecl fos
     let
         (hs, cs, idss, bindss) = unzip4 fives

compiler/deSugar/DsMonad.lhs-boot

+\begin{code}
+module DsMonad (DsM) where
+
+import TcRnTypes
+
+data DsGblEnv
+data DsLclEnv
+type DsM result = TcRnIf DsGblEnv DsLclEnv result
+
+\end{code}
+
+Some notes about this boot file (from Edsko):
+
+
+DsMonad has a (transitive) dependency on Hooks in at least two ways:
+once through Finder, which imports Packages, which imports Hooks; but
+that's easily solved, because Finder can import PackageState
+instead. However, it is less obvious to me how to resolve the
+following import cycle
+
+- DsMonad imports tcIfaceGlobal from TcIface
+- TcIface imports (loadWiredInHomeIface, loadInterface, loadDecls,
+findAndReadIface) from LoadIface
+- LoadIFace imports Hooks
+
+(There might be still others, this is the most direct one at the moment.)
+
+(Just to be clear, Hooks imports DsMonad because it needs the DsM type
+for the dsForeignsHook.)
+
+I'm sure this cycle can be broken somehow, but I'm not familiar enough
+with this part of the compiler to see if there is a natural point to
+do it.

compiler/ghc.cabal.in

@@ -134,6 +134,7 @@ Library
         Demand
         Exception
         GhcMonad
+        Hooks
         Id
         IdInfo
         Literal
@@ -276,6 +277,7 @@ Library
         Constants
         DriverMkDepend
         DriverPhases
+        PipelineMonad
         DriverPipeline
         DynFlags
         ErrUtils

compiler/ghc.mk

@@ -445,7 +445,7 @@ compiler_stage3_SplitObjs = NO
 # We therefore need to split some of the modules off into a separate
 # DLL. This clump are the modules reachable from DynFlags:
 compiler_stage2_dll0_START_MODULE = DynFlags
-compiler_stage2_dll0_MODULES = Annotations Avail Bag BasicTypes BinIface Binary Bitmap BlockId BooleanFormula BreakArray BufWrite BuildTyCl ByteCodeAsm ByteCodeInstr ByteCodeItbls ByteCodeLink CLabel Class CmdLineParser Cmm CmmCallConv CmmExpr CmmInfo CmmMachOp CmmNode CmmType CmmUtils CoAxiom CodeGen.Platform CodeGen.Platform.ARM CodeGen.Platform.NoRegs CodeGen.Platform.PPC CodeGen.Platform.PPC_Darwin CodeGen.Platform.SPARC CodeGen.Platform.X86 CodeGen.Platform.X86_64 Coercion Config Constants CoreArity CoreFVs CoreLint CoreSubst CoreSyn CoreTidy CoreUnfold CoreUtils CostCentre DataCon Demand Digraph DriverPhases DynFlags Encoding ErrUtils Exception ExtsCompat46 FamInst FamInstEnv FastBool FastFunctions FastMutInt FastString FastTypes Finder Fingerprint FiniteMap ForeignCall Hoopl Hoopl.Dataflow HsBinds HsDecls HsDoc HsExpr HsImpExp HsLit HsPat HsSyn HsTypes HsUtils HscTypes IOEnv Id IdInfo IfaceEnv IfaceSyn IfaceType InstEnv InteractiveEvalTypes Kind ListSetOps Literal LoadIface Maybes MkCore MkGraph MkId Module MonadUtils Name NameEnv NameSet ObjLink OccName OccurAnal OptCoercion OrdList Outputable PackageConfig Packages Pair Panic Platform PlatformConstants PprCmm PprCmmDecl PprCmmExpr PprCore PrelInfo PrelNames PrelRules Pretty PrimOp RdrName Reg RegClass Rules SMRep Serialized SrcLoc StaticFlags StgCmmArgRep StgCmmClosure StgCmmEnv StgCmmLayout StgCmmMonad StgCmmProf StgCmmTicky StgCmmUtils StgSyn Stream StringBuffer TcEvidence TcIface TcMType TcRnMonad TcRnTypes TcType TcTypeNats TrieMap TyCon Type TypeRep TysPrim TysWiredIn Unify UniqFM UniqSet UniqSupply Unique Util Var VarEnv VarSet
+compiler_stage2_dll0_MODULES = Annotations Avail Bag BasicTypes BinIface Binary Bitmap BlockId BooleanFormula BreakArray BufWrite BuildTyCl ByteCodeAsm ByteCodeInstr ByteCodeItbls CLabel Class CmdLineParser Cmm CmmCallConv CmmExpr CmmInfo CmmMachOp CmmNode CmmType CmmUtils CoAxiom CodeGen.Platform CodeGen.Platform.ARM CodeGen.Platform.NoRegs CodeGen.Platform.PPC CodeGen.Platform.PPC_Darwin CodeGen.Platform.SPARC CodeGen.Platform.X86 CodeGen.Platform.X86_64 Coercion Config Constants CoreArity CoreFVs CoreLint CoreSubst CoreSyn CoreTidy CoreUnfold CoreUtils CostCentre DataCon Demand Digraph DriverPhases DsMonad DynFlags Encoding ErrUtils Exception ExtsCompat46 FamInst FamInstEnv FastBool FastFunctions FastMutInt FastString FastTypes Finder Fingerprint FiniteMap ForeignCall Hooks Hoopl Hoopl.Dataflow HsBinds HsDecls HsDoc HsExpr HsImpExp HsLit HsPat HsSyn HsTypes HsUtils HscTypes IOEnv Id IdInfo IfaceEnv IfaceSyn IfaceType InstEnv InteractiveEvalTypes Kind ListSetOps Literal LoadIface Maybes MkCore MkGraph MkId Module MonadUtils Name NameEnv NameSet OccName OccurAnal OptCoercion OrdList Outputable PackageConfig Packages Pair Panic PipelineMonad Platform PlatformConstants PprCmm PprCmmDecl PprCmmExpr PprCore PrelInfo PrelNames PrelRules Pretty PrimOp RdrName Reg RegClass Rules SMRep Serialized SrcLoc StaticFlags StgCmmArgRep StgCmmClosure StgCmmEnv StgCmmLayout StgCmmMonad StgCmmProf StgCmmTicky StgCmmUtils StgSyn Stream StringBuffer TcEvidence TcIface TcMType TcRnMonad TcRnTypes TcType TcTypeNats TrieMap TyCon Type TypeRep TysPrim TysWiredIn Unify UniqFM UniqSet UniqSupply Unique Util Var VarEnv VarSet
 
 compiler_stage2_dll0_HS_OBJS = \
     $(patsubst %,compiler/stage2/build/%.$(dyn_osuf),$(subst .,/,$(compiler_stage2_dll0_MODULES)))

compiler/ghci/ByteCodeLink.lhs

@@ -8,7 +8,6 @@ ByteCodeLink: Bytecode assembler and linker
 {-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
 
 module ByteCodeLink (
-        HValue,
         ClosureEnv, emptyClosureEnv, extendClosureEnv,
         linkBCO, lookupStaticPtr, lookupName
        ,lookupIE
@@ -21,6 +20,7 @@ import ByteCodeAsm
 import ObjLink
 
 import DynFlags
+import BasicTypes
 import Name
 import NameEnv
 import PrimOp
@@ -52,7 +52,6 @@ import GHC.Ptr          ( castPtr )
 
 \begin{code}
 type ClosureEnv = NameEnv (Name, HValue)
-newtype HValue = HValue Any
 
 emptyClosureEnv :: ClosureEnv
 emptyClosureEnv = emptyNameEnv

compiler/ghci/ByteCodeLink.lhs-boot

->module ByteCodeLink where
->
->data HValue

compiler/ghci/Linker.lhs

@@ -11,7 +11,7 @@
 {-# OPTIONS -fno-cse #-}
 -- -fno-cse is needed for GLOBAL_VAR's to behave properly
 
-module Linker ( HValue, getHValue, showLinkerState,
+module Linker ( getHValue, showLinkerState,
                 linkExpr, linkDecls, unload, withExtendedLinkEnv,
                 extendLinkEnv, deleteFromLinkEnv,
                 extendLoadedPkgs,

compiler/ghci/RtClosureInspect.hs

@@ -35,8 +35,8 @@ module RtClosureInspect(
 import DebuggerUtils
 import ByteCodeItbls    ( StgInfoTable, peekItbl )
 import qualified ByteCodeItbls as BCI( StgInfoTable(..) )
+import BasicTypes       ( HValue )
 import HscTypes
-import Linker
 
 import DataCon
 import Type

compiler/iface/LoadIface.lhs

@@ -59,6 +59,7 @@ import Panic
 import Util
 import FastString
 import Fingerprint
+import Hooks
 
 import Control.Monad
 import Data.IORef
@@ -516,7 +517,9 @@ findAndReadIface doc_str mod hi_boot_file
 
        -- Check for GHC.Prim, and return its static interface
        if mod == gHC_PRIM
-           then return (Succeeded (ghcPrimIface,
+           then do
+               iface <- getHooked ghcPrimIfaceHook ghcPrimIface
+               return (Succeeded (iface,
                                    "<built in interface for GHC.Prim>"))
            else do
                dflags <- getDynFlags

compiler/main/DriverPipeline.hs

@@ -23,17 +23,26 @@ module DriverPipeline (
    compileOne, compileOne',
    link,
 
+        -- Exports for hooks to override runPhase and link
+   PhasePlus(..), CompPipeline(..), PipeEnv(..), PipeState(..),
+   phaseOutputFilename, getPipeState, getPipeEnv,
+   hscPostBackendPhase, getLocation, setModLocation, setDynFlags,
+   runPhase, exeFileName,
+   mkExtraObjToLinkIntoBinary, mkNoteObjsToLinkIntoBinary,
+   maybeCreateManifest, runPhase_MoveBinary,
+   linkingNeeded, checkLinkInfo
   ) where
 
 #include "HsVersions.h"
 
+import PipelineMonad
 import Packages
 import HeaderInfo
 import DriverPhases
 import SysTools
 import HscMain
 import Finder
-import HscTypes
+import HscTypes hiding ( Hsc )
 import Outputable
 import Module
 import UniqFM           ( eltsUFM )
@@ -52,6 +61,7 @@ import LlvmCodeGen      ( llvmFixupAsm )
 import MonadUtils
 import Platform
 import TcRnTypes
+import Hooks
 
 import Exception
 import Data.IORef       ( readIORef )
@@ -283,23 +293,26 @@ link :: GhcLink                 -- interactive or batch
 -- exports main, i.e., we have good reason to believe that linking
 -- will succeed.
 
-link LinkInMemory _ _ _
-    = if cGhcWithInterpreter == "YES"
-      then -- Not Linking...(demand linker will do the job)
-           return Succeeded
-      else panicBadLink LinkInMemory
+link ghcLink dflags
+  = lookupHook linkHook l dflags ghcLink dflags
+  where
+    l LinkInMemory _ _ _
+      = if cGhcWithInterpreter == "YES"
+        then -- Not Linking...(demand linker will do the job)
+             return Succeeded
+        else panicBadLink LinkInMemory
 
-link NoLink _ _ _
-   = return Succeeded
+    l NoLink _ _ _
+      = return Succeeded
 
-link LinkBinary dflags batch_attempt_linking hpt
-   = link' dflags batch_attempt_linking hpt
+    l LinkBinary dflags batch_attempt_linking hpt
+      = link' dflags batch_attempt_linking hpt
 
-link LinkStaticLib dflags batch_attempt_linking hpt
-   = link' dflags batch_attempt_linking hpt
+    l LinkStaticLib dflags batch_attempt_linking hpt
+      = link' dflags batch_attempt_linking hpt
 
-link LinkDynLib dflags batch_attempt_linking hpt
-   = link' dflags batch_attempt_linking hpt
+    l LinkDynLib dflags batch_attempt_linking hpt
+      = link' dflags batch_attempt_linking hpt
 
 panicBadLink :: GhcLink -> a
 panicBadLink other = panic ("link: GHC not built to link this way: " ++
@@ -499,20 +512,6 @@ doLink dflags stop_phase o_files
 
 -- ---------------------------------------------------------------------------
 
-data PipelineOutput
-  = Temporary
-        -- ^ Output should be to a temporary file: we're going to
-        -- run more compilation steps on this output later.
-  | Persistent
-        -- ^ We want a persistent file, i.e. a file in the current directory
-        -- derived from the input filename, but with the appropriate extension.
-        -- eg. in "ghc -c Foo.hs" the output goes into ./Foo.o.
-  | SpecificFile
-        -- ^ The output must go into the specific outputFile in DynFlags.
-        -- We don't store the filename in the constructor as it changes
-        -- when doing -dynamic-too.
-    deriving Show
-
 -- | Run a compilation pipeline, consisting of multiple phases.
 --
 -- This is the interface to the compilation pipeline, which runs
@@ -615,83 +614,6 @@ runPipeline' start_phase hsc_env env input_fn
 
   evalP (pipeLoop start_phase input_fn) env state
 
--- -----------------------------------------------------------------------------
--- The pipeline uses a monad to carry around various bits of information
-
--- PipeEnv: invariant information passed down
-data PipeEnv = PipeEnv {
-       pe_isHaskellishFile :: Bool,
-       stop_phase   :: Phase,       -- ^ Stop just before this phase
-       src_filename :: String,      -- ^ basename of original input source
-       src_basename :: String,      -- ^ basename of original input source
-       src_suffix   :: String,      -- ^ its extension
-       output_spec  :: PipelineOutput -- ^ says where to put the pipeline output
-  }
-
--- PipeState: information that might change during a pipeline run
-data PipeState = PipeState {
-       hsc_env   :: HscEnv,
-          -- ^ only the DynFlags change in the HscEnv.  The DynFlags change
-          -- at various points, for example when we read the OPTIONS_GHC
-          -- pragmas in the Cpp phase.
-       maybe_loc :: Maybe ModLocation,
-          -- ^ the ModLocation.  This is discovered during compilation,
-          -- in the Hsc phase where we read the module header.
-       maybe_stub_o :: Maybe FilePath
-          -- ^ the stub object.  This is set by the Hsc phase if a stub
-          -- object was created.  The stub object will be joined with
-          -- the main compilation object using "ld -r" at the end.
-  }
-
-getPipeEnv :: CompPipeline PipeEnv
-getPipeEnv = P $ \env state -> return (state, env)
-
-getPipeState :: CompPipeline PipeState
-getPipeState = P $ \_env state -> return (state, state)
-
-instance HasDynFlags CompPipeline where
-    getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state))
-
-setDynFlags :: DynFlags -> CompPipeline ()
-setDynFlags dflags = P $ \_env state ->
-  return (state{hsc_env= (hsc_env state){ hsc_dflags = dflags }}, ())
-
-setModLocation :: ModLocation -> CompPipeline ()
-setModLocation loc = P $ \_env state ->
-  return (state{ maybe_loc = Just loc }, ())
-
-setStubO :: FilePath -> CompPipeline ()
-setStubO stub_o = P $ \_env state ->
-  return (state{ maybe_stub_o = Just stub_o }, ())
-
-newtype CompPipeline a = P { unP :: PipeEnv -> PipeState -> IO (PipeState, a) }
-
-evalP :: CompPipeline a -> PipeEnv -> PipeState -> IO a
-evalP f env st = liftM snd $ unP f env st
-
-instance Functor CompPipeline where
-    fmap = liftM
-
-instance Applicative CompPipeline where
-    pure = return
-    (<*>) = ap
-
-instance Monad CompPipeline where
-  return a = P $ \_env state -> return (state, a)
-  P m >>= k = P $ \env state -> do (state',a) <- m env state
-                                   unP (k a) env state'
-
-instance MonadIO CompPipeline where
-    liftIO m = P $ \_env state -> do a <- m; return (state, a)
-
-phaseOutputFilename :: Phase{-next phase-} -> CompPipeline FilePath
-phaseOutputFilename next_phase = do
-  PipeEnv{stop_phase, src_basename, output_spec} <- getPipeEnv
-  PipeState{maybe_loc, hsc_env} <- getPipeState
-  let dflags = hsc_dflags hsc_env
-  liftIO $ getOutputFilename stop_phase output_spec
-                             src_basename dflags next_phase maybe_loc
-
 -- ---------------------------------------------------------------------------
 -- outer pipeline loop
 
@@ -735,7 +657,7 @@ pipeLoop phase input_fn = do
    _
      -> do liftIO $ debugTraceMsg dflags 4
                                   (ptext (sLit "Running phase") <+> ppr phase)
-           (next_phase, output_fn) <- runPhase phase input_fn dflags
+           (next_phase, output_fn) <- runHookedPhase phase input_fn dflags
            r <- pipeLoop next_phase output_fn
            case phase of
                HscOut {} ->
@@ -748,11 +670,24 @@ pipeLoop phase input_fn = do
                    return ()
            return r
 
+runHookedPhase :: PhasePlus -> FilePath -> DynFlags
+               -> CompPipeline (PhasePlus, FilePath)
+runHookedPhase pp input dflags =
+  lookupHook runPhaseHook runPhase dflags pp input dflags
+
 -- -----------------------------------------------------------------------------
 -- In each phase, we need to know into what filename to generate the
 -- output.  All the logic about which filenames we generate output
 -- into is embodied in the following function.
 
+phaseOutputFilename :: Phase{-next phase-} -> CompPipeline FilePath
+phaseOutputFilename next_phase = do
+  PipeEnv{stop_phase, src_basename, output_spec} <- getPipeEnv
+  PipeState{maybe_loc, hsc_env} <- getPipeState
+  let dflags = hsc_dflags hsc_env
+  liftIO $ getOutputFilename stop_phase output_spec
+                             src_basename dflags next_phase maybe_loc
+
 getOutputFilename
   :: Phase -> PipelineOutput -> String
   -> DynFlags -> Phase{-next phase-} -> Maybe ModLocation -> IO FilePath
@@ -801,13 +736,6 @@ getOutputFilename stop_phase output basename dflags next_phase maybe_location
              | Just d <- odir = d </> persistent
              | otherwise      = persistent
 
-data PhasePlus = RealPhase Phase
-               | HscOut HscSource ModuleName HscStatus
-
-instance Outputable PhasePlus where
-    ppr (RealPhase p) = ppr p
-    ppr (HscOut {}) = text "HscOut"
-
 -- -----------------------------------------------------------------------------
 -- | Each phase in the pipeline returns the next phase to execute, and the
 -- name of the file in which the output was placed.

compiler/main/DynFlags.hs

@@ -142,6 +142,7 @@ import Platform
 import PlatformConstants
 import Module
 import PackageConfig
+import {-# SOURCE #-} Hooks
 import {-# SOURCE #-} PrelNames ( mAIN )
 import {-# SOURCE #-} Packages (PackageState)
 import DriverPhases     ( Phase(..), phaseInputExt )
@@ -671,6 +672,9 @@ data DynFlags = DynFlags {
   pluginModNames        :: [ModuleName],
   pluginModNameOpts     :: [(ModuleName,String)],
 
+  -- GHC API hooks
+  hooks                 :: Hooks,
+
   --  For ghc -M
   depMakefile           :: FilePath,
   depIncludePkgDeps     :: Bool,
@@ -1314,6 +1318,7 @@ defaultDynFlags mySettings =
 
         pluginModNames          = [],
         pluginModNameOpts       = [],
+        hooks                   = emptyHooks,
 
         outputFile              = Nothing,
         dynOutputFile           = Nothing,

compiler/main/DynamicLoading.hs

@@ -11,6 +11,7 @@ module DynamicLoading (
         
         -- * Loading values
         getValueSafely,
+        getHValueSafely,
         lessUnsafeCoerce
 #endif
     ) where
@@ -29,6 +30,7 @@ import PrelNames        ( iNTERACTIVE )
 import DynFlags
 
 import HscTypes         ( HscEnv(..), FindResult(..), ModIface(..), lookupTypeHscEnv )
+import BasicTypes       ( HValue )
 import TypeRep          ( TyThing(..), pprTyThingCategory )
 import Type             ( Type, eqType )
 import TyCon            ( TyCon )
@@ -40,6 +42,7 @@ import FastString
 import ErrUtils
 import Outputable
 import Exception
+import Hooks
 
 import Data.Maybe        ( mapMaybe )
 import GHC.Exts          ( unsafeCoerce# )
@@ -86,8 +89,18 @@ forceLoadTyCon hsc_env con_name = do
 
 getValueSafely :: HscEnv -> Name -> Type -> IO (Maybe a)
 getValueSafely hsc_env val_name expected_type = do
-    forceLoadNameModuleInterface hsc_env (ptext (sLit "contains a name used in an invocation of getValueSafely")) val_name
-    
+  mb_hval <- lookupHook getValueSafelyHook getHValueSafely dflags hsc_env val_name expected_type
+  case mb_hval of
+    Nothing   -> return Nothing
+    Just hval -> do
+      value <- lessUnsafeCoerce dflags "getValueSafely" hval
+      return (Just value)
+  where
+    dflags = hsc_dflags hsc_env
+
+getHValueSafely :: HscEnv -> Name -> Type -> IO (Maybe HValue)
+getHValueSafely hsc_env val_name expected_type = do
+    forceLoadNameModuleInterface hsc_env (ptext (sLit "contains a name used in an invocation of getHValueSafely")) val_name
     -- Now look up the names for the value and type constructor in the type environment
     mb_val_thing <- lookupTypeHscEnv hsc_env val_name
     case mb_val_thing of
@@ -104,12 +117,10 @@ getValueSafely hsc_env val_name expected_type = do
                     Nothing ->  return ()
                 -- Find the value that we just linked in and cast it given that we have proved it's type
                 hval <- getHValue hsc_env val_name
-                value <- lessUnsafeCoerce (hsc_dflags hsc_env) "getValueSafely" hval
-                return $ Just value
+                return (Just hval)
              else return Nothing
         Just val_thing -> throwCmdLineErrorS dflags $ wrongTyThingError val_name val_thing
-  where dflags = hsc_dflags hsc_env
-
+   where dflags = hsc_dflags hsc_env
 
 -- | Coerce a value as usual, but:
 --

compiler/main/GHC.hs

@@ -254,7 +254,6 @@ module GHC (
 #include "HsVersions.h"
 
 #ifdef GHCI
-import Linker           ( HValue )
 import ByteCodeInstr
 import BreakArray
 import InteractiveEval

compiler/main/Hooks.lhs

+\section[Hooks]{Low level API hooks}
+
+\begin{code}
+module Hooks ( Hooks
+             , emptyHooks
+             , lookupHook
+             , getHooked
+               -- the hooks:
+             , dsForeignsHook
+             , tcForeignImportsHook
+             , tcForeignExportsHook
+             , hscFrontendHook
+             , hscCompileOneShotHook
+             , hscCompileCoreExprHook
+             , ghcPrimIfaceHook
+             , runPhaseHook
+             , linkHook
+             , runQuasiQuoteHook
+             , getValueSafelyHook
+             ) where
+
+import DynFlags
+import HsTypes
+import Name
+import PipelineMonad
+import HscTypes
+import HsDecls
+import HsBinds
+import {-# SOURCE #-} DsMonad
+import OrdList
+import Id
+import TcRnTypes
+import Bag
+import RdrName
+import CoreSyn
+import BasicTypes
+import Type
+import SrcLoc
+
+import Data.Maybe
+\end{code}
+
+%************************************************************************
+%*                                                                      *
+\subsection{Hooks}
+%*                                                                      *
+%************************************************************************
+
+\begin{code}
+
+-- | Hooks can be used by GHC API clients to replace parts of
+--   the compiler pipeline. If a hook is not installed, GHC
+--   uses the default built-in behaviour
+
+emptyHooks :: Hooks
+emptyHooks = Hooks Nothing Nothing Nothing Nothing Nothing Nothing
+                   Nothing Nothing Nothing Nothing Nothing
+
+data Hooks = Hooks
+  { dsForeignsHook         :: Maybe ([LForeignDecl Id] -> DsM (ForeignStubs, OrdList (Id, CoreExpr)))
+  , tcForeignImportsHook   :: Maybe ([LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id], Bag GlobalRdrElt))
+  , tcForeignExportsHook   :: Maybe ([LForeignDecl Name] -> TcM (LHsBinds TcId, [LForeignDecl TcId], Bag GlobalRdrElt))
+  , hscFrontendHook        :: Maybe (ModSummary -> Hsc TcGblEnv)
+  , hscCompileOneShotHook  :: Maybe (HscEnv -> FilePath -> ModSummary -> SourceModified -> IO HscStatus)
+  , hscCompileCoreExprHook :: Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO HValue)
+  , ghcPrimIfaceHook       :: Maybe ModIface
+  , runPhaseHook           :: Maybe (PhasePlus -> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath))
+  , linkHook               :: Maybe (GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag)
+  , runQuasiQuoteHook      :: Maybe (HsQuasiQuote Name -> RnM (HsQuasiQuote Name))
+  , getValueSafelyHook     :: Maybe (HscEnv -> Name -> Type -> IO (Maybe HValue))
+  }
+
+getHooked :: (Functor f, HasDynFlags f) => (Hooks -> Maybe a) -> a -> f a
+getHooked hook def = fmap (lookupHook hook def) getDynFlags
+
+lookupHook :: (Hooks -> Maybe a) -> a -> DynFlags -> a
+lookupHook hook def = fromMaybe def . hook . hooks
+
+\end{code}
+

compiler/main/Hooks.lhs-boot

+\begin{code}
+module Hooks where
+
+data Hooks
+
+emptyHooks :: Hooks
+
+\end{code}
+

compiler/main/HscMain.hs

@@ -70,11 +70,18 @@ module HscMain
     , hscDecls, hscDeclsWithLocation
     , hscTcExpr, hscImport, hscKcType
     , hscCompileCoreExpr
+    -- * Low-level exports for hooks
+    , hscCompileCoreExpr'
 #endif
+    , hscParse', hscSimplify', hscDesugar', tcRnModule'
+    , hscSimpleIface', hscNormalIface'
+    , oneShotMsg
+    , hscFileFrontEnd, genericHscFrontend, dumpIfaceStats
     ) where
 
 #ifdef GHCI
 import Id
+import BasicTypes       ( HValue )
 import ByteCodeGen      ( byteCodeGen, coreExprToBCOs )
 import Linker
 import CoreTidy         ( tidyExpr )
@@ -128,6 +135,7 @@ import NameSet          ( emptyNameSet )
 import InstEnv
 import FamInstEnv
 import Fingerprint      ( Fingerprint )
+import Hooks
 
 import DynFlags
 import ErrUtils
@@ -190,38 +198,6 @@ knownKeyNames =              -- where templateHaskellNames are defined
 #endif
 
 -- -----------------------------------------------------------------------------
--- The Hsc monad: Passing an enviornment and warning state
-
-newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages))
-
-instance Functor Hsc where
-    fmap = liftM
-
-instance Applicative Hsc where
-    pure = return
-    (<*>) = ap
-
-instance Monad Hsc where
-    return a    = Hsc $ \_ w -> return (a, w)
-    Hsc m >>= k = Hsc $ \e w -> do (a, w1) <- m e w
-                                   case k a of
-                                       Hsc k' -> k' e w1
-
-instance MonadIO Hsc where