{-# LANGUAGE NamedFieldPuns #-}
-- | The CompPipeline monad and associated ops
--
-- Defined in separate module so that it can safely be imported from Hooks
module PipelineMonad (
    CompPipeline(..), evalP
  , PhasePlus(..)
  , PipeEnv(..), PipeState(..), PipelineOutput(..)
  , getPipeEnv, getPipeState, setDynFlags, setModLocation, setForeignOs
  ) 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) }

evalP :: CompPipeline a -> PipeEnv -> PipeState -> IO a
evalP :: CompPipeline a -> PipeEnv -> PipeState -> IO a
evalP CompPipeline a
f PipeEnv
env PipeState
st = ((PipeState, a) -> a) -> IO (PipeState, a) -> IO a
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (PipeState, a) -> a
forall a b. (a, b) -> b
snd (IO (PipeState, a) -> IO a) -> IO (PipeState, a) -> IO a
forall a b. (a -> b) -> a -> b
$ CompPipeline a -> PipeEnv -> PipeState -> IO (PipeState, a)
forall a.
CompPipeline a -> PipeEnv -> PipeState -> IO (PipeState, a)
unP CompPipeline a
f PipeEnv
env PipeState
st

instance Functor CompPipeline where
    fmap :: (a -> b) -> CompPipeline a -> CompPipeline b
fmap = (a -> b) -> CompPipeline a -> CompPipeline b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

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"

-- -----------------------------------------------------------------------------
-- 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 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
  }

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)

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 }, ())