Allow recursive (undecidable) superclasses
[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 return = pure
35 P m >>= k = P $ \env state -> do (state',a) <- m env state
36 unP (k a) env state'
37
38 instance MonadIO CompPipeline where
39 liftIO m = P $ \_env state -> do a <- m; return (state, a)
40
41 data PhasePlus = RealPhase Phase
42 | HscOut HscSource ModuleName HscStatus
43
44 instance Outputable PhasePlus where
45 ppr (RealPhase p) = ppr p
46 ppr (HscOut {}) = text "HscOut"
47
48 -- -----------------------------------------------------------------------------
49 -- The pipeline uses a monad to carry around various bits of information
50
51 -- PipeEnv: invariant information passed down
52 data PipeEnv = PipeEnv {
53 stop_phase :: Phase, -- ^ Stop just before this phase
54 src_filename :: String, -- ^ basename of original input source
55 src_basename :: String, -- ^ basename of original input source
56 src_suffix :: String, -- ^ its extension
57 output_spec :: PipelineOutput -- ^ says where to put the pipeline output
58 }
59
60 -- PipeState: information that might change during a pipeline run
61 data PipeState = PipeState {
62 hsc_env :: HscEnv,
63 -- ^ only the DynFlags change in the HscEnv. The DynFlags change
64 -- at various points, for example when we read the OPTIONS_GHC
65 -- pragmas in the Cpp phase.
66 maybe_loc :: Maybe ModLocation,
67 -- ^ the ModLocation. This is discovered during compilation,
68 -- in the Hsc phase where we read the module header.
69 maybe_stub_o :: Maybe FilePath
70 -- ^ the stub object. This is set by the Hsc phase if a stub
71 -- object was created. The stub object will be joined with
72 -- the main compilation object using "ld -r" at the end.
73 }
74
75 data PipelineOutput
76 = Temporary
77 -- ^ Output should be to a temporary file: we're going to
78 -- run more compilation steps on this output later.
79 | Persistent
80 -- ^ We want a persistent file, i.e. a file in the current directory
81 -- derived from the input filename, but with the appropriate extension.
82 -- eg. in "ghc -c Foo.hs" the output goes into ./Foo.o.
83 | SpecificFile
84 -- ^ The output must go into the specific outputFile in DynFlags.
85 -- We don't store the filename in the constructor as it changes
86 -- when doing -dynamic-too.
87 deriving Show
88
89 getPipeEnv :: CompPipeline PipeEnv
90 getPipeEnv = P $ \env state -> return (state, env)
91
92 getPipeState :: CompPipeline PipeState
93 getPipeState = P $ \_env state -> return (state, state)
94
95 instance HasDynFlags CompPipeline where
96 getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state))
97
98 setDynFlags :: DynFlags -> CompPipeline ()
99 setDynFlags dflags = P $ \_env state ->
100 return (state{hsc_env= (hsc_env state){ hsc_dflags = dflags }}, ())
101
102 setModLocation :: ModLocation -> CompPipeline ()
103 setModLocation loc = P $ \_env state ->
104 return (state{ maybe_loc = Just loc }, ())
105
106 setStubO :: FilePath -> CompPipeline ()
107 setStubO stub_o = P $ \_env state ->
108 return (state{ maybe_stub_o = Just stub_o }, ())