X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FHscTypes.lhs;h=83dda3f81b8ec908c32af0cbde8e1a9f09fd0b30;hp=e4e669759b6cb30f752fa44d9fa7e465b5dfb58e;hb=66579ff945831c5fc9a17c58c722ff01f2268d76;hpb=3d2acdeb7a920cb7eca6047b6c055d12504fccf7

diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index e4e6697..83dda3f 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -6,8 +6,18 @@
 \begin{code}
 -- | Types for the per-module compiler
 module HscTypes ( 
+        -- * 'Ghc' monad stuff
+        Ghc(..), GhcT(..), liftGhcT,
+        GhcMonad(..), WarnLogMonad(..),
+        liftIO,
+        ioMsgMaybe, ioMsg,
+        logWarnings, clearWarnings, hasWarnings,
+        SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr,
+        handleSourceError,
+        reflectGhc, reifyGhc,
+
 	-- * Sessions and compilation state
-	Session(..), withSession, modifySession, 
+	Session(..), withSession, modifySession,
         HscEnv(..), hscEPS,
 	FinderCache, FindResult(..), ModLocationCache,
 	Target(..), TargetId(..), pprTarget, pprTargetId,
@@ -95,7 +105,7 @@ import {-# SOURCE #-}  InteractiveEval ( Resume )
 #endif
 
 import RdrName
-import Name		( Name, NamedThing, getName, nameOccName, nameModule )
+import Name
 import NameEnv
 import NameSet	
 import OccName		( OccName, OccEnv, lookupOccEnv, mkOccEnv, emptyOccEnv, 
@@ -132,6 +142,16 @@ import UniqSupply	( UniqSupply )
 import FastString
 import StringBuffer	( StringBuffer )
 import Fingerprint
+import MonadUtils
+import Bag              ( emptyBag, unionBags, isEmptyBag )
+import Data.Dynamic     ( Typeable )
+import qualified Data.Dynamic as Dyn
+#if __GLASGOW_HASKELL__ < 609
+import Data.Dynamic     ( toDyn, fromDyn, fromDynamic )
+#else
+import Bag              ( bagToList )
+#endif
+import ErrUtils         ( ErrorMessages, WarningMessages, Messages )
 
 import System.FilePath
 import System.Time	( ClockTime )
@@ -139,6 +159,7 @@ import Data.IORef
 import Data.Array       ( Array, array )
 import Data.List
 import Control.Monad    ( mplus, guard, liftM )
+import Exception
 \end{code}
 
 
@@ -154,13 +175,278 @@ import Control.Monad    ( mplus, guard, liftM )
 -- session.  A compilation session consists of a set of modules
 -- constituting the current program or library, the context for
 -- interactive evaluation, and various caches.
-newtype Session = Session (IORef HscEnv)
+data Session = Session !(IORef HscEnv) !(IORef WarningMessages)
+
+mkSrcErr :: ErrorMessages -> SourceError
+srcErrorMessages :: SourceError -> ErrorMessages
+mkApiErr :: SDoc -> GhcApiError
+
+#if __GLASGOW_HASKELL__ >= 609
+
+-- | A source error is an error that is caused by one or more errors in the
+-- source code.  A 'SourceError' is thrown by many functions in the
+-- compilation pipeline.  Inside GHC these errors are merely printed via
+-- 'log_action', but API clients may treat them differently, for example,
+-- insert them into a list box.  If you want the default behaviour, use the
+-- idiom:
+--
+-- > handleSourceError printExceptionAndWarnings $ do
+-- >   ... api calls that may fail ...
+--
+-- The 'SourceError's error messages can be accessed via 'srcErrorMessages'.
+-- This list may be empty if the compiler failed due to @-Werror@
+-- ('Opt_WarnIsError').
+--
+-- See 'printExceptionAndWarnings' for more information on what to take care
+-- of when writing a custom error handler.
+data SourceError = SourceError ErrorMessages
+
+instance Show SourceError where
+  show (SourceError msgs) = unlines . map show . bagToList $ msgs
+    -- ToDo: is there some nicer way to print this?
+
+sourceErrorTc :: Dyn.TyCon
+sourceErrorTc = Dyn.mkTyCon "SourceError"
+{-# NOINLINE sourceErrorTc #-}
+instance Typeable SourceError where
+  typeOf _ = Dyn.mkTyConApp sourceErrorTc []
+
+instance Exception SourceError
+
+mkSrcErr = SourceError
+
+-- | Perform the given action and call the exception handler if the action
+-- throws a 'SourceError'.  See 'SourceError' for more information.
+handleSourceError :: (ExceptionMonad m) =>
+                     (SourceError -> m a) -- ^ exception handler
+                  -> m a -- ^ action to perform
+                  -> m a
+handleSourceError handler act =
+  gcatch act (\(e :: SourceError) -> handler e)
+
+srcErrorMessages (SourceError msgs) = msgs
+
+-- | XXX: what exactly is an API error?
+data GhcApiError = GhcApiError SDoc
+
+instance Show GhcApiError where
+  show (GhcApiError msg) = showSDoc msg
+
+ghcApiErrorTc :: Dyn.TyCon
+ghcApiErrorTc = Dyn.mkTyCon "GhcApiError"
+{-# NOINLINE ghcApiErrorTc #-}
+instance Typeable GhcApiError where
+  typeOf _ = Dyn.mkTyConApp ghcApiErrorTc []
+
+instance Exception GhcApiError
+
+mkApiErr = GhcApiError
+
+#else
+------------------------------------------------------------------------
+-- implementation for bootstrapping without extensible exceptions
+
+data SourceException = SourceException ErrorMessages
+sourceExceptionTc :: Dyn.TyCon
+sourceExceptionTc = Dyn.mkTyCon "SourceException"
+{-# NOINLINE sourceExceptionTc #-}
+instance Typeable SourceException where
+  typeOf _ = Dyn.mkTyConApp sourceExceptionTc []
+
+-- Source error has to look like a normal exception.  Throwing a DynException
+-- directly would not allow us to use the Exception monad.  We also cannot
+-- make it part of GhcException as that would lead to circular imports.
+
+type SourceError = Exception
+type GhcApiError = Exception
+
+mkSrcErr msgs = DynException . toDyn $ SourceException msgs
+
+mkApiErr = IOException . userError . showSDoc
+
+srcErrorMessages (DynException ms) =
+    let SourceException msgs = (fromDyn ms (panic "SourceException expected"))
+    in msgs
+srcErrorMessages _ = panic "SourceError expected"
+
+handleSourceError :: ExceptionMonad m => (Exception -> m a) -> m a -> m a
+handleSourceError handler act =
+  gcatch act
+         (\e -> case e of
+                  DynException dyn
+                    | Just (SourceException _) <- fromDynamic dyn
+                        -> handler e
+                  _ -> throw e)
+#endif
+
+-- | A monad that allows logging of warnings.
+class Monad m => WarnLogMonad m where
+  setWarnings  :: WarningMessages -> m ()
+  getWarnings :: m WarningMessages
+
+logWarnings :: WarnLogMonad m => WarningMessages -> m ()
+logWarnings warns = do
+    warns0 <- getWarnings
+    setWarnings (unionBags warns warns0)
+
+-- | Clear the log of 'Warnings'.
+clearWarnings :: WarnLogMonad m => m ()
+clearWarnings = setWarnings emptyBag
 
-withSession :: Session -> (HscEnv -> IO a) -> IO a
-withSession (Session ref) f = do h <- readIORef ref; f h
+-- | Returns true if there were any warnings.
+hasWarnings :: WarnLogMonad m => m Bool
+hasWarnings = getWarnings >>= return . not . isEmptyBag
 
-modifySession :: Session -> (HscEnv -> HscEnv) -> IO ()
-modifySession (Session ref) f = do h <- readIORef ref; writeIORef ref $! f h
+-- | 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, WarnLogMonad 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
+
+-- | 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
+
+-- | 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 }
+
+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
+#if __GLASGOW_HASKELL__ < 609
+  gcatchDyn act handler =
+      Ghc $ \s -> unGhc act s `gcatchDyn` \e -> unGhc (handler e) s
+#endif
+instance WarnLogMonad Ghc where
+  setWarnings warns = Ghc $ \(Session _ wref) -> writeIORef wref warns
+  -- | Return 'Warnings' accumulated so far.
+  getWarnings       = Ghc $ \(Session _ wref) -> readIORef wref
+
+instance GhcMonad Ghc where
+  getSession = Ghc $ \(Session r _) -> readIORef r
+  setSession s' = Ghc $ \(Session r _) -> writeIORef r s'
+
+-- | 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
+#if __GLASGOW_HASKELL__ < 609
+  gcatchDyn _act _handler = error "cannot use GhcT in stage1"
+#endif
+
+instance MonadIO m => WarnLogMonad (GhcT m) where
+  setWarnings warns = GhcT $ \(Session _ wref) -> liftIO $ writeIORef wref warns
+  -- | Return 'Warnings' accumulated so far.
+  getWarnings       = GhcT $ \(Session _ wref) -> liftIO $ readIORef wref
+
+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'
+
+-- | Lift an IO action returning errors messages into a 'GhcMonad'.
+--
+-- In order to reduce dependencies to other parts of the compiler, functions
+-- outside the "main" parts of GHC return warnings and errors as a parameter
+-- and signal success via by wrapping the result in a 'Maybe' type.  This
+-- function logs the returned warnings and propagates errors as exceptions
+-- (of type 'SourceError').
+--
+-- This function assumes the following invariants:
+--
+--  1. If the second result indicates success (is of the form 'Just x'),
+--     there must be no error messages in the first result.
+--
+--  2. If there are no error messages, but the second result indicates failure
+--     there should be warnings in the first result.  That is, if the action
+--     failed, it must have been due to the warnings (i.e., @-Werror@).
+ioMsgMaybe :: GhcMonad m =>
+              IO (Messages, Maybe a) -> m a
+ioMsgMaybe ioA = do
+  ((warns,errs), mb_r) <- liftIO ioA
+  logWarnings warns
+  case mb_r of
+    Nothing -> throw (mkSrcErr errs)
+    Just r  -> ASSERT( isEmptyBag errs ) return r
+
+-- | Lift a non-failing IO action into a 'GhcMonad'.
+--
+-- Like 'ioMsgMaybe', but assumes that the action will never return any error
+-- messages.
+ioMsg :: GhcMonad m => IO (Messages, a) -> m a
+ioMsg ioA = do
+    ((warns,errs), r) <- liftIO ioA
+    logWarnings warns
+    ASSERT( isEmptyBag errs ) return r
+
+-- | 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
 \end{code}
 
 \begin{code}
@@ -255,7 +541,10 @@ hscEPS hsc_env = readIORef (hsc_EPS hsc_env)
 -- module.  If so, use this instead of the file contents (this
 -- is for use in an IDE where the file hasn't been saved by
 -- the user yet).
-data Target = Target TargetId (Maybe (StringBuffer,ClockTime))
+data Target = Target
+      TargetId                          -- module or filename
+      Bool                              -- object code allowed?
+      (Maybe (StringBuffer,ClockTime))  -- in-memory text buffer?
 
 data TargetId
   = TargetModule ModuleName
@@ -268,7 +557,8 @@ data TargetId
   deriving Eq
 
 pprTarget :: Target -> SDoc
-pprTarget (Target id _) = pprTargetId id
+pprTarget (Target id obj _) = 
+   (if obj then char '*' else empty) <> pprTargetId id
 
 instance Outputable Target where
     ppr = pprTarget
@@ -799,11 +1089,11 @@ extendInteractiveContext
         -> TyVarSet
         -> InteractiveContext
 extendInteractiveContext ictxt ids tyvars
-  = ictxt { ic_tmp_ids =  ic_tmp_ids ictxt ++ ids,
+  = ictxt { ic_tmp_ids =  snub((ic_tmp_ids ictxt \\ ids) ++ ids),
                           -- NB. must be this way around, because we want
                           -- new ids to shadow existing bindings.
             ic_tyvars   = ic_tyvars ictxt `unionVarSet` tyvars }
-
+    where snub = map head . group . sort
 
 substInteractiveContext :: InteractiveContext -> TvSubst -> InteractiveContext
 substInteractiveContext ictxt subst | isEmptyTvSubst subst = ictxt
@@ -870,7 +1160,7 @@ mkPrintUnqualified dflags env = (qual_name, qual_mod)
 
 	| otherwise = panic "mkPrintUnqualified"
       where
-	right_name gre = nameModule (gre_name gre) == mod
+	right_name gre = nameModule_maybe (gre_name gre) == Just mod
 
         unqual_gres = lookupGRE_RdrName (mkRdrUnqual occ) env
         qual_gres   = filter right_name (lookupGlobalRdrEnv env occ)
@@ -1040,7 +1330,7 @@ lookupType dflags hpt pte name
        lookupNameEnv (md_types (hm_details hm)) name
   | otherwise
   = lookupNameEnv pte name
-  where mod = nameModule name
+  where mod = ASSERT( isExternalName name ) nameModule name
 	this_pkg = thisPackage dflags
 
 -- | As 'lookupType', but with a marginally easier-to-use interface
@@ -1195,7 +1485,7 @@ data GenAvailInfo name	= Avail name	 -- ^ An ordinary identifier in scope
 				         --  2) The available pieces of type or class.
 					 --     NB: If the type or class is itself
 					 --     to be in scope, it must be in this list.
-					 --     Thus, typically: @AvailTC Eq [Eq, ==, /=]@
+					 --     Thus, typically: @AvailTC Eq [Eq, ==, \/=]@
 			deriving( Eq )
 			-- Equality used when deciding if the interface has changed