X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FGhcMonad.hs;fp=compiler%2Fmain%2FGhcMonad.hs;h=c62ea4c09387cf2bb4829ff4c08ed7a62e632af8;hb=94bf0d3604ff0d2ecab246924af712bdd1c29a40;hp=0000000000000000000000000000000000000000;hpb=2493b18037055a5c284563d10931386e589a79b0;p=ghc-hetmet.git

diff --git a/compiler/main/GhcMonad.hs b/compiler/main/GhcMonad.hs
new file mode 100644
index 0000000..c62ea4c
--- /dev/null
+++ b/compiler/main/GhcMonad.hs
@@ -0,0 +1,177 @@
+{-# OPTIONS_GHC -funbox-strict-fields #-}
+-- -----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow, 2010
+--
+-- The Session type and related functionality
+--
+-- -----------------------------------------------------------------------------
+
+module GhcMonad (
+        -- * 'Ghc' monad stuff
+        GhcMonad(..),
+        Ghc(..), 
+        GhcT(..), liftGhcT,
+        reflectGhc, reifyGhc,
+        getSessionDynFlags, 
+        liftIO,
+	Session(..), withSession, modifySession, withTempSession,
+
+        -- ** Warnings
+        logWarnings
+  ) where
+
+import MonadUtils
+import HscTypes
+import DynFlags
+import Exception
+import ErrUtils
+
+import Data.IORef
+
+-- -----------------------------------------------------------------------------
+-- | A monad that has all the features needed by GHC API calls.
+--
+-- In short, a GHC monad
+--
+--   - allows embedding of IO actions,
+--
+--   - can log warnings,
+--
+--   - allows handling of (extensible) exceptions, and
+--
+--   - maintains a current session.
+--
+-- If you do not use 'Ghc' or 'GhcT', make sure to call 'GHC.initGhcMonad'
+-- before any call to the GHC API functions can occur.
+--
+class (Functor m, MonadIO m, ExceptionMonad m) => GhcMonad m where
+  getSession :: m HscEnv
+  setSession :: HscEnv -> m ()
+
+
+-- | Call the argument with the current session.
+withSession :: GhcMonad m => (HscEnv -> m a) -> m a
+withSession f = getSession >>= f
+
+-- | Grabs the DynFlags from the Session
+getSessionDynFlags :: GhcMonad m => m DynFlags
+getSessionDynFlags = withSession (return . hsc_dflags)
+
+-- | Set the current session to the result of applying the current session to
+-- the argument.
+modifySession :: GhcMonad m => (HscEnv -> HscEnv) -> m ()
+modifySession f = do h <- getSession
+                     setSession $! f h
+
+withSavedSession :: GhcMonad m => m a -> m a
+withSavedSession m = do
+  saved_session <- getSession
+  m `gfinally` setSession saved_session
+
+-- | Call an action with a temporarily modified Session.
+withTempSession :: GhcMonad m => (HscEnv -> HscEnv) -> m a -> m a
+withTempSession f m =
+  withSavedSession $ modifySession f >> m
+
+-- -----------------------------------------------------------------------------
+-- | A monad that allows logging of warnings.
+
+logWarnings :: GhcMonad m => WarningMessages -> m ()
+logWarnings warns = do
+  dflags <- getSessionDynFlags
+  liftIO $ printOrThrowWarnings dflags warns
+
+-- -----------------------------------------------------------------------------
+-- | A minimal implementation of a 'GhcMonad'.  If you need a custom monad,
+-- e.g., to maintain additional state consider wrapping this monad or using
+-- 'GhcT'.
+newtype Ghc a = Ghc { unGhc :: Session -> IO a }
+
+-- | The Session is a handle to the complete state of a compilation
+-- session.  A compilation session consists of a set of modules
+-- constituting the current program or library, the context for
+-- interactive evaluation, and various caches.
+data Session = Session !(IORef HscEnv) 
+
+instance Functor Ghc where
+  fmap f m = Ghc $ \s -> f `fmap` unGhc m s
+
+instance Monad Ghc where
+  return a = Ghc $ \_ -> return a
+  m >>= g  = Ghc $ \s -> do a <- unGhc m s; unGhc (g a) s
+
+instance MonadIO Ghc where
+  liftIO ioA = Ghc $ \_ -> ioA
+
+instance ExceptionMonad Ghc where
+  gcatch act handle =
+      Ghc $ \s -> unGhc act s `gcatch` \e -> unGhc (handle e) s
+  gblock (Ghc m)   = Ghc $ \s -> gblock (m s)
+  gunblock (Ghc m) = Ghc $ \s -> gunblock (m s)
+  gmask f =
+      Ghc $ \s -> gmask $ \io_restore ->
+                             let
+                                g_restore (Ghc m) = Ghc $ \s -> io_restore (m s)
+                             in
+                                unGhc (f g_restore) s
+
+instance GhcMonad Ghc where
+  getSession = Ghc $ \(Session r) -> readIORef r
+  setSession s' = Ghc $ \(Session r) -> writeIORef r s'
+
+-- | Reflect a computation in the 'Ghc' monad into the 'IO' monad.
+--
+-- You can use this to call functions returning an action in the 'Ghc' monad
+-- inside an 'IO' action.  This is needed for some (too restrictive) callback
+-- arguments of some library functions:
+--
+-- > libFunc :: String -> (Int -> IO a) -> IO a
+-- > ghcFunc :: Int -> Ghc a
+-- >
+-- > ghcFuncUsingLibFunc :: String -> Ghc a -> Ghc a
+-- > ghcFuncUsingLibFunc str =
+-- >   reifyGhc $ \s ->
+-- >     libFunc $ \i -> do
+-- >       reflectGhc (ghcFunc i) s
+--
+reflectGhc :: Ghc a -> Session -> IO a
+reflectGhc m = unGhc m
+
+-- > Dual to 'reflectGhc'.  See its documentation.
+reifyGhc :: (Session -> IO a) -> Ghc a
+reifyGhc act = Ghc $ act
+
+-- -----------------------------------------------------------------------------
+-- | A monad transformer to add GHC specific features to another monad.
+--
+-- Note that the wrapped monad must support IO and handling of exceptions.
+newtype GhcT m a = GhcT { unGhcT :: Session -> m a }
+liftGhcT :: Monad m => m a -> GhcT m a
+liftGhcT m = GhcT $ \_ -> m
+
+instance Functor m => Functor (GhcT m) where
+  fmap f m = GhcT $ \s -> f `fmap` unGhcT m s
+
+instance Monad m => Monad (GhcT m) where
+  return x = GhcT $ \_ -> return x
+  m >>= k  = GhcT $ \s -> do a <- unGhcT m s; unGhcT (k a) s
+
+instance MonadIO m => MonadIO (GhcT m) where
+  liftIO ioA = GhcT $ \_ -> liftIO ioA
+
+instance ExceptionMonad m => ExceptionMonad (GhcT m) where
+  gcatch act handle =
+      GhcT $ \s -> unGhcT act s `gcatch` \e -> unGhcT (handle e) s
+  gblock (GhcT m) = GhcT $ \s -> gblock (m s)
+  gunblock (GhcT m) = GhcT $ \s -> gunblock (m s)
+  gmask f =
+      GhcT $ \s -> gmask $ \io_restore ->
+                           let
+                              g_restore (GhcT m) = GhcT $ \s -> io_restore (m s)
+                           in
+                              unGhcT (f g_restore) s
+
+instance (Functor m, ExceptionMonad m, MonadIO m) => GhcMonad (GhcT m) where
+  getSession = GhcT $ \(Session r) -> liftIO $ readIORef r
+  setSession s' = GhcT $ \(Session r) -> liftIO $ writeIORef r s'