-- \section[Hooks]{Low level API hooks}

-- NB: this module is SOURCE-imported by DynFlags, and should primarily
--     refer to *types*, rather than *code*

{-# LANGUAGE CPP, RankNTypes #-}

module GHC.Driver.Hooks
   ( Hooks
   , emptyHooks
   , lookupHook
   , getHooked
     -- the hooks:
   , dsForeignsHook
   , tcForeignImportsHook
   , tcForeignExportsHook
   , hscFrontendHook
   , hscCompileCoreExprHook
   , ghcPrimIfaceHook
   , runPhaseHook
   , runMetaHook
   , linkHook
   , runRnSpliceHook
   , getValueSafelyHook
   , createIservProcessHook
   , stgToCmmHook
   , cmmToRawCmmHook
   )
where

import GHC.Prelude

import GHC.Driver.Session
import GHC.Driver.Pipeline.Monad
import GHC.Driver.Types
import GHC.Hs.Decls
import GHC.Hs.Binds
import GHC.Hs.Expr
import GHC.Data.OrdList
import GHC.Tc.Types
import GHC.Data.Bag
import GHC.Types.Name.Reader
import GHC.Types.Name
import GHC.Types.Id
import GHC.Core
import GHCi.RemoteTypes
import GHC.Types.SrcLoc
import GHC.Core.Type
import System.Process
import GHC.Types.Basic
import GHC.Unit.Module
import GHC.Core.TyCon
import GHC.Types.CostCentre
import GHC.Stg.Syntax
import GHC.Data.Stream
import GHC.Cmm
import GHC.Hs.Extension
import GHC.StgToCmm.Types (ModuleLFInfos)

import Data.Maybe

{-
************************************************************************
*                                                                      *
\subsection{Hooks}
*                                                                      *
************************************************************************
-}

-- | 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
emptyHooks = Hooks :: Maybe
  ([LForeignDecl GhcTc]
   -> DsM (ForeignStubs, OrdList (Id, CoreExpr)))
-> Maybe
     ([LForeignDecl GhcRn]
      -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt))
-> Maybe
     ([LForeignDecl GhcRn]
      -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt))
-> Maybe (ModSummary -> Hsc FrontendResult)
-> Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue)
-> Maybe ModIface
-> Maybe
     (PhasePlus
      -> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath))
-> Maybe (MetaHook TcM)
-> Maybe
     (GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag)
-> Maybe (HsSplice GhcRn -> RnM (HsSplice GhcRn))
-> Maybe (HscEnv -> Name -> Type -> IO (Maybe HValue))
-> Maybe (CreateProcess -> IO ProcessHandle)
-> Maybe
     (DynFlags
      -> Module
      -> [TyCon]
      -> CollectedCCs
      -> [CgStgTopBinding]
      -> HpcInfo
      -> Stream IO CmmGroup ModuleLFInfos)
-> (forall a.
    Maybe
      (DynFlags
       -> Maybe Module
       -> Stream IO CmmGroupSRTs a
       -> IO (Stream IO RawCmmGroup a)))
-> Hooks
Hooks
  { dsForeignsHook :: Maybe
  ([LForeignDecl GhcTc]
   -> DsM (ForeignStubs, OrdList (Id, CoreExpr)))
dsForeignsHook         = Maybe
  ([LForeignDecl GhcTc]
   -> DsM (ForeignStubs, OrdList (Id, CoreExpr)))
forall a. Maybe a
Nothing
  , tcForeignImportsHook :: Maybe
  ([LForeignDecl GhcRn]
   -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt))
tcForeignImportsHook   = Maybe
  ([LForeignDecl GhcRn]
   -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt))
forall a. Maybe a
Nothing
  , tcForeignExportsHook :: Maybe
  ([LForeignDecl GhcRn]
   -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt))
tcForeignExportsHook   = Maybe
  ([LForeignDecl GhcRn]
   -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt))
forall a. Maybe a
Nothing
  , hscFrontendHook :: Maybe (ModSummary -> Hsc FrontendResult)
hscFrontendHook        = Maybe (ModSummary -> Hsc FrontendResult)
forall a. Maybe a
Nothing
  , hscCompileCoreExprHook :: Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue)
hscCompileCoreExprHook = Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue)
forall a. Maybe a
Nothing
  , ghcPrimIfaceHook :: Maybe ModIface
ghcPrimIfaceHook       = Maybe ModIface
forall a. Maybe a
Nothing
  , runPhaseHook :: Maybe
  (PhasePlus
   -> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath))
runPhaseHook           = Maybe
  (PhasePlus
   -> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath))
forall a. Maybe a
Nothing
  , runMetaHook :: Maybe (MetaHook TcM)
runMetaHook            = Maybe (MetaHook TcM)
forall a. Maybe a
Nothing
  , linkHook :: Maybe
  (GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag)
linkHook               = Maybe
  (GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag)
forall a. Maybe a
Nothing
  , runRnSpliceHook :: Maybe (HsSplice GhcRn -> RnM (HsSplice GhcRn))
runRnSpliceHook        = Maybe (HsSplice GhcRn -> RnM (HsSplice GhcRn))
forall a. Maybe a
Nothing
  , getValueSafelyHook :: Maybe (HscEnv -> Name -> Type -> IO (Maybe HValue))
getValueSafelyHook     = Maybe (HscEnv -> Name -> Type -> IO (Maybe HValue))
forall a. Maybe a
Nothing
  , createIservProcessHook :: Maybe (CreateProcess -> IO ProcessHandle)
createIservProcessHook = Maybe (CreateProcess -> IO ProcessHandle)
forall a. Maybe a
Nothing
  , stgToCmmHook :: Maybe
  (DynFlags
   -> Module
   -> [TyCon]
   -> CollectedCCs
   -> [CgStgTopBinding]
   -> HpcInfo
   -> Stream IO CmmGroup ModuleLFInfos)
stgToCmmHook           = Maybe
  (DynFlags
   -> Module
   -> [TyCon]
   -> CollectedCCs
   -> [CgStgTopBinding]
   -> HpcInfo
   -> Stream IO CmmGroup ModuleLFInfos)
forall a. Maybe a
Nothing
  , cmmToRawCmmHook :: forall a.
Maybe
  (DynFlags
   -> Maybe Module
   -> Stream IO CmmGroupSRTs a
   -> IO (Stream IO RawCmmGroup a))
cmmToRawCmmHook        = forall a. Maybe a
forall a.
Maybe
  (DynFlags
   -> Maybe Module
   -> Stream IO CmmGroupSRTs a
   -> IO (Stream IO RawCmmGroup a))
Nothing
  }

data Hooks = Hooks
  { Hooks
-> Maybe
     ([LForeignDecl GhcTc]
      -> DsM (ForeignStubs, OrdList (Id, CoreExpr)))
dsForeignsHook         :: Maybe ([LForeignDecl GhcTc]
                           -> DsM (ForeignStubs, OrdList (Id, CoreExpr)))
  , Hooks
-> Maybe
     ([LForeignDecl GhcRn]
      -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt))
tcForeignImportsHook   :: Maybe ([LForeignDecl GhcRn]
                          -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt))
  , Hooks
-> Maybe
     ([LForeignDecl GhcRn]
      -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt))
tcForeignExportsHook   :: Maybe ([LForeignDecl GhcRn]
            -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt))
  , Hooks -> Maybe (ModSummary -> Hsc FrontendResult)
hscFrontendHook        :: Maybe (ModSummary -> Hsc FrontendResult)
  , Hooks -> Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue)
hscCompileCoreExprHook ::
               Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue)
  , Hooks -> Maybe ModIface
ghcPrimIfaceHook       :: Maybe ModIface
  , Hooks
-> Maybe
     (PhasePlus
      -> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath))
runPhaseHook           :: Maybe (PhasePlus -> FilePath -> DynFlags
                                         -> CompPipeline (PhasePlus, FilePath))
  , Hooks -> Maybe (MetaHook TcM)
runMetaHook            :: Maybe (MetaHook TcM)
  , Hooks
-> Maybe
     (GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag)
linkHook               :: Maybe (GhcLink -> DynFlags -> Bool
                                         -> HomePackageTable -> IO SuccessFlag)
  , Hooks -> Maybe (HsSplice GhcRn -> RnM (HsSplice GhcRn))
runRnSpliceHook        :: Maybe (HsSplice GhcRn -> RnM (HsSplice GhcRn))
  , Hooks -> Maybe (HscEnv -> Name -> Type -> IO (Maybe HValue))
getValueSafelyHook     :: Maybe (HscEnv -> Name -> Type
                                                          -> IO (Maybe HValue))
  , Hooks -> Maybe (CreateProcess -> IO ProcessHandle)
createIservProcessHook :: Maybe (CreateProcess -> IO ProcessHandle)
  , Hooks
-> Maybe
     (DynFlags
      -> Module
      -> [TyCon]
      -> CollectedCCs
      -> [CgStgTopBinding]
      -> HpcInfo
      -> Stream IO CmmGroup ModuleLFInfos)
stgToCmmHook           :: Maybe (DynFlags -> Module -> [TyCon] -> CollectedCCs
                                 -> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup ModuleLFInfos)
  , Hooks
-> forall a.
   Maybe
     (DynFlags
      -> Maybe Module
      -> Stream IO CmmGroupSRTs a
      -> IO (Stream IO RawCmmGroup a))
cmmToRawCmmHook        :: forall a . Maybe (DynFlags -> Maybe Module -> Stream IO CmmGroupSRTs a
                                 -> IO (Stream IO RawCmmGroup a))
  }

getHooked :: (Functor f, HasDynFlags f) => (Hooks -> Maybe a) -> a -> f a
getHooked :: forall (f :: * -> *) a.
(Functor f, HasDynFlags f) =>
(Hooks -> Maybe a) -> a -> f a
getHooked Hooks -> Maybe a
hook a
def = (DynFlags -> a) -> f DynFlags -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Hooks -> Maybe a) -> a -> DynFlags -> a
forall a. (Hooks -> Maybe a) -> a -> DynFlags -> a
lookupHook Hooks -> Maybe a
hook a
def) f DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags

lookupHook :: (Hooks -> Maybe a) -> a -> DynFlags -> a
lookupHook :: forall a. (Hooks -> Maybe a) -> a -> DynFlags -> a
lookupHook Hooks -> Maybe a
hook a
def = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
def (Maybe a -> a) -> (DynFlags -> Maybe a) -> DynFlags -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hooks -> Maybe a
hook (Hooks -> Maybe a) -> (DynFlags -> Hooks) -> DynFlags -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> Hooks
hooks