module PipelineMonad (
CompPipeline(..), evalP
, PhasePlus(..)
, PipeEnv(..), PipeState(..), PipelineOutput(..)
, getPipeEnv, getPipeState, setDynFlags, setModLocation, setStubO
) where
import MonadUtils
import Outputable
import DynFlags
import DriverPhases
import HscTypes
import Module
import Control.Monad
newtype CompPipeline a = P { unP :: PipeEnv -> PipeState -> IO (PipeState, a) }
evalP :: CompPipeline a -> PipeEnv -> PipeState -> IO a
evalP f env st = liftM snd $ unP f env st
instance Functor CompPipeline where
fmap = liftM
instance Applicative CompPipeline where
pure = return
(<*>) = ap
instance Monad CompPipeline where
return a = P $ \_env state -> return (state, a)
P m >>= k = P $ \env state -> do (state',a) <- m env state
unP (k a) env state'
instance MonadIO CompPipeline where
liftIO m = P $ \_env state -> do a <- m; return (state, a)
data PhasePlus = RealPhase Phase
| HscOut HscSource ModuleName HscStatus
instance Outputable PhasePlus where
ppr (RealPhase p) = ppr p
ppr (HscOut {}) = text "HscOut"
data PipeEnv = PipeEnv {
pe_isHaskellishFile :: Bool,
stop_phase :: Phase,
src_filename :: String,
src_basename :: String,
src_suffix :: String,
output_spec :: PipelineOutput
}
data PipeState = PipeState {
hsc_env :: HscEnv,
maybe_loc :: Maybe ModLocation,
maybe_stub_o :: Maybe FilePath
}
data PipelineOutput
= Temporary
| Persistent
| SpecificFile
deriving Show
getPipeEnv :: CompPipeline PipeEnv
getPipeEnv = P $ \env state -> return (state, env)
getPipeState :: CompPipeline PipeState
getPipeState = P $ \_env state -> return (state, state)
instance HasDynFlags CompPipeline where
getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state))
setDynFlags :: DynFlags -> CompPipeline ()
setDynFlags dflags = P $ \_env state ->
return (state{hsc_env= (hsc_env state){ hsc_dflags = dflags }}, ())
setModLocation :: ModLocation -> CompPipeline ()
setModLocation loc = P $ \_env state ->
return (state{ maybe_loc = Just loc }, ())
setStubO :: FilePath -> CompPipeline ()
setStubO stub_o = P $ \_env state ->
return (state{ maybe_stub_o = Just stub_o }, ())