Add some commented-out tracing in SpecConstr
[ghc.git] / compiler / main / PipelineMonad.hs
1 {-# LANGUAGE NamedFieldPuns #-}
2 -- | The CompPipeline monad and associated ops
3 --
4 -- Defined in separate module so that it can safely be imported from Hooks
5 module PipelineMonad (
6 CompPipeline(..), evalP
7 , PhasePlus(..)
8 , PipeEnv(..), PipeState(..), PipelineOutput(..)
9 , getPipeEnv, getPipeState, setDynFlags, setModLocation, setStubO
10 ) where
11
12 import MonadUtils
13 import Outputable
14 import DynFlags
15 import DriverPhases
16 import HscTypes
17 import Module
18
19 import Control.Monad
20
21 newtype CompPipeline a = P { unP :: PipeEnv -> PipeState -> IO (PipeState, a) }
22
23 evalP :: CompPipeline a -> PipeEnv -> PipeState -> IO a
24 evalP f env st = liftM snd $ unP f env st
25
26 instance Functor CompPipeline where
27 fmap = liftM
28
29 instance Applicative CompPipeline where
30 pure a = P $ \_env state -> return (state, a)
31 (<*>) = ap
32
33 instance Monad CompPipeline where
34 P m >>= k = P $ \env state -> do (state',a) <- m env state
35 unP (k a) env state'
36
37 instance MonadIO CompPipeline where
38 liftIO m = P $ \_env state -> do a <- m; return (state, a)
39
40 data PhasePlus = RealPhase Phase
41 | HscOut HscSource ModuleName HscStatus
42
43 instance Outputable PhasePlus where
44 ppr (RealPhase p) = ppr p
45 ppr (HscOut {}) = text "HscOut"
46
47 -- -----------------------------------------------------------------------------
48 -- The pipeline uses a monad to carry around various bits of information
49
50 -- PipeEnv: invariant information passed down
51 data PipeEnv = PipeEnv {
52 stop_phase :: Phase, -- ^ Stop just before this phase
53 src_filename :: String, -- ^ basename of original input source
54 src_basename :: String, -- ^ basename of original input source
55 src_suffix :: String, -- ^ its extension
56 output_spec :: PipelineOutput -- ^ says where to put the pipeline output
57 }
58
59 -- PipeState: information that might change during a pipeline run
60 data PipeState = PipeState {
61 hsc_env :: HscEnv,
62 -- ^ only the DynFlags change in the HscEnv. The DynFlags change
63 -- at various points, for example when we read the OPTIONS_GHC
64 -- pragmas in the Cpp phase.
65 maybe_loc :: Maybe ModLocation,
66 -- ^ the ModLocation. This is discovered during compilation,
67 -- in the Hsc phase where we read the module header.
68 maybe_stub_o :: Maybe FilePath
69 -- ^ the stub object. This is set by the Hsc phase if a stub
70 -- object was created. The stub object will be joined with
71 -- the main compilation object using "ld -r" at the end.
72 }
73
74 data PipelineOutput
75 = Temporary
76 -- ^ Output should be to a temporary file: we're going to
77 -- run more compilation steps on this output later.
78 | Persistent
79 -- ^ We want a persistent file, i.e. a file in the current directory
80 -- derived from the input filename, but with the appropriate extension.
81 -- eg. in "ghc -c Foo.hs" the output goes into ./Foo.o.
82 | SpecificFile
83 -- ^ The output must go into the specific outputFile in DynFlags.
84 -- We don't store the filename in the constructor as it changes
85 -- when doing -dynamic-too.
86 deriving Show
87
88 getPipeEnv :: CompPipeline PipeEnv
89 getPipeEnv = P $ \env state -> return (state, env)
90
91 getPipeState :: CompPipeline PipeState
92 getPipeState = P $ \_env state -> return (state, state)
93
94 instance HasDynFlags CompPipeline where
95 getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state))
96
97 setDynFlags :: DynFlags -> CompPipeline ()
98 setDynFlags dflags = P $ \_env state ->
99 return (state{hsc_env= (hsc_env state){ hsc_dflags = dflags }}, ())
100
101 setModLocation :: ModLocation -> CompPipeline ()
102 setModLocation loc = P $ \_env state ->
103 return (state{ maybe_loc = Just loc }, ())
104
105 setStubO :: FilePath -> CompPipeline ()
106 setStubO stub_o = P $ \_env state ->
107 return (state{ maybe_stub_o = Just stub_o }, ())