compiler/main/GhcMonad.hs

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