diff options
Diffstat (limited to 'compiler/main/CmdLineParser.hs')
| -rw-r--r-- | compiler/main/CmdLineParser.hs | 110 |
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 |