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,
PackageInstEnv, PackageRuleBase,
+
+ -- * Annotations
+ prepareAnnotations,
+
-- * Interactive context
InteractiveContext(..), emptyInteractiveContext,
icPrintUnqual, mkPrintUnqualified, extendInteractiveContext,
import {-# SOURCE #-} InteractiveEval ( Resume )
#endif
+import HsSyn
import RdrName
import Name
import NameEnv
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 )
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 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}
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'.
-- > 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.
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
-- ^ 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 = [],
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)
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
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
-- 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
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
-- (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
projects / ghc-hetmet.git / blobdiff