{-# LANGUAGE DeriveFunctor #-}
-- | The CompPipeline monad and associated ops
--
-- Defined in separate module so that it can safely be imported from Hooks
module GHC.Driver.Pipeline.Monad (
    CompPipeline(..), evalP
  , PhasePlus(..)
  , PipeEnv(..), PipeState(..), PipelineOutput(..)
  , getPipeEnv, getPipeState, getPipeSession
  , setDynFlags, setModLocation, setForeignOs, setIface
  , pipeStateDynFlags, pipeStateModIface, setPlugins
  ) where

import GHC.Prelude

import GHC.Utils.Monad
import GHC.Utils.Outputable
import GHC.Utils.Logger

import GHC.Driver.Session
import GHC.Driver.Phases
import GHC.Driver.Env
import GHC.Driver.Plugins

import GHC.Utils.TmpFs (TempFileLifetime)

import GHC.Types.SourceFile

import GHC.Unit.Module
import GHC.Unit.Module.ModDetails
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.Status

import Control.Monad

newtype CompPipeline a = P { forall a.
CompPipeline a -> PipeEnv -> PipeState -> IO (PipeState, a)
unP :: PipeEnv -> PipeState -> IO (PipeState, a) }
    deriving ((forall a b. (a -> b) -> CompPipeline a -> CompPipeline b)
-> (forall a b. a -> CompPipeline b -> CompPipeline a)
-> Functor CompPipeline
forall a b. a -> CompPipeline b -> CompPipeline a
forall a b. (a -> b) -> CompPipeline a -> CompPipeline b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> CompPipeline b -> CompPipeline a
$c<$ :: forall a b. a -> CompPipeline b -> CompPipeline a
fmap :: forall a b. (a -> b) -> CompPipeline a -> CompPipeline b
$cfmap :: forall a b. (a -> b) -> CompPipeline a -> CompPipeline b
Functor)

evalP :: CompPipeline a -> PipeEnv -> PipeState -> IO (PipeState, a)
evalP :: forall a.
CompPipeline a -> PipeEnv -> PipeState -> IO (PipeState, a)
evalP (P PipeEnv -> PipeState -> IO (PipeState, a)
f) PipeEnv
env PipeState
st = PipeEnv -> PipeState -> IO (PipeState, a)
f PipeEnv
env PipeState
st

instance Applicative CompPipeline where
    pure :: forall a. a -> CompPipeline a
pure a
a = (PipeEnv -> PipeState -> IO (PipeState, a)) -> CompPipeline a
forall a.
(PipeEnv -> PipeState -> IO (PipeState, a)) -> CompPipeline a
P ((PipeEnv -> PipeState -> IO (PipeState, a)) -> CompPipeline a)
-> (PipeEnv -> PipeState -> IO (PipeState, a)) -> CompPipeline a
forall a b. (a -> b) -> a -> b
$ \PipeEnv
_env PipeState
state -> (PipeState, a) -> IO (PipeState, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (PipeState
state, a
a)
    <*> :: forall a b.
CompPipeline (a -> b) -> CompPipeline a -> CompPipeline b
(<*>) = CompPipeline (a -> b) -> CompPipeline a -> CompPipeline b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad CompPipeline where
  P PipeEnv -> PipeState -> IO (PipeState, a)
m >>= :: forall a b.
CompPipeline a -> (a -> CompPipeline b) -> CompPipeline b
>>= a -> CompPipeline b
k = (PipeEnv -> PipeState -> IO (PipeState, b)) -> CompPipeline b
forall a.
(PipeEnv -> PipeState -> IO (PipeState, a)) -> CompPipeline a
P ((PipeEnv -> PipeState -> IO (PipeState, b)) -> CompPipeline b)
-> (PipeEnv -> PipeState -> IO (PipeState, b)) -> CompPipeline b
forall a b. (a -> b) -> a -> b
$ \PipeEnv
env PipeState
state -> do (PipeState
state',a
a) <- PipeEnv -> PipeState -> IO (PipeState, a)
m PipeEnv
env PipeState
state
                                   CompPipeline b -> PipeEnv -> PipeState -> IO (PipeState, b)
forall a.
CompPipeline a -> PipeEnv -> PipeState -> IO (PipeState, a)
unP (a -> CompPipeline b
k a
a) PipeEnv
env PipeState
state'

instance MonadIO CompPipeline where
    liftIO :: forall a. IO a -> CompPipeline a
liftIO IO a
m = (PipeEnv -> PipeState -> IO (PipeState, a)) -> CompPipeline a
forall a.
(PipeEnv -> PipeState -> IO (PipeState, a)) -> CompPipeline a
P ((PipeEnv -> PipeState -> IO (PipeState, a)) -> CompPipeline a)
-> (PipeEnv -> PipeState -> IO (PipeState, a)) -> CompPipeline a
forall a b. (a -> b) -> a -> b
$ \PipeEnv
_env PipeState
state -> do a
a <- IO a
m; (PipeState, a) -> IO (PipeState, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (PipeState
state, a
a)

data PhasePlus = RealPhase Phase
               | HscOut HscSource ModuleName HscStatus

instance Outputable PhasePlus where
    ppr :: PhasePlus -> SDoc
ppr (RealPhase Phase
p) = Phase -> SDoc
forall a. Outputable a => a -> SDoc
ppr Phase
p
    ppr (HscOut {}) = String -> SDoc
text String
"HscOut"

-- -----------------------------------------------------------------------------
-- The pipeline uses a monad to carry around various bits of information

-- PipeEnv: invariant information passed down
data PipeEnv = PipeEnv {
       PipeEnv -> Phase
stop_phase   :: Phase,       -- ^ Stop just before this phase
       PipeEnv -> String
src_filename :: String,      -- ^ basename of original input source
       PipeEnv -> String
src_basename :: String,      -- ^ basename of original input source
       PipeEnv -> String
src_suffix   :: String,      -- ^ its extension
       PipeEnv -> PipelineOutput
output_spec  :: PipelineOutput -- ^ says where to put the pipeline output
  }

-- PipeState: information that might change during a pipeline run
data PipeState = PipeState {
       PipeState -> HscEnv
hsc_env   :: HscEnv,
          -- ^ only the DynFlags and the Plugins change in the HscEnv.  The
          -- DynFlags change at various points, for example when we read the
          -- OPTIONS_GHC pragmas in the Cpp phase.
       PipeState -> Maybe ModLocation
maybe_loc :: Maybe ModLocation,
          -- ^ the ModLocation.  This is discovered during compilation,
          -- in the Hsc phase where we read the module header.
       PipeState -> [String]
foreign_os :: [FilePath],
         -- ^ additional object files resulting from compiling foreign
         -- code. They come from two sources: foreign stubs, and
         -- add{C,Cxx,Objc,Objcxx}File from template haskell
       PipeState -> Maybe (ModIface, ModDetails)
iface :: Maybe (ModIface, ModDetails)
         -- ^ Interface generated by HscOut phase. Only available after the
         -- phase runs.
  }

pipeStateDynFlags :: PipeState -> DynFlags
pipeStateDynFlags :: PipeState -> DynFlags
pipeStateDynFlags = HscEnv -> DynFlags
hsc_dflags (HscEnv -> DynFlags)
-> (PipeState -> HscEnv) -> PipeState -> DynFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PipeState -> HscEnv
hsc_env

pipeStateModIface :: PipeState -> Maybe (ModIface, ModDetails)
pipeStateModIface :: PipeState -> Maybe (ModIface, ModDetails)
pipeStateModIface = PipeState -> Maybe (ModIface, ModDetails)
iface

data PipelineOutput
  = Temporary TempFileLifetime
        -- ^ 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 Int -> PipelineOutput -> ShowS
[PipelineOutput] -> ShowS
PipelineOutput -> String
(Int -> PipelineOutput -> ShowS)
-> (PipelineOutput -> String)
-> ([PipelineOutput] -> ShowS)
-> Show PipelineOutput
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PipelineOutput] -> ShowS
$cshowList :: [PipelineOutput] -> ShowS
show :: PipelineOutput -> String
$cshow :: PipelineOutput -> String
showsPrec :: Int -> PipelineOutput -> ShowS
$cshowsPrec :: Int -> PipelineOutput -> ShowS
Show

getPipeEnv :: CompPipeline PipeEnv
getPipeEnv :: CompPipeline PipeEnv
getPipeEnv = (PipeEnv -> PipeState -> IO (PipeState, PipeEnv))
-> CompPipeline PipeEnv
forall a.
(PipeEnv -> PipeState -> IO (PipeState, a)) -> CompPipeline a
P ((PipeEnv -> PipeState -> IO (PipeState, PipeEnv))
 -> CompPipeline PipeEnv)
-> (PipeEnv -> PipeState -> IO (PipeState, PipeEnv))
-> CompPipeline PipeEnv
forall a b. (a -> b) -> a -> b
$ \PipeEnv
env PipeState
state -> (PipeState, PipeEnv) -> IO (PipeState, PipeEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (PipeState
state, PipeEnv
env)

getPipeState :: CompPipeline PipeState
getPipeState :: CompPipeline PipeState
getPipeState = (PipeEnv -> PipeState -> IO (PipeState, PipeState))
-> CompPipeline PipeState
forall a.
(PipeEnv -> PipeState -> IO (PipeState, a)) -> CompPipeline a
P ((PipeEnv -> PipeState -> IO (PipeState, PipeState))
 -> CompPipeline PipeState)
-> (PipeEnv -> PipeState -> IO (PipeState, PipeState))
-> CompPipeline PipeState
forall a b. (a -> b) -> a -> b
$ \PipeEnv
_env PipeState
state -> (PipeState, PipeState) -> IO (PipeState, PipeState)
forall (m :: * -> *) a. Monad m => a -> m a
return (PipeState
state, PipeState
state)

getPipeSession :: CompPipeline HscEnv
getPipeSession :: CompPipeline HscEnv
getPipeSession = (PipeEnv -> PipeState -> IO (PipeState, HscEnv))
-> CompPipeline HscEnv
forall a.
(PipeEnv -> PipeState -> IO (PipeState, a)) -> CompPipeline a
P ((PipeEnv -> PipeState -> IO (PipeState, HscEnv))
 -> CompPipeline HscEnv)
-> (PipeEnv -> PipeState -> IO (PipeState, HscEnv))
-> CompPipeline HscEnv
forall a b. (a -> b) -> a -> b
$ \PipeEnv
_env PipeState
state -> (PipeState, HscEnv) -> IO (PipeState, HscEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (PipeState
state, PipeState -> HscEnv
hsc_env PipeState
state)

instance HasDynFlags CompPipeline where
    getDynFlags :: CompPipeline DynFlags
getDynFlags = (PipeEnv -> PipeState -> IO (PipeState, DynFlags))
-> CompPipeline DynFlags
forall a.
(PipeEnv -> PipeState -> IO (PipeState, a)) -> CompPipeline a
P ((PipeEnv -> PipeState -> IO (PipeState, DynFlags))
 -> CompPipeline DynFlags)
-> (PipeEnv -> PipeState -> IO (PipeState, DynFlags))
-> CompPipeline DynFlags
forall a b. (a -> b) -> a -> b
$ \PipeEnv
_env PipeState
state -> (PipeState, DynFlags) -> IO (PipeState, DynFlags)
forall (m :: * -> *) a. Monad m => a -> m a
return (PipeState
state, HscEnv -> DynFlags
hsc_dflags (PipeState -> HscEnv
hsc_env PipeState
state))

instance HasLogger CompPipeline where
    getLogger :: CompPipeline Logger
getLogger = (PipeEnv -> PipeState -> IO (PipeState, Logger))
-> CompPipeline Logger
forall a.
(PipeEnv -> PipeState -> IO (PipeState, a)) -> CompPipeline a
P ((PipeEnv -> PipeState -> IO (PipeState, Logger))
 -> CompPipeline Logger)
-> (PipeEnv -> PipeState -> IO (PipeState, Logger))
-> CompPipeline Logger
forall a b. (a -> b) -> a -> b
$ \PipeEnv
_env PipeState
state -> (PipeState, Logger) -> IO (PipeState, Logger)
forall (m :: * -> *) a. Monad m => a -> m a
return (PipeState
state, HscEnv -> Logger
hsc_logger (PipeState -> HscEnv
hsc_env PipeState
state))

setDynFlags :: DynFlags -> CompPipeline ()
setDynFlags :: DynFlags -> CompPipeline ()
setDynFlags DynFlags
dflags = (PipeEnv -> PipeState -> IO (PipeState, ())) -> CompPipeline ()
forall a.
(PipeEnv -> PipeState -> IO (PipeState, a)) -> CompPipeline a
P ((PipeEnv -> PipeState -> IO (PipeState, ())) -> CompPipeline ())
-> (PipeEnv -> PipeState -> IO (PipeState, ())) -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ \PipeEnv
_env PipeState
state ->
  (PipeState, ()) -> IO (PipeState, ())
forall (m :: * -> *) a. Monad m => a -> m a
return (PipeState
state{hsc_env :: HscEnv
hsc_env= (PipeState -> HscEnv
hsc_env PipeState
state){ hsc_dflags :: DynFlags
hsc_dflags = DynFlags
dflags }}, ())

setPlugins :: [LoadedPlugin] -> [StaticPlugin] -> CompPipeline ()
setPlugins :: [LoadedPlugin] -> [StaticPlugin] -> CompPipeline ()
setPlugins [LoadedPlugin]
dyn [StaticPlugin]
static = (PipeEnv -> PipeState -> IO (PipeState, ())) -> CompPipeline ()
forall a.
(PipeEnv -> PipeState -> IO (PipeState, a)) -> CompPipeline a
P ((PipeEnv -> PipeState -> IO (PipeState, ())) -> CompPipeline ())
-> (PipeEnv -> PipeState -> IO (PipeState, ())) -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ \PipeEnv
_env PipeState
state ->
  let hsc_env' :: HscEnv
hsc_env' = (PipeState -> HscEnv
hsc_env PipeState
state){ hsc_plugins :: [LoadedPlugin]
hsc_plugins = [LoadedPlugin]
dyn, hsc_static_plugins :: [StaticPlugin]
hsc_static_plugins = [StaticPlugin]
static }
  in (PipeState, ()) -> IO (PipeState, ())
forall (m :: * -> *) a. Monad m => a -> m a
return (PipeState
state{hsc_env :: HscEnv
hsc_env = HscEnv
hsc_env'}, ())

setModLocation :: ModLocation -> CompPipeline ()
setModLocation :: ModLocation -> CompPipeline ()
setModLocation ModLocation
loc = (PipeEnv -> PipeState -> IO (PipeState, ())) -> CompPipeline ()
forall a.
(PipeEnv -> PipeState -> IO (PipeState, a)) -> CompPipeline a
P ((PipeEnv -> PipeState -> IO (PipeState, ())) -> CompPipeline ())
-> (PipeEnv -> PipeState -> IO (PipeState, ())) -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ \PipeEnv
_env PipeState
state ->
  (PipeState, ()) -> IO (PipeState, ())
forall (m :: * -> *) a. Monad m => a -> m a
return (PipeState
state{ maybe_loc :: Maybe ModLocation
maybe_loc = ModLocation -> Maybe ModLocation
forall a. a -> Maybe a
Just ModLocation
loc }, ())

setForeignOs :: [FilePath] -> CompPipeline ()
setForeignOs :: [String] -> CompPipeline ()
setForeignOs [String]
os = (PipeEnv -> PipeState -> IO (PipeState, ())) -> CompPipeline ()
forall a.
(PipeEnv -> PipeState -> IO (PipeState, a)) -> CompPipeline a
P ((PipeEnv -> PipeState -> IO (PipeState, ())) -> CompPipeline ())
-> (PipeEnv -> PipeState -> IO (PipeState, ())) -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ \PipeEnv
_env PipeState
state ->
  (PipeState, ()) -> IO (PipeState, ())
forall (m :: * -> *) a. Monad m => a -> m a
return (PipeState
state{ foreign_os :: [String]
foreign_os = [String]
os }, ())

setIface :: ModIface -> ModDetails -> CompPipeline ()
setIface :: ModIface -> ModDetails -> CompPipeline ()
setIface ModIface
iface ModDetails
details = (PipeEnv -> PipeState -> IO (PipeState, ())) -> CompPipeline ()
forall a.
(PipeEnv -> PipeState -> IO (PipeState, a)) -> CompPipeline a
P ((PipeEnv -> PipeState -> IO (PipeState, ())) -> CompPipeline ())
-> (PipeEnv -> PipeState -> IO (PipeState, ())) -> CompPipeline ()
forall a b. (a -> b) -> a -> b
$ \PipeEnv
_env PipeState
state -> (PipeState, ()) -> IO (PipeState, ())
forall (m :: * -> *) a. Monad m => a -> m a
return (PipeState
state{ iface :: Maybe (ModIface, ModDetails)
iface = (ModIface, ModDetails) -> Maybe (ModIface, ModDetails)
forall a. a -> Maybe a
Just (ModIface
iface, ModDetails
details) }, ())