SafeHaskell: Disable certain ghc extensions in Safe.

This patch disables the use of some GHC extensions in
Safe mode and also the use of certain flags. Some
are disabled completely while others are only allowed
on the command line and not in source PRAGMAS.

We also check that Safe imports are indeed importing
a Safe or Trustworthy module.

1 files changed, 23 insertions, 22 deletions

diff --git a/ghc/Main.hs b/ghc/Main.hs
index 12d8dd202b..71a45f8a9a 100644
--- a/ghc/Main.hs
+++ b/ghc/Main.hs
@@ -479,7 +479,7 @@ parseModeFlags :: [Located String]
                       [Located String])
 parseModeFlags args = do
   let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) =
-          runCmdLine (processArgs mode_flags args)
+          runCmdLine (processArgs mode_flags args CmdLineOnly True)
                      (Nothing, [], [])
       mode = case mModeFlag of
              Nothing     -> doMakeMode
@@ -495,16 +495,16 @@ type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String])
 mode_flags :: [Flag ModeM]
 mode_flags =
   [  ------- help / version ----------------------------------------------
-    Flag "?"                     (PassFlag (setMode showGhcUsageMode))
-  , Flag "-help"                 (PassFlag (setMode showGhcUsageMode))
-  , Flag "V"                     (PassFlag (setMode showVersionMode))
-  , Flag "-version"              (PassFlag (setMode showVersionMode))
-  , Flag "-numeric-version"      (PassFlag (setMode showNumVersionMode))
-  , Flag "-info"                 (PassFlag (setMode showInfoMode))
-  , Flag "-supported-languages"  (PassFlag (setMode showSupportedExtensionsMode))
-  , Flag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))
+    flagC "?"                     (PassFlag (setMode showGhcUsageMode))
+  , flagC "-help"                 (PassFlag (setMode showGhcUsageMode))
+  , flagC "V"                     (PassFlag (setMode showVersionMode))
+  , flagC "-version"              (PassFlag (setMode showVersionMode))
+  , flagC "-numeric-version"      (PassFlag (setMode showNumVersionMode))
+  , flagC "-info"                 (PassFlag (setMode showInfoMode))
+  , flagC "-supported-languages"  (PassFlag (setMode showSupportedExtensionsMode))
+  , flagC "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))
   ] ++
-  [ Flag k'                     (PassFlag (setMode (printSetting k)))
+  [ flagC k'                      (PassFlag (setMode (printSetting k)))
   | k <- ["Project version",
           "Booter version",
           "Stage",
@@ -530,21 +530,21 @@ mode_flags =
         replaceSpace c   = c
   ] ++
       ------- interfaces ----------------------------------------------------
-  [ Flag "-show-iface"  (HasArg (\f -> setMode (showInterfaceMode f)
+  [ flagC "-show-iface"  (HasArg (\f -> setMode (showInterfaceMode f)
                                                "--show-iface"))
 
       ------- primary modes ------------------------------------------------
-  , Flag "c"            (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f
-                                            addFlag "-no-link" f))
-  , Flag "M"            (PassFlag (setMode doMkDependHSMode))
-  , Flag "E"            (PassFlag (setMode (stopBeforeMode anyHsc)))
-  , Flag "C"            (PassFlag (\f -> do setMode (stopBeforeMode HCc) f
-                                            addFlag "-fvia-C" f))
-  , Flag "S"            (PassFlag (setMode (stopBeforeMode As)))
-  , Flag "-make"        (PassFlag (setMode doMakeMode))
-  , Flag "-interactive" (PassFlag (setMode doInteractiveMode))
-  , Flag "-abi-hash"    (PassFlag (setMode doAbiHashMode))
-  , Flag "e"            (SepArg   (\s -> setMode (doEvalMode s) "-e"))
+  , flagC "c"            (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f
+                                             addFlag "-no-link" f))
+  , flagC "M"            (PassFlag (setMode doMkDependHSMode))
+  , flagC "E"            (PassFlag (setMode (stopBeforeMode anyHsc)))
+  , flagC "C"            (PassFlag (\f -> do setMode (stopBeforeMode HCc) f
+                                             addFlag "-fvia-C" f))
+  , flagC "S"            (PassFlag (setMode (stopBeforeMode As)))
+  , flagC "-make"        (PassFlag (setMode doMakeMode))
+  , flagC "-interactive" (PassFlag (setMode doInteractiveMode))
+  , flagC "-abi-hash"    (PassFlag (setMode doAbiHashMode))
+  , flagC "e"            (SepArg   (\s -> setMode (doEvalMode s) "-e"))
   ]
 
 setMode :: Mode -> String -> EwM ModeM ()
@@ -773,3 +773,4 @@ abiHash strs = do
 
 unknownFlagsErr :: [String] -> a
 unknownFlagsErr fs = ghcError (UsageError ("unrecognised flags: " ++ unwords fs))
+