{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE NamedFieldPuns #-}
module PipelineMonad (
CompPipeline(..), evalP
, PhasePlus(..)
, PipeEnv(..), PipeState(..), PipelineOutput(..)
, getPipeEnv, getPipeState, setDynFlags, setModLocation, setForeignOs, setIface
, pipeStateDynFlags, pipeStateModIface
) where
import GhcPrelude
import MonadUtils
import Outputable
import DynFlags
import DriverPhases
import HscTypes
import Module
import FileCleanup (TempFileLifetime)
import Control.Monad
newtype CompPipeline a = P { CompPipeline a -> PipeEnv -> PipeState -> IO (PipeState, a)
unP :: PipeEnv -> PipeState -> IO (PipeState, a) }
deriving (a -> CompPipeline b -> CompPipeline a
(a -> b) -> CompPipeline a -> CompPipeline b
(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
<$ :: a -> CompPipeline b -> CompPipeline a
$c<$ :: forall a b. a -> CompPipeline b -> CompPipeline a
fmap :: (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 :: 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 :: 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)
<*> :: 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 >>= :: 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 :: 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"
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 (HscEnv -> DynFlags)
-> (PipeState -> HscEnv) -> PipeState -> DynFlags
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
(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)
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))
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 }}, ())
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 -> CompPipeline ()
setIface :: ModIface -> CompPipeline ()
setIface ModIface
iface = (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
iface = ModIface -> Maybe ModIface
forall a. a -> Maybe a
Just ModIface
iface }, ())