driver: use PROGBITS type for .debug-ghc-link-info section
[ghc.git] / compiler / main / GhcMonad.hs
1 {-# LANGUAGE CPP, RankNTypes #-}
2 {-# OPTIONS_GHC -funbox-strict-fields #-}
3 -- -----------------------------------------------------------------------------
4 --
5 -- (c) The University of Glasgow, 2010
6 --
7 -- The Session type and related functionality
8 --
9 -- -----------------------------------------------------------------------------
10
11 module GhcMonad (
12 -- * 'Ghc' monad stuff
13 GhcMonad(..),
14 Ghc(..),
15 GhcT(..), liftGhcT,
16 reflectGhc, reifyGhc,
17 getSessionDynFlags,
18 liftIO,
19 Session(..), withSession, modifySession, withTempSession,
20
21 -- ** Warnings
22 logWarnings, printException,
23 WarnErrLogger, defaultWarnErrLogger
24 ) where
25
26 import MonadUtils
27 import HscTypes
28 import DynFlags
29 import Exception
30 import ErrUtils
31
32 import Data.IORef
33
34 -- -----------------------------------------------------------------------------
35 -- | A monad that has all the features needed by GHC API calls.
36 --
37 -- In short, a GHC monad
38 --
39 -- - allows embedding of IO actions,
40 --
41 -- - can log warnings,
42 --
43 -- - allows handling of (extensible) exceptions, and
44 --
45 -- - maintains a current session.
46 --
47 -- If you do not use 'Ghc' or 'GhcT', make sure to call 'GHC.initGhcMonad'
48 -- before any call to the GHC API functions can occur.
49 --
50 class (Functor m, MonadIO m, ExceptionMonad m, HasDynFlags m) => GhcMonad m where
51 getSession :: m HscEnv
52 setSession :: HscEnv -> m ()
53
54 -- | Call the argument with the current session.
55 withSession :: GhcMonad m => (HscEnv -> m a) -> m a
56 withSession f = getSession >>= f
57
58 -- | Grabs the DynFlags from the Session
59 getSessionDynFlags :: GhcMonad m => m DynFlags
60 getSessionDynFlags = withSession (return . hsc_dflags)
61
62 -- | Set the current session to the result of applying the current session to
63 -- the argument.
64 modifySession :: GhcMonad m => (HscEnv -> HscEnv) -> m ()
65 modifySession f = do h <- getSession
66 setSession $! f h
67
68 withSavedSession :: GhcMonad m => m a -> m a
69 withSavedSession m = do
70 saved_session <- getSession
71 m `gfinally` setSession saved_session
72
73 -- | Call an action with a temporarily modified Session.
74 withTempSession :: GhcMonad m => (HscEnv -> HscEnv) -> m a -> m a
75 withTempSession f m =
76 withSavedSession $ modifySession f >> m
77
78 -- -----------------------------------------------------------------------------
79 -- | A monad that allows logging of warnings.
80
81 logWarnings :: GhcMonad m => WarningMessages -> m ()
82 logWarnings warns = do
83 dflags <- getSessionDynFlags
84 liftIO $ printOrThrowWarnings dflags warns
85
86 -- -----------------------------------------------------------------------------
87 -- | A minimal implementation of a 'GhcMonad'. If you need a custom monad,
88 -- e.g., to maintain additional state consider wrapping this monad or using
89 -- 'GhcT'.
90 newtype Ghc a = Ghc { unGhc :: Session -> IO a }
91
92 -- | The Session is a handle to the complete state of a compilation
93 -- session. A compilation session consists of a set of modules
94 -- constituting the current program or library, the context for
95 -- interactive evaluation, and various caches.
96 data Session = Session !(IORef HscEnv)
97
98 instance Functor Ghc where
99 fmap f m = Ghc $ \s -> f `fmap` unGhc m s
100
101 instance Applicative Ghc where
102 pure a = Ghc $ \_ -> return a
103 g <*> m = do f <- g; a <- m; return (f a)
104
105 instance Monad Ghc where
106 return = pure
107 m >>= g = Ghc $ \s -> do a <- unGhc m s; unGhc (g a) s
108
109 instance MonadIO Ghc where
110 liftIO ioA = Ghc $ \_ -> ioA
111
112 instance MonadFix Ghc where
113 mfix f = Ghc $ \s -> mfix (\x -> unGhc (f x) s)
114
115 instance ExceptionMonad Ghc where
116 gcatch act handle =
117 Ghc $ \s -> unGhc act s `gcatch` \e -> unGhc (handle e) s
118 gmask f =
119 Ghc $ \s -> gmask $ \io_restore ->
120 let
121 g_restore (Ghc m) = Ghc $ \s -> io_restore (m s)
122 in
123 unGhc (f g_restore) s
124
125 instance HasDynFlags Ghc where
126 getDynFlags = getSessionDynFlags
127
128 instance GhcMonad Ghc where
129 getSession = Ghc $ \(Session r) -> readIORef r
130 setSession s' = Ghc $ \(Session r) -> writeIORef r s'
131
132 -- | Reflect a computation in the 'Ghc' monad into the 'IO' monad.
133 --
134 -- You can use this to call functions returning an action in the 'Ghc' monad
135 -- inside an 'IO' action. This is needed for some (too restrictive) callback
136 -- arguments of some library functions:
137 --
138 -- > libFunc :: String -> (Int -> IO a) -> IO a
139 -- > ghcFunc :: Int -> Ghc a
140 -- >
141 -- > ghcFuncUsingLibFunc :: String -> Ghc a -> Ghc a
142 -- > ghcFuncUsingLibFunc str =
143 -- > reifyGhc $ \s ->
144 -- > libFunc $ \i -> do
145 -- > reflectGhc (ghcFunc i) s
146 --
147 reflectGhc :: Ghc a -> Session -> IO a
148 reflectGhc m = unGhc m
149
150 -- > Dual to 'reflectGhc'. See its documentation.
151 reifyGhc :: (Session -> IO a) -> Ghc a
152 reifyGhc act = Ghc $ act
153
154 -- -----------------------------------------------------------------------------
155 -- | A monad transformer to add GHC specific features to another monad.
156 --
157 -- Note that the wrapped monad must support IO and handling of exceptions.
158 newtype GhcT m a = GhcT { unGhcT :: Session -> m a }
159
160 liftGhcT :: m a -> GhcT m a
161 liftGhcT m = GhcT $ \_ -> m
162
163 instance Functor m => Functor (GhcT m) where
164 fmap f m = GhcT $ \s -> f `fmap` unGhcT m s
165
166 instance Applicative m => Applicative (GhcT m) where
167 pure x = GhcT $ \_ -> pure x
168 g <*> m = GhcT $ \s -> unGhcT g s <*> unGhcT m s
169
170 instance (Applicative m, Monad m) => Monad (GhcT m) where
171 return = pure
172 m >>= k = GhcT $ \s -> do a <- unGhcT m s; unGhcT (k a) s
173
174 instance (Applicative m, MonadIO m) => MonadIO (GhcT m) where
175 liftIO ioA = GhcT $ \_ -> liftIO ioA
176
177 instance ExceptionMonad m => ExceptionMonad (GhcT m) where
178 gcatch act handle =
179 GhcT $ \s -> unGhcT act s `gcatch` \e -> unGhcT (handle e) s
180 gmask f =
181 GhcT $ \s -> gmask $ \io_restore ->
182 let
183 g_restore (GhcT m) = GhcT $ \s -> io_restore (m s)
184 in
185 unGhcT (f g_restore) s
186
187 #if __GLASGOW_HASKELL__ < 710
188 -- Pre-AMP change
189 instance (ExceptionMonad m, Functor m) => HasDynFlags (GhcT m) where
190 #else
191 instance (ExceptionMonad m) => HasDynFlags (GhcT m) where
192 #endif
193 getDynFlags = getSessionDynFlags
194
195 #if __GLASGOW_HASKELL__ < 710
196 -- Pre-AMP change
197 instance (ExceptionMonad m, Functor m) => GhcMonad (GhcT m) where
198 #else
199 instance (ExceptionMonad m) => GhcMonad (GhcT m) where
200 #endif
201 getSession = GhcT $ \(Session r) -> liftIO $ readIORef r
202 setSession s' = GhcT $ \(Session r) -> liftIO $ writeIORef r s'
203
204
205 -- | Print the error message and all warnings. Useful inside exception
206 -- handlers. Clears warnings after printing.
207 printException :: GhcMonad m => SourceError -> m ()
208 printException err = do
209 dflags <- getSessionDynFlags
210 liftIO $ printBagOfErrors dflags (srcErrorMessages err)
211
212 -- | A function called to log warnings and errors.
213 type WarnErrLogger = forall m. GhcMonad m => Maybe SourceError -> m ()
214
215 defaultWarnErrLogger :: WarnErrLogger
216 defaultWarnErrLogger Nothing = return ()
217 defaultWarnErrLogger (Just e) = printException e
218