{-# LANGUAGE DeriveFunctor #-}
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.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 -> 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 = forall a.
(PipeEnv -> PipeState -> IO (PipeState, a)) -> CompPipeline a
P forall a b. (a -> b) -> a -> b
$ \PipeEnv
_env PipeState
state -> forall (m :: * -> *) a. Monad m => a -> m a
return (PipeState
state, a
a)
<*> :: forall a 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 = forall a.
(PipeEnv -> PipeState -> IO (PipeState, a)) -> CompPipeline a
P 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
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 = forall a.
(PipeEnv -> PipeState -> IO (PipeState, a)) -> CompPipeline a
P forall a b. (a -> b) -> a -> b
$ \PipeEnv
_env PipeState
state -> do a
a <- IO a
m; 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) = forall a. Outputable a => a -> SDoc
ppr Phase
p
ppr (HscOut {}) = String -> SDoc
text String
"HscOut"
data PipeEnv = PipeEnv {
PipeEnv -> Phase
stop_phase :: Phase,
PipeEnv -> String
src_filename :: String,
PipeEnv -> String
src_basename :: String,
PipeEnv -> String
src_suffix :: String,
PipeEnv -> PipelineOutput
output_spec :: PipelineOutput
}
data PipeState = PipeState {
PipeState -> HscEnv
hsc_env :: HscEnv,
PipeState -> Maybe ModLocation
maybe_loc :: Maybe ModLocation,
PipeState -> [String]
foreign_os :: [FilePath],
PipeState -> Maybe ModIface
iface :: Maybe ModIface
}
pipeStateDynFlags :: PipeState -> DynFlags
pipeStateDynFlags :: PipeState -> DynFlags
pipeStateDynFlags = HscEnv -> DynFlags
hsc_dflags forall b c a. (b -> c) -> (a -> b) -> a -> c
. PipeState -> HscEnv
hsc_env
pipeStateModIface :: PipeState -> Maybe ModIface
pipeStateModIface :: PipeState -> Maybe ModIface
pipeStateModIface = PipeState -> Maybe ModIface
iface
data PipelineOutput
= Temporary TempFileLifetime
| Persistent
| SpecificFile
deriving Int -> PipelineOutput -> ShowS
[PipelineOutput] -> ShowS
PipelineOutput -> String
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 = forall a.
(PipeEnv -> PipeState -> IO (PipeState, a)) -> CompPipeline a
P forall a b. (a -> b) -> a -> b
$ \PipeEnv
env PipeState
state -> forall (m :: * -> *) a. Monad m => a -> m a
return (PipeState
state, PipeEnv
env)
getPipeState :: CompPipeline PipeState
getPipeState :: CompPipeline PipeState
getPipeState = forall a.
(PipeEnv -> PipeState -> IO (PipeState, a)) -> CompPipeline a
P forall a b. (a -> b) -> a -> b
$ \PipeEnv
_env PipeState
state -> forall (m :: * -> *) a. Monad m => a -> m a
return (PipeState
state, PipeState
state)
getPipeSession :: CompPipeline HscEnv
getPipeSession :: CompPipeline HscEnv
getPipeSession = forall a.
(PipeEnv -> PipeState -> IO (PipeState, a)) -> CompPipeline a
P forall a b. (a -> b) -> a -> b
$ \PipeEnv
_env PipeState
state -> 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 = forall a.
(PipeEnv -> PipeState -> IO (PipeState, a)) -> CompPipeline a
P forall a b. (a -> b) -> a -> b
$ \PipeEnv
_env PipeState
state -> 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 = forall a.
(PipeEnv -> PipeState -> IO (PipeState, a)) -> CompPipeline a
P forall a b. (a -> b) -> a -> b
$ \PipeEnv
_env PipeState
state -> 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 = forall a.
(PipeEnv -> PipeState -> IO (PipeState, a)) -> CompPipeline a
P forall a b. (a -> b) -> a -> b
$ \PipeEnv
_env PipeState
state ->
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 = forall a.
(PipeEnv -> PipeState -> IO (PipeState, a)) -> CompPipeline a
P 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 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 = forall a.
(PipeEnv -> PipeState -> IO (PipeState, a)) -> CompPipeline a
P forall a b. (a -> b) -> a -> b
$ \PipeEnv
_env PipeState
state ->
forall (m :: * -> *) a. Monad m => a -> m a
return (PipeState
state{ maybe_loc :: Maybe ModLocation
maybe_loc = forall a. a -> Maybe a
Just ModLocation
loc }, ())
setForeignOs :: [FilePath] -> CompPipeline ()
setForeignOs :: [String] -> CompPipeline ()
setForeignOs [String]
os = forall a.
(PipeEnv -> PipeState -> IO (PipeState, a)) -> CompPipeline a
P forall a b. (a -> b) -> a -> b
$ \PipeEnv
_env PipeState
state ->
forall (m :: * -> *) a. Monad m => a -> m a
return (PipeState
state{ foreign_os :: [String]
foreign_os = [String]
os }, ())
setIface :: ModIface -> CompPipeline ()
setIface :: ModIface -> CompPipeline ()
setIface ModIface
iface = forall a.
(PipeEnv -> PipeState -> IO (PipeState, a)) -> CompPipeline a
P forall a b. (a -> b) -> a -> b
$ \PipeEnv
_env PipeState
state -> forall (m :: * -> *) a. Monad m => a -> m a
return (PipeState
state{ iface :: Maybe ModIface
iface = forall a. a -> Maybe a
Just ModIface
iface }, ())