Hooks.hs 3.34 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1
-- \section[Hooks]{Low level API hooks}
2

3 4 5 6 7
-- NB: this module is SOURCE-imported by DynFlags, and should primarily
--     refer to *types*, rather than *code*
-- If you import too muchhere , then the revolting compiler_stage2_dll0_MODULES
-- stuff in compiler/ghc.mk makes DynFlags link to too much stuff

8
{-# LANGUAGE CPP #-}
9 10 11 12 13 14 15 16 17 18 19 20
module Hooks ( Hooks
             , emptyHooks
             , lookupHook
             , getHooked
               -- the hooks:
             , dsForeignsHook
             , tcForeignImportsHook
             , tcForeignExportsHook
             , hscFrontendHook
             , hscCompileCoreExprHook
             , ghcPrimIfaceHook
             , runPhaseHook
Luite Stegeman's avatar
Luite Stegeman committed
21
             , runMetaHook
22
             , linkHook
23
             , runRnSpliceHook
24
             , getValueSafelyHook
25
             , createIservProcessHook
26 27 28 29 30 31 32 33
             ) where

import DynFlags
import Name
import PipelineMonad
import HscTypes
import HsDecls
import HsBinds
34
import HsExpr
35 36 37 38 39 40
import OrdList
import Id
import TcRnTypes
import Bag
import RdrName
import CoreSyn
41
import GHCi.RemoteTypes
42 43
import SrcLoc
import Type
44
import System.Process
45 46 47 48
import BasicTypes

import Data.Maybe

Austin Seipp's avatar
Austin Seipp committed
49 50 51
{-
************************************************************************
*                                                                      *
52
\subsection{Hooks}
Austin Seipp's avatar
Austin Seipp committed
53 54 55
*                                                                      *
************************************************************************
-}
56 57 58 59 60 61

-- | 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
62 63 64 65 66 67 68 69 70 71 72 73
emptyHooks = Hooks
  { dsForeignsHook         = Nothing
  , tcForeignImportsHook   = Nothing
  , tcForeignExportsHook   = Nothing
  , hscFrontendHook        = Nothing
  , hscCompileCoreExprHook = Nothing
  , ghcPrimIfaceHook       = Nothing
  , runPhaseHook           = Nothing
  , runMetaHook            = Nothing
  , linkHook               = Nothing
  , runRnSpliceHook        = Nothing
  , getValueSafelyHook     = Nothing
74
  , createIservProcessHook = Nothing
75
  }
76 77 78 79 80

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))
81
  , hscFrontendHook        :: Maybe (ModSummary -> Hsc FrontendResult)
82
  , hscCompileCoreExprHook :: Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue)
83 84
  , ghcPrimIfaceHook       :: Maybe ModIface
  , runPhaseHook           :: Maybe (PhasePlus -> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath))
Luite Stegeman's avatar
Luite Stegeman committed
85
  , runMetaHook            :: Maybe (MetaHook TcM)
86
  , linkHook               :: Maybe (GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag)
87
  , runRnSpliceHook        :: Maybe (HsSplice Name -> RnM (HsSplice Name))
88
  , getValueSafelyHook     :: Maybe (HscEnv -> Name -> Type -> IO (Maybe HValue))
89
  , createIservProcessHook :: Maybe (CreateProcess -> IO ProcessHandle)
90 91 92 93 94 95 96
  }

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