Commit 6f799899 authored by Austin Seipp's avatar Austin Seipp

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's avatarLuite Stegeman <stegeman@gmail.com>
Authored-by: Edsko de Vries's avatarEdsko de Vries <edsko@well-typed.com>
Signed-off-by: default avatarAustin Seipp <austin@well-typed.com>
parent ea2af9b2
......@@ -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}
......@@ -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
......
\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.
......@@ -134,6 +134,7 @@ Library
Demand
Exception
GhcMonad
Hooks
Id
IdInfo
Literal
......@@ -276,6 +277,7 @@ Library
Constants
DriverMkDepend
DriverPhases
PipelineMonad
DriverPipeline
DynFlags
ErrUtils
......
......@@ -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)))
......
......@@ -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
......
>module ByteCodeLink where
>
>data HValue
......@@ -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,
......
......@@ -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
......
......@@ -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
......
......@@ -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.
......
......@@ -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,
......
......@@ -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:
--
......
......@@ -254,7 +254,6 @@ module GHC (
#include "HsVersions.h"
#ifdef GHCI
import Linker ( HValue )
import ByteCodeInstr
import BreakArray
import InteractiveEval
......
\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}
\begin{code}
module Hooks where
data Hooks
emptyHooks :: Hooks
\end{code}
......@@ -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