Commit 45c64c1d authored by dterei's avatar dterei

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.
parent 94434054
......@@ -909,7 +909,7 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names
= case lookupModuleEnv direct_imports mod of
Just ((_,_,_,safe):_xs) -> (True, safe)
Just _ -> pprPanic "mkUsage: empty direct import" empty
Nothing -> (False, safeImportsRequired dflags)
Nothing -> (False, safeImplicitImpsReq dflags)
-- Nothing case is for implicit imports like 'System.IO' when 'putStrLn'
-- is used in the source code. We require them to be safe in SafeHaskell
......
......@@ -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
......
......@@ -754,7 +754,7 @@ runPhase (Cpp sf) input_fn dflags0
= do
src_opts <- io $ getOptionsFromFile dflags0 input_fn
(dflags1, unhandled_flags, warns)
<- io $ parseDynamicNoPackageFlags dflags0 src_opts
<- io $ parseDynamicFilePragma dflags0 src_opts
setDynFlags dflags1
io $ checkProcessArgsResult unhandled_flags
......@@ -772,7 +772,7 @@ runPhase (Cpp sf) input_fn dflags0
-- See #2464,#3457
src_opts <- io $ getOptionsFromFile dflags0 output_fn
(dflags2, unhandled_flags, warns)
<- io $ parseDynamicNoPackageFlags dflags0 src_opts
<- io $ parseDynamicFilePragma dflags0 src_opts
io $ checkProcessArgsResult unhandled_flags
unless (dopt Opt_Pp dflags2) $ io $ handleFlagWarnings dflags2 warns
-- the HsPp pass below will emit warnings
......@@ -806,7 +806,7 @@ runPhase (HsPp sf) input_fn dflags
-- re-read pragmas now that we've parsed the file (see #3674)
src_opts <- io $ getOptionsFromFile dflags output_fn
(dflags1, unhandled_flags, warns)
<- io $ parseDynamicNoPackageFlags dflags src_opts
<- io $ parseDynamicFilePragma dflags src_opts
setDynFlags dflags1
io $ checkProcessArgsResult unhandled_flags
io $ handleFlagWarnings dflags1 warns
......
This diff is collapsed.
......@@ -460,6 +460,11 @@ setSessionDynFlags dflags = do
return preload
parseDynamicFlags :: Monad m =>
DynFlags -> [Located String]
-> m (DynFlags, [Located String], [Located String])
parseDynamicFlags = parseDynamicFlagsCmdLine
-- %************************************************************************
-- %* *
......
......@@ -1408,7 +1408,7 @@ preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
let local_opts = getOptions dflags buf src_fn
(dflags', leftovers, warns)
<- parseDynamicNoPackageFlags dflags local_opts
<- parseDynamicFilePragma dflags local_opts
checkProcessArgsResult leftovers
handleFlagWarnings dflags' warns
......
......@@ -104,13 +104,13 @@ mkPrelImports this_mod implicit_prelude import_decls
preludeImportDecl :: LImportDecl RdrName
preludeImportDecl
= L loc $
ImportDecl (L loc pRELUDE_NAME)
Nothing {- no specific package -}
False {- Not a boot interface -}
False {- Not a safe interface -}
False {- Not qualified -}
Nothing {- No "as" -}
Nothing {- No import list -}
ImportDecl (L loc pRELUDE_NAME)
Nothing {- No specific package -}
False {- Not a boot interface -}
False {- Not a safe import -}
False {- Not qualified -}
Nothing {- No "as" -}
Nothing {- No import list -}
loc = mkGeneralSrcSpan (fsLit "Implicit import declaration")
......
......@@ -86,7 +86,8 @@ import Panic
#endif
import Id ( Id )
import Module ( emptyModuleEnv, ModLocation(..), Module )
import Module
import Packages
import RdrName
import HsSyn
import CoreSyn
......@@ -770,12 +771,109 @@ batchMsg hsc_env mb_mod_index recomp mod_summary
--------------------------------------------------------------
hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv
hscFileFrontEnd mod_summary =
do rdr_module <- hscParse' mod_summary
hsc_env <- getHscEnv
{-# SCC "Typecheck-Rename" #-}
ioMsgMaybe $
tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module
hscFileFrontEnd mod_summary = do
rdr_module <- hscParse' mod_summary
hsc_env <- getHscEnv
{-# SCC "Typecheck-Rename" #-}
tcg_env <- ioMsgMaybe $
tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module
dflags <- getDynFlags
tcg_env' <- checkSafeImports dflags hsc_env tcg_env
return tcg_env'
--------------------------------------------------------------
-- SafeHaskell
--------------------------------------------------------------
-- | Validate that safe imported modules are actually safe.
-- For modules in the HomePackage (the package the module we
-- are compiling in resides) this just involves checking its
-- trust type is 'Safe' or 'Trustworthy'. For modules that
-- reside in another package we also must check that the
-- external pacakge is trusted.
checkSafeImports :: DynFlags -> HscEnv -> TcGblEnv -> Hsc TcGblEnv
checkSafeImports dflags hsc_env tcg_env
| not (safeHaskellOn dflags)
= return tcg_env
| otherwise
= do
imps <- mapM condense imports'
mapM_ checkSafe imps
return tcg_env
where
imp_info = tcg_imports tcg_env -- ImportAvails
imports = imp_mods imp_info -- ImportedMods
imports' = moduleEnvToList imports -- (Module, [ImportedModsVal])
condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport)
condense (_, []) = panic "HscMain.condense: Pattern match failure!"
condense (m, x:xs) = do (_,_,l,s) <- foldlM cond' x xs
return (m, l, s)
-- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport)
cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal
cond' v1@(m1,_,l1,s1) (_,_,_,s2)
| s1 /= s2
= liftIO $ throwIO $ mkSrcErr $ unitBag $ mkPlainErrMsg l1
(text "Module" <+> ppr m1 <+> (text $ "is imported"
++ " both as a safe and unsafe import!"))
| otherwise
= return v1
lookup' :: Module -> Hsc (Maybe ModIface)
lookup' m = do
hsc_eps <- liftIO $ hscEPS hsc_env
let pkgIfaceT = eps_PIT hsc_eps
homePkgT = hsc_HPT hsc_env
iface = lookupIfaceByModule dflags homePkgT pkgIfaceT m
return iface
-- | Check the package a module resides in is trusted.
-- Modules in the home package are trusted but otherwise
-- we check the packages trust flag.
packageTrusted :: Module -> Bool
packageTrusted m
| thisPackage dflags == modulePackageId m = True
| otherwise = trusted $ getPackageDetails (pkgState dflags)
(modulePackageId m)
-- Is a module a Safe importable? Return Nothing if True, or a String
-- if it isn't containing the reason it isn't
isModSafe :: Module -> SrcSpan -> Hsc (Maybe SDoc)
isModSafe m l = do
iface <- lookup' m
case iface of
-- can't load iface to check trust!
Nothing -> liftIO $ throwIO $ mkSrcErr $ unitBag $ mkPlainErrMsg l
$ text "Can't load the interface file for" <+> ppr m <>
text ", to check that it can be safely imported"
-- got iface, check trust
Just iface' -> do
let trust = getSafeMode $ mi_trust iface'
-- check module is trusted
safeM = trust `elem` [Sf_Safe, Sf_Trustworthy,
Sf_TrustworthyWithSafeLanguage]
-- check package is trusted
safeP = packageTrusted m
if safeM && safeP
then return Nothing
else return $ Just $ if safeM
then text "The package (" <> ppr (modulePackageId m) <>
text ") the module resides in isn't trusted."
else text "The module itself isn't safe."
checkSafe :: (Module, SrcSpan, IsSafeImport) -> Hsc ()
checkSafe (_, _, False) = return ()
checkSafe (m, l, True ) = do
module_safe <- isModSafe m l
case module_safe of
Nothing -> return ()
Just s -> liftIO $ throwIO $ mkSrcErr $ unitBag $ mkPlainErrMsg l
$ text "Safe import of" <+> ppr m <+> text "can't be met!"
<+> s
--------------------------------------------------------------
-- Simplifiers
......
......@@ -15,7 +15,7 @@ module HscTypes (
-- * Information about modules
ModDetails(..), emptyModDetails,
ModGuts(..), CgGuts(..), ForeignStubs(..), appendStubC,
ImportedMods,
ImportedMods, ImportedModsVal,
ModSummary(..), ms_mod_name, showModMsg, isBootSummary,
msHsFilePath, msHiFilePath, msObjFilePath,
......@@ -718,7 +718,9 @@ emptyModDetails = ModDetails { md_types = emptyTypeEnv,
}
-- | Records the modules directly imported by a module for extracting e.g. usage information
type ImportedMods = ModuleEnv [(ModuleName, Bool, SrcSpan, IsSafeImport)]
type ImportedMods = ModuleEnv [ImportedModsVal]
type ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport)
-- TODO: we are not actually using the codomain of this type at all, so it can be
-- replaced with ModuleEnv ()
......
......@@ -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
(leftover, errs, warns1) <- processArgs static_flags args CmdLineOnly True
when (not (null errs)) $ ghcError $ errorsToGhcException errs
-- deal with the way flags: the way (eg. prof) gives rise to
......@@ -62,7 +62,8 @@ parseStaticFlags args = do
let unreg_flags | cGhcUnregisterised == "YES" = unregFlags
| otherwise = []
(more_leftover, errs, warns2) <- processArgs static_flags (unreg_flags ++ way_flags')
(more_leftover, errs, warns2) <-
processArgs static_flags (unreg_flags ++ way_flags') CmdLineOnly True
-- see sanity code in staticOpts
writeIORef v_opt_C_ready True
......@@ -103,65 +104,65 @@ static_flags :: [Flag IO]
static_flags = [
------- GHCi -------------------------------------------------------
Flag "ignore-dot-ghci" (PassFlag addOpt)
, Flag "read-dot-ghci" (NoArg (removeOpt "-ignore-dot-ghci"))
flagC "ignore-dot-ghci" (PassFlag addOpt)
, flagC "read-dot-ghci" (NoArg (removeOpt "-ignore-dot-ghci"))
------- ways --------------------------------------------------------
, 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))
, 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))
-- -ticky enables ticky-ticky code generation, and also implies -debug which
-- is required to get the RTS ticky support.
------ Debugging ----------------------------------------------------
, 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)
, 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)
-- rest of the debugging flags are dynamic
----- Linker --------------------------------------------------------
, Flag "static" (PassFlag addOpt)
, Flag "dynamic" (NoArg (removeOpt "-static" >> addWay WayDyn))
, flagC "static" (PassFlag addOpt)
, flagC "dynamic" (NoArg (removeOpt "-static" >> addWay WayDyn))
-- ignored for compat w/ gcc:
, Flag "rdynamic" (NoArg (return ()))
, flagC "rdynamic" (NoArg (return ()))
----- RTS opts ------------------------------------------------------
, Flag "H" (HasArg (\s -> liftEwM (setHeapSize (fromIntegral (decodeSize s)))))
, flagC "H" (HasArg (\s -> liftEwM (setHeapSize (fromIntegral (decodeSize s)))))
, Flag "Rghc-timing" (NoArg (liftEwM enableTimingStats))
, flagC "Rghc-timing" (NoArg (liftEwM enableTimingStats))
------ Compiler flags -----------------------------------------------
-- -fPIC requires extra checking: only the NCG supports it.
-- See also DynFlags.parseDynamicFlags.
, Flag "fPIC" (PassFlag setPIC)
, flagC "fPIC" (PassFlag setPIC)
-- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline
, Flag "fno-"
, flagC "fno-"
(PrefixPred (\s -> isStaticFlag ("f"++s)) (\s -> removeOpt ("-f"++s)))
-- Pass all remaining "-f<blah>" options to hsc
, Flag "f" (AnySuffixPred isStaticFlag addOpt)
, flagC "f" (AnySuffixPred isStaticFlag addOpt)
]
setPIC :: String -> StaticP ()
......
......@@ -219,7 +219,10 @@ rnImportDecl this_mod implicit_prelude
Just (is_hiding, ls) -> not is_hiding && null ls
_ -> False
mod_safe' = mod_safe || safeImportsRequired dflags
-- should the import be safe?
mod_safe' = mod_safe
|| (not implicit_prelude && safeDirectImpsReq dflags)
|| (implicit_prelude && safeImplicitImpsReq dflags)
imports = ImportAvails {
imp_mods = unitModuleEnv imp_mod [(qual_mod_name, import_all, loc, mod_safe')],
......
......@@ -1073,7 +1073,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)
......
......@@ -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
......
......@@ -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))