safe haskell wip

compiler/main/DynFlags.hs

@@ -1037,12 +1037,6 @@ safeLanguageOn dflags = safeHaskell dflags == Sf_Safe
 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 ||

compiler/main/HscMain.lhs

@@ -161,12 +161,13 @@ 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
+  { eps_var  <- newIORef initExternalPackageState
+  ; us       <- mkSplitUniqSupply 'r'
+  ; nc_var   <- newIORef (initNameCache us knownKeyNames)
+  ; fc_var   <- newIORef emptyUFM
+  ; mlc_var  <- newIORef emptyModuleEnv
+  ; optFuel  <- initOptFuelState
+  ; safe_var <- newIORef True
   ; return (HscEnv { hsc_dflags       = dflags,
   		     hsc_targets      = [],
   		     hsc_mod_graph    = [],
@@ -177,7 +178,8 @@ newHscEnv dflags = do
   		     hsc_FC           = fc_var,
   		     hsc_MLC          = mlc_var,
   		     hsc_OptFuel      = optFuel,
-                     hsc_type_env_var = Nothing } ) }
+                     hsc_type_env_var = Nothing,
+                     hsc_safeInf      = safe_var } ) }
 
 
 knownKeyNames :: [Name]      -- Put here to avoid loops involving DsMeta,
@@ -191,40 +193,37 @@ knownKeyNames =              -- where templateHaskellNames are defined
 -- -----------------------------------------------------------------------------
 -- The Hsc monad: Passing an enviornment and warning state
 
-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 $ \_ _ -> 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
@@ -607,7 +606,7 @@ hscOneShotCompiler =
 
   , hscRecompile = genericHscRecompile hscOneShotCompiler
 
-  , hscBackend = \ tc_result mod_summary mb_old_hash -> do
+  , hscBackend = \tc_result mod_summary mb_old_hash -> do
        dflags <- getDynFlags
        case hscTarget dflags of
          HscNothing -> return (HscRecomp Nothing ())
@@ -902,18 +901,21 @@ checkSafeImports dflags hsc_env tcg_env
         logWarnings oldErrs
 
         -- See the Note [ Safe Haskell Inference]
-        when (not $ isEmptyBag errs) (
-            -- did we fail safe inference or fail -XSafe?
-            case safeInferOn dflags 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
-        let new_trust = emptyImportAvails { imp_trust_pkgs = catMaybes pkgs }
-        return tcg_env { tcg_imports = imp_info `plusImportAvails` new_trust }
+        case (not $ isEmptyBag errs) of
+
+            -- We have errors!
+            True ->
+                -- did we fail safe inference or fail -XSafe?
+                case safeInferOn dflags of
+                    True  -> wipeTrust tcg_env
+                    False -> liftIO . throwIO . mkSrcErr $ errs
+            
+            -- All good matey!
+            False -> do
+                when (packageTrustOn dflags) $ checkPkgTrust pkg_reqs
+                -- add in trusted package requirements for this module
+                let new_trust = emptyImportAvails { imp_trust_pkgs = catMaybes pkgs }
+                return tcg_env { tcg_imports = imp_info `plusImportAvails` new_trust }
 
     where
         imp_info = tcg_imports tcg_env     -- ImportAvails
@@ -1029,8 +1031,8 @@ checkSafeImports dflags hsc_env tcg_env
 -- | Set module to unsafe and wipe trust information.
 wipeTrust :: TcGblEnv -> Hsc TcGblEnv
 wipeTrust tcg_env = do
-    dflags <- getDynFlags
-    setDynFlags (dflags { safeHaskell = Sf_None })
+    env <- getHscEnv
+    liftIO $ hscSetSafeInf env False
     let imps = (tcg_imports tcg_env) { imp_trust_pkgs = [] }
     return $ tcg_env { tcg_imports = imps }
 

compiler/main/HscTypes.lhs

@@ -95,6 +95,7 @@ module HscTypes (
         noIfaceVectInfo,
 
         -- * Safe Haskell information
+        hscGetSafeInf, hscSetSafeInf,
         IfaceTrustInfo, getSafeMode, setSafeMode, noIfaceTrustInfo,
         trustInfoToNum, numToTrustInfo, IsSafeImport,
 
@@ -315,12 +316,25 @@ data HscEnv
                 -- by limiting the number of transformations,
                 -- we can use binary search to help find compiler bugs.
 
-        hsc_type_env_var :: Maybe (Module, IORef TypeEnv)
+        hsc_type_env_var :: Maybe (Module, IORef TypeEnv),
                 -- ^ Used for one-shot compilation only, to initialise
                 -- the 'IfGblEnv'. See 'TcRnTypes.tcg_type_env_var' for 
                 -- 'TcRunTypes.TcGblEnv'
+
+        hsc_safeInf :: {-# UNPACK #-} !(IORef Bool)
+                -- ^ Have we infered the module being compiled as
+                -- being safe?
  }
 
+-- | Get if the current module is considered safe or not by inference.
+hscGetSafeInf :: HscEnv -> IO Bool
+hscGetSafeInf hsc_env = readIORef (hsc_safeInf hsc_env)
+
+-- | Set if the current module is considered safe or not by inference.
+hscSetSafeInf :: HscEnv -> Bool -> IO ()
+hscSetSafeInf hsc_env b = writeIORef (hsc_safeInf hsc_env) b
+
+-- | Retrieve the ExternalPackageState cache.
 hscEPS :: HscEnv -> IO ExternalPackageState
 hscEPS hsc_env = readIORef (hsc_EPS hsc_env)