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, 79 insertions, 31 deletions

diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs
index 372bd3507e..3ff75e1043 100644
--- a/compiler/main/CmdLineParser.hs
+++ b/compiler/main/CmdLineParser.hs
@@ -12,8 +12,8 @@
 module CmdLineParser (
         processArgs, OptKind(..),
         CmdLineP(..), getCmdLineState, putCmdLineState,
-        Flag(..), 
-        errorsToGhcException,
+        Flag(..), FlagSafety(..), flagA, flagR, flagC, flagN,
+        errorsToGhcException, determineSafeLevel,
 
         EwM, addErr, addWarn, getArg, liftEwM, deprecate
   ) where
@@ -34,9 +34,36 @@ import Data.List
 
 data Flag m = Flag
     {   flagName    :: String,       -- Flag, without the leading "-"
+        flagSafety  :: FlagSafety,   -- Flag safety level (SafeHaskell)
         flagOptKind :: OptKind m     -- What to do if we see it
     }
 
+-- | This determines how a flag should behave when SafeHaskell
+-- mode is on.
+data FlagSafety
+ = EnablesSafe         -- ^ This flag is a little bit of a hack. We give
+                       -- the safe haskell flags (-XSafe and -XSafeLanguage)
+                       -- this safety type so we can easily detect when safe
+                       -- haskell mode has been enable in a module pragma
+                       -- as this changes how the rest of the parsing should
+                       -- happen.
+
+ | AlwaysAllowed       -- ^ Flag is always allowed
+ | RestrictedFunction  -- ^ Flag is allowed but functions in a reduced way
+ | CmdLineOnly         -- ^ Flag is only allowed on command line, not in pragma
+ | NeverAllowed        -- ^ Flag isn't allowed at all
+ deriving ( Eq, Ord )
+
+determineSafeLevel :: Bool -> FlagSafety
+determineSafeLevel False = RestrictedFunction
+determineSafeLevel True  = CmdLineOnly
+
+flagA, flagR, flagC, flagN :: String -> OptKind m -> Flag m
+flagA n o = Flag n AlwaysAllowed o
+flagR n o = Flag n RestrictedFunction o
+flagC n o = Flag n CmdLineOnly o
+flagN n o = Flag n NeverAllowed o
+
 -------------------------------
 data OptKind m                      -- Suppose the flag is -f
  = NoArg     (EwM m ())                 -- -f all by itself
@@ -64,22 +91,32 @@ type Warns = Bag Warn
 -- EwM (short for "errors and warnings monad") is a
 -- monad transformer for m that adds an (err, warn) state
 newtype EwM m a = EwM { unEwM :: Located String	    -- Current arg
+                              -> FlagSafety         -- arg safety level
+                              -> FlagSafety         -- global safety level
                               -> Errs -> Warns
                               -> m (Errs, Warns, a) }
 
 instance Monad m => Monad (EwM m) where
-  (EwM f) >>= k = EwM (\l e w -> do { (e', w', r) <- f l e w 
-                                    ; unEwM (k r) l e' w' })
-  return v = EwM (\_ e w -> return (e, w, v))
-
-setArg :: Located String -> EwM m a -> EwM m a
-setArg l (EwM f) = EwM (\_ es ws -> f l es ws)
+  (EwM f) >>= k = EwM (\l s c e w -> do { (e', w', r) <- f l s c e w
+                                        ; unEwM (k r) l s c e' w' })
+  return v = EwM (\_ _ _ e w -> return (e, w, v))
+
+setArg :: Monad m => Located String -> FlagSafety -> EwM m () -> EwM m ()
+setArg l s (EwM f) = EwM (\_ _ c es ws ->
+    let check | s <= c    = f l s c es ws
+              | otherwise = err l es ws
+        err (L loc ('-' : arg)) es ws =
+            let msg = "Warning: " ++ arg ++ " is not allowed in "
+                   ++ "SafeHaskell; ignoring " ++ arg
+            in return (es, ws `snocBag` L loc msg, ())
+        err _ _ _ = error "Bad pattern match in setArg"
+    in check)
 
 addErr :: Monad m => String -> EwM m ()
-addErr e = EwM (\(L loc _) es ws -> return (es `snocBag` L loc e, ws, ()))
+addErr e = EwM (\(L loc _) _ _ es ws -> return (es `snocBag` L loc e, ws, ()))
 
 addWarn :: Monad m => String -> EwM m ()
-addWarn msg = EwM (\(L loc _) es ws -> return (es, ws `snocBag` L loc w, ()))
+addWarn msg = EwM (\(L loc _) _ _ es ws -> return (es, ws `snocBag` L loc w, ()))
   where
     w = "Warning: " ++ msg
 
@@ -89,10 +126,10 @@ deprecate s
        ; addWarn (arg ++ " is deprecated: " ++ s) }
 
 getArg :: Monad m => EwM m String
-getArg = EwM (\(L _ arg) es ws -> return (es, ws, arg))
+getArg = EwM (\(L _ arg) _ _ es ws -> return (es, ws, arg))
 
 liftEwM :: Monad m => m a -> EwM m a
-liftEwM action = EwM (\_ es ws -> do { r <- action; return (es, ws, r) })
+liftEwM action = EwM (\_ _ _ es ws -> do { r <- action; return (es, ws, r) })
 
 -- -----------------------------------------------------------------------------
 -- A state monad for use in the command-line parser
@@ -119,31 +156,41 @@ putCmdLineState s = CmdLineP $ \_ -> ((),s)
 processArgs :: Monad m
             => [Flag m] -- cmdline parser spec
             -> [Located String]      -- args
+            -> FlagSafety            -- flag clearance lvl
+            -> Bool
             -> m (
                   [Located String],  -- spare args
                   [Located String],  -- errors
                   [Located String]   -- warnings
                  )
-processArgs spec args 
-  = do { (errs, warns, spare) <- unEwM (process args []) 
-                                       (panic "processArgs: no arg yet")
-                                       emptyBag emptyBag 
-       ; return (spare, bagToList errs, bagToList warns) }
+processArgs spec args clvl0 cmdline
+  = let (clvl1, action) = process clvl0 args []
+    in do { (errs, warns, spare) <- unEwM action (panic "processArgs: no arg yet")
+                                    AlwaysAllowed clvl1 emptyBag emptyBag
+          ; return (spare, bagToList errs, bagToList warns) }
   where
-    -- process :: [Located String] -> [Located String] -> EwM m [Located String]
-    process [] spare = return (reverse spare)
+    -- process :: FlagSafety -> [Located String] -> [Located String] -> (FlagSafety, EwM m [Located String])
+    --
+    process clvl [] spare = (clvl, return (reverse spare))
 
-    process (locArg@(L _ ('-' : arg)) : args) spare =
+    process clvl (locArg@(L _ ('-' : arg)) : args) spare =
       case findArg spec arg of
-        Just (rest, opt_kind) ->
-           case processOneArg opt_kind rest arg args of
-              Left err            -> do { setArg locArg $ addErr err
-                                        ; process args spare }
-              Right (action,rest) -> do { setArg locArg $ action
-                                        ; process rest spare }
-        Nothing -> process args (locArg : spare) 
+        Just (rest, opt_kind, fsafe) ->
+           let clvl1 = if fsafe == EnablesSafe then determineSafeLevel cmdline else clvl
+           in case processOneArg opt_kind rest arg args of
+               Left err ->
+                   let (clvl2,b) = process clvl1 args spare
+                       clvl3 = min clvl1 clvl2
+                   in (clvl3, (setArg locArg fsafe $ addErr err) >> b)
+
+               Right (action,rest) ->
+                   let (clvl2,b) = process clvl1 rest spare
+                       clvl3 = min clvl1 clvl2
+                   in (clvl3, (setArg locArg fsafe $ action) >> b)
+
+        Nothing -> process clvl args (locArg : spare) 
 
-    process (arg : args) spare = process args (arg : spare) 
+    process clvl (arg : args) spare = process clvl args (arg : spare) 
 
 
 processOneArg :: OptKind m -> String -> String -> [Located String]
@@ -184,11 +231,12 @@ processOneArg opt_kind rest arg args
         AnySuffixPred _ f -> Right (f dash_arg, args)
 
 
-findArg :: [Flag m] -> String -> Maybe (String, OptKind m)
+findArg :: [Flag m] -> String -> Maybe (String, OptKind m, FlagSafety)
 findArg spec arg
-  = case [ (removeSpaces rest, optKind)
+  = case [ (removeSpaces rest, optKind, flagSafe)
          | flag <- spec,
-           let optKind = flagOptKind flag,
+           let optKind  = flagOptKind flag,
+           let flagSafe = flagSafety flag,
            Just rest <- [stripPrefix (flagName flag) arg],
            arg_ok optKind rest arg ]
     of