[commit: ghc] master: SafeHaskell: Disable user written rewrite rules in Safe mode (0f13e11)

[David Terei]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/0f13e110c01674fe185ead1cd24e234dba2fa22e

>---------------------------------------------------------------

commit 0f13e110c01674fe185ead1cd24e234dba2fa22e
Author: David Terei <davidterei at gmail.com>
Date:   Mon Apr 25 15:58:10 2011 -0700

    SafeHaskell: Disable user written rewrite rules in Safe mode

>---------------------------------------------------------------

 compiler/main/DynFlags.hs |    6 ++----
 compiler/main/HscMain.lhs |   33 +++++++++++++++++++++++++++------
 2 files changed, 29 insertions(+), 10 deletions(-)

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 7a587da..3585915 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -1260,8 +1260,6 @@ shFlagsDisallowed dflags = foldl check_method (dflags, []) bad_flags
 
         bad_flags = [(xopt Opt_GeneralizedNewtypeDeriving, "-XGeneralizedNewtypeDeriving",
                      flip xopt_unset Opt_GeneralizedNewtypeDeriving),
-                     (dopt Opt_EnableRewriteRules, "-enable-rewrite-rules",
-                     flip dopt_unset Opt_EnableRewriteRules),
                      (xopt Opt_TemplateHaskell, "-XTemplateHaskell",
                      flip xopt_unset Opt_TemplateHaskell)]
 
@@ -1778,8 +1776,8 @@ fFlags = [
   ( "print-bind-result",                AlwaysAllowed, Opt_PrintBindResult, nop ),
   ( "force-recomp",                     AlwaysAllowed, Opt_ForceRecomp, nop ),
   ( "hpc-no-auto",                      AlwaysAllowed, Opt_Hpc_No_Auto, nop ),
-  ( "rewrite-rules",                    NeverAllowed,  Opt_EnableRewriteRules, useInstead "enable-rewrite-rules" ),
-  ( "enable-rewrite-rules",             NeverAllowed,  Opt_EnableRewriteRules, nop ),
+  ( "rewrite-rules",                    AlwaysAllowed, Opt_EnableRewriteRules, useInstead "enable-rewrite-rules" ),
+  ( "enable-rewrite-rules",             AlwaysAllowed, Opt_EnableRewriteRules, nop ),
   ( "break-on-exception",               AlwaysAllowed, Opt_BreakOnException, nop ),
   ( "break-on-error",                   AlwaysAllowed, Opt_BreakOnError, nop ),
   ( "print-evld-with-show",             AlwaysAllowed, Opt_PrintEvldWithShow, nop ),
diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs
index 24f610f..dddee58 100644
--- a/compiler/main/HscMain.lhs
+++ b/compiler/main/HscMain.lhs
@@ -778,8 +778,27 @@ hscFileFrontEnd mod_summary = do
         tcg_env <- ioMsgMaybe $
             tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module
     dflags <- getDynFlags
-    tcg_env' <- checkSafeImports dflags hsc_env tcg_env
-    return tcg_env'
+    -- XXX: See Note [SafeHaskell API]
+    if safeHaskellOn dflags
+        then do
+            tcg_env1 <- checkSafeImports dflags hsc_env tcg_env
+            if safeLanguageOn dflags
+                then do
+                    -- we also nuke user written RULES.
+                    logWarnings $ warns (tcg_rules tcg_env1)
+                    return tcg_env1 { tcg_rules = [] }
+                else
+                    return tcg_env1
+
+        else
+            return tcg_env
+
+    where
+        warns rules = listToBag $ map warnRules rules
+        warnRules (L loc (HsRule n _ _ _ _ _ _)) =
+            mkPlainWarnMsg loc $
+                text "Rule \"" <> ftext n <> text "\" ignored" $+$
+                text "User defined rules are disabled under SafeHaskell"
 
 --------------------------------------------------------------
 -- SafeHaskell
@@ -791,12 +810,14 @@ hscFileFrontEnd mod_summary = do
 -- trust type is 'Safe' or 'Trustworthy'. For modules that
 -- reside in another package we also must check that the
 -- external pacakge is trusted.
+--
+-- Note [SafeHaskell API]
+-- ~~~~~~~~~~~~~~~~~~~~~~
+-- XXX: We only call this in hscFileFrontend and don't expose
+-- it to the GHC API. External users of GHC can't properly use
+-- the GHC API and SafeHaskell.
 checkSafeImports :: DynFlags -> HscEnv -> TcGblEnv -> Hsc TcGblEnv
 checkSafeImports dflags hsc_env tcg_env
-    | not (safeHaskellOn dflags)
-    = return tcg_env
-
-    | otherwise
     = do
         imps <- mapM condense imports'
         mapM_ checkSafe imps