never executed always true always false
1 {-# LANGUAGE DeriveFunctor, DerivingVia, 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 GHC.Driver.Monad (
12 -- * 'Ghc' monad stuff
13 GhcMonad(..),
14 Ghc(..),
15 GhcT(..), liftGhcT,
16 reflectGhc, reifyGhc,
17 getSessionDynFlags,
18 liftIO,
19 Session(..), withSession, modifySession, modifySessionM,
20 withTempSession,
21
22 -- * Logger
23 modifyLogger,
24 pushLogHookM,
25 popLogHookM,
26 putLogMsgM,
27 putMsgM,
28 withTimingM,
29
30 -- ** Diagnostics
31 logDiagnostics, printException,
32 WarnErrLogger, defaultWarnErrLogger
33 ) where
34
35 import GHC.Prelude
36
37 import GHC.Driver.Session
38 import GHC.Driver.Env
39 import GHC.Driver.Errors ( printOrThrowDiagnostics, printMessages )
40 import GHC.Driver.Errors.Types
41 import GHC.Driver.Config.Diagnostic
42
43 import GHC.Utils.Monad
44 import GHC.Utils.Exception
45 import GHC.Utils.Error
46 import GHC.Utils.Logger
47
48 import GHC.Types.SrcLoc
49 import GHC.Types.SourceError
50
51 import Control.Monad
52 import Control.Monad.Catch as MC
53 import Control.Monad.Trans.Reader
54 import Data.IORef
55
56 -- -----------------------------------------------------------------------------
57 -- | A monad that has all the features needed by GHC API calls.
58 --
59 -- In short, a GHC monad
60 --
61 -- - allows embedding of IO actions,
62 --
63 -- - can log warnings,
64 --
65 -- - allows handling of (extensible) exceptions, and
66 --
67 -- - maintains a current session.
68 --
69 -- If you do not use 'Ghc' or 'GhcT', make sure to call 'GHC.initGhcMonad'
70 -- before any call to the GHC API functions can occur.
71 --
72 class (Functor m, ExceptionMonad m, HasDynFlags m, HasLogger m ) => GhcMonad m where
73 getSession :: m HscEnv
74 setSession :: HscEnv -> m ()
75
76 -- | Call the argument with the current session.
77 withSession :: GhcMonad m => (HscEnv -> m a) -> m a
78 withSession f = getSession >>= f
79
80 -- | Grabs the DynFlags from the Session
81 getSessionDynFlags :: GhcMonad m => m DynFlags
82 getSessionDynFlags = withSession (return . hsc_dflags)
83
84 -- | Set the current session to the result of applying the current session to
85 -- the argument.
86 modifySession :: GhcMonad m => (HscEnv -> HscEnv) -> m ()
87 modifySession f = do h <- getSession
88 setSession $! f h
89
90 -- | Set the current session to the result of applying the current session to
91 -- the argument.
92 modifySessionM :: GhcMonad m => (HscEnv -> m HscEnv) -> m ()
93 modifySessionM f = do h <- getSession
94 h' <- f h
95 setSession $! h'
96
97 withSavedSession :: GhcMonad m => m a -> m a
98 withSavedSession m = do
99 saved_session <- getSession
100 m `MC.finally` setSession saved_session
101
102 -- | Call an action with a temporarily modified Session.
103 withTempSession :: GhcMonad m => (HscEnv -> HscEnv) -> m a -> m a
104 withTempSession f m =
105 withSavedSession $ modifySession f >> m
106
107 ----------------------------------------
108 -- Logging
109 ----------------------------------------
110
111 -- | Modify the logger
112 modifyLogger :: GhcMonad m => (Logger -> Logger) -> m ()
113 modifyLogger f = modifySession $ \hsc_env ->
114 hsc_env { hsc_logger = f (hsc_logger hsc_env) }
115
116 -- | Push a log hook on the stack
117 pushLogHookM :: GhcMonad m => (LogAction -> LogAction) -> m ()
118 pushLogHookM = modifyLogger . pushLogHook
119
120 -- | Pop a log hook from the stack
121 popLogHookM :: GhcMonad m => m ()
122 popLogHookM = modifyLogger popLogHook
123
124 -- | Put a log message
125 putMsgM :: GhcMonad m => SDoc -> m ()
126 putMsgM doc = do
127 logger <- getLogger
128 liftIO $ putMsg logger doc
129
130 -- | Put a log message
131 putLogMsgM :: GhcMonad m => MessageClass -> SrcSpan -> SDoc -> m ()
132 putLogMsgM msg_class loc doc = do
133 logger <- getLogger
134 liftIO $ logMsg logger msg_class loc doc
135
136 -- | Time an action
137 withTimingM :: GhcMonad m => SDoc -> (b -> ()) -> m b -> m b
138 withTimingM doc force action = do
139 logger <- getLogger
140 withTiming logger doc force action
141
142 -- -----------------------------------------------------------------------------
143 -- | A monad that allows logging of diagnostics.
144
145 logDiagnostics :: GhcMonad m => Messages GhcMessage -> m ()
146 logDiagnostics warns = do
147 dflags <- getSessionDynFlags
148 logger <- getLogger
149 let !diag_opts = initDiagOpts dflags
150 liftIO $ printOrThrowDiagnostics logger diag_opts warns
151
152 -- -----------------------------------------------------------------------------
153 -- | A minimal implementation of a 'GhcMonad'. If you need a custom monad,
154 -- e.g., to maintain additional state consider wrapping this monad or using
155 -- 'GhcT'.
156 newtype Ghc a = Ghc { unGhc :: Session -> IO a }
157 deriving (Functor)
158 deriving (MonadThrow, MonadCatch, MonadMask) via (ReaderT Session IO)
159
160 -- | The Session is a handle to the complete state of a compilation
161 -- session. A compilation session consists of a set of modules
162 -- constituting the current program or library, the context for
163 -- interactive evaluation, and various caches.
164 data Session = Session !(IORef HscEnv)
165
166 instance Applicative Ghc where
167 pure a = Ghc $ \_ -> return a
168 g <*> m = do f <- g; a <- m; return (f a)
169
170 instance Monad Ghc where
171 m >>= g = Ghc $ \s -> do a <- unGhc m s; unGhc (g a) s
172
173 instance MonadIO Ghc where
174 liftIO ioA = Ghc $ \_ -> ioA
175
176 instance MonadFix Ghc where
177 mfix f = Ghc $ \s -> mfix (\x -> unGhc (f x) s)
178
179 instance HasDynFlags Ghc where
180 getDynFlags = getSessionDynFlags
181
182 instance HasLogger Ghc where
183 getLogger = hsc_logger <$> getSession
184
185 instance GhcMonad Ghc where
186 getSession = Ghc $ \(Session r) -> readIORef r
187 setSession s' = Ghc $ \(Session r) -> writeIORef r s'
188
189 -- | Reflect a computation in the 'Ghc' monad into the 'IO' monad.
190 --
191 -- You can use this to call functions returning an action in the 'Ghc' monad
192 -- inside an 'IO' action. This is needed for some (too restrictive) callback
193 -- arguments of some library functions:
194 --
195 -- > libFunc :: String -> (Int -> IO a) -> IO a
196 -- > ghcFunc :: Int -> Ghc a
197 -- >
198 -- > ghcFuncUsingLibFunc :: String -> Ghc a -> Ghc a
199 -- > ghcFuncUsingLibFunc str =
200 -- > reifyGhc $ \s ->
201 -- > libFunc $ \i -> do
202 -- > reflectGhc (ghcFunc i) s
203 --
204 reflectGhc :: Ghc a -> Session -> IO a
205 reflectGhc m = unGhc m
206
207 -- > Dual to 'reflectGhc'. See its documentation.
208 reifyGhc :: (Session -> IO a) -> Ghc a
209 reifyGhc act = Ghc $ act
210
211 -- -----------------------------------------------------------------------------
212 -- | A monad transformer to add GHC specific features to another monad.
213 --
214 -- Note that the wrapped monad must support IO and handling of exceptions.
215 newtype GhcT m a = GhcT { unGhcT :: Session -> m a }
216 deriving (Functor)
217 deriving (MonadThrow, MonadCatch, MonadMask) via (ReaderT Session m)
218
219 liftGhcT :: m a -> GhcT m a
220 liftGhcT m = GhcT $ \_ -> m
221
222 instance Applicative m => Applicative (GhcT m) where
223 pure x = GhcT $ \_ -> pure x
224 g <*> m = GhcT $ \s -> unGhcT g s <*> unGhcT m s
225
226 instance Monad m => Monad (GhcT m) where
227 m >>= k = GhcT $ \s -> do a <- unGhcT m s; unGhcT (k a) s
228
229 instance MonadIO m => MonadIO (GhcT m) where
230 liftIO ioA = GhcT $ \_ -> liftIO ioA
231
232 instance MonadIO m => HasDynFlags (GhcT m) where
233 getDynFlags = GhcT $ \(Session r) -> liftM hsc_dflags (liftIO $ readIORef r)
234
235 instance MonadIO m => HasLogger (GhcT m) where
236 getLogger = GhcT $ \(Session r) -> liftM hsc_logger (liftIO $ readIORef r)
237
238 instance ExceptionMonad m => GhcMonad (GhcT m) where
239 getSession = GhcT $ \(Session r) -> liftIO $ readIORef r
240 setSession s' = GhcT $ \(Session r) -> liftIO $ writeIORef r s'
241
242
243 -- | Print the all diagnostics in a 'SourceError'. Useful inside exception
244 -- handlers.
245 printException :: (HasLogger m, MonadIO m, HasDynFlags m) => SourceError -> m ()
246 printException err = do
247 dflags <- getDynFlags
248 logger <- getLogger
249 let !diag_opts = initDiagOpts dflags
250 liftIO $ printMessages logger diag_opts (srcErrorMessages err)
251
252 -- | A function called to log warnings and errors.
253 type WarnErrLogger = forall m. (HasDynFlags m , MonadIO m, HasLogger m) => Maybe SourceError -> m ()
254
255 defaultWarnErrLogger :: WarnErrLogger
256 defaultWarnErrLogger Nothing = return ()
257 defaultWarnErrLogger (Just e) = printException e