Fix segfault in array copy primops on 32-bit

[ghc-hetmet.git] / compiler / main / GhcMonad.hs

diff --git a/compiler/main/GhcMonad.hs b/compiler/main/GhcMonad.hs
index c62ea4c..4c72f14 100644 (file)
--- a/compiler/main/GhcMonad.hs
+++ b/compiler/main/GhcMonad.hs
@@ -15,10 +15,11 @@ module GhcMonad (
         reflectGhc, reifyGhc,
         getSessionDynFlags, 
         liftIO,
-       Session(..), withSession, modifySession, withTempSession,
+        Session(..), withSession, modifySession, withTempSession,
 
         -- ** Warnings
-        logWarnings
+        logWarnings, printException, printExceptionAndWarnings,
+        WarnErrLogger, defaultWarnErrLogger
   ) where
 
 import MonadUtils
@@ -175,3 +176,23 @@ instance ExceptionMonad m => ExceptionMonad (GhcT m) where
 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'
+
+
+-- | Print the error message and all warnings.  Useful inside exception
+--   handlers.  Clears warnings after printing.
+printException :: GhcMonad m => SourceError -> m ()
+printException err = do
+  dflags <- getSessionDynFlags
+  liftIO $ printBagOfErrors dflags (srcErrorMessages err)
+
+{-# DEPRECATED printExceptionAndWarnings "use printException instead" #-}
+printExceptionAndWarnings :: GhcMonad m => SourceError -> m ()
+printExceptionAndWarnings = printException
+
+-- | A function called to log warnings and errors.
+type WarnErrLogger = GhcMonad m => Maybe SourceError -> m ()
+
+defaultWarnErrLogger :: WarnErrLogger
+defaultWarnErrLogger Nothing  = return ()
+defaultWarnErrLogger (Just e) = printException e
+