SafeHaskell: Add Safe & Trustworthy pragmas

compiler/iface/BinIface.hs

@@ -390,7 +390,8 @@ instance Binary ModIface where
 		 mi_rules     = rules,
 		 mi_orphan_hash = orphan_hash,
                  mi_vect_info = vect_info,
-		 mi_hpc       = hpc_info }) = do
+		 mi_hpc       = hpc_info,
+		 mi_trust     = trust }) = do
 	put_ bh mod
 	put_ bh is_boot
 	put_ bh iface_hash
@@ -411,6 +412,7 @@ instance Binary ModIface where
 	put_ bh orphan_hash
         put_ bh vect_info
 	put_ bh hpc_info
+	put_ bh trust
 
    get bh = do
 	mod_name  <- get bh
@@ -433,6 +435,7 @@ instance Binary ModIface where
 	orphan_hash <- get bh
         vect_info <- get bh
         hpc_info  <- get bh
+        trust     <- get bh
 	return (ModIface {
 		 mi_module    = mod_name,
 		 mi_boot      = is_boot,
@@ -455,6 +458,7 @@ instance Binary ModIface where
 		 mi_orphan_hash = orphan_hash,
                  mi_vect_info = vect_info,
 		 mi_hpc       = hpc_info,
+		 mi_trust     = trust,
 			-- And build the cached values
 		 mi_warn_fn   = mkIfaceWarnCache warns,
 		 mi_fix_fn    = mkIfaceFixCache fixities,
@@ -1522,4 +1526,7 @@ instance Binary IfaceVectInfo where
 	    a5 <- get bh
 	    return (IfaceVectInfo a1 a2 a3 a4 a5)
 
+instance Binary IfaceTrustInfo where
+    put_ bh iftrust = putByte bh $ trustInfoToNum iftrust
+    get bh = getByte bh >>= (return . numToTrustInfo)
 

compiler/iface/LoadIface.lhs

@@ -666,7 +666,9 @@ pprModIface iface
 	, vcat (map ppr (mi_fam_insts iface))
 	, vcat (map ppr (mi_rules iface))
         , pprVectInfo (mi_vect_info iface)
+        , pprVectInfo (mi_vect_info iface)
 	, ppr (mi_warns iface)
+	, pprTrustInfo (mi_trust iface)
  	]
   where
     pp_boot | mi_boot iface = ptext (sLit "[boot]")
@@ -743,6 +745,9 @@ pprVectInfo (IfaceVectInfo { ifaceVectInfoVar          = vars
   , ptext (sLit "scalar tycons:") <+> hsep (map ppr scalarTyCons)
   ]
 
+pprTrustInfo :: IfaceTrustInfo -> SDoc
+pprTrustInfo trust = ptext (sLit "trusted:") <+> ppr trust
+
 instance Outputable Warnings where
     ppr = pprWarns
 

compiler/iface/MkIface.lhs

@@ -106,24 +106,24 @@ import System.FilePath
 
 
 %************************************************************************
-%*				 					*
+%*                                                                      *
 \subsection{Completing an interface}
-%*				 					*
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
 mkIface :: HscEnv
-	-> Maybe Fingerprint	-- The old fingerprint, if we have it
-	-> ModDetails		-- The trimmed, tidied interface
-	-> ModGuts		-- Usages, deprecations, etc
-	-> IO (Messages,
+        -> Maybe Fingerprint    -- The old fingerprint, if we have it
+        -> ModDetails           -- The trimmed, tidied interface
+        -> ModGuts              -- Usages, deprecations, etc
+        -> IO (Messages,
                Maybe (ModIface, -- The new one
-	              Bool))	-- True <=> there was an old Iface, and the
+                      Bool))    -- True <=> there was an old Iface, and the
                                 --          new one is identical, so no need
                                 --          to write it
 
 mkIface hsc_env maybe_old_fingerprint mod_details
-	 ModGuts{     mg_module    = this_mod,
+         ModGuts{     mg_module    = this_mod,
 		      mg_boot      = is_boot,
 		      mg_used_names = used_names,
 		      mg_deps      = deps,
@@ -232,6 +232,7 @@ mkIface_ hsc_env maybe_old_fingerprint
 		; iface_insts = map instanceToIfaceInst insts
 		; iface_fam_insts = map famInstToIfaceFamInst fam_insts
                 ; iface_vect_info = flattenVectInfo vect_info
+                ; trust_info = (setSafeMode . safeHaskell . hsc_dflags) hsc_env
 
 	        ; intermediate_iface = ModIface { 
 			mi_module   = this_mod,
@@ -264,6 +265,7 @@ mkIface_ hsc_env maybe_old_fingerprint
 			mi_decls     = deliberatelyOmitted "decls",
 			mi_hash_fn   = deliberatelyOmitted "hash_fn",
 			mi_hpc       = isHpcUsed hpc_info,
+			mi_trust     = trust_info,
 
 			-- And build the cached values
 			mi_warn_fn = mkIfaceWarnCache warns,
@@ -1029,53 +1031,50 @@ checkOldIface :: HscEnv
 	      -> IO (RecompileRequired, Maybe ModIface)
 
 checkOldIface hsc_env mod_summary source_unchanged maybe_iface
-  = do	{ showPass (hsc_dflags hsc_env) 
-	           ("Checking old interface for " ++ 
-			showSDoc (ppr (ms_mod mod_summary))) ;
-
-	; initIfaceCheck hsc_env $
-	  check_old_iface hsc_env mod_summary source_unchanged maybe_iface
-     }
+  = do  showPass (hsc_dflags hsc_env) $
+            "Checking old interface for " ++ (showSDoc $ ppr $ ms_mod mod_summary)
+        initIfaceCheck hsc_env $
+            check_old_iface hsc_env mod_summary source_unchanged maybe_iface
 
 check_old_iface :: HscEnv -> ModSummary -> Bool -> Maybe ModIface
                 -> IfG (Bool, Maybe ModIface)
-check_old_iface hsc_env mod_summary source_unchanged maybe_iface
- =  do 	-- CHECK WHETHER THE SOURCE HAS CHANGED
-    { when (not source_unchanged)
-	   (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off")))
-
-     -- If the source has changed and we're in interactive mode, avoid reading
-     -- an interface; just return the one we might have been supplied with.
-    ; let dflags = hsc_dflags hsc_env
-    ; if not (isObjectTarget (hscTarget dflags)) && not source_unchanged then
-         return (outOfDate, maybe_iface)
-      else
-      case maybe_iface of {
-        Just old_iface -> do -- Use the one we already have
-	  { traceIf (text "We already have the old interface for" <+> ppr (ms_mod mod_summary))
-	  ; recomp <- checkVersions hsc_env source_unchanged mod_summary old_iface
-	  ; return (recomp, Just old_iface) }
-
-      ; Nothing -> do
-
-	-- Try and read the old interface for the current module
-	-- from the .hi file left from the last time we compiled it
-    { let iface_path = msHiFilePath mod_summary
-    ; read_result <- readIface (ms_mod mod_summary) iface_path False
-    ; case read_result of {
-         Failed err -> do	-- Old interface file not found, or garbled; give up
-		{ traceIf (text "FYI: cannot read old interface file:"
-			   	 $$ nest 4 err)
-	        ; return (outOfDate, Nothing) }
-
-      ;  Succeeded iface -> do
-
-	-- We have got the old iface; check its versions
-    { traceIf (text "Read the interface file" <+> text iface_path)
-    ; recomp <- checkVersions hsc_env source_unchanged mod_summary iface
-    ; return (recomp, Just iface)
-    }}}}}
-
+check_old_iface hsc_env mod_summary src_unchanged maybe_iface
+  = let src_changed = not src_unchanged
+        dflags = hsc_dflags hsc_env
+        getIface =
+             case maybe_iface of
+                 Just _  -> do
+                     traceIf (text "We already have the old interface for" <+> ppr (ms_mod mod_summary))
+                     return maybe_iface
+                 Nothing -> do
+                     let iface_path = msHiFilePath mod_summary
+                     read_result <- readIface (ms_mod mod_summary) iface_path False
+                     case read_result of
+                         Failed err -> do
+                             traceIf (text "FYI: cannont read old interface file:" $$ nest 4 err)
+                             return Nothing
+                         Succeeded iface -> do
+                             traceIf (text "Read the interface file" <+> text iface_path)
+                             return $ Just iface
+
+    in do
+        when src_changed
+             (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off")))
+
+         -- If the source has changed and we're in interactive mode, avoid reading
+         -- an interface; just return the one we might have been supplied with.
+        if not (isObjectTarget $ hscTarget dflags) && src_changed
+            then return (outOfDate, maybe_iface)
+            else do
+                -- Try and read the old interface for the current module
+                -- from the .hi file left from the last time we compiled it
+                maybe_iface' <- getIface
+                case maybe_iface' of
+                    Nothing -> return (outOfDate, maybe_iface')
+                    Just iface -> do
+                        -- We have got the old iface; check its versions
+                        recomp <- checkVersions hsc_env src_unchanged mod_summary iface
+                        return recomp
 \end{code}
 
 @recompileRequired@ is called from the HscMain.   It checks whether
@@ -1089,41 +1088,50 @@ upToDate, outOfDate :: Bool
 upToDate  = False	-- Recompile not required
 outOfDate = True	-- Recompile required
 
+-- | Check the safe haskell flags haven't changed
+--   (e.g different flag on command line now)
+checkSafeHaskell :: HscEnv -> ModIface -> Bool
+checkSafeHaskell hsc_env iface
+  = (getSafeMode $ mi_trust iface) /= (safeHaskell $ hsc_dflags hsc_env)
+
 checkVersions :: HscEnv
 	      -> Bool		-- True <=> source unchanged
               -> ModSummary
 	      -> ModIface 	-- Old interface
-	      -> IfG RecompileRequired
+	      -> IfG (RecompileRequired, Maybe ModIface)
 checkVersions hsc_env source_unchanged mod_summary iface
   | not source_unchanged
-  = return outOfDate
+  = return (outOfDate, Just iface)
   | otherwise
-  = do	{ traceHiDiffs (text "Considering whether compilation is required for" <+> 
-		        ppr (mi_module iface) <> colon)
+  = do  { traceHiDiffs (text "Considering whether compilation is required for" <+> 
+                        ppr (mi_module iface) <> colon)
 
         ; recomp <- checkDependencies hsc_env mod_summary iface
-        ; if recomp then return outOfDate else do {
+        ; if recomp then return (outOfDate, Just iface) else do {
+        ; if trust_dif then return (outOfDate, Nothing) else do {
 
-	-- Source code unchanged and no errors yet... carry on 
+        -- Source code unchanged and no errors yet... carry on 
         --
-	-- First put the dependent-module info, read from the old
-	-- interface, into the envt, so that when we look for
-	-- interfaces we look for the right one (.hi or .hi-boot)
-	-- 
-	-- It's just temporary because either the usage check will succeed 
-	-- (in which case we are done with this module) or it'll fail (in which
-	-- case we'll compile the module from scratch anyhow).
-	--	
-	-- We do this regardless of compilation mode, although in --make mode
-	-- all the dependent modules should be in the HPT already, so it's
-	-- quite redundant
-	  updateEps_ $ \eps  -> eps { eps_is_boot = mod_deps }
-
-	; let this_pkg = thisPackage (hsc_dflags hsc_env)
-	; checkList [checkModUsage this_pkg u | u <- mi_usages iface]
-    }}
+        -- First put the dependent-module info, read from the old
+        -- interface, into the envt, so that when we look for
+        -- interfaces we look for the right one (.hi or .hi-boot)
+        -- 
+        -- It's just temporary because either the usage check will succeed 
+        -- (in which case we are done with this module) or it'll fail (in which
+        -- case we'll compile the module from scratch anyhow).
+        -- 
+        -- We do this regardless of compilation mode, although in --make mode
+        -- all the dependent modules should be in the HPT already, so it's
+        -- quite redundant
+  updateEps_ $ \eps  -> eps { eps_is_boot = mod_deps }
+
+        ; let this_pkg = thisPackage (hsc_dflags hsc_env)
+        ; recomp <- checkList [checkModUsage this_pkg u | u <- mi_usages iface]
+        ; return (recomp, Just iface)
+    }}}
   where
-	-- This is a bit of a hack really
+    trust_dif = checkSafeHaskell hsc_env iface
+    -- This is a bit of a hack really
     mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface)
     mod_deps = mkModDeps (dep_mods (mi_deps iface))
 

compiler/main/DynFlags.hs

@@ -31,6 +31,7 @@ module DynFlags (
         fFlags, fLangFlags, xFlags,
         DPHBackend(..), dphPackageMaybe,
         wayNames,
+        SafeHaskellMode(..),
 
         Settings(..),
         ghcUsagePath, ghciUsagePath, topDir, tmpDir, rawSettings,
@@ -319,6 +320,24 @@ data DynFlag
 
 data Language = Haskell98 | Haskell2010
 
+-- | The various SafeHaskell modes
+data SafeHaskellMode
+   = Sf_None
+   | Sf_SafeImports
+   | Sf_SafeLanguage
+   | Sf_Trustworthy
+   | Sf_TrustworthyWithSafeLanguage
+   | Sf_Safe
+   deriving (Eq)
+
+instance Show SafeHaskellMode where
+    show Sf_None = "None"
+    show Sf_SafeImports = "SafeImports"
+    show Sf_SafeLanguage = "SafeLanguage"
+    show Sf_Trustworthy = "Trustworthy"
+    show Sf_TrustworthyWithSafeLanguage = "Trustworthy + SafeLanguage"
+    show Sf_Safe = "Safe"
+
 data ExtensionFlag
    = Opt_Cpp
    | Opt_OverlappingInstances
@@ -511,6 +530,8 @@ data DynFlags = DynFlags {
   flags                 :: [DynFlag],
   -- Don't change this without updating extensionFlags:
   language              :: Maybe Language,
+  -- | Safe Haskell mode
+  safeHaskell           :: SafeHaskellMode,
   -- Don't change this without updating extensionFlags:
   extensions            :: [OnOff ExtensionFlag],
   -- extensionFlags should always be equal to
@@ -831,6 +852,7 @@ defaultDynFlags mySettings =
         haddockOptions = Nothing,
         flags = defaultFlags,
         language = Nothing,
+        safeHaskell = Sf_None,
         extensions = [],
         extensionFlags = flattenExtensionFlags Nothing [],
 
@@ -949,6 +971,47 @@ setLanguage l = upd f
                          extensionFlags = flattenExtensionFlags mLang oneoffs
                      }
 
+-- | Set a 'SafeHaskell' flag
+setSafeHaskell :: SafeHaskellMode -> DynP ()
+setSafeHaskell s = upd f
+    where f dfs = let sf = safeHaskell dfs
+                  in dfs {
+                         safeHaskell = combineSafeFlags sf s
+                     }
+
+-- | Combine two SafeHaskell modes correctly. Used for dealing with multiple flags.
+-- This makes SafeHaskell 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 -> SafeHaskellMode
+combineSafeFlags a b =
+    case (a,b) of
+        (Sf_None, sf) -> sf
+        (sf, Sf_None) -> sf
+
+        (Sf_SafeImports, sf) -> sf
+        (sf, Sf_SafeImports) -> sf
+
+        (Sf_SafeLanguage, Sf_Safe) -> err
+        (Sf_Safe, Sf_SafeLanguage) -> err
+
+        (Sf_SafeLanguage, Sf_Trustworthy) -> Sf_TrustworthyWithSafeLanguage
+        (Sf_Trustworthy, Sf_SafeLanguage) -> Sf_TrustworthyWithSafeLanguage
+
+        (Sf_TrustworthyWithSafeLanguage, Sf_Trustworthy)  -> Sf_TrustworthyWithSafeLanguage
+        (Sf_TrustworthyWithSafeLanguage, Sf_SafeLanguage) -> Sf_TrustworthyWithSafeLanguage
+        (Sf_Trustworthy, Sf_TrustworthyWithSafeLanguage)  -> Sf_TrustworthyWithSafeLanguage
+        (Sf_SafeLanguage, Sf_TrustworthyWithSafeLanguage) -> Sf_TrustworthyWithSafeLanguage
+
+        (Sf_Trustworthy, Sf_Safe) -> err
+        (Sf_Safe, Sf_Trustworthy) -> err
+
+        (a,b) | a == b -> a
+              | otherwise -> err
+
+    where err = ghcError (CmdLineError $ "Incompatible SafeHaskell flags! ("
+                                        ++ show a ++ "," ++ show b ++ ")")
+
 -- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order
 getOpts :: DynFlags             -- ^ 'DynFlags' to retrieve the options from
         -> (DynFlags -> [a])    -- ^ Relevant record accessor: one of the @opt_*@ accessors
@@ -1467,6 +1530,7 @@ dynamic_flags = [
  ++ map (mkFlag turnOn  "X"    setExtensionFlag  ) xFlags
  ++ map (mkFlag turnOff "XNo"  unSetExtensionFlag) xFlags
  ++ map (mkFlag turnOn  "X"    setLanguage) languageFlags
+ ++ map (mkFlag turnOn  "X"    setSafeHaskell) safeHaskellFlags
 
 package_flags :: [Flag (CmdLineP DynFlags)]
 package_flags = [
@@ -1645,11 +1709,15 @@ fLangFlags = [
 supportedLanguages :: [String]
 supportedLanguages = [ name | (name, _, _) <- languageFlags ]
 
+supportedLanguageOverlays :: [String]
+supportedLanguageOverlays = [ name | (name, _, _) <- safeHaskellFlags ]
+
 supportedExtensions :: [String]
 supportedExtensions = [ name' | (name, _, _) <- xFlags, name' <- [name, "No" ++ name] ]
 
 supportedLanguagesAndExtensions :: [String]
-supportedLanguagesAndExtensions = supportedLanguages ++ supportedExtensions
+supportedLanguagesAndExtensions =
+    supportedLanguages ++ supportedLanguageOverlays ++ supportedExtensions
 
 -- | These -X<blah> flags cannot be reversed with -XNo<blah>
 languageFlags :: [FlagSpec Language]
@@ -1658,6 +1726,13 @@ languageFlags = [
   ( "Haskell2010",                      Haskell2010, nop )
   ]
 
+-- | These -X<blah> flags cannot be reversed with -XNo<blah>
+-- They are used to place hard requirements on what GHC Haskell language
+-- features can be used.
+safeHaskellFlags :: [FlagSpec SafeHaskellMode]
+safeHaskellFlags = map mkF [Sf_SafeImports, Sf_SafeLanguage, Sf_Trustworthy, Sf_Safe]
+    where mkF flag = (show flag, flag, nop)
+
 -- | These -X<blah> flags can all be reversed with -XNo<blah>
 xFlags :: [FlagSpec ExtensionFlag]
 xFlags = [

compiler/main/HscTypes.lhs

@@ -91,6 +91,10 @@ module HscTypes (
         VectInfo(..), IfaceVectInfo(..), noVectInfo, plusVectInfo, 
         noIfaceVectInfo,
 
+        -- * Safe Haskell information
+        IfaceTrustInfo, getSafeMode, setSafeMode, noIfaceTrustInfo,
+        trustInfoToNum, numToTrustInfo,
+
         -- * Compilation errors and warnings
         SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr,
         throwOneError, handleSourceError,
@@ -127,7 +131,7 @@ import DataCon		( DataCon, dataConImplicitIds, dataConWrapId )
 import PrelNames	( gHC_PRIM )
 import Packages hiding ( Version(..) )
 import DynFlags		( DynFlags(..), isOneShot, HscTarget (..), dopt,
-                          DynFlag(..) )
+                          DynFlag(..), SafeHaskellMode(..) )
 import DriverPhases	( HscSource(..), isHsBoot, hscSourceString, Phase )
 import BasicTypes	( IPName, defaultFixity, WarningTxt(..) )
 import OptimizationFuel	( OptFuelState )
@@ -154,6 +158,7 @@ import Data.IORef
 import Data.Array       ( Array, array )
 import Data.List
 import Data.Map (Map)
+import Data.Word
 import Control.Monad    ( mplus, guard, liftM, when )
 import Exception
 
@@ -680,8 +685,10 @@ data ModIface
 			-- isn't in decls. It's useful to know that when
 			-- seeing if we are up to date wrt. the old interface.
                         -- The 'OccName' is the parent of the name, if it has one.
-	mi_hpc    :: !AnyHpcUsage
+	mi_hpc    :: !AnyHpcUsage,
 	        -- ^ True if this program uses Hpc at any point in the program.
+	mi_trust  :: !IfaceTrustInfo
+	        -- ^ Safe Haskell Trust information for this module.
      }
 
 -- | The 'ModDetails' is essentially a cache for information in the 'ModIface'
@@ -852,7 +859,8 @@ emptyModIface mod
 	       mi_warn_fn    = emptyIfaceWarnCache,
 	       mi_fix_fn    = emptyIfaceFixCache,
 	       mi_hash_fn   = emptyIfaceHashCache,
-	       mi_hpc       = False
+	       mi_hpc       = False,
+	       mi_trust     = noIfaceTrustInfo
     }		
 \end{code}
 
@@ -1792,6 +1800,58 @@ noIfaceVectInfo :: IfaceVectInfo
 noIfaceVectInfo = IfaceVectInfo [] [] [] [] []
 \end{code}
 
+%************************************************************************
+%*									*
+\subsection{Safe Haskell Support}
+%*									*
+%************************************************************************
+
+This stuff here is related to supporting the Safe Haskell extension,
+primarily about storing under what trust type a module has been compiled.
+
+\begin{code}
+-- | Safe Haskell information for 'ModIface'
+-- Simply a wrapper around SafeHaskellMode to sepperate iface and flags
+newtype IfaceTrustInfo = TrustInfo SafeHaskellMode
+
+getSafeMode :: IfaceTrustInfo -> SafeHaskellMode
+getSafeMode (TrustInfo x) = x
+
+setSafeMode :: SafeHaskellMode -> IfaceTrustInfo
+setSafeMode = TrustInfo
+
+noIfaceTrustInfo :: IfaceTrustInfo
+noIfaceTrustInfo = setSafeMode Sf_None
+
+trustInfoToNum :: IfaceTrustInfo -> Word8
+trustInfoToNum it
+  = case getSafeMode it of
+            Sf_None -> 0
+            Sf_SafeImports -> 1
+            Sf_SafeLanguage -> 2
+            Sf_Trustworthy -> 3
+            Sf_TrustworthyWithSafeLanguage -> 4
+            Sf_Safe -> 5
+
+numToTrustInfo :: Word8 -> IfaceTrustInfo
+numToTrustInfo 0 = setSafeMode Sf_None
+numToTrustInfo 1 = setSafeMode Sf_SafeImports
+numToTrustInfo 2 = setSafeMode Sf_SafeLanguage
+numToTrustInfo 3 = setSafeMode Sf_Trustworthy
+numToTrustInfo 4 = setSafeMode Sf_TrustworthyWithSafeLanguage
+numToTrustInfo 5 = setSafeMode Sf_Safe
+numToTrustInfo n = error $ "numToTrustInfo: bad input number! (" ++ show n ++ ")"
+
+instance Outputable IfaceTrustInfo where
+    ppr (TrustInfo Sf_None)         = ptext $ sLit "none"
+    ppr (TrustInfo Sf_SafeImports)  = ptext $ sLit "safe-imports"
+    ppr (TrustInfo Sf_SafeLanguage) = ptext $ sLit "safe-language"
+    ppr (TrustInfo Sf_Trustworthy)  = ptext $ sLit "trustworthy"
+    ppr (TrustInfo Sf_TrustworthyWithSafeLanguage)
+                                    = ptext $ sLit "trustworthy + safe-language"
+    ppr (TrustInfo Sf_Safe)         = ptext $ sLit "safe"
+\end{code}
+
 %************************************************************************
 %*									*
 \subsection{Linkable stuff}