X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FHscTypes.lhs;h=6b59a5915deed4bb786707579a18790f3ff898c8;hb=7f1db085b2256e3372feca52d493ca7577413cbe;hp=e4e669759b6cb30f752fa44d9fa7e465b5dfb58e;hpb=3d2acdeb7a920cb7eca6047b6c055d12504fccf7;p=ghc-hetmet.git diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index e4e6697..6b59a59 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -6,12 +6,25 @@ \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, + throwOneError, handleSourceError, + reflectGhc, reifyGhc, + handleFlagWarnings, + -- * Sessions and compilation state - Session(..), withSession, modifySession, + Session(..), withSession, modifySession, withTempSession, HscEnv(..), hscEPS, FinderCache, FindResult(..), ModLocationCache, Target(..), TargetId(..), pprTarget, pprTargetId, ModuleGraph, emptyMG, + -- ** Callbacks + GhcApiCallbacks(..), withLocalCallbacks, -- * Information about modules ModDetails(..), emptyModDetails, @@ -35,6 +48,10 @@ module HscTypes ( PackageInstEnv, PackageRuleBase, + + -- * Annotations + prepareAnnotations, + -- * Interactive context InteractiveContext(..), emptyInteractiveContext, icPrintUnqual, mkPrintUnqualified, extendInteractiveContext, @@ -94,8 +111,9 @@ import ByteCodeAsm ( CompiledByteCode ) import {-# SOURCE #-} InteractiveEval ( Resume ) #endif +import HsSyn import RdrName -import Name ( Name, NamedThing, getName, nameOccName, nameModule ) +import Name import NameEnv import NameSet import OccName ( OccName, OccEnv, lookupOccEnv, mkOccEnv, emptyOccEnv, @@ -111,12 +129,14 @@ import Var import Id import Type +import Annotations import Class ( Class, classSelIds, classATs, classTyCon ) import TyCon import DataCon ( DataCon, dataConImplicitIds, dataConWrapId ) import PrelNames ( gHC_PRIM ) import Packages hiding ( Version(..) ) -import DynFlags ( DynFlags(..), isOneShot, HscTarget (..) ) +import DynFlags ( DynFlags(..), isOneShot, HscTarget (..), dopt, + DynFlag(..) ) import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, Phase ) import BasicTypes ( IPName, Fixity, defaultFixity, WarningTxt(..) ) import OptimizationFuel ( OptFuelState ) @@ -126,19 +146,25 @@ import CoreSyn ( CoreRule ) import Maybes ( orElse, expectJust, catMaybes ) import Outputable import BreakArray -import SrcLoc ( SrcSpan, Located ) +import SrcLoc ( SrcSpan, Located(..) ) import LazyUniqFM ( lookupUFM, eltsUFM, emptyUFM ) import UniqSupply ( UniqSupply ) import FastString import StringBuffer ( StringBuffer ) import Fingerprint +import MonadUtils +import Data.Dynamic ( Typeable ) +import qualified Data.Dynamic as Dyn +import Bag +import ErrUtils import System.FilePath import System.Time ( ClockTime ) import Data.IORef import Data.Array ( Array, array ) import Data.List -import Control.Monad ( mplus, guard, liftM ) +import Control.Monad ( mplus, guard, liftM, when ) +import Exception \end{code} @@ -154,17 +180,315 @@ 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 + +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 +-- 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 + +-- | 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 + +-- | Returns true if there were any warnings. +hasWarnings :: WarnLogMonad m => m Bool +hasWarnings = getWarnings >>= return . not . isEmptyBag + +-- | 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 + +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 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 + 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. + 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 + 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 + -- | Return 'Warnings' accumulated so far. + getWarnings = GhcT $ \(Session _ wref) -> liftIO $ readIORef wref -withSession :: Session -> (HscEnv -> IO a) -> IO a -withSession (Session ref) f = do h <- readIORef ref; f h +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' -modifySession :: Session -> (HscEnv -> HscEnv) -> IO () -modifySession (Session ref) f = do h <- readIORef ref; writeIORef ref $! f h +-- | 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 -> liftIO $ throwIO (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 + +handleFlagWarnings :: GhcMonad m => DynFlags -> [Located String] -> m () +handleFlagWarnings dflags warns + = when (dopt Opt_WarnDeprecatedFlags dflags) + (handleFlagWarnings' dflags warns) + +handleFlagWarnings' :: GhcMonad m => DynFlags -> [Located String] -> m () +handleFlagWarnings' _ [] = return () +handleFlagWarnings' dflags warns + = do -- It would be nicer if warns :: [Located Message], but that has circular + -- import problems. + logWarnings $ listToBag (map mkFlagWarning warns) + when (dopt Opt_WarnIsError dflags) $ + liftIO $ throwIO $ mkSrcErr emptyBag + +mkFlagWarning :: Located String -> WarnMsg +mkFlagWarning (L loc warn) + = mkPlainWarnMsg loc (text warn) \end{code} \begin{code} --- | HscEnv is like 'Session', except that some of the fields are immutable. +-- | These functions are called in various places of the GHC API. +-- +-- API clients can override any of these callbacks to change GHC's default +-- behaviour. +data GhcApiCallbacks + = GhcApiCallbacks { + + -- | Called by 'load' after the compilating of each module. + -- + -- The default implementation simply prints all warnings and errors to + -- @stderr@. Don't forget to call 'clearWarnings' when implementing your + -- own call. + -- + -- The first argument is the module that was compiled. + -- + -- The second argument is @Nothing@ if no errors occured, but there may + -- have been warnings. If it is @Just err@ at least one error has + -- occured. If 'srcErrorMessages' is empty, compilation failed due to + -- @-Werror@. + reportModuleCompilationResult :: GhcMonad m => + ModSummary -> Maybe SourceError + -> m () + } + +-- | Temporarily modify the callbacks. After the action is executed all +-- callbacks are reset (not, however, any other modifications to the session +-- state.) +withLocalCallbacks :: GhcMonad m => + (GhcApiCallbacks -> GhcApiCallbacks) + -> m a -> m a +withLocalCallbacks f m = do + hsc_env <- getSession + let cb0 = hsc_callbacks hsc_env + let cb' = f cb0 + setSession (hsc_env { hsc_callbacks = cb' `seq` cb' }) + r <- m + hsc_env' <- getSession + setSession (hsc_env' { hsc_callbacks = cb0 }) + return r + +\end{code} + +\begin{code} +-- | Hscenv is like 'Session', except that some of the fields are immutable. -- An HscEnv is used to compile a single module from plain Haskell source -- code (after preprocessing) to either C, assembly or C--. Things like -- the module graph don't change during a single compilation. @@ -179,6 +503,9 @@ data HscEnv hsc_dflags :: DynFlags, -- ^ The dynamic flag settings + hsc_callbacks :: GhcApiCallbacks, + -- ^ Callbacks for the GHC API. + hsc_targets :: [Target], -- ^ The targets (or roots) of the current session @@ -255,7 +582,12 @@ 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 :: TargetId -- ^ module or filename + , targetAllowObjCode :: Bool -- ^ object code allowed? + , targetContents :: Maybe (StringBuffer,ClockTime) + -- ^ in-memory text buffer? + } data TargetId = TargetModule ModuleName @@ -268,7 +600,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 @@ -297,30 +630,31 @@ emptyPackageIfaceTable = emptyModuleEnv -- | Information about modules in the package being compiled data HomeModInfo - = HomeModInfo { hm_iface :: !ModIface, -- ^ The basic loaded interface file: every - -- loaded module has one of these, even if - -- it is imported from another package - hm_details :: !ModDetails, -- ^ Extra information that has been created - -- from the 'ModIface' for the module, - -- typically during typechecking - hm_linkable :: !(Maybe Linkable) - -- ^ The actual artifact we would like to link to access - -- things in this module. - -- - -- 'hm_linkable' might be Nothing: - -- - -- 1. If this is an .hs-boot module - -- - -- 2. Temporarily during compilation if we pruned away - -- the old linkable because it was out of date. - -- - -- After a complete compilation ('GHC.load'), all 'hm_linkable' - -- fields in the 'HomePackageTable' will be @Just@. - -- - -- When re-linking a module ('HscMain.HscNoRecomp'), we construct - -- the 'HomeModInfo' by building a new 'ModDetails' from the - -- old 'ModIface' (only). - } + = HomeModInfo { + hm_iface :: !ModIface, + -- ^ The basic loaded interface file: every loaded module has one of + -- these, even if it is imported from another package + hm_details :: !ModDetails, + -- ^ Extra information that has been created from the 'ModIface' for + -- the module, typically during typechecking + hm_linkable :: !(Maybe Linkable) + -- ^ The actual artifact we would like to link to access things in + -- this module. + -- + -- 'hm_linkable' might be Nothing: + -- + -- 1. If this is an .hs-boot module + -- + -- 2. Temporarily during compilation if we pruned away + -- the old linkable because it was out of date. + -- + -- After a complete compilation ('GHC.load'), all 'hm_linkable' fields + -- in the 'HomePackageTable' will be @Just@. + -- + -- When re-linking a module ('HscMain.HscNoRecomp'), we construct the + -- 'HomeModInfo' by building a new 'ModDetails' from the old + -- 'ModIface' (only). + } -- | Find the 'ModIface' for a 'Module', searching in both the loaded home -- and external package module information @@ -373,6 +707,12 @@ hptRules :: HscEnv -> [(ModuleName, IsBootInterface)] -> [CoreRule] -- ^ Get rules from modules \"below\" this one (in the dependency sense) hptRules = hptSomeThingsBelowUs (md_rules . hm_details) False + +hptAnns :: HscEnv -> Maybe [(ModuleName, IsBootInterface)] -> [Annotation] +-- ^ Get annotations from modules \"below\" this one (in the dependency sense) +hptAnns hsc_env (Just deps) = hptSomeThingsBelowUs (md_anns . hm_details) False hsc_env deps +hptAnns hsc_env Nothing = hptAllThings (md_anns . hm_details) hsc_env + hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a] hptAllThings extract hsc_env = concatMap extract (eltsUFM (hsc_HPT hsc_env)) @@ -407,7 +747,32 @@ hptSomeThingsBelowUs extract include_hi_boot hsc_env deps -- And get its dfuns , thing <- things ] +\end{code} + +%************************************************************************ +%* * +\subsection{Dealing with Annotations} +%* * +%************************************************************************ +\begin{code} +prepareAnnotations :: HscEnv -> Maybe ModGuts -> IO AnnEnv +-- ^ Deal with gathering annotations in from all possible places +-- and combining them into a single 'AnnEnv' +prepareAnnotations hsc_env mb_guts + = do { eps <- hscEPS hsc_env + ; let -- Extract annotations from the module being compiled if supplied one + mb_this_module_anns = fmap (mkAnnEnv . mg_anns) mb_guts + -- Extract dependencies of the module if we are supplied one, + -- otherwise load annotations from all home package table + -- entries regardless of dependency ordering. + home_pkg_anns = (mkAnnEnv . hptAnns hsc_env) $ fmap (dep_mods . mg_deps) mb_guts + other_pkg_anns = eps_ann_env eps + ann_env = foldl1' plusAnnEnv $ catMaybes [mb_this_module_anns, + Just home_pkg_anns, + Just other_pkg_anns] + + ; return ann_env } \end{code} %************************************************************************ @@ -510,6 +875,11 @@ data ModIface -- NOT STRICT! we read this field lazily from the interface file + mi_anns :: [IfaceAnnotation], + -- ^ Annotations + + -- NOT STRICT! we read this field lazily from the interface file + -- Type, class and variable declarations -- The hash of an Id changes if its fixity or deprecations change -- (as well as its type of course) @@ -568,6 +938,8 @@ data ModDetails md_insts :: ![Instance], -- ^ 'DFunId's for the instances in this module md_fam_insts :: ![FamInst], md_rules :: ![CoreRule], -- ^ Domain may include 'Id's from other modules + md_anns :: ![Annotation], -- ^ Annotations present in this module: currently + -- they only annotate things also declared in this module md_vect_info :: !VectInfo -- ^ Module vectorisation information } @@ -577,6 +949,7 @@ emptyModDetails = ModDetails { md_types = emptyTypeEnv, md_insts = [], md_rules = [], md_fam_insts = [], + md_anns = [], md_vect_info = noVectInfo } @@ -615,6 +988,7 @@ data ModGuts mg_binds :: ![CoreBind], -- ^ Bindings for this module mg_foreign :: !ForeignStubs, -- ^ Foreign exports declared in this module mg_warns :: !Warnings, -- ^ Warnings declared in the module + mg_anns :: [Annotation], -- ^ Annotations declared in this module mg_hpc_info :: !HpcInfo, -- ^ Coverage tick boxes in the module mg_modBreaks :: !ModBreaks, -- ^ Breakpoints for the module mg_vect_info :: !VectInfo, -- ^ Pool of vectorised declarations in the module @@ -728,6 +1102,7 @@ emptyModIface mod mi_exp_hash = fingerprint0, mi_fixities = [], mi_warns = NoWarnings, + mi_anns = [], mi_insts = [], mi_fam_insts = [], mi_rules = [], @@ -774,6 +1149,8 @@ data InteractiveContext #ifdef GHCI , ic_resume :: [Resume] -- ^ The stack of breakpoint contexts #endif + + , ic_cwd :: Maybe FilePath -- virtual CWD of the program } @@ -787,6 +1164,7 @@ emptyInteractiveContext #ifdef GHCI , ic_resume = [] #endif + , ic_cwd = Nothing } icPrintUnqual :: DynFlags -> InteractiveContext -> PrintUnqualified @@ -799,11 +1177,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 +1248,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) @@ -918,14 +1296,13 @@ mkPrintUnqualified dflags env = (qual_name, qual_mod) implicitTyThings :: TyThing -> [TyThing] -- For data and newtype declarations: -implicitTyThings (ATyCon tc) = - -- fields (names of selectors) - map AnId (tyConSelIds tc) ++ - -- (possibly) implicit coercion and family coercion - -- depending on whether it's a newtype or a family instance or both +implicitTyThings (ATyCon tc) + = -- fields (names of selectors) + -- (possibly) implicit coercion and family coercion + -- depending on whether it's a newtype or a family instance or both implicitCoTyCon tc ++ - -- for each data constructor in order, - -- the contructor, worker, and (possibly) wrapper + -- for each data constructor in order, + -- the contructor, worker, and (possibly) wrapper concatMap (extras_plus . ADataCon) (tyConDataCons tc) implicitTyThings (AClass cl) @@ -1040,7 +1417,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 @@ -1048,7 +1425,7 @@ lookupType dflags hpt pte name lookupTypeHscEnv :: HscEnv -> Name -> IO (Maybe TyThing) lookupTypeHscEnv hsc_env name = do eps <- readIORef (hsc_EPS hsc_env) - return $ lookupType dflags hpt (eps_PTE eps) name + return $! lookupType dflags hpt (eps_PTE eps) name where dflags = hsc_dflags hsc_env hpt = hsc_HPT hsc_env @@ -1195,7 +1572,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 @@ -1358,6 +1735,7 @@ type PackageRuleBase = RuleBase type PackageInstEnv = InstEnv type PackageFamInstEnv = FamInstEnv type PackageVectInfo = VectInfo +type PackageAnnEnv = AnnEnv -- | Information about other packages that we have slurped in by reading -- their interface files @@ -1409,6 +1787,8 @@ data ExternalPackageState -- from all the external-package modules eps_vect_info :: !PackageVectInfo, -- ^ The total 'VectInfo' accumulated -- from all the external-package modules + eps_ann_env :: !PackageAnnEnv, -- ^ The total 'AnnEnv' accumulated + -- from all the external-package modules eps_mod_fam_inst_env :: !(ModuleEnv FamInstEnv), -- ^ The family instances accumulated from external -- packages, keyed off the module that declared them @@ -1476,7 +1856,8 @@ type OrigIParamCache = FiniteMap (IPName OccName) (IPName Name) -- There will be a node for each source module, plus a node for each hi-boot -- module. -- --- The graph is not necessarily stored in topologically-sorted order. +-- The graph is not necessarily stored in topologically-sorted order. Use +-- 'GHC.topSortModuleGraph' and 'Digraph.flattenSCC' to achieve this. type ModuleGraph = [ModSummary] emptyMG :: ModuleGraph @@ -1496,8 +1877,8 @@ data ModSummary ms_location :: ModLocation, -- ^ Location of the various files belonging to the module ms_hs_date :: ClockTime, -- ^ Timestamp of source file ms_obj_date :: Maybe ClockTime, -- ^ Timestamp of object, if we have one - ms_srcimps :: [Located ModuleName], -- ^ Source imports of the module - ms_imps :: [Located ModuleName], -- ^ Non-source imports of the module + ms_srcimps :: [Located (ImportDecl RdrName)], -- ^ Source imports of the module + ms_imps :: [Located (ImportDecl RdrName)], -- ^ Non-source imports of the module ms_hspp_file :: FilePath, -- ^ Filename of preprocessed source file ms_hspp_opts :: DynFlags, -- ^ Cached flags from @OPTIONS@, @INCLUDE@ -- and @LANGUAGE@ pragmas in the modules source code @@ -1663,8 +2044,14 @@ data Linkable = LM { -- (i.e. when the bytecodes were produced, -- or the mod date on the files) linkableModule :: Module, -- ^ The linkable module itself - linkableUnlinked :: [Unlinked] -- ^ Those files and chunks of code we have - -- yet to link + linkableUnlinked :: [Unlinked] + -- ^ Those files and chunks of code we have yet to link. + -- + -- INVARIANT: A valid linkable always has at least one 'Unlinked' item. + -- If this list is empty, the Linkable represents a fake linkable, which + -- is generated in HscNothing mode to avoid recompiling modules. + -- + -- XXX: Do items get removed from this list when they get linked? } isObjectLinkable :: Linkable -> Bool