Revert "More updates to Safe Haskell to implement new design (done!)."
authorIan Lynagh <igloo@earth.li>
Wed, 26 Oct 2011 16:37:35 +0000 (17:37 +0100)
committerIan Lynagh <igloo@earth.li>
Wed, 26 Oct 2011 16:37:35 +0000 (17:37 +0100)
This reverts commit bb0eb57e329bcdd781e24b0d86993a0df25beed8.

compiler/main/DynFlags.hs
compiler/main/HscMain.lhs
compiler/main/HscTypes.lhs
compiler/typecheck/TcForeign.lhs
compiler/typecheck/TcInstDcls.lhs
compiler/typecheck/TcRnDriver.lhs
compiler/typecheck/TcRnMonad.lhs
compiler/typecheck/TcRnTypes.lhs

index 1c047b7..99a8ca8 100644 (file)
@@ -39,9 +39,9 @@ module DynFlags (
 
         -- ** Safe Haskell
         SafeHaskellMode(..),
-        safeHaskellOn, safeImportsOn, safeLanguageOn, safeInferOn,
-        packageTrustOn,
+        safeImportsOn, safeLanguageOn,
         safeDirectImpsReq, safeImplicitImpsReq,
+        packageTrustOn,
 
         -- ** System tool settings and locations
         Settings(..),
@@ -1025,24 +1025,10 @@ dynFlagDependencies = pluginModNames
 packageTrustOn :: DynFlags -> Bool
 packageTrustOn = dopt Opt_PackageTrust
 
--- | Is Safe Haskell on in some way (including inference mode)
-safeHaskellOn :: DynFlags -> Bool
-safeHaskellOn dflags = safeHaskell dflags /= Sf_None
-
 -- | Is the Safe Haskell safe language in use
 safeLanguageOn :: DynFlags -> Bool
 safeLanguageOn dflags = safeHaskell dflags == Sf_Safe
 
--- | Is the Safe Haskell safe inference mode active
-safeInferOn :: DynFlags -> Bool
-safeInferOn dflags = safeHaskell dflags == Sf_SafeInfered
-
--- | Turn off Safe Haskell inference mode (set module to unsafe)
-setSafeInferOff :: DynFlags -> DynFlags
-setSafeInferOff dflags
-  | safeHaskell dflags == Sf_SafeInfered = dflags { safeHaskell = Sf_None }
-  | otherwise                            = dflags
-
 -- | Test if Safe Imports are on in some form
 safeImportsOn :: DynFlags -> Bool
 safeImportsOn dflags = safeHaskell dflags == Sf_Unsafe ||
@@ -1060,24 +1046,33 @@ setSafeHaskell s = updM f
 -- | Are all direct imports required to be safe for this Safe Haskell mode?
 -- Direct imports are when the code explicitly imports a module
 safeDirectImpsReq :: DynFlags -> Bool
-safeDirectImpsReq d = safeLanguageOn d || safeInferOn d
+safeDirectImpsReq = safeLanguageOn
 
 -- | Are all implicit imports required to be safe for this Safe Haskell mode?
 -- Implicit imports are things in the prelude. e.g System.IO when print is used.
 safeImplicitImpsReq :: DynFlags -> Bool
-safeImplicitImpsReq d = safeLanguageOn d || safeInferOn d
+safeImplicitImpsReq = safeLanguageOn
 
 -- | Combine two Safe Haskell modes correctly. Used for dealing with multiple flags.
 -- This makes Safe Haskell very much a monoid but for now I prefer this as I don't
 -- want to export this functionality from the module but do want to export the
 -- type constructors.
 combineSafeFlags :: SafeHaskellMode -> SafeHaskellMode -> DynP SafeHaskellMode
-combineSafeFlags a b | a `elem` [Sf_None, Sf_SafeInfered] = return b
-                     | b `elem` [Sf_None, Sf_SafeInfered] = return a
-                     | a == b                             = return a
-                     | otherwise = addErr errm >> return (panic errm)
-    where errm = "Incompatible Safe Haskell flags! ("
-                    ++ showPpr a ++ ", " ++ showPpr b ++ ")"
+combineSafeFlags a b =
+    case (a,b) of
+        (Sf_None, sf) -> return sf
+        (sf, Sf_None) -> return sf
+
+        (Sf_SafeInfered, sf) -> return sf
+        (sf, Sf_SafeInfered) -> return sf
+
+        (a,b) | a == b -> return a
+              | otherwise -> err
+
+    where err = do
+              let s = "Incompatible Safe Haskell flags! (" ++ showPpr a ++ ", " ++ showPpr b ++ ")"
+              addErr s
+              return $ panic s -- Just for saftey instead of returning say, a
 
 -- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order
 getOpts :: DynFlags             -- ^ 'DynFlags' to retrieve the options from
@@ -1280,41 +1275,21 @@ parseDynamicFlags dflags0 args cmdline = do
   when (not (null errs)) $ ghcError $ errorsToGhcException errs
 
   -- check for disabled flags in safe haskell
-  let (dflags2, sh_warns) = safeFlagCheck dflags1
-  
-  return (dflags2, leftover, sh_warns ++ warns)
+  let (dflags2, sh_warns) = if (safeLanguageOn dflags1)
+                                then shFlagsDisallowed dflags1
+                                else (dflags1, [])
 
--- | Check (and potentially disable) any extensions that aren't allowed
--- in safe mode.
-safeFlagCheck :: DynFlags -> (DynFlags, [Located String])
-safeFlagCheck dflags | not (safeLanguageOn dflags || safeInferOn dflags)
-                     = (dflags, [])
-safeFlagCheck dflags =
-    case safeLanguageOn dflags of
-        True -> (dflags', warns)
-
-        False | null warns && safeInfOk
-              -> (dflags', [])
+  return (dflags2, leftover, sh_warns ++ warns)
 
-              | otherwise
-              -> (dflags' { safeHaskell = Sf_None }, [])
-                -- Have we infered Unsafe?
-                -- See Note [HscMain . Safe Haskell Inference]
+-- | Extensions that can't be enabled at all when compiling in Safe mode
+-- checkSafeHaskellFlags :: MonadIO m => DynFlags -> m ()
+shFlagsDisallowed :: DynFlags -> (DynFlags, [Located String])
+shFlagsDisallowed dflags = foldl check_method (dflags, []) bad_flags
     where
-        -- TODO: Can we do better than this for inference?
-        safeInfOk = not $ xopt Opt_OverlappingInstances dflags
-
-        (dflags', warns) = foldl check_method (dflags, []) bad_flags
-
         check_method (df, warns) (str,loc,test,fix)
-            | test df   = (apFix fix df, warns ++ safeFailure loc str)
+            | test df   = (fix df, warns ++ safeFailure loc str)
             | otherwise = (df, warns)
 
-        apFix f = if safeInferOn dflags then id else f
-
-        safeFailure loc str = [L loc $ "Warning: " ++ str ++ " is not allowed in"
-                                      ++ " Safe Haskell; ignoring " ++ str]
-
         bad_flags = [("-XGeneralizedNewtypeDeriving", newDerivOnLoc dflags,
                          xopt Opt_GeneralizedNewtypeDeriving,
                          flip xopt_unset Opt_GeneralizedNewtypeDeriving),
@@ -1322,6 +1297,9 @@ safeFlagCheck dflags =
                          xopt Opt_TemplateHaskell,
                          flip xopt_unset Opt_TemplateHaskell)]
 
+        safeFailure loc str = [L loc $ "Warning: " ++ str ++ " is not allowed in"
+                                      ++ " Safe Haskell; ignoring " ++ str]
+
 
 {- **********************************************************************
 %*                                                                      *
@@ -1853,7 +1831,7 @@ languageFlags = [
 -- features can be used.
 safeHaskellFlags :: [FlagSpec SafeHaskellMode]
 safeHaskellFlags = [mkF Sf_Unsafe, mkF Sf_Trustworthy, mkF Sf_Safe]
-    where mkF flag = (showPpr flag, flag, nop)
+    where mkF  flag = (showPpr flag, flag, nop)
 
 -- | These -X<blah> flags can all be reversed with -XNo<blah>
 xFlags :: [FlagSpec ExtensionFlag]
index 3961de0..f2e8c3b 100644 (file)
@@ -71,16 +71,16 @@ module HscMain
     ) where
 
 #ifdef GHCI
-import ByteCodeGen      ( byteCodeGen, coreExprToBCOs )
+import ByteCodeGen     ( byteCodeGen, coreExprToBCOs )
 import Linker
-import CoreTidy         ( tidyExpr )
-import Type             ( Type )
+import CoreTidy                ( tidyExpr )
+import Type            ( Type )
 import PrelNames
-import {- Kind parts of -} Type         ( Kind )
-import CoreLint         ( lintUnfolding )
-import DsMeta           ( templateHaskellNames )
+import {- Kind parts of -} Type                ( Kind )
+import CoreLint                ( lintUnfolding )
+import DsMeta          ( templateHaskellNames )
 import VarSet
-import VarEnv           ( emptyTidyEnv )
+import VarEnv          ( emptyTidyEnv )
 import Panic
 import Class
 import Data.List
@@ -97,28 +97,28 @@ import Parser
 import Lexer hiding (getDynFlags)
 import SrcLoc
 import TcRnDriver
-import TcIface          ( typecheckIface )
+import TcIface         ( typecheckIface )
 import TcRnMonad
-import IfaceEnv         ( initNameCache )
-import LoadIface        ( ifaceStats, initExternalPackageState )
+import IfaceEnv                ( initNameCache )
+import LoadIface       ( ifaceStats, initExternalPackageState )
 import PrelInfo
 import MkIface
 import Desugar
 import SimplCore
 import TidyPgm
 import CorePrep
-import CoreToStg        ( coreToStg )
-import qualified StgCmm ( codeGen )
+import CoreToStg       ( coreToStg )
+import qualified StgCmm        ( codeGen )
 import StgSyn
 import CostCentre
 import ProfInit
 import TyCon
 import Name
-import SimplStg         ( stg2stg )
-import CodeGen          ( codeGen )
+import SimplStg                ( stg2stg )
+import CodeGen         ( codeGen )
 import OldCmm as Old    ( CmmGroup )
-import PprCmm           ( pprCmms )
-import CmmParse         ( parseCmmFile )
+import PprCmm          ( pprCmms )
+import CmmParse                ( parseCmmFile )
 import CmmBuildInfoTables
 import CmmPipeline
 import CmmInfo
@@ -133,14 +133,14 @@ import Fingerprint      ( Fingerprint )
 
 import DynFlags
 import ErrUtils
-import UniqSupply       ( mkSplitUniqSupply )
+import UniqSupply      ( mkSplitUniqSupply )
 
 import Outputable
-import HscStats         ( ppSourceStats )
+import HscStats                ( ppSourceStats )
 import HscTypes
-import MkExternalCore   ( emitExternalCore )
+import MkExternalCore  ( emitExternalCore )
 import FastString
-import UniqFM           ( emptyUFM )
+import UniqFM          ( emptyUFM )
 import UniqSupply       ( initUs_ )
 import Bag
 import Exception
@@ -160,71 +160,69 @@ import Data.IORef
 
 \begin{code}
 newHscEnv :: DynFlags -> IO HscEnv
-newHscEnv dflags = do
-  { eps_var <- newIORef initExternalPackageState
-  ; us      <- mkSplitUniqSupply 'r'
-  ; nc_var  <- newIORef (initNameCache us knownKeyNames)
-  ; fc_var  <- newIORef emptyUFM
-  ; mlc_var <- newIORef emptyModuleEnv
-  ; optFuel <- initOptFuelState
-  ; return (HscEnv { hsc_dflags       = dflags,
-                    hsc_targets      = [],
-                    hsc_mod_graph    = [],
-                    hsc_IC           = emptyInteractiveContext,
-                    hsc_HPT          = emptyHomePackageTable,
-                    hsc_EPS          = eps_var,
-                    hsc_NC           = nc_var,
-                    hsc_FC           = fc_var,
-                    hsc_MLC          = mlc_var,
-                    hsc_OptFuel      = optFuel,
-                     hsc_type_env_var = Nothing } ) }
+newHscEnv dflags
+  = do         { eps_var <- newIORef initExternalPackageState
+        ; us      <- mkSplitUniqSupply 'r'
+        ; nc_var  <- newIORef (initNameCache us knownKeyNames)
+        ; fc_var  <- newIORef emptyUFM
+       ; mlc_var <- newIORef emptyModuleEnv
+        ; optFuel <- initOptFuelState
+       ; return (HscEnv { hsc_dflags = dflags,
+                          hsc_targets = [],
+                          hsc_mod_graph = [],
+                          hsc_IC      = emptyInteractiveContext,
+                          hsc_HPT     = emptyHomePackageTable,
+                          hsc_EPS     = eps_var,
+                          hsc_NC      = nc_var,
+                          hsc_FC      = fc_var,
+                          hsc_MLC     = mlc_var,
+                          hsc_OptFuel = optFuel,
+                           hsc_type_env_var = Nothing } ) }
 
 
 knownKeyNames :: [Name]      -- Put here to avoid loops involving DsMeta,
-knownKeyNames =              -- where templateHaskellNames are defined
-  map getName wiredInThings 
+                             -- where templateHaskellNames are defined
+knownKeyNames
+  = map getName wiredInThings 
     ++ basicKnownKeyNames
 #ifdef GHCI
     ++ templateHaskellNames
 #endif
 
 -- -----------------------------------------------------------------------------
--- The Hsc monad: Passing an enviornment and warning state
+-- The Hsc monad: collecting warnings
 
-newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages, HscEnv))
+newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages))
 
 instance Monad Hsc where
-  return a    = Hsc $ \e w -> return (a, w, e)
-  Hsc m >>= k = Hsc $ \e w -> do (a, w1, e1) <- m e w
+  return a = Hsc $ \_ w -> return (a, w)
+  Hsc m >>= k = Hsc $ \e w -> do (a, w1) <- m e w
                                  case k a of
-                                   Hsc k' -> k' e1 w1
+                                    Hsc k' -> k' e w1
 
 instance MonadIO Hsc where
-  liftIO io = Hsc $ \e w -> do a <- io; return (a, w, e)
+  liftIO io = Hsc $ \_ w -> do a <- io; return (a, w)
 
 runHsc :: HscEnv -> Hsc a -> IO a
 runHsc hsc_env (Hsc hsc) = do
-  (a, w, e) <- hsc hsc_env emptyBag
-  printOrThrowWarnings (hsc_dflags e) w
+  (a, w) <- hsc hsc_env emptyBag
+  printOrThrowWarnings (hsc_dflags hsc_env) w
   return a
 
 getWarnings :: Hsc WarningMessages
-getWarnings = Hsc $ \e w -> return (w, w, e)
+getWarnings = Hsc $ \_ w -> return (w, w)
 
 clearWarnings :: Hsc ()
-clearWarnings = Hsc $ \e _w -> return ((), emptyBag, e)
+clearWarnings = Hsc $ \_ _w -> return ((), emptyBag)
 
 logWarnings :: WarningMessages -> Hsc ()
-logWarnings w = Hsc $ \e w0 -> return ((), w0 `unionBags` w, e)
+logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w)
 
 getHscEnv :: Hsc HscEnv
-getHscEnv = Hsc $ \e w -> return (e, w, e)
+getHscEnv = Hsc $ \e w -> return (e, w)
 
 getDynFlags :: Hsc DynFlags
-getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w, e)
-
-setDynFlags :: DynFlags -> Hsc ()
-setDynFlags dflags = Hsc $ \e w -> return ((), w, e { hsc_dflags = dflags })
+getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w)
 
 handleWarnings :: Hsc ()
 handleWarnings = do
@@ -239,11 +237,7 @@ logWarningsReportErrors :: Messages -> Hsc ()
 logWarningsReportErrors (warns,errs) = do
   logWarnings warns
   when (not (isEmptyBag errs)) $ do
-    throwErrors errs
-
--- | Throw some errors.
-throwErrors :: ErrorMessages -> Hsc a
-throwErrors = liftIO . throwIO . mkSrcErr
+    liftIO $ throwIO $ mkSrcErr errs
 
 -- | Deal with errors and warnings returned by a compilation step
 --
@@ -266,7 +260,7 @@ ioMsgMaybe ioA = do
   ((warns,errs), mb_r) <- liftIO $ ioA
   logWarnings warns
   case mb_r of
-    Nothing -> throwErrors errs
+    Nothing -> liftIO $ throwIO (mkSrcErr errs)
     Just r  -> ASSERT( isEmptyBag errs ) return r
 
 -- | like ioMsgMaybe, except that we ignore error messages and return
@@ -299,12 +293,19 @@ hscTcRnGetInfo hsc_env name =
 
 #ifdef GHCI
 hscGetModuleInterface :: HscEnv -> Module -> IO ModIface
-hscGetModuleInterface hsc_env mod =
-  runHsc hsc_env $ ioMsgMaybe $ getModuleInterface hsc_env mod
+hscGetModuleInterface hsc_env mod
+  runHsc hsc_env $ ioMsgMaybe $ getModuleInterface hsc_env mod
 
 -- -----------------------------------------------------------------------------
 -- | Rename some import declarations
-hscRnImportDecls :: HscEnv -> [LImportDecl RdrName] -> IO GlobalRdrEnv
+hscRnImportDecls
+        :: HscEnv
+        -> [LImportDecl RdrName]
+        -> IO GlobalRdrEnv
+
+-- It is important that we use tcRnImports instead of calling rnImports directly
+-- because tcRnImports will force-load any orphan modules necessary, making extra
+-- instances/family instances visible (GHC #4832)
 hscRnImportDecls hsc_env import_decls
   = runHsc hsc_env $ ioMsgMaybe $ tcRnImportDecls hsc_env import_decls
 #endif
@@ -317,36 +318,38 @@ hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary
 
 -- internal version, that doesn't fail due to -Werror
 hscParse' :: ModSummary -> Hsc (Located (HsModule RdrName))
-hscParse' mod_summary = do
-  dflags <- getDynFlags
-  let src_filename  = ms_hspp_file mod_summary
-      maybe_src_buf = ms_hspp_buf  mod_summary
+hscParse' mod_summary
+ = do
+   dflags <- getDynFlags
+   let 
+       src_filename  = ms_hspp_file mod_summary
+       maybe_src_buf = ms_hspp_buf  mod_summary
 
    --------------------------  Parser  ----------------
-  liftIO $ showPass dflags "Parser"
-  {-# SCC "Parser" #-} do
-
-    -- sometimes we already have the buffer in memory, perhaps
-    -- because we needed to parse the imports out of it, or get the
-    -- module name.
-  buf <- case maybe_src_buf of
-           Just b  -> return b
-           Nothing -> liftIO $ hGetStringBuffer src_filename
-
-  let loc = mkRealSrcLoc (mkFastString src_filename) 1 1
-
-  case unP parseModule (mkPState dflags buf loc) of
-    PFailed span err ->
-      liftIO $ throwOneError (mkPlainErrMsg span err)
-
-    POk pst rdr_module -> do
-      logWarningsReportErrors (getMessages pst)
-      liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" $
-                             ppr rdr_module
-      liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" $
-                             ppSourceStats False rdr_module
-      return rdr_module
-       -- ToDo: free the string buffer later.
+   liftIO $ showPass dflags "Parser"
+   {-# SCC "Parser" #-} do
+
+       -- sometimes we already have the buffer in memory, perhaps
+       -- because we needed to parse the imports out of it, or get the
+       -- module name.
+   buf <- case maybe_src_buf of
+            Just b  -> return b
+            Nothing -> liftIO $ hGetStringBuffer src_filename
+
+   let loc  = mkRealSrcLoc (mkFastString src_filename) 1 1
+
+   case unP parseModule (mkPState dflags buf loc) of
+     PFailed span err ->
+         liftIO $ throwOneError (mkPlainErrMsg span err)
+
+     POk pst rdr_module -> do
+         logWarningsReportErrors (getMessages pst)
+         liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" $
+                                ppr rdr_module
+         liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" $
+                                ppSourceStats False rdr_module
+         return rdr_module
+          -- ToDo: free the string buffer later.
 
 -- XXX: should this really be a Maybe X?  Check under which circumstances this
 -- can become a Nothing and decide whether this should instead throw an
@@ -358,46 +361,52 @@ type RenamedStuff =
 -- | Rename and typecheck a module, additionally returning the renamed syntax
 hscTypecheckRename :: HscEnv -> ModSummary -> Located (HsModule RdrName)
                    -> IO (TcGblEnv, RenamedStuff)
-hscTypecheckRename hsc_env mod_summary rdr_module =
-  runHsc hsc_env $ do
-    tc_result <- {-# SCC "Typecheck-Rename" #-}
-                 ioMsgMaybe $ 
-                   tcRnModule hsc_env (ms_hsc_src mod_summary) True rdr_module
+hscTypecheckRename hsc_env mod_summary rdr_module
+  = runHsc hsc_env $ do
+      tc_result
+          <- {-# SCC "Typecheck-Rename" #-}
+              ioMsgMaybe $ 
+                  tcRnModule hsc_env (ms_hsc_src mod_summary) True rdr_module
 
-        -- This 'do' is in the Maybe monad!
-    let rn_info = do decl <- tcg_rn_decls tc_result
-                     let imports = tcg_rn_imports tc_result
-                         exports = tcg_rn_exports tc_result
-                         doc_hdr = tcg_doc_hdr tc_result
-                     return (decl,imports,exports,doc_hdr)
+      let -- This 'do' is in the Maybe monad!
+          rn_info = do decl <- tcg_rn_decls tc_result
+                       let imports = tcg_rn_imports tc_result
+                           exports = tcg_rn_exports tc_result
+                           doc_hdr  = tcg_doc_hdr tc_result
+                       return (decl,imports,exports,doc_hdr)
 
-    return (tc_result, rn_info)
+      return (tc_result, rn_info)
 
 -- | Convert a typechecked module to Core
 hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
-hscDesugar hsc_env mod_summary tc_result =
-  runHsc hsc_env $ hscDesugar' mod_summary tc_result
+hscDesugar hsc_env mod_summary tc_result
+  runHsc hsc_env $ hscDesugar' mod_summary tc_result
 
 hscDesugar' :: ModSummary -> TcGblEnv -> Hsc ModGuts
-hscDesugar' mod_summary tc_result = do
-  hsc_env <- getHscEnv
-  r <- ioMsgMaybe $ deSugar hsc_env (ms_location mod_summary) tc_result
+hscDesugar' mod_summary tc_result
+ = do
+      hsc_env <- getHscEnv
+      r <- ioMsgMaybe $ 
+             deSugar hsc_env (ms_location mod_summary) tc_result
 
-  -- always check -Werror after desugaring, this is the last opportunity for
-  -- warnings to arise before the backend.
-  handleWarnings
-  return r
+      handleWarnings
+                -- always check -Werror after desugaring, this is 
+                -- the last opportunity for warnings to arise before
+                -- the backend.
+      return r
 
 -- | Make a 'ModIface' from the results of typechecking.  Used when
 -- not optimising, and the interface doesn't need to contain any
 -- unfoldings or other cross-module optimisation info.
 -- ToDo: the old interface is only needed to get the version numbers,
 -- we should use fingerprint versions instead.
-makeSimpleIface :: HscEnv -> Maybe ModIface -> TcGblEnv -> ModDetails
+makeSimpleIface :: HscEnv -> 
+                   Maybe ModIface -> TcGblEnv -> ModDetails
                 -> IO (ModIface,Bool)
-makeSimpleIface hsc_env maybe_old_iface tc_result details =
-  runHsc hsc_env $ ioMsgMaybe $ 
-      mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) details tc_result
+makeSimpleIface hsc_env maybe_old_iface tc_result details
+  = runHsc hsc_env $
+     ioMsgMaybe $ 
+       mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) details tc_result
 
 -- | Make a 'ModDetails' from the results of typechecking.  Used when
 -- typechecking only, as opposed to full compilation.
@@ -415,6 +424,7 @@ makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result
                         The compilation proper
                    --------------------------------
 
+
 It's the task of the compilation proper to compile Haskell, hs-boot and
 core files to either byte-code, hard-code (C, asm, LLVM, ect) or to
 nothing at all (the module is still parsed and type-checked. This
@@ -466,13 +476,13 @@ type BatchResult       = (HscStatus, ModIface, ModDetails)
 type NothingResult     = (HscStatus, ModIface, ModDetails)
 type InteractiveResult = (InteractiveStatus, ModIface, ModDetails)
 
--- ToDo: The old interface and module index are only using in 'batch' and
---       'interactive' mode. They should be removed from 'oneshot' mode.
+-- FIXME: The old interface and module index are only using in 'batch' and
+--        'interactive' mode. They should be removed from 'oneshot' mode.
 type Compiler result =  HscEnv
                      -> ModSummary
                      -> SourceModified
-                     -> Maybe ModIface  -- Old interface, if available
-                     -> Maybe (Int,Int) -- Just (i,n) <=> module i of n (for msgs)
+                     -> Maybe ModIface      -- Old interface, if available
+                     -> Maybe (Int,Int)     -- Just (i,n) <=> module i of n (for msgs)
                      -> IO result
 
 data HsCompiler a
@@ -792,21 +802,51 @@ hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv
 hscFileFrontEnd mod_summary = do
     rdr_module <- hscParse' mod_summary
     hsc_env <- getHscEnv
-    dflags  <- getDynFlags
     tcg_env <-
         {-# SCC "Typecheck-Rename" #-}
         ioMsgMaybe $
             tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module
-    tcSafeOK <- liftIO $ readIORef (tcg_safeInfer tcg_env)
-    -- if safe haskell off or safe infer failed, wipe trust
-    if not (safeHaskellOn dflags) || (safeInferOn dflags && not tcSafeOK)
-        then wipeTrust tcg_env
-        else hscCheckSafeImports tcg_env
+    dflags <- getDynFlags
+    -- XXX: See Note [Safe Haskell API]
+    if safeImportsOn dflags
+        then do
+            tcg_env1 <- checkSafeImports dflags hsc_env tcg_env
+            if safeLanguageOn dflags
+                then do
+                    -- we also nuke user written RULES.
+                    logWarnings $ warns (tcg_rules tcg_env1)
+                    return tcg_env1 { tcg_rules = [] }
+                else do
+                    -- Wipe out trust required packages if the module isn't
+                    -- trusted. Not doing this doesn't cause any problems
+                    -- but means the hi file will say some pkgs should be
+                    -- trusted when they don't need to be (since its an
+                    -- untrusted module) and we don't force them to be.
+                    let imps  = tcg_imports tcg_env1
+                        imps' = imps { imp_trust_pkgs = [] }
+                    return tcg_env1 { tcg_imports = imps' }
+
+        else
+            return tcg_env
+
+    where
+        warns rules = listToBag $ map warnRules rules
+        warnRules (L loc (HsRule n _ _ _ _ _ _)) =
+            mkPlainWarnMsg loc $
+                text "Rule \"" <> ftext n <> text "\" ignored" $+$
+                text "User defined rules are disabled under Safe Haskell"
 
 --------------------------------------------------------------
 -- Safe Haskell
 --------------------------------------------------------------
 
+-- Note [Safe Haskell API]
+-- ~~~~~~~~~~~~~~~~~~~~~~
+-- XXX: We only call this in hscFileFrontend and don't expose
+-- it to the GHC API. External users of GHC can't properly use
+-- the GHC API and Safe Haskell.
+
+
 -- Note [Safe Haskell Trust Check]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 -- Safe Haskell checks that an import is trusted according to the following
@@ -827,50 +867,6 @@ hscFileFrontEnd mod_summary = do
 -- source in this matter, not the comments or code.
 
 
--- Note [Safe Haskell Inference]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Safe Haskell does Safe inference on modules that don't have any specific
--- safe haskell mode flag. The basic aproach to this is:
---   * When deciding if we need to do a Safe language check, treat
---     an unmarked module as having -XSafe mode specified.
---   * For checks, don't throw errors but return them to the caller.
---   * Caller checks if there are errors:
---     * For modules explicitly marked -XSafe, we throw the errors.
---     * For unmarked modules (inference mode), we drop the errors
---       and mark the module as being Unsafe.
-
-
--- | Check that the safe imports of the module being compiled are valid.
--- If not we either issue a compilation error if the module is explicitly
--- using Safe Haskell, or mark the module as unsafe if we're in safe
--- inference mode.
-hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv
-hscCheckSafeImports tcg_env = do
-    hsc_env  <- getHscEnv
-    dflags   <- getDynFlags
-    tcg_env' <- checkSafeImports dflags hsc_env tcg_env
-    case safeLanguageOn dflags of
-        True -> do
-            -- we nuke user written RULES in -XSafe
-            logWarnings $ warns (tcg_rules tcg_env')
-            return tcg_env' { tcg_rules = [] }
-        False
-              -- user defined RULES, so not safe or already unsafe
-            | safeInferOn dflags && not (null $ tcg_rules tcg_env') ||
-              safeHaskell dflags == Sf_None
-            -> wipeTrust tcg_env'
-
-              -- trustworthy
-            | otherwise
-            -> return tcg_env'
-
-    where
-        warns rules = listToBag $ map warnRules rules
-        warnRules (L loc (HsRule n _ _ _ _ _ _)) =
-            mkPlainWarnMsg loc $
-                text "Rule \"" <> ftext n <> text "\" ignored" $+$
-                text "User defined rules are disabled under Safe Haskell"
-
 -- | Validate that safe imported modules are actually safe.
 -- For modules in the HomePackage (the package the module we
 -- are compiling in resides) this just involves checking its
@@ -888,27 +884,8 @@ hscCheckSafeImports tcg_env = do
 checkSafeImports :: DynFlags -> HscEnv -> TcGblEnv -> Hsc TcGblEnv
 checkSafeImports dflags hsc_env tcg_env
     = do
-        -- We want to use the warning state specifically for detecting if safe
-        -- inference has failed, so store and clear any existing warnings.
-        oldErrs <- getWarnings
-        clearWarnings
-
         imps <- mapM condense imports'
         pkgs <- mapM checkSafe imps
-
-        -- grab any safe haskell specific errors and restore old warnings
-        errs <- getWarnings
-        clearWarnings
-        logWarnings oldErrs
-
-        -- See the Note [ Safe Haskell Inference]
-        when (not $ isEmptyBag errs) (
-            -- did we fail safe inference or fail -XSafe?
-            case safeHaskell dflags == Sf_SafeInfered of
-                True  -> setDynFlags (dflags { safeHaskell = Sf_None } )
-                False -> liftIO . throwIO . mkSrcErr $ errs
-            )
-
         when (packageTrustOn dflags) $ checkPkgTrust pkg_reqs
 
         -- add in trusted package requirements for this module
@@ -930,7 +907,7 @@ checkSafeImports dflags hsc_env tcg_env
         cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal
         cond' v1@(m1,_,l1,s1) (_,_,_,s2)
             | s1 /= s2
-            = throwErrors $ unitBag $ mkPlainErrMsg l1
+            = liftIO $ throwIO $ mkSrcErr $ unitBag $ mkPlainErrMsg l1
                     (text "Module" <+> ppr m1 <+> (text $ "is imported"
                         ++ " both as a safe and unsafe import!"))
             | otherwise
@@ -956,9 +933,8 @@ checkSafeImports dflags hsc_env tcg_env
         -- we check the package trust flag.
         packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool
         packageTrusted _ _ _
-            | not (packageTrustOn dflags)     = True
-        packageTrusted Sf_Safe        False _ = True
-        packageTrusted Sf_SafeInfered False _ = True
+            | not (packageTrustOn dflags) = True
+        packageTrusted Sf_Safe False _    = True
         packageTrusted _ _ m
             | isHomePkg m = True
             | otherwise   = trusted $ getPackageDetails (pkgState dflags)
@@ -969,12 +945,12 @@ checkSafeImports dflags hsc_env tcg_env
         -- if the module trustworthy (true) or safe (false) so we know
         -- if we should check if the package itself is trusted in the
         -- future.
-        isModSafe :: Module -> SrcSpan -> Hsc (Bool)
+        isModSafe :: Module -> SrcSpan -> Hsc (Maybe SDoc, Bool)
         isModSafe m l = do
             iface <- lookup' m
             case iface of
                 -- can't load iface to check trust!
-                Nothing -> throwErrors $ unitBag $ mkPlainErrMsg l
+                Nothing -> liftIO $ throwIO $ mkSrcErr $ unitBag $ mkPlainErrMsg l
                             $ text "Can't load the interface file for" <+> ppr m <>
                               text ", to check that it can be safely imported"
 
@@ -983,27 +959,20 @@ checkSafeImports dflags hsc_env tcg_env
                     let trust = getSafeMode $ mi_trust iface'
                         trust_own_pkg = mi_trust_pkg iface'
                         -- check module is trusted
-                        safeM = trust `elem` [Sf_SafeInfered, Sf_Safe, Sf_Trustworthy]
+                        safeM = trust `elem` [Sf_Safe, Sf_Trustworthy]
                         -- check package is trusted
                         safeP = packageTrusted trust trust_own_pkg m
-                    case (safeM, safeP) of
-                        -- General errors we throw but Safe errors we log
-                        (True, True ) -> return $ trust == Sf_Trustworthy
-                        (True, False) -> liftIO . throwIO $ pkgTrustErr
-                        (False, _   ) -> logWarnings modTrustErr >> return (trust == Sf_Trustworthy)
-
-                    where
-                        pkgTrustErr = mkSrcErr $ unitBag $ mkPlainErrMsg l $ ppr m
-                            <+> text "can't be safely imported!" <+> text "The package ("
-                            <> ppr (modulePackageId m)
-                            <> text ") the module resides in isn't trusted."
-                        modTrustErr = unitBag $ mkPlainErrMsg l $ ppr m
-                            <+> text "can't be safely imported!"
-                            <+> text "The module itself isn't safe."
+                    if safeM && safeP
+                        then return (Nothing, trust == Sf_Trustworthy)
+                        else let err = Just $ if safeM
+                                    then text "The package (" <> ppr (modulePackageId m) <>
+                                         text ") the module resides in isn't trusted."
+                                    else text "The module itself isn't safe."
+                              in return (err, False)
 
         -- Here we check the transitive package trust requirements are OK still.
         checkPkgTrust :: [PackageId] -> Hsc ()
-        checkPkgTrust pkgs =
+        checkPkgTrust pkgs = do
             case errors of
                 [] -> return ()
                 _  -> (liftIO . throwIO . mkSrcErr . listToBag) errors
@@ -1020,20 +989,16 @@ checkSafeImports dflags hsc_env tcg_env
         checkSafe :: (Module, SrcSpan, IsSafeImport) -> Hsc (Maybe PackageId)
         checkSafe (_, _, False) = return Nothing
         checkSafe (m, l, True ) = do
-            tw <- isModSafe m l
-            return $ pkg tw
+            (module_safe, tw) <- isModSafe m l
+            case module_safe of
+                Nothing -> return $ pkg tw
+                Just s  -> liftIO $ throwIO $ mkSrcErr $ unitBag $ mkPlainErrMsg l
+                            $ ppr m <+> text "can't be safely imported!"
+                                <+> s
             where pkg False = Nothing
                   pkg True | isHomePkg m = Nothing
                            | otherwise   = Just (modulePackageId m)
-
--- | Set module to unsafe and wipe trust information.
-wipeTrust :: TcGblEnv -> Hsc TcGblEnv
-wipeTrust tcg_env = do
-    dflags <- getDynFlags
-    setDynFlags (dflags { safeHaskell = Sf_None })
-    let imps = (tcg_imports tcg_env) { imp_trust_pkgs = [] }
-    return $ tcg_env { tcg_imports = imps }
-
+                            
 --------------------------------------------------------------
 -- Simplifiers
 --------------------------------------------------------------
@@ -1447,7 +1412,7 @@ hscTcExpr hsc_env expr = runHsc hsc_env $ do
         Just (L _ (ExprStmt expr _ _ _)) ->
             ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr
         _ ->
-            throwErrors $ unitBag $ mkPlainErrMsg noSrcSpan
+            liftIO $ throwIO $ mkSrcErr $ unitBag $ mkPlainErrMsg noSrcSpan
                 (text "not an expression:" <+> quotes (text expr))
 
 -- | Find the kind of a type
@@ -1505,7 +1470,7 @@ hscParseThingWithLocation source linenumber parser str
 
         PFailed span err -> do
           let msg = mkPlainErrMsg span err
-          throwErrors $ unitBag msg
+          liftIO $ throwIO (mkSrcErr (unitBag msg))
 
         POk pst thing -> do
           logWarningsReportErrors (getMessages pst)
index 5ad122d..cb67275 100644 (file)
@@ -4,7 +4,6 @@
 \section[HscTypes]{Types for the per-module compiler}
 
 \begin{code}
-
 -- | Types for the per-module compiler
 module HscTypes ( 
         -- * compilation state
@@ -37,6 +36,7 @@ module HscTypes (
         
         PackageInstEnv, PackageRuleBase,
 
+
         -- * Annotations
         prepareAnnotations,
 
@@ -1560,7 +1560,6 @@ noDependencies = Deps [] [] [] []
 
 -- | Records modules that we depend on by making a direct import from
 data Usage
-  -- | Module from another package
   = UsagePackageModule {
         usg_mod      :: Module,
            -- ^ External package module depended on
@@ -1568,8 +1567,7 @@ data Usage
             -- ^ Cached module fingerprint
         usg_safe :: IsSafeImport
             -- ^ Was this module imported as a safe import
-    }
-  -- | Module from the current package
+    }                                           -- ^ Module from another package
   | UsageHomeModule {
         usg_mod_name :: ModuleName,
             -- ^ Name of the module
@@ -1584,7 +1582,7 @@ data Usage
             -- if we depend on the export list
         usg_safe :: IsSafeImport
             -- ^ Was this module imported as a safe import
-    }
+    }                                           -- ^ Module from the current package
     deriving( Eq )
         -- The export list field is (Just v) if we depend on the export list:
         --      i.e. we imported the module directly, whether or not we
@@ -1773,14 +1771,14 @@ ms_imps ms = ms_textual_imps ms ++ map mk_additional_import (dynFlagDependencies
     -- import that did not occur in the program text, such as those induced by the use of
     -- plugins (the -plgFoo flag)
     mk_additional_import mod_nm = noLoc $ ImportDecl {
-      ideclName      = noLoc mod_nm,
-      ideclPkgQual   = Nothing,
-      ideclSource    = False,
-      ideclImplicit  = True,   -- Maybe implicit because not "in the program text"
+      ideclName = noLoc mod_nm,
+      ideclPkgQual = Nothing,
+      ideclSource = False,
+      ideclImplicit = True,     -- Maybe implicit because not "in the program text"
       ideclQualified = False,
-      ideclAs        = Nothing,
-      ideclHiding    = Nothing,
-      ideclSafe      = False
+      ideclAs = Nothing,
+      ideclHiding = Nothing,
+      ideclSafe = False
     }
 
 -- The ModLocation contains both the original source filename and the
index 8083dbc..59b3986 100644 (file)
@@ -236,7 +236,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar
           check (isFFIDynArgumentTy arg1_ty)
                 (illegalForeignTyErr argument arg1_ty)
           checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
-          let safe_on = safeLanguageOn dflags || safeInferOn dflags
+          let safe_on = safeLanguageOn dflags
               ioOK    = if safe_on then mustBeIO else nonIOok
           checkForeignRes ioOK safe_on (isFFIImportResultTy dflags) res_ty
           return idecl
@@ -250,17 +250,17 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar
             (text "The safe/unsafe annotation should not be used with `foreign import prim'.")
       checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys
       -- prim import result is more liberal, allows (#,,#)
-      let safe_on = safeLanguageOn dflags || safeInferOn dflags
+      let safe_on = safeLanguageOn dflags
           ioOK    = if safe_on then mustBeIO else nonIOok
       checkForeignRes ioOK safe_on (isFFIPrimResultTy dflags) res_ty
       return idecl
   | otherwise = do              -- Normal foreign import
-      checkCg checkCOrAsmOrLlvmOrDotNetOrInterp
+      checkCg (checkCOrAsmOrLlvmOrDotNetOrInterp)
       checkCConv cconv
       checkCTarget target
       dflags <- getDOpts
       checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
-      let safe_on = safeLanguageOn dflags || safeInferOn dflags
+      let safe_on = safeLanguageOn dflags
           ioOK    = if safe_on then mustBeIO else nonIOok
       checkForeignRes ioOK safe_on (isFFIImportResultTy dflags) res_ty
       checkMissingAmpersand dflags arg_tys res_ty
@@ -377,14 +377,9 @@ checkForeignRes non_io_result_ok safehs_check pred_res_ty ty
     Just (_, res_ty)
      | pred_res_ty res_ty ->
         return ()
-
-    _ -> do
-        dflags <- getDOpts
-        case safeInferOn dflags && safehs_check of
-            True | pred_res_ty ty -> recordUnsafeInfer
-
-            _ -> check (non_io_result_ok && pred_res_ty ty)
-                     (illegalForeignTyErr result ty $+$ safeHsErr safehs_check)
+    _ ->
+        check (non_io_result_ok && pred_res_ty ty)
+              (illegalForeignTyErr result ty $+$ safeHsErr safehs_check)
 \end{code}
 
 \begin{code}
index bddeb2d..0061e5f 100644 (file)
@@ -407,19 +407,15 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
        -- performed. Derived instances are OK.
        ; dflags <- getDOpts
        ; when (safeLanguageOn dflags) $
-             mapM_ (\x -> when (typInstCheck x)
+             mapM_ (\x -> when (is_cls (iSpec x) `elem` typeableClassNames)
                                (addErrAt (getSrcSpan $ iSpec x) typInstErr))
                    local_info
-       -- As above but for Safe Inference mode.
-       ; when (safeInferOn dflags) $
-             mapM_ (\x -> when (typInstCheck x) recordUnsafeInfer) local_info
 
        ; return ( gbl_env
                 , (bagToList deriv_inst_info) ++ local_info
                 , aux_binds `plusHsValBinds` deriv_binds)
     }}}
   where
-    typInstCheck ty = is_cls (iSpec ty) `elem` typeableClassNames
     typInstErr = ptext $ sLit $ "Can't create hand written instances of Typeable in Safe"
                               ++ " Haskell! Can only derive them"
 
index 412784e..69ccf25 100644 (file)
@@ -110,7 +110,6 @@ import Control.Monad
 
 
 \begin{code}
--- | Top level entry point for typechecker and renamer
 tcRnModule :: HscEnv 
           -> HscSource
           -> Bool              -- True <=> save renamed syntax
index 0c58a68..ef6f31a 100644 (file)
@@ -2,8 +2,6 @@
 % (c) The University of Glasgow 2006
 %
 
-Functions for working with the typechecker environment (setters, getters...).
-
 \begin{code}
 module TcRnMonad(
         module TcRnMonad,
@@ -63,7 +61,6 @@ import Control.Monad
 
 \begin{code}
 
--- | Setup the initial typechecking environment
 initTc :: HscEnv
        -> HscSource
        -> Bool          -- True <=> retain renamed syntax trees
@@ -81,7 +78,6 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
         used_rdr_var <- newIORef Set.empty ;
         th_var       <- newIORef False ;
         th_splice_var<- newIORef False ;
-        infer_var    <- newIORef True ;
         lie_var      <- newIORef emptyWC ;
         dfun_n_var   <- newIORef emptyOccSet ;
         type_env_var <- case hsc_type_env_var hsc_env of {
@@ -94,46 +90,45 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
                 | otherwise      = Nothing ;
 
              gbl_env = TcGblEnv {
-                tcg_mod            = mod,
-                tcg_src            = hsc_src,
-                tcg_rdr_env        = emptyGlobalRdrEnv,
-                tcg_fix_env        = emptyNameEnv,
-                tcg_field_env      = RecFields emptyNameEnv emptyNameSet,
-                tcg_default        = Nothing,
-                tcg_type_env       = emptyNameEnv,
-                tcg_type_env_var   = type_env_var,
-                tcg_inst_env       = emptyInstEnv,
-                tcg_fam_inst_env   = emptyFamInstEnv,
-                tcg_th_used        = th_var,
-                tcg_th_splice_used = th_splice_var,
-                tcg_exports        = [],
-                tcg_imports        = emptyImportAvails,
-                tcg_used_rdrnames  = used_rdr_var,
-                tcg_dus            = emptyDUs,
-
-                tcg_rn_imports     = [],
-                tcg_rn_exports     = maybe_rn_syntax [],
-                tcg_rn_decls       = maybe_rn_syntax emptyRnGroup,
-
-                tcg_binds          = emptyLHsBinds,
-                tcg_imp_specs      = [],
-                tcg_sigs           = emptyNameSet,
-                tcg_ev_binds       = emptyBag,
-                tcg_warns          = NoWarnings,
-                tcg_anns           = [],
-                tcg_tcs            = [],
-                tcg_clss           = [],
-                tcg_insts          = [],
-                tcg_fam_insts      = [],
-                tcg_rules          = [],
-                tcg_fords          = [],
-                tcg_vects          = [],
-                tcg_dfun_n         = dfun_n_var,
-                tcg_keep           = keep_var,
-                tcg_doc_hdr        = Nothing,
-                tcg_hpc            = False,
-                tcg_main           = Nothing,
-                tcg_safeInfer      = infer_var
+                tcg_mod       = mod,
+                tcg_src       = hsc_src,
+                tcg_rdr_env   = emptyGlobalRdrEnv,
+                tcg_fix_env   = emptyNameEnv,
+                tcg_field_env = RecFields emptyNameEnv emptyNameSet,
+                tcg_default   = Nothing,
+                tcg_type_env  = emptyNameEnv,
+                tcg_type_env_var = type_env_var,
+                tcg_inst_env  = emptyInstEnv,
+                tcg_fam_inst_env  = emptyFamInstEnv,
+                tcg_th_used   = th_var,
+                tcg_th_splice_used   = th_splice_var,
+                tcg_exports  = [],
+                tcg_imports  = emptyImportAvails,
+                tcg_used_rdrnames = used_rdr_var,
+                tcg_dus      = emptyDUs,
+
+                tcg_rn_imports = [],
+                tcg_rn_exports = maybe_rn_syntax [],
+                tcg_rn_decls   = maybe_rn_syntax emptyRnGroup,
+
+                tcg_binds     = emptyLHsBinds,
+                tcg_imp_specs = [],
+                tcg_sigs      = emptyNameSet,
+                tcg_ev_binds  = emptyBag,
+                tcg_warns     = NoWarnings,
+                tcg_anns      = [],
+                tcg_tcs       = [],
+                tcg_clss      = [],
+                tcg_insts     = [],
+                tcg_fam_insts = [],
+                tcg_rules     = [],
+                tcg_fords     = [],
+                tcg_vects     = [],
+                tcg_dfun_n    = dfun_n_var,
+                tcg_keep      = keep_var,
+                tcg_doc_hdr   = Nothing,
+                tcg_hpc       = False,
+                tcg_main      = Nothing
              } ;
              lcl_env = TcLclEnv {
                 tcl_errs       = errs_var,
@@ -276,15 +271,15 @@ unsetWOptM flag = updEnv (\ env@(Env { env_top = top }) ->
 
 -- | Do it flag is true
 ifDOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
-ifDOptM flag thing_inside = do { b <- doptM flag ;
+ifDOptM flag thing_inside = do { b <- doptM flag;
                                 if b then thing_inside else return () }
 
 ifWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
-ifWOptM flag thing_inside = do { b <- woptM flag ;
+ifWOptM flag thing_inside = do { b <- woptM flag;
                                 if b then thing_inside else return () }
 
 ifXOptM :: ExtensionFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
-ifXOptM flag thing_inside = do { b <- xoptM flag ;
+ifXOptM flag thing_inside = do { b <- xoptM flag;
                                 if b then thing_inside else return () }
 
 getGhcMode :: TcRnIf gbl lcl GhcMode
@@ -559,7 +554,7 @@ setErrsVar :: TcRef Messages -> TcRn a -> TcRn a
 setErrsVar v = updLclEnv (\ env -> env { tcl_errs =  v })
 
 addErr :: Message -> TcRn ()    -- Ignores the context stack
-addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg }
+addErr msg = do { loc <- getSrcSpanM ; addErrAt loc msg }
 
 failWith :: Message -> TcRn a
 failWith msg = addErr msg >> failM
@@ -1082,18 +1077,6 @@ setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
 
 %************************************************************************
 %*                                                                      *
-             Safe Haskell context
-%*                                                                      *
-%************************************************************************
-
-\begin{code}
-recordUnsafeInfer :: TcM ()
-recordUnsafeInfer = getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) False
-\end{code}
-
-
-%************************************************************************
-%*                                                                      *
              Stuff for the renamer's local env
 %*                                                                      *
 %************************************************************************
index 5363910..45004c6 100644 (file)
@@ -2,19 +2,6 @@
 % (c) The University of Glasgow 2006
 % (c) The GRASP Project, Glasgow University, 1992-2002
 %
-
-Various types used during typechecking, please see TcRnMonad as well for
-operations on these types. You probably want to import it, instead of this
-module.
-
-All the monads exported here are built on top of the same IOEnv monad. The
-monad functions like a Reader monad in the way it passes the environment
-around. This is done to allow the environment to be manipulated in a stack
-like fashion when entering expressions... ect.
-
-For state that is global and should be returned at the end (e.g not part
-of the stack mechanism), you should use an TcRef (= IORef) to store them.
-
 \begin{code}
 module TcRnTypes(
        TcRnIf, TcRn, TcM, RnM, IfM, IfL, IfG, -- The monad is opaque outside this module
@@ -148,34 +135,29 @@ instance Outputable TcTyVarBind where
 
 
 %************************************************************************
-%*                                                                      *
-                The main environment types
-%*                                                                      *
+%*                                                                     *
+               The main environment types
+%*                                                                     *
 %************************************************************************
 
 \begin{code}
--- We 'stack' these envs through the Reader like monad infastructure
--- as we move into an expression (although the change is focused in
--- the lcl type).
-data Env gbl lcl
+data Env gbl lcl       -- Changes as we move into an expression
   = Env {
-        env_top  :: HscEnv,  -- Top-level stuff that never changes
-                             -- Includes all info about imported things
+       env_top  :: HscEnv,     -- Top-level stuff that never changes
+                               -- Includes all info about imported things
 
-        env_us   :: {-# UNPACK #-} !(IORef UniqSupply),
-                             -- Unique supply for local varibles
+       env_us   :: {-# UNPACK #-} !(IORef UniqSupply), 
+                               -- Unique supply for local varibles
 
-        env_gbl  :: gbl,     -- Info about things defined at the top level
-                             -- of the module being compiled
+       env_gbl  :: gbl,        -- Info about things defined at the top level
+                               -- of the module being compiled
 
-        env_lcl  :: lcl      -- Nested stuff; changes as we go into 
+       env_lcl  :: lcl         -- Nested stuff; changes as we go into 
     }
 
 -- TcGblEnv describes the top-level of the module at the 
 -- point at which the typechecker is finished work.
 -- It is this structure that is handed on to the desugarer
--- For state that needs to be updated during the typechecking
--- phase and returned at end, use a TcRef (= IORef).
 
 data TcGblEnv
   = TcGblEnv {
@@ -216,8 +198,7 @@ data TcGblEnv
        tcg_exports :: [AvailInfo],     -- ^ What is exported
        tcg_imports :: ImportAvails,
           -- ^ Information about what was imported from where, including
-         -- things bound in this module. Also store Safe Haskell info
-          -- here about transative trusted packaage requirements.
+         -- things bound in this module.
 
        tcg_dus :: DefUses,
           -- ^ What is defined in this module and what is used.
@@ -299,11 +280,9 @@ data TcGblEnv
         tcg_hpc       :: AnyHpcUsage,        -- ^ @True@ if any part of the
                                              --  prog uses hpc instrumentation.
 
-        tcg_main      :: Maybe Name,         -- ^ The Name of the main
+        tcg_main      :: Maybe Name          -- ^ The Name of the main
                                              -- function, if this module is
                                              -- the main module.
-        tcg_safeInfer :: TcRef Bool          -- Has the typechecker infered this
-                                             -- module as -XSafe (Safe Haskell)
     }
 
 data RecFieldEnv