More updates to Safe Haskell to implement new design (done!).

compiler/main/DynFlags.hs

@@ -39,9 +39,9 @@ module DynFlags (
 
         -- ** Safe Haskell
         SafeHaskellMode(..),
-        safeImportsOn, safeLanguageOn,
-        safeDirectImpsReq, safeImplicitImpsReq,
+        safeHaskellOn, safeImportsOn, safeLanguageOn, safeInferOn,
         packageTrustOn,
+        safeDirectImpsReq, safeImplicitImpsReq,
 
         -- ** System tool settings and locations
         Settings(..),
@@ -1025,10 +1025,24 @@ 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 ||
@@ -1046,33 +1060,24 @@ 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 = safeLanguageOn
+safeDirectImpsReq d = safeLanguageOn d || safeInferOn d
 
 -- | 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 = safeLanguageOn
+safeImplicitImpsReq d = safeLanguageOn d || safeInferOn d
 
 -- | 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 =
-    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
+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 ++ ")"
 
 -- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order
 getOpts :: DynFlags             -- ^ 'DynFlags' to retrieve the options from
@@ -1275,21 +1280,41 @@ parseDynamicFlags dflags0 args cmdline = do
   when (not (null errs)) $ ghcError $ errorsToGhcException errs
 
   -- check for disabled flags in safe haskell
-  let (dflags2, sh_warns) = if (safeLanguageOn dflags1)
-                                then shFlagsDisallowed dflags1
-                                else (dflags1, [])
-
+  let (dflags2, sh_warns) = safeFlagCheck dflags1
+  
   return (dflags2, leftover, sh_warns ++ warns)
 
--- | 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
+-- | 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', [])
+
+              | otherwise
+              -> (dflags' { safeHaskell = Sf_None }, [])
+                -- Have we infered Unsafe?
+                -- See Note [HscMain . Safe Haskell Inference]
     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   = (fix df, warns ++ safeFailure loc str)
+            | test df   = (apFix 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),
@@ -1297,9 +1322,6 @@ shFlagsDisallowed dflags = foldl check_method (dflags, []) bad_flags
                          xopt Opt_TemplateHaskell,
                          flip xopt_unset Opt_TemplateHaskell)]
 
-        safeFailure loc str = [L loc $ "Warning: " ++ str ++ " is not allowed in"
-                                      ++ " Safe Haskell; ignoring " ++ str]
-
 
 {- **********************************************************************
 %*                                                                      *
@@ -1831,7 +1853,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]

compiler/main/HscTypes.lhs

@@ -4,6 +4,7 @@
 \section[HscTypes]{Types for the per-module compiler}
 
 \begin{code}
+
 -- | Types for the per-module compiler
 module HscTypes ( 
         -- * compilation state
@@ -36,7 +37,6 @@ module HscTypes (
         
         PackageInstEnv, PackageRuleBase,
 
-
         -- * Annotations
         prepareAnnotations,
 
@@ -1560,6 +1560,7 @@ 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
@@ -1567,7 +1568,8 @@ data Usage
             -- ^ Cached module fingerprint
         usg_safe :: IsSafeImport
             -- ^ Was this module imported as a safe import
-    }                                           -- ^ Module from another package
+    }
+  -- | Module from the current package
   | UsageHomeModule {
         usg_mod_name :: ModuleName,
             -- ^ Name of the module
@@ -1582,7 +1584,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
@@ -1771,14 +1773,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

compiler/typecheck/TcForeign.lhs

@@ -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
+          let safe_on = safeLanguageOn dflags || safeInferOn 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
+      let safe_on = safeLanguageOn dflags || safeInferOn 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
+      let safe_on = safeLanguageOn dflags || safeInferOn dflags
           ioOK    = if safe_on then mustBeIO else nonIOok
       checkForeignRes ioOK safe_on (isFFIImportResultTy dflags) res_ty
       checkMissingAmpersand dflags arg_tys res_ty
@@ -377,9 +377,14 @@ checkForeignRes non_io_result_ok safehs_check pred_res_ty ty
     Just (_, res_ty)
      | pred_res_ty res_ty ->
         return ()
-    _ ->
-        check (non_io_result_ok && pred_res_ty ty)
-              (illegalForeignTyErr result ty $+$ safeHsErr safehs_check)
+
+    _ -> 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)
 \end{code}
 
 \begin{code}

compiler/typecheck/TcInstDcls.lhs

@@ -407,15 +407,19 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
        -- performed. Derived instances are OK.
        ; dflags <- getDOpts
        ; when (safeLanguageOn dflags) $
-             mapM_ (\x -> when (is_cls (iSpec x) `elem` typeableClassNames)
+             mapM_ (\x -> when (typInstCheck x)
                                (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"
 

compiler/typecheck/TcRnDriver.lhs

@@ -110,6 +110,7 @@ import Control.Monad
 
 
 \begin{code}
+-- | Top level entry point for typechecker and renamer
 tcRnModule :: HscEnv 
 	   -> HscSource
 	   -> Bool 		-- True <=> save renamed syntax

compiler/typecheck/TcRnMonad.lhs

@@ -2,6 +2,8 @@
 % (c) The University of Glasgow 2006
 %
 
+Functions for working with the typechecker environment (setters, getters...).
+
 \begin{code}
 module TcRnMonad(
         module TcRnMonad,
@@ -61,6 +63,7 @@ import Control.Monad
 
 \begin{code}
 
+-- | Setup the initial typechecking environment
 initTc :: HscEnv
        -> HscSource
        -> Bool          -- True <=> retain renamed syntax trees
@@ -78,6 +81,7 @@ 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 {
@@ -90,45 +94,46 @@ 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_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
              } ;
              lcl_env = TcLclEnv {
                 tcl_errs       = errs_var,
@@ -271,15 +276,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
@@ -554,7 +559,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
@@ -1075,6 +1080,18 @@ setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
 \end{code}
 
 
+%************************************************************************
+%*                                                                      *
+             Safe Haskell context
+%*                                                                      *
+%************************************************************************
+
+\begin{code}
+recordUnsafeInfer :: TcM ()
+recordUnsafeInfer = getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) False
+\end{code}
+
+
 %************************************************************************
 %*                                                                      *
              Stuff for the renamer's local env

compiler/typecheck/TcRnTypes.lhs

@@ -2,6 +2,19 @@
 % (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
@@ -135,29 +148,34 @@ instance Outputable TcTyVarBind where
 
 
 %************************************************************************
-%*									*
-		The main environment types
-%*									*
+%*                                                                      *
+                The main environment types
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
-data Env gbl lcl	-- Changes as we move into an expression
+-- 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
   = 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 {
@@ -198,7 +216,8 @@ data TcGblEnv
 	tcg_exports :: [AvailInfo],	-- ^ What is exported
 	tcg_imports :: ImportAvails,
           -- ^ Information about what was imported from where, including
-	  -- things bound in this module.
+	  -- things bound in this module. Also store Safe Haskell info
+          -- here about transative trusted packaage requirements.
 
 	tcg_dus :: DefUses,
           -- ^ What is defined in this module and what is used.
@@ -280,9 +299,11 @@ 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