Use an extensible-exceptions package when bootstrapping

[ghc-hetmet.git] / compiler / main / HscTypes.lhs

diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index e508e09..343e75d 100644 (file)
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -105,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, 
@@ -146,11 +146,7 @@ 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
@@ -181,8 +177,6 @@ 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
@@ -242,43 +236,6 @@ 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 ()
@@ -345,10 +302,6 @@ instance MonadIO Ghc where
 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.
@@ -378,9 +331,6 @@ instance MonadIO m => MonadIO (GhcT m) where
 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
@@ -1089,11 +1039,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
@@ -1160,7 +1110,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)
@@ -1330,7 +1280,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