\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,
+
-- * Sessions and compilation state
- Session(..), withSession, modifySession,
+ Session(..), withSession, modifySession,
HscEnv(..), hscEPS,
FinderCache, FindResult(..), ModLocationCache,
Target(..), TargetId(..), pprTarget, pprTargetId,
PackageInstEnv, PackageRuleBase,
+
+ -- * Annotations
+ prepareAnnotations,
+
-- * Interactive context
InteractiveContext(..), emptyInteractiveContext,
icPrintUnqual, mkPrintUnqualified, extendInteractiveContext,
#endif
import RdrName
-import Name ( Name, NamedThing, getName, nameOccName, nameModule )
+import Name
import NameEnv
import NameSet
import OccName ( OccName, OccEnv, lookupOccEnv, mkOccEnv, emptyOccEnv,
import Id
import Type
+import Annotations
import Class ( Class, classSelIds, classATs, classTyCon )
import TyCon
import DataCon ( DataCon, dataConImplicitIds, dataConWrapId )
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.Array ( Array, array )
import Data.List
import Control.Monad ( mplus, guard, liftM )
+import Exception
\end{code}
-- 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
+
+-- | 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
-withSession :: Session -> (HscEnv -> IO a) -> IO a
-withSession (Session ref) f = do h <- readIORef ref; f h
+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
-modifySession :: Session -> (HscEnv -> HscEnv) -> IO ()
-modifySession (Session ref) f = do h <- readIORef ref; writeIORef ref $! f h
+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
+
+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 -> 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
\end{code}
\begin{code}
-- 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
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
-- | 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
-- ^ 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))
-- 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}
%************************************************************************
-- 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)
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
}
md_insts = [],
md_rules = [],
md_fam_insts = [],
+ md_anns = [],
md_vect_info = noVectInfo
}
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
mi_exp_hash = fingerprint0,
mi_fixities = [],
mi_warns = NoWarnings,
+ mi_anns = [],
mi_insts = [],
mi_fam_insts = [],
mi_rules = [],
-> 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
-- 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
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
-- 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
projects / ghc-hetmet.git / blobdiff