ioMsgMaybe, ioMsg,
logWarnings, clearWarnings, hasWarnings,
SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr,
- handleSourceError,
+ throwOneError, handleSourceError,
reflectGhc, reifyGhc,
-- * Sessions and compilation state
#endif
import RdrName
-import Name ( Name, NamedThing, getName, nameOccName, nameModule )
+import Name
import NameEnv
import NameSet
import OccName ( OccName, OccEnv, lookupOccEnv, mkOccEnv, emptyOccEnv,
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 Bag
+import ErrUtils
import System.FilePath
import System.Time ( ClockTime )
srcErrorMessages :: SourceError -> ErrorMessages
mkApiErr :: SDoc -> GhcApiError
-#if __GLASGOW_HASKELL__ >= 609
+throwOneError :: MonadIO m => ErrMsg -> m ab
+throwOneError err = liftIO $ throwIO $ mkSrcErr $ unitBag err
-- | 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
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 ()
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
+ gblock (Ghc m) = Ghc $ \s -> gblock (m s)
+ gunblock (Ghc m) = Ghc $ \s -> gunblock (m s)
+
instance WarnLogMonad Ghc where
setWarnings warns = Ghc $ \(Session _ wref) -> writeIORef wref warns
-- | Return 'Warnings' accumulated so far.
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
+ gblock (GhcT m) = GhcT $ \s -> gblock (m s)
+ gunblock (GhcT m) = GhcT $ \s -> gunblock (m s)
instance MonadIO m => WarnLogMonad (GhcT m) where
setWarnings warns = GhcT $ \(Session _ wref) -> liftIO $ writeIORef wref warns
((warns,errs), mb_r) <- liftIO ioA
logWarnings warns
case mb_r of
- Nothing -> throw (mkSrcErr errs)
+ Nothing -> liftIO $ throwIO (mkSrcErr errs)
Just r -> ASSERT( isEmptyBag errs ) return r
-- | Lift a non-failing IO action into a 'GhcMonad'.
-- is for use in an IDE where the file hasn't been saved by
-- the user yet).
data Target = Target
- TargetId -- module or filename
- Bool -- object code allowed?
- (Maybe (StringBuffer,ClockTime)) -- in-memory text buffer?
+ { targetId :: TargetId -- ^ module or filename
+ , targetAllowObjCode :: Bool -- ^ object code allowed?
+ , targetContents :: Maybe (StringBuffer,ClockTime)
+ -- ^ in-memory text buffer?
+ }
data TargetId
= TargetModule ModuleName
-> 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
| 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)
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
projects / ghc-hetmet.git / blobdiff