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