SafeHaskell: Add Safe & Trustworthy pragmas
authorDavid Terei <davidterei@gmail.com>
Mon, 25 Apr 2011 19:12:56 +0000 (12:12 -0700)
committerDavid Terei <davidterei@gmail.com>
Sat, 18 Jun 2011 01:19:48 +0000 (18:19 -0700)
compiler/iface/BinIface.hs
compiler/iface/LoadIface.lhs
compiler/iface/MkIface.lhs
compiler/main/DynFlags.hs
compiler/main/HscTypes.lhs

index 502eefa..211417d 100644 (file)
@@ -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)
 
index 97acc52..ccaaf69 100644 (file)
@@ -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
 
index 0bce56b..9deceb5 100644 (file)
@@ -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))
 
index 1671777..f25df2d 100644 (file)
@@ -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 = [
index ea0cd63..d39e1da 100644 (file)
@@ -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}
 
@@ -1794,6 +1802,58 @@ noIfaceVectInfo = IfaceVectInfo [] [] [] [] []
 
 %************************************************************************
 %*                                                                     *
+\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}
 %*                                                                     *
 %************************************************************************