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