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.

2 files changed, 26 insertions, 25 deletions

diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs
index 884059aece..2d8d6ff02d 100644
--- a/ghc/InteractiveUI.hs
+++ b/ghc/InteractiveUI.hs
@@ -1556,10 +1556,10 @@ setCmd ""
           vcat (text "other dynamic, non-language, flag settings:" 
                :map (flagSetting dflags) others)
           ))
-  where flagSetting dflags (str, f, _)
+  where flagSetting dflags (str, _, f, _)
           | dopt f dflags = text "  " <> text "-f"    <> text str
           | otherwise     = text "  " <> text "-fno-" <> text str
-        (ghciFlags,others)  = partition (\(_, f, _) -> f `elem` flags)
+        (ghciFlags,others)  = partition (\(_, _, f, _) -> f `elem` flags)
                                         DynFlags.fFlags
         flags = [Opt_PrintExplicitForalls
                 ,Opt_PrintBindResult
@@ -1804,7 +1804,7 @@ showLanguages = do
    dflags <- getDynFlags
    liftIO $ putStrLn $ showSDoc $ vcat $
       text "active language flags:" :
-      [text ("  -X" ++ str) | (str, f, _) <- DynFlags.xFlags, xopt f dflags]
+      [text ("  -X" ++ str) | (str, _, f, _) <- DynFlags.xFlags, xopt f dflags]
 
 -- -----------------------------------------------------------------------------
 -- Completion
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))
+