Fix GHC API with respect to safe haskell. (#5989)

This fixes haddock so it correctly reports
the safe haskell mode of a module.

1 files changed, 45 insertions, 25 deletions

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 9e33aae2bb..53320530b0 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -72,10 +72,12 @@ module GHC (
         modInfoIsExportedName,
         modInfoLookupName,
         modInfoIface,
-        lookupGlobalName,
-        findGlobalAnns,
+        modInfoSafe,
+	lookupGlobalName,
+	findGlobalAnns,
         mkPrintUnqualifiedForModule,
         ModIface(..),
+        SafeHaskellMode(..),
 
         -- * Querying the environment
         packageDbModules,
@@ -254,6 +256,7 @@ import HscMain
 import GhcMake
 import DriverPipeline   ( compile' )
 import GhcMonad
+import TcRnMonad        ( finalSafeMode )
 import TcRnTypes
 import Packages
 import NameSet
@@ -737,6 +740,7 @@ typecheckModule pmod = do
                       HsParsedModule { hpm_module = parsedSource pmod,
                                        hpm_src_files = pm_extra_src_files pmod }
  details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env
+ safe    <- liftIO $ finalSafeMode (ms_hspp_opts ms) tc_gbl_env
  return $
      TypecheckedModule {
        tm_internals_          = (tc_gbl_env, details),
@@ -749,7 +753,8 @@ typecheckModule pmod = do
            minf_exports   = availsToNameSet $ md_exports details,
            minf_rdr_env   = Just (tcg_rdr_env tc_gbl_env),
            minf_instances = md_insts details,
-           minf_iface     = Nothing
+           minf_iface     = Nothing,
+           minf_safe      = safe
 #ifdef GHCI
           ,minf_modBreaks = emptyModBreaks
 #endif
@@ -823,12 +828,16 @@ data CoreModule
       -- | Type environment for types declared in this module
       cm_types    :: !TypeEnv,
       -- | Declarations
-      cm_binds    :: CoreProgram
+      cm_binds    :: CoreProgram,
+      -- | Safe Haskell mode
+      cm_safe     :: SafeHaskellMode
     }
 
 instance Outputable CoreModule where
-   ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb}) =
-      text "%module" <+> ppr mn <+> ppr te $$ vcat (map ppr cb)
+   ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb,
+                    cm_safe = sf})
+    = text "%module" <+> ppr mn <+> parens (ppr sf) <+> ppr te
+      $$ vcat (map ppr cb)
 
 -- | This is the way to get access to the Core bindings corresponding
 -- to a module. 'compileToCore' parses, typechecks, and
@@ -865,7 +874,7 @@ compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do
   modLocation <- liftIO $ mkHiOnlyModLocation dflags (hiSuf dflags) cwd
                    ((moduleNameSlashes . moduleName) mName)
 
-  let modSummary = ModSummary { ms_mod = mName,
+  let modSum = ModSummary { ms_mod = mName,
          ms_hsc_src = ExtCoreFile,
          ms_location = modLocation,
          -- By setting the object file timestamp to Nothing,
@@ -884,7 +893,7 @@ compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do
       }
 
   hsc_env <- getSession
-  liftIO $ hscCompileCore hsc_env simplify modSummary (cm_binds cm)
+  liftIO $ hscCompileCore hsc_env simplify (cm_safe cm) modSum (cm_binds cm)
 
 
 compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule
@@ -902,7 +911,7 @@ compileCore simplify fn = do
        mod_guts <- coreModule `fmap`
                       -- TODO: space leaky: call hsc* directly?
                       (desugarModule =<< typecheckModule =<< parseModule modSummary)
-       liftM gutsToCoreModule $
+       liftM (gutsToCoreModule (mg_safe_haskell mod_guts)) $
          if simplify
           then do
              -- If simplify is true: simplify (hscSimplify), then tidy
@@ -919,18 +928,22 @@ compileCore simplify fn = do
   where -- two versions, based on whether we simplify (thus run tidyProgram,
         -- which returns a (CgGuts, ModDetails) pair, or not (in which case
         -- we just have a ModGuts.
-        gutsToCoreModule :: Either (CgGuts, ModDetails) ModGuts -> CoreModule
-        gutsToCoreModule (Left (cg, md))  = CoreModule {
+        gutsToCoreModule :: SafeHaskellMode
+                         -> Either (CgGuts, ModDetails) ModGuts
+                         -> CoreModule
+        gutsToCoreModule safe_mode (Left (cg, md)) = CoreModule {
           cm_module = cg_module cg,
-          cm_types = md_types md,
-          cm_binds = cg_binds cg
+          cm_types  = md_types md,
+          cm_binds  = cg_binds cg,
+          cm_safe   = safe_mode
         }
-        gutsToCoreModule (Right mg) = CoreModule {
+        gutsToCoreModule safe_mode (Right mg) = CoreModule {
           cm_module  = mg_module mg,
           cm_types   = typeEnvFromEntities (bindersOfBinds (mg_binds mg))
                                            (mg_tcs mg)
                                            (mg_fam_insts mg),
-          cm_binds   = mg_binds mg
+          cm_binds   = mg_binds mg,
+          cm_safe    = safe_mode
          }
 
 -- %************************************************************************
@@ -973,13 +986,14 @@ getPrintUnqual = withSession $ \hsc_env ->
 
 -- | Container for information about a 'Module'.
 data ModuleInfo = ModuleInfo {
-        minf_type_env  :: TypeEnv,
-        minf_exports   :: NameSet, -- ToDo, [AvailInfo] like ModDetails?
-        minf_rdr_env   :: Maybe GlobalRdrEnv,   -- Nothing for a compiled/package mod
+	minf_type_env  :: TypeEnv,
+	minf_exports   :: NameSet, -- ToDo, [AvailInfo] like ModDetails?
+	minf_rdr_env   :: Maybe GlobalRdrEnv,	-- Nothing for a compiled/package mod
         minf_instances :: [ClsInst],
-        minf_iface     :: Maybe ModIface
+        minf_iface     :: Maybe ModIface,
+        minf_safe      :: SafeHaskellMode
 #ifdef GHCI
-       ,minf_modBreaks :: ModBreaks 
+       ,minf_modBreaks :: ModBreaks
 #endif
   }
         -- We don't want HomeModInfo here, because a ModuleInfo applies
@@ -1020,6 +1034,7 @@ getPackageModuleInfo hsc_env mdl
                         minf_rdr_env   = Just $! availsToGlobalRdrEnv (moduleName mdl) avails,
                         minf_instances = error "getModuleInfo: instances for package module unimplemented",
                         minf_iface     = Just iface,
+                        minf_safe      = getSafeMode $ mi_trust iface,
                         minf_modBreaks = emptyModBreaks  
                 }))
 #else
@@ -1036,11 +1051,12 @@ getHomeModuleInfo hsc_env mdl =
       let details = hm_details hmi
           iface   = hm_iface hmi
       return (Just (ModuleInfo {
-                        minf_type_env  = md_types details,
-                        minf_exports   = availsToNameSet (md_exports details),
-                        minf_rdr_env   = mi_globals $! hm_iface hmi,
-                        minf_instances = md_insts details,
-                        minf_iface     = Just iface
+			minf_type_env  = md_types details,
+			minf_exports   = availsToNameSet (md_exports details),
+			minf_rdr_env   = mi_globals $! hm_iface hmi,
+			minf_instances = md_insts details,
+                        minf_iface     = Just iface,
+                        minf_safe      = getSafeMode $ mi_trust iface
 #ifdef GHCI
                        ,minf_modBreaks = getModBreaks hmi
 #endif
@@ -1085,6 +1101,10 @@ modInfoLookupName minf name = withSession $ \hsc_env -> do
 modInfoIface :: ModuleInfo -> Maybe ModIface
 modInfoIface = minf_iface
 
+-- | Retrieve module safe haskell mode
+modInfoSafe :: ModuleInfo -> SafeHaskellMode
+modInfoSafe = minf_safe
+
 #ifdef GHCI
 modInfoModBreaks :: ModuleInfo -> ModBreaks
 modInfoModBreaks = minf_modBreaks