X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Fmain%2FHscTypes.lhs;h=a6ff043922c79359f53d79d6d8761f0202b9c02e;hb=9ffadf219cbc4f8ec57264786df936a3cee88aec;hp=03bcca5e1e541f077ea2ad34bd77372911b2b334;hpb=9bcd95bad83ee937c178970e8b729732e680fe1e;p=ghc-hetmet.git

diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index 03bcca5..a6ff043 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -15,13 +15,16 @@ module HscTypes (
         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,
@@ -108,6 +111,7 @@ import ByteCodeAsm	( CompiledByteCode )
 import {-# SOURCE #-}  InteractiveEval ( Resume )
 #endif
 
+import HsSyn
 import RdrName
 import Name
 import NameEnv
@@ -131,7 +135,8 @@ 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 )
@@ -141,7 +146,7 @@ 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
@@ -158,7 +163,7 @@ 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}
 
@@ -291,6 +296,16 @@ 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'.
@@ -409,10 +424,71 @@ 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.
@@ -427,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
 
@@ -1214,14 +1293,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) 
@@ -1344,7 +1422,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
@@ -1775,7 +1853,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
@@ -1795,8 +1874,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
@@ -1962,8 +2041,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