Commit 189f6663 authored by dterei's avatar dterei

Remove cruft code from old Safe Haskell implementation method

parent 926cadfe
......@@ -12,8 +12,8 @@
module CmdLineParser (
processArgs, OptKind(..),
CmdLineP(..), getCmdLineState, putCmdLineState,
Flag(..), FlagSafety(..), flagA, flagR, flagC, flagN,
errorsToGhcException, determineSafeLevel,
Flag(..),
errorsToGhcException,
EwM, addErr, addWarn, getArg, liftEwM, deprecate
) where
......@@ -29,43 +29,16 @@ import SrcLoc
import Data.List
--------------------------------------------------------
-- The Flag and OptKind types
-- The Flag and OptKind types
--------------------------------------------------------
data Flag m = Flag
{ flagName :: String, -- Flag, without the leading "-"
flagSafety :: FlagSafety, -- Flag safety level (Safe Haskell)
flagOptKind :: OptKind m -- What to do if we see it
}
-- | This determines how a flag should behave when Safe Haskell
-- 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
data OptKind m -- Suppose the flag is -f
= NoArg (EwM m ()) -- -f all by itself
| HasArg (String -> EwM m ()) -- -farg or -f arg
| SepArg (String -> EwM m ()) -- -f arg
......@@ -80,7 +53,7 @@ data OptKind m -- Suppose the flag is -f
--------------------------------------------------------
-- The EwM monad
-- The EwM monad
--------------------------------------------------------
type Err = Located String
......@@ -90,46 +63,36 @@ 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
newtype EwM m a = EwM { unEwM :: Located String -- Current arg
-> Errs -> Warns
-> m (Errs, Warns, a) }
instance Monad m => Monad (EwM m) where
(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 "
++ "Safe Haskell; ignoring " ++ arg
in return (es, ws `snocBag` L loc msg, ())
err _ _ _ = error "Bad pattern match in setArg"
in check)
(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 :: Monad m => Located String -> EwM m () -> EwM m ()
setArg l (EwM f) = EwM (\_ es ws -> f l es ws)
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
deprecate :: Monad m => String -> EwM m ()
deprecate s
= do { arg <- getArg
; addWarn (arg ++ " is deprecated: " ++ s) }
= do arg <- getArg
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
......@@ -150,47 +113,42 @@ putCmdLineState s = CmdLineP $ \_ -> ((),s)
--------------------------------------------------------
-- Processing arguments
-- Processing arguments
--------------------------------------------------------
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 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) }
processArgs spec args
= let action = process args []
in do (errs, warns, spare) <- unEwM action (panic "processArgs: no arg yet")
emptyBag emptyBag
return (spare, bagToList errs, bagToList warns)
where
-- process :: FlagSafety -> [Located String] -> [Located String] -> (FlagSafety, EwM m [Located String])
-- process :: [Located String] -> [Located String] -> EwM m [Located String]
--
process clvl [] spare = (clvl, return (reverse spare))
process [] spare = return (reverse spare)
process clvl (locArg@(L _ ('-' : arg)) : args) spare =
process (locArg@(L _ ('-' : arg)) : args) spare =
case findArg spec arg of
Just (rest, opt_kind, fsafe) ->
let clvl1 = if fsafe == EnablesSafe then determineSafeLevel cmdline else clvl
in case processOneArg opt_kind rest arg args of
Just (rest, opt_kind) ->
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)
let b = process args spare
in (setArg locArg $ addErr err) >> b
Right (action,rest) ->
let (clvl2,b) = process clvl1 rest spare
clvl3 = min clvl1 clvl2
in (clvl3, (setArg locArg fsafe $ action) >> b)
let b = process rest spare
in (setArg locArg $ action) >> b
Nothing -> process clvl args (locArg : spare)
Nothing -> process args (locArg : spare)
process clvl (arg : args) spare = process clvl args (arg : spare)
process (arg : args) spare = process args (arg : spare)
processOneArg :: OptKind m -> String -> String -> [Located String]
......@@ -231,12 +189,11 @@ processOneArg opt_kind rest arg args
AnySuffixPred _ f -> Right (f dash_arg, args)
findArg :: [Flag m] -> String -> Maybe (String, OptKind m, FlagSafety)
findArg :: [Flag m] -> String -> Maybe (String, OptKind m)
findArg spec arg
= case [ (removeSpaces rest, optKind, flagSafe)
= case [ (removeSpaces rest, optKind)
| flag <- spec,
let optKind = flagOptKind flag,
let flagSafe = flagSafety flag,
Just rest <- [stripPrefix (flagName flag) arg],
arg_ok optKind rest arg ]
of
......
This diff is collapsed.
......@@ -50,7 +50,7 @@ parseStaticFlags args = do
ready <- readIORef v_opt_C_ready
when ready $ ghcError (ProgramError "Too late for parseStaticFlags: call it before newSession")
(leftover, errs, warns1) <- processArgs static_flags args CmdLineOnly True
(leftover, errs, warns1) <- processArgs static_flags args
when (not (null errs)) $ ghcError $ errorsToGhcException errs
-- deal with the way flags: the way (eg. prof) gives rise to
......@@ -60,10 +60,10 @@ parseStaticFlags args = do
-- if we're unregisterised, add some more flags
let unreg_flags | cGhcUnregisterised == "YES" = unregFlags
| otherwise = []
| otherwise = []
(more_leftover, errs, warns2) <-
processArgs static_flags (unreg_flags ++ way_flags') CmdLineOnly True
processArgs static_flags (unreg_flags ++ way_flags')
-- see sanity code in staticOpts
writeIORef v_opt_C_ready True
......@@ -96,7 +96,7 @@ static_flags :: [Flag IO]
--
-- The common (PassFlag addOpt) action puts the static flag into the bunch of
-- things that are searched up by the top-level definitions like
-- opt_foo = lookUp (fsLit "-dfoo")
-- opt_foo = lookUp (fsLit "-dfoo")
-- Note that ordering is important in the following list: any flag which
-- is a prefix flag (i.e. HasArg, Prefix, OptPrefix, AnySuffix) will override
......@@ -104,65 +104,65 @@ static_flags :: [Flag IO]
static_flags = [
------- GHCi -------------------------------------------------------
flagC "ignore-dot-ghci" (PassFlag addOpt)
, flagC "read-dot-ghci" (NoArg (removeOpt "-ignore-dot-ghci"))
Flag "ignore-dot-ghci" (PassFlag addOpt)
, Flag "read-dot-ghci" (NoArg (removeOpt "-ignore-dot-ghci"))
------- ways --------------------------------------------------------
, flagC "prof" (NoArg (addWay WayProf))
, flagC "eventlog" (NoArg (addWay WayEventLog))
, flagC "parallel" (NoArg (addWay WayPar))
, flagC "gransim" (NoArg (addWay WayGran))
, flagC "smp" (NoArg (addWay WayThreaded >> deprecate "Use -threaded instead"))
, flagC "debug" (NoArg (addWay WayDebug))
, flagC "ndp" (NoArg (addWay WayNDP))
, flagC "threaded" (NoArg (addWay WayThreaded))
, flagC "ticky" (PassFlag (\f -> do addOpt f; addWay WayDebug))
, Flag "prof" (NoArg (addWay WayProf))
, Flag "eventlog" (NoArg (addWay WayEventLog))
, Flag "parallel" (NoArg (addWay WayPar))
, Flag "gransim" (NoArg (addWay WayGran))
, Flag "smp" (NoArg (addWay WayThreaded >> deprecate "Use -threaded instead"))
, Flag "debug" (NoArg (addWay WayDebug))
, Flag "ndp" (NoArg (addWay WayNDP))
, Flag "threaded" (NoArg (addWay WayThreaded))
, Flag "ticky" (PassFlag (\f -> do addOpt f; addWay WayDebug))
-- -ticky enables ticky-ticky code generation, and also implies -debug which
-- is required to get the RTS ticky support.
------ Debugging ----------------------------------------------------
, flagC "dppr-debug" (PassFlag addOpt)
, flagC "dppr-cols" (AnySuffix addOpt)
, flagC "dppr-user-length" (AnySuffix addOpt)
, flagC "dppr-case-as-let" (PassFlag addOpt)
, flagC "dsuppress-all" (PassFlag addOpt)
, flagC "dsuppress-uniques" (PassFlag addOpt)
, flagC "dsuppress-coercions" (PassFlag addOpt)
, flagC "dsuppress-module-prefixes" (PassFlag addOpt)
, flagC "dsuppress-type-applications" (PassFlag addOpt)
, flagC "dsuppress-idinfo" (PassFlag addOpt)
, flagC "dsuppress-type-signatures" (PassFlag addOpt)
, flagC "dopt-fuel" (AnySuffix addOpt)
, flagC "dtrace-level" (AnySuffix addOpt)
, flagC "dno-debug-output" (PassFlag addOpt)
, flagC "dstub-dead-values" (PassFlag addOpt)
, Flag "dppr-debug" (PassFlag addOpt)
, Flag "dppr-cols" (AnySuffix addOpt)
, Flag "dppr-user-length" (AnySuffix addOpt)
, Flag "dppr-case-as-let" (PassFlag addOpt)
, Flag "dsuppress-all" (PassFlag addOpt)
, Flag "dsuppress-uniques" (PassFlag addOpt)
, Flag "dsuppress-coercions" (PassFlag addOpt)
, Flag "dsuppress-module-prefixes" (PassFlag addOpt)
, Flag "dsuppress-type-applications" (PassFlag addOpt)
, Flag "dsuppress-idinfo" (PassFlag addOpt)
, Flag "dsuppress-type-signatures" (PassFlag addOpt)
, Flag "dopt-fuel" (AnySuffix addOpt)
, Flag "dtrace-level" (AnySuffix addOpt)
, Flag "dno-debug-output" (PassFlag addOpt)
, Flag "dstub-dead-values" (PassFlag addOpt)
-- rest of the debugging flags are dynamic
----- Linker --------------------------------------------------------
, flagC "static" (PassFlag addOpt)
, flagC "dynamic" (NoArg (removeOpt "-static" >> addWay WayDyn))
, Flag "static" (PassFlag addOpt)
, Flag "dynamic" (NoArg (removeOpt "-static" >> addWay WayDyn))
-- ignored for compat w/ gcc:
, flagC "rdynamic" (NoArg (return ()))
, Flag "rdynamic" (NoArg (return ()))
----- RTS opts ------------------------------------------------------
, flagC "H" (HasArg (\s -> liftEwM (setHeapSize (fromIntegral (decodeSize s)))))
, Flag "H" (HasArg (\s -> liftEwM (setHeapSize (fromIntegral (decodeSize s)))))
, flagC "Rghc-timing" (NoArg (liftEwM enableTimingStats))
, Flag "Rghc-timing" (NoArg (liftEwM enableTimingStats))
------ Compiler flags -----------------------------------------------
-- -fPIC requires extra checking: only the NCG supports it.
-- See also DynFlags.parseDynamicFlags.
, flagC "fPIC" (PassFlag setPIC)
, Flag "fPIC" (PassFlag setPIC)
-- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline
, flagC "fno-"
, Flag "fno-"
(PrefixPred (\s -> isStaticFlag ("f"++s)) (\s -> removeOpt ("-f"++s)))
-- Pass all remaining "-f<blah>" options to hsc
, flagC "f" (AnySuffixPred isStaticFlag addOpt)
, Flag "f" (AnySuffixPred isStaticFlag addOpt)
]
setPIC :: String -> StaticP ()
......
......@@ -1033,7 +1033,7 @@ checkFlag flag (dflags, _)
where
why = ptext (sLit "You need -X") <> text flag_str
<+> ptext (sLit "to derive an instance for this class")
flag_str = case [ s | (s, _, f, _) <- xFlags, f==flag ] of
flag_str = case [ s | (s, f, _) <- xFlags, f==flag ] of
[s] -> s
other -> pprPanic "checkFlag" (ppr other)
......
......@@ -1728,17 +1728,17 @@ setCmd ""
nest 2 (vcat (map (warnSetting dflags) DynFlags.fWarningFlags))
))
where flagSetting dflags (str, _, f, _)
where flagSetting dflags (str, f, _)
| dopt f dflags = fstr str
| otherwise = fnostr str
warnSetting dflags (str, _, f, _)
warnSetting dflags (str, f, _)
| wopt f dflags = fstr str
| otherwise = fnostr str
fstr str = text "-f" <> text str
fnostr str = 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
......@@ -2021,7 +2021,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]
-- -----------------------------------------------------------------------------
......
......@@ -478,7 +478,7 @@ parseModeFlags :: [Located String]
[Located String])
parseModeFlags args = do
let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) =
runCmdLine (processArgs mode_flags args CmdLineOnly True)
runCmdLine (processArgs mode_flags args)
(Nothing, [], [])
mode = case mModeFlag of
Nothing -> doMakeMode
......@@ -494,16 +494,16 @@ type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String])
mode_flags :: [Flag ModeM]
mode_flags =
[ ------- help / version ----------------------------------------------
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 "?" (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 k' (PassFlag (setMode (printSetting k)))
[ Flag k' (PassFlag (setMode (printSetting k)))
| k <- ["Project version",
"Booter version",
"Stage",
......@@ -529,21 +529,21 @@ mode_flags =
replaceSpace c = c
] ++
------- interfaces ----------------------------------------------------
[ flagC "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f)
[ Flag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f)
"--show-iface"))
------- primary modes ------------------------------------------------
, 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"))
, 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"))
]
setMode :: Mode -> String -> EwM ModeM ()
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment