diff options
Diffstat (limited to 'compiler/main')
| -rw-r--r-- | compiler/main/CmdLineParser.hs | 110 | ||||
| -rw-r--r-- | compiler/main/DriverPipeline.hs | 6 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 989 | ||||
| -rw-r--r-- | compiler/main/GHC.hs | 5 | ||||
| -rw-r--r-- | compiler/main/GhcMake.hs | 2 | ||||
| -rw-r--r-- | compiler/main/HeaderInfo.hs | 14 | ||||
| -rw-r--r-- | compiler/main/HscMain.lhs | 112 | ||||
| -rw-r--r-- | compiler/main/HscTypes.lhs | 6 | ||||
| -rw-r--r-- | compiler/main/StaticFlagParser.hs | 75 |
9 files changed, 795 insertions, 524 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 diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index afbd03e2c7..4eca8706e1 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -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 diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 30ad0adf50..665b44a407 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -34,7 +34,8 @@ module DynFlags ( -- ** SafeHaskell SafeHaskellMode(..), - safeHaskellOn, safeImportsRequired, + safeHaskellOn, safeLanguageOn, + safeDirectImpsReq, safeImplicitImpsReq, Settings(..), ghcUsagePath, ghciUsagePath, topDir, tmpDir, rawSettings, @@ -57,8 +58,8 @@ module DynFlags ( doingTickyProfiling, -- ** Parsing DynFlags - parseDynamicFlags, - parseDynamicNoPackageFlags, + parseDynamicFlagsCmdLine, + parseDynamicFilePragma, allFlags, supportedLanguagesAndExtensions, @@ -975,6 +976,10 @@ setLanguage l = upd f extensionFlags = flattenExtensionFlags mLang oneoffs } +safeLanguageOn :: DynFlags -> Bool +safeLanguageOn dflags = s == Sf_SafeLanguage || s == Sf_Safe + where s = safeHaskell dflags + -- | Test if SafeHaskell is on in some form safeHaskellOn :: DynFlags -> Bool safeHaskellOn dflags = safeHaskell dflags /= Sf_None @@ -987,10 +992,15 @@ setSafeHaskell s = upd f safeHaskell = combineSafeFlags sf s } --- | Are all imports required to be safe for this SafeHaskell mode? -safeImportsRequired :: DynFlags -> Bool -safeImportsRequired dflags = m == Sf_SafeLanguage || m == Sf_Safe - where m = safeHaskell dflags +-- | Are all direct imports required to be safe for this SafeHaskell mode? +-- Direct imports are when the code explicitly imports a module +safeDirectImpsReq :: DynFlags -> Bool +safeDirectImpsReq = safeLanguageOn + +-- | Are all implicit imports required to be safe for this SafeHaskell mode? +-- Implicit imports are things in the prelude. e.g System.IO when print is used. +safeImplicitImpsReq :: DynFlags -> Bool +safeImplicitImpsReq _ = False -- | Combine two SafeHaskell modes correctly. Used for dealing with multiple flags. -- This makes SafeHaskell very much a monoid but for now I prefer this as I don't @@ -1128,6 +1138,7 @@ data Option -- transformed (e.g., "/out=") String -- the filepath/filename portion | Option String + deriving ( Eq ) showOpt :: Option -> String showOpt (FileOption pre f) = pre ++ f @@ -1183,26 +1194,27 @@ getStgToDo dflags -- the parsed 'DynFlags', the left-over arguments, and a list of warnings. -- Throws a 'UsageError' if errors occurred during parsing (such as unknown -- flags or missing arguments). -parseDynamicFlags :: Monad m => +parseDynamicFlagsCmdLine :: Monad m => DynFlags -> [Located String] -> m (DynFlags, [Located String], [Located String]) -- ^ Updated 'DynFlags', left-over arguments, and -- list of warnings. -parseDynamicFlags dflags args = parseDynamicFlags_ dflags args True +parseDynamicFlagsCmdLine dflags args = parseDynamicFlags dflags args True --- | Like 'parseDynamicFlags' but does not allow the package flags (-package, --- -hide-package, -ignore-package, -hide-all-packages, -package-conf). -parseDynamicNoPackageFlags :: Monad m => +-- | Like 'parseDynamicFlagsCmdLine' but does not allow the package flags +-- (-package, -hide-package, -ignore-package, -hide-all-packages, -package-conf). +-- Used to parse flags set in a modules pragma. +parseDynamicFilePragma :: Monad m => DynFlags -> [Located String] -> m (DynFlags, [Located String], [Located String]) -- ^ Updated 'DynFlags', left-over arguments, and -- list of warnings. -parseDynamicNoPackageFlags dflags args = parseDynamicFlags_ dflags args False +parseDynamicFilePragma dflags args = parseDynamicFlags dflags args False -parseDynamicFlags_ :: Monad m => +parseDynamicFlags :: Monad m => DynFlags -> [Located String] -> Bool -> m (DynFlags, [Located String], [Located String]) -parseDynamicFlags_ dflags0 args pkg_flags = do +parseDynamicFlags dflags0 args cmdline = do -- XXX Legacy support code -- We used to accept things like -- optdep-f -optdepdepend @@ -1216,14 +1228,116 @@ parseDynamicFlags_ dflags0 args pkg_flags = do args' = f args -- Note: -ignore-package (package_flags) must precede -i* (dynamic_flags) - flag_spec | pkg_flags = package_flags ++ dynamic_flags + flag_spec | cmdline = package_flags ++ dynamic_flags | otherwise = dynamic_flags + let safeLevel = if safeLanguageOn dflags0 + then determineSafeLevel cmdline else NeverAllowed let ((leftover, errs, warns), dflags1) - = runCmdLine (processArgs flag_spec args') dflags0 + = runCmdLine (processArgs flag_spec args' safeLevel cmdline) dflags0 when (not (null errs)) $ ghcError $ errorsToGhcException errs - return (dflags1, leftover, warns) + -- check for disabled flags in safe haskell + -- Hack: unfortunately flags that are completely disabled can't be stopped from being + -- enabled on the command line before a -XSafe or -XSafeLanguage flag is encountered. + -- the easiest way to fix this is to just check that they aren't enabled now. The down + -- side is that flags marked as NeverAllowed must also be checked here placing a sync + -- burden on the ghc hacker. + let sh_warns = if (safeLanguageOn dflags2) + then shFlagsDisallowed dflags2 + else [] + + return (dflags2, leftover, sh_warns ++ warns) + +-- | Extensions that can't be enabled at all when compiling in Safe mode +-- checkSafeHaskellFlags :: MonadIO m => DynFlags -> m () +shFlagsDisallowed :: DynFlags -> [Located String] +shFlagsDisallowed dflags = concat $ map check_method bad_flags + where + check_method (flag,str) | (flag dflags) = safeFailure str + | otherwise = [] + + bad_flags = [(xopt Opt_GeneralizedNewtypeDeriving, "-XGeneralizedNewtypeDeriving")] + + safeFailure str = [L noSrcSpan $ "Warning: " ++ str ++ " is not allowed in" + ++ " SafeHaskell; ignoring " ++ str] + +{- + -- ALTERNATE SAFE HASKELL CHECK METHOD + +-- | Extensions that can only be enabled on the command line when compiling in +-- Safe mode +shFlagsCmdLineOnly :: Monad m => DynFlags -> DynFlags -> m () +shFlagsCmdLineOnly oldf newf = mapM_ check_method bad_flags + where + check_method (test,str) = when test $ safeFailure str + + ext_test ext = xopt ext newf && not (xopt ext oldf) + pgm_test pgm = pgm oldf == pgm newf + dyn_test dyn = dopt dyn newf && not (dopt dyn oldf) + + bad_flags = [ (ext_test Opt_TemplateHaskell, "TemplateHaskell") + , (ext_test Opt_Cpp, "CPP") + , (dyn_test Opt_Pp, "F") + + , (pgm_test pgm_lo, "pgmlo") + , (pgm_test pgm_lc, "pgmlc") + , (pgm_test pgm_L, "pgmL") + , (pgm_test pgm_P, "pgmP") + , (pgm_test pgm_F, "pgmF") + , (pgm_test pgm_c, "pgmc") + , (pgm_test pgm_m, "pgmm") + , (pgm_test pgm_s, "pgms") + , (pgm_test pgm_a, "pgma") + , (pgm_test pgm_l, "pgml") + , (pgm_test pgm_dll, "pgmdll") + , (pgm_test pgm_windres, "pgmwindres") + + , (pgm_test opt_lo, "optlo") + , (pgm_test opt_lc, "optlc") + , (pgm_test opt_L, "optL") + , (pgm_test opt_P, "optP") + , (pgm_test opt_F, "optF") + , (pgm_test opt_c, "optc") + , (pgm_test opt_m, "optm") + , (pgm_test opt_a, "opta") + , (pgm_test opt_l, "optl OR l") + , (pgm_test opt_windres, "optlwindres") + + , (pgm_test mainFunIs + && pgm_test mainModIs, "main-is") + , (pgm_test libraryPaths, "L") + , (pgm_test dynLibLoader, "dynload") + + , (pgm_test hcSuf, "hcsuf") + , (pgm_test hiSuf, "hisuf") + , (pgm_test objectSuf, "osuf") + , (pgm_test hiDir, "hidir") + , (pgm_test objectDir, "odir") + , (pgm_test stubDir, "stubdir") + , (pgm_test outputHi, "ohi") + , (pgm_test outputFile, "o") + , (pgm_test tmpDir, "tmpdir") + + , (pgm_test includePaths, "I") + + , (pgm_test rtsOpts, "with-rtsopts") + , (pgm_test rtsOptsEnabled, "rtsopts") + + , (pgm_test dylibInstallName, "dylib-install-name") + ] + +-- safeFailure :: MonadIO m => String -> m () +safeFailure :: Monad m => String -> m () +safeFailure s = ghcError $ CmdLineError $ "Illegal extension (" ++ s + ++ ") in use while compiling with Safe Haskell!" +{- + -- prefer this error but circular imports arise. + = liftIO $ throwIO $ mkSrcErr $ unitBag $ mkPlainErrMsg noSrcSpan $ + text "Illegal extension (" <> text s <> + text ") in use while compiling with Safe Haskell!" +-} +-} {- ********************************************************************** @@ -1240,301 +1354,301 @@ allFlags = map ('-':) $ map ("f"++) flags' ++ map ("X"++) supportedExtensions where ok (PrefixPred _ _) = False - ok _ = True - flags = [ name | (name, _, _) <- fFlags ] - flags' = [ name | (name, _, _) <- fLangFlags ] + ok _ = True + flags = [ name | (name, _, _, _) <- fFlags ] + flags' = [ name | (name, _, _, _) <- fLangFlags ] --------------- The main flags themselves ------------------ dynamic_flags :: [Flag (CmdLineP DynFlags)] dynamic_flags = [ - Flag "n" (NoArg (addWarn "The -n flag is deprecated and no longer has any effect")) - , Flag "cpp" (NoArg (setExtensionFlag Opt_Cpp)) - , Flag "F" (NoArg (setDynFlag Opt_Pp)) - , Flag "#include" + flagA "n" (NoArg (addWarn "The -n flag is deprecated and no longer has any effect")) + , flagC "cpp" (NoArg (setExtensionFlag Opt_Cpp)) + , flagC "F" (NoArg (setDynFlag Opt_Pp)) + , flagA "#include" (HasArg (\s -> do { addCmdlineHCInclude s ; addWarn "-#include and INCLUDE pragmas are deprecated: They no longer have any effect" })) - , Flag "v" (OptIntSuffix setVerbosity) + , flagA "v" (OptIntSuffix setVerbosity) ------- Specific phases -------------------------------------------- -- need to appear before -pgmL to be parsed as LLVM flags. - , Flag "pgmlo" (hasArg (\f -> alterSettings (\s -> s { sPgm_lo = (f,[])}))) - , Flag "pgmlc" (hasArg (\f -> alterSettings (\s -> s { sPgm_lc = (f,[])}))) - , Flag "pgmL" (hasArg (\f -> alterSettings (\s -> s { sPgm_L = f}))) - , Flag "pgmP" (hasArg setPgmP) - , Flag "pgmF" (hasArg (\f -> alterSettings (\s -> s { sPgm_F = f}))) - , Flag "pgmc" (hasArg (\f -> alterSettings (\s -> s { sPgm_c = (f,[])}))) - , Flag "pgmm" (HasArg (\_ -> addWarn "The -keep-raw-s-files flag does nothing; it will be removed in a future GHC release")) - , Flag "pgms" (hasArg (\f -> alterSettings (\s -> s { sPgm_s = (f,[])}))) - , Flag "pgma" (hasArg (\f -> alterSettings (\s -> s { sPgm_a = (f,[])}))) - , Flag "pgml" (hasArg (\f -> alterSettings (\s -> s { sPgm_l = (f,[])}))) - , Flag "pgmdll" (hasArg (\f -> alterSettings (\s -> s { sPgm_dll = (f,[])}))) - , Flag "pgmwindres" (hasArg (\f -> alterSettings (\s -> s { sPgm_windres = f}))) + , flagC "pgmlo" (hasArg (\f -> alterSettings (\s -> s { sPgm_lo = (f,[])}))) + , flagC "pgmlc" (hasArg (\f -> alterSettings (\s -> s { sPgm_lc = (f,[])}))) + , flagC "pgmL" (hasArg (\f -> alterSettings (\s -> s { sPgm_L = f}))) + , flagC "pgmP" (hasArg setPgmP) + , flagC "pgmF" (hasArg (\f -> alterSettings (\s -> s { sPgm_F = f}))) + , flagC "pgmc" (hasArg (\f -> alterSettings (\s -> s { sPgm_c = (f,[])}))) + , flagC "pgmm" (HasArg (\_ -> addWarn "The -keep-raw-s-files flag does nothing; it will be removed in a future GHC release")) + , flagC "pgms" (hasArg (\f -> alterSettings (\s -> s { sPgm_s = (f,[])}))) + , flagC "pgma" (hasArg (\f -> alterSettings (\s -> s { sPgm_a = (f,[])}))) + , flagC "pgml" (hasArg (\f -> alterSettings (\s -> s { sPgm_l = (f,[])}))) + , flagC "pgmdll" (hasArg (\f -> alterSettings (\s -> s { sPgm_dll = (f,[])}))) + , flagC "pgmwindres" (hasArg (\f -> alterSettings (\s -> s { sPgm_windres = f}))) -- need to appear before -optl/-opta to be parsed as LLVM flags. - , Flag "optlo" (hasArg (\f -> alterSettings (\s -> s { sOpt_lo = f : sOpt_lo s}))) - , Flag "optlc" (hasArg (\f -> alterSettings (\s -> s { sOpt_lc = f : sOpt_lc s}))) - , Flag "optL" (hasArg (\f -> alterSettings (\s -> s { sOpt_L = f : sOpt_L s}))) - , Flag "optP" (hasArg addOptP) - , Flag "optF" (hasArg (\f -> alterSettings (\s -> s { sOpt_F = f : sOpt_F s}))) - , Flag "optc" (hasArg (\f -> alterSettings (\s -> s { sOpt_c = f : sOpt_c s}))) - , Flag "optm" (hasArg (\f -> alterSettings (\s -> s { sOpt_m = f : sOpt_m s}))) - , Flag "opta" (hasArg (\f -> alterSettings (\s -> s { sOpt_a = f : sOpt_a s}))) - , Flag "optl" (hasArg addOptl) - , Flag "optwindres" (hasArg (\f -> alterSettings (\s -> s { sOpt_windres = f : sOpt_windres s}))) - - , Flag "split-objs" + , flagC "optlo" (hasArg (\f -> alterSettings (\s -> s { sOpt_lo = f : sOpt_lo s}))) + , flagC "optlc" (hasArg (\f -> alterSettings (\s -> s { sOpt_lc = f : sOpt_lc s}))) + , flagC "optL" (hasArg (\f -> alterSettings (\s -> s { sOpt_L = f : sOpt_L s}))) + , flagC "optP" (hasArg addOptP) + , flagC "optF" (hasArg (\f -> alterSettings (\s -> s { sOpt_F = f : sOpt_F s}))) + , flagC "optc" (hasArg (\f -> alterSettings (\s -> s { sOpt_c = f : sOpt_c s}))) + , flagC "optm" (hasArg (\f -> alterSettings (\s -> s { sOpt_m = f : sOpt_m s}))) + , flagC "opta" (hasArg (\f -> alterSettings (\s -> s { sOpt_a = f : sOpt_a s}))) + , flagC "optl" (hasArg addOptl) + , flagC "optwindres" (hasArg (\f -> alterSettings (\s -> s { sOpt_windres = f : sOpt_windres s}))) + + , flagC "split-objs" (NoArg (if can_split then setDynFlag Opt_SplitObjs else addWarn "ignoring -fsplit-objs")) -------- ghc -M ----------------------------------------------------- - , Flag "dep-suffix" (hasArg addDepSuffix) - , Flag "optdep-s" (hasArgDF addDepSuffix "Use -dep-suffix instead") - , Flag "dep-makefile" (hasArg setDepMakefile) - , Flag "optdep-f" (hasArgDF setDepMakefile "Use -dep-makefile instead") - , Flag "optdep-w" (NoArg (deprecate "doesn't do anything")) - , Flag "include-pkg-deps" (noArg (setDepIncludePkgDeps True)) - , Flag "optdep--include-prelude" (noArgDF (setDepIncludePkgDeps True) "Use -include-pkg-deps instead") - , Flag "optdep--include-pkg-deps" (noArgDF (setDepIncludePkgDeps True) "Use -include-pkg-deps instead") - , Flag "exclude-module" (hasArg addDepExcludeMod) - , Flag "optdep--exclude-module" (hasArgDF addDepExcludeMod "Use -exclude-module instead") - , Flag "optdep-x" (hasArgDF addDepExcludeMod "Use -exclude-module instead") + , flagA "dep-suffix" (hasArg addDepSuffix) + , flagA "optdep-s" (hasArgDF addDepSuffix "Use -dep-suffix instead") + , flagA "dep-makefile" (hasArg setDepMakefile) + , flagA "optdep-f" (hasArgDF setDepMakefile "Use -dep-makefile instead") + , flagA "optdep-w" (NoArg (deprecate "doesn't do anything")) + , flagA "include-pkg-deps" (noArg (setDepIncludePkgDeps True)) + , flagA "optdep--include-prelude" (noArgDF (setDepIncludePkgDeps True) "Use -include-pkg-deps instead") + , flagA "optdep--include-pkg-deps" (noArgDF (setDepIncludePkgDeps True) "Use -include-pkg-deps instead") + , flagA "exclude-module" (hasArg addDepExcludeMod) + , flagA "optdep--exclude-module" (hasArgDF addDepExcludeMod "Use -exclude-module instead") + , flagA "optdep-x" (hasArgDF addDepExcludeMod "Use -exclude-module instead") -------- Linking ---------------------------------------------------- - , Flag "no-link" (noArg (\d -> d{ ghcLink=NoLink })) - , Flag "shared" (noArg (\d -> d{ ghcLink=LinkDynLib })) - , Flag "dynload" (hasArg parseDynLibLoaderMode) - , Flag "dylib-install-name" (hasArg setDylibInstallName) + , flagA "no-link" (noArg (\d -> d{ ghcLink=NoLink })) + , flagA "shared" (noArg (\d -> d{ ghcLink=LinkDynLib })) + , flagC "dynload" (hasArg parseDynLibLoaderMode) + , flagC "dylib-install-name" (hasArg setDylibInstallName) ------- Libraries --------------------------------------------------- - , Flag "L" (Prefix addLibraryPath) - , Flag "l" (hasArg (addOptl . ("-l" ++))) + , flagC "L" (Prefix addLibraryPath) + , flagC "l" (hasArg (addOptl . ("-l" ++))) ------- Frameworks -------------------------------------------------- -- -framework-path should really be -F ... - , Flag "framework-path" (HasArg addFrameworkPath) - , Flag "framework" (hasArg addCmdlineFramework) + , flagC "framework-path" (HasArg addFrameworkPath) + , flagC "framework" (hasArg addCmdlineFramework) ------- Output Redirection ------------------------------------------ - , Flag "odir" (hasArg setObjectDir) - , Flag "o" (SepArg (upd . setOutputFile . Just)) - , Flag "ohi" (hasArg (setOutputHi . Just )) - , Flag "osuf" (hasArg setObjectSuf) - , Flag "hcsuf" (hasArg setHcSuf) - , Flag "hisuf" (hasArg setHiSuf) - , Flag "hidir" (hasArg setHiDir) - , Flag "tmpdir" (hasArg setTmpDir) - , Flag "stubdir" (hasArg setStubDir) - , Flag "outputdir" (hasArg setOutputDir) - , Flag "ddump-file-prefix" (hasArg (setDumpPrefixForce . Just)) + , flagC "odir" (hasArg setObjectDir) + , flagC "o" (SepArg (upd . setOutputFile . Just)) + , flagC "ohi" (hasArg (setOutputHi . Just )) + , flagC "osuf" (hasArg setObjectSuf) + , flagC "hcsuf" (hasArg setHcSuf) + , flagC "hisuf" (hasArg setHiSuf) + , flagC "hidir" (hasArg setHiDir) + , flagC "tmpdir" (hasArg setTmpDir) + , flagC "stubdir" (hasArg setStubDir) + , flagC "outputdir" (hasArg setOutputDir) + , flagC "ddump-file-prefix" (hasArg (setDumpPrefixForce . Just)) ------- Keeping temporary files ------------------------------------- -- These can be singular (think ghc -c) or plural (think ghc --make) - , Flag "keep-hc-file" (NoArg (setDynFlag Opt_KeepHcFiles)) - , Flag "keep-hc-files" (NoArg (setDynFlag Opt_KeepHcFiles)) - , Flag "keep-s-file" (NoArg (setDynFlag Opt_KeepSFiles)) - , Flag "keep-s-files" (NoArg (setDynFlag Opt_KeepSFiles)) - , Flag "keep-raw-s-file" (NoArg (addWarn "The -keep-raw-s-file flag does nothing; it will be removed in a future GHC release")) - , Flag "keep-raw-s-files" (NoArg (addWarn "The -keep-raw-s-files flag does nothing; it will be removed in a future GHC release")) - , Flag "keep-llvm-file" (NoArg (setDynFlag Opt_KeepLlvmFiles)) - , Flag "keep-llvm-files" (NoArg (setDynFlag Opt_KeepLlvmFiles)) + , flagA "keep-hc-file" (NoArg (setDynFlag Opt_KeepHcFiles)) + , flagA "keep-hc-files" (NoArg (setDynFlag Opt_KeepHcFiles)) + , flagA "keep-s-file" (NoArg (setDynFlag Opt_KeepSFiles)) + , flagA "keep-s-files" (NoArg (setDynFlag Opt_KeepSFiles)) + , flagA "keep-raw-s-file" (NoArg (addWarn "The -keep-raw-s-file flag does nothing; it will be removed in a future GHC release")) + , flagA "keep-raw-s-files" (NoArg (addWarn "The -keep-raw-s-files flag does nothing; it will be removed in a future GHC release")) + , flagA "keep-llvm-file" (NoArg (setDynFlag Opt_KeepLlvmFiles)) + , flagA "keep-llvm-files" (NoArg (setDynFlag Opt_KeepLlvmFiles)) -- This only makes sense as plural - , Flag "keep-tmp-files" (NoArg (setDynFlag Opt_KeepTmpFiles)) + , flagA "keep-tmp-files" (NoArg (setDynFlag Opt_KeepTmpFiles)) ------- Miscellaneous ---------------------------------------------- - , Flag "no-auto-link-packages" (NoArg (unSetDynFlag Opt_AutoLinkPackages)) - , Flag "no-hs-main" (NoArg (setDynFlag Opt_NoHsMain)) - , Flag "with-rtsopts" (HasArg setRtsOpts) - , Flag "rtsopts" (NoArg (setRtsOptsEnabled RtsOptsAll)) - , Flag "rtsopts=all" (NoArg (setRtsOptsEnabled RtsOptsAll)) - , Flag "rtsopts=some" (NoArg (setRtsOptsEnabled RtsOptsSafeOnly)) - , Flag "rtsopts=none" (NoArg (setRtsOptsEnabled RtsOptsNone)) - , Flag "no-rtsopts" (NoArg (setRtsOptsEnabled RtsOptsNone)) - , Flag "main-is" (SepArg setMainIs) - , Flag "haddock" (NoArg (setDynFlag Opt_Haddock)) - , Flag "haddock-opts" (hasArg addHaddockOpts) - , Flag "hpcdir" (SepArg setOptHpcDir) + , flagA "no-auto-link-packages" (NoArg (unSetDynFlag Opt_AutoLinkPackages)) + , flagA "no-hs-main" (NoArg (setDynFlag Opt_NoHsMain)) + , flagC "with-rtsopts" (HasArg setRtsOpts) + , flagC "rtsopts" (NoArg (setRtsOptsEnabled RtsOptsAll)) + , flagC "rtsopts=all" (NoArg (setRtsOptsEnabled RtsOptsAll)) + , flagC "rtsopts=some" (NoArg (setRtsOptsEnabled RtsOptsSafeOnly)) + , flagC "rtsopts=none" (NoArg (setRtsOptsEnabled RtsOptsNone)) + , flagA "no-rtsopts" (NoArg (setRtsOptsEnabled RtsOptsNone)) + , flagC "main-is" (SepArg setMainIs) + , flagA "haddock" (NoArg (setDynFlag Opt_Haddock)) + , flagA "haddock-opts" (hasArg addHaddockOpts) + , flagA "hpcdir" (SepArg setOptHpcDir) ------- recompilation checker -------------------------------------- - , Flag "recomp" (NoArg (do { unSetDynFlag Opt_ForceRecomp + , flagA "recomp" (NoArg (do { unSetDynFlag Opt_ForceRecomp ; deprecate "Use -fno-force-recomp instead" })) - , Flag "no-recomp" (NoArg (do { setDynFlag Opt_ForceRecomp + , flagA "no-recomp" (NoArg (do { setDynFlag Opt_ForceRecomp ; deprecate "Use -fforce-recomp instead" })) ------ HsCpp opts --------------------------------------------------- - , Flag "D" (AnySuffix (upd . addOptP)) - , Flag "U" (AnySuffix (upd . addOptP)) + , flagC "D" (AnySuffix (upd . addOptP)) + , flagC "U" (AnySuffix (upd . addOptP)) ------- Include/Import Paths ---------------------------------------- - , Flag "I" (Prefix addIncludePath) - , Flag "i" (OptPrefix addImportPath) + , flagC "I" (Prefix addIncludePath) + , flagC "i" (OptPrefix addImportPath) ------ Debugging ---------------------------------------------------- - , Flag "dstg-stats" (NoArg (setDynFlag Opt_StgStats)) - - , Flag "ddump-cmm" (setDumpFlag Opt_D_dump_cmm) - , Flag "ddump-raw-cmm" (setDumpFlag Opt_D_dump_raw_cmm) - , Flag "ddump-cmmz" (setDumpFlag Opt_D_dump_cmmz) - , Flag "ddump-cmmz-pretty" (setDumpFlag Opt_D_dump_cmmz_pretty) - , Flag "ddump-cmmz-cbe" (setDumpFlag Opt_D_dump_cmmz_cbe) - , Flag "ddump-cmmz-spills" (setDumpFlag Opt_D_dump_cmmz_spills) - , Flag "ddump-cmmz-proc" (setDumpFlag Opt_D_dump_cmmz_proc) - , Flag "ddump-cmmz-rewrite" (setDumpFlag Opt_D_dump_cmmz_rewrite) - , Flag "ddump-cmmz-dead" (setDumpFlag Opt_D_dump_cmmz_dead) - , Flag "ddump-cmmz-stub" (setDumpFlag Opt_D_dump_cmmz_stub) - , Flag "ddump-cmmz-sp" (setDumpFlag Opt_D_dump_cmmz_sp) - , Flag "ddump-cmmz-procmap" (setDumpFlag Opt_D_dump_cmmz_procmap) - , Flag "ddump-cmmz-split" (setDumpFlag Opt_D_dump_cmmz_split) - , Flag "ddump-cmmz-lower" (setDumpFlag Opt_D_dump_cmmz_lower) - , Flag "ddump-cmmz-info" (setDumpFlag Opt_D_dump_cmmz_info) - , Flag "ddump-cmmz-cafs" (setDumpFlag Opt_D_dump_cmmz_cafs) - , Flag "ddump-core-stats" (setDumpFlag Opt_D_dump_core_stats) - , Flag "ddump-cps-cmm" (setDumpFlag Opt_D_dump_cps_cmm) - , Flag "ddump-cvt-cmm" (setDumpFlag Opt_D_dump_cvt_cmm) - , Flag "ddump-asm" (setDumpFlag Opt_D_dump_asm) - , Flag "ddump-asm-native" (setDumpFlag Opt_D_dump_asm_native) - , Flag "ddump-asm-liveness" (setDumpFlag Opt_D_dump_asm_liveness) - , Flag "ddump-asm-coalesce" (setDumpFlag Opt_D_dump_asm_coalesce) - , Flag "ddump-asm-regalloc" (setDumpFlag Opt_D_dump_asm_regalloc) - , Flag "ddump-asm-conflicts" (setDumpFlag Opt_D_dump_asm_conflicts) - , Flag "ddump-asm-regalloc-stages" (setDumpFlag Opt_D_dump_asm_regalloc_stages) - , Flag "ddump-asm-stats" (setDumpFlag Opt_D_dump_asm_stats) - , Flag "ddump-asm-expanded" (setDumpFlag Opt_D_dump_asm_expanded) - , Flag "ddump-llvm" (NoArg (do { setObjTarget HscLlvm - ; setDumpFlag' Opt_D_dump_llvm})) - , Flag "ddump-cpranal" (setDumpFlag Opt_D_dump_cpranal) - , Flag "ddump-deriv" (setDumpFlag Opt_D_dump_deriv) - , Flag "ddump-ds" (setDumpFlag Opt_D_dump_ds) - , Flag "ddump-flatC" (setDumpFlag Opt_D_dump_flatC) - , Flag "ddump-foreign" (setDumpFlag Opt_D_dump_foreign) - , Flag "ddump-inlinings" (setDumpFlag Opt_D_dump_inlinings) - , Flag "ddump-rule-firings" (setDumpFlag Opt_D_dump_rule_firings) - , Flag "ddump-rule-rewrites" (setDumpFlag Opt_D_dump_rule_rewrites) - , Flag "ddump-occur-anal" (setDumpFlag Opt_D_dump_occur_anal) - , Flag "ddump-parsed" (setDumpFlag Opt_D_dump_parsed) - , Flag "ddump-rn" (setDumpFlag Opt_D_dump_rn) - , Flag "ddump-core-pipeline" (setDumpFlag Opt_D_dump_core_pipeline) - , Flag "ddump-simpl" (setDumpFlag Opt_D_dump_simpl) - , Flag "ddump-simpl-iterations" (setDumpFlag Opt_D_dump_simpl_iterations) - , Flag "ddump-simpl-phases" (OptPrefix setDumpSimplPhases) - , Flag "ddump-spec" (setDumpFlag Opt_D_dump_spec) - , Flag "ddump-prep" (setDumpFlag Opt_D_dump_prep) - , Flag "ddump-stg" (setDumpFlag Opt_D_dump_stg) - , Flag "ddump-stranal" (setDumpFlag Opt_D_dump_stranal) - , Flag "ddump-tc" (setDumpFlag Opt_D_dump_tc) - , Flag "ddump-types" (setDumpFlag Opt_D_dump_types) - , Flag "ddump-rules" (setDumpFlag Opt_D_dump_rules) - , Flag "ddump-cse" (setDumpFlag Opt_D_dump_cse) - , Flag "ddump-worker-wrapper" (setDumpFlag Opt_D_dump_worker_wrapper) - , Flag "ddump-rn-trace" (setDumpFlag Opt_D_dump_rn_trace) - , Flag "ddump-if-trace" (setDumpFlag Opt_D_dump_if_trace) - , Flag "ddump-cs-trace" (setDumpFlag Opt_D_dump_cs_trace) - , Flag "ddump-tc-trace" (setDumpFlag Opt_D_dump_tc_trace) - , Flag "ddump-vt-trace" (setDumpFlag Opt_D_dump_vt_trace) - , Flag "ddump-splices" (setDumpFlag Opt_D_dump_splices) - , Flag "ddump-rn-stats" (setDumpFlag Opt_D_dump_rn_stats) - , Flag "ddump-opt-cmm" (setDumpFlag Opt_D_dump_opt_cmm) - , Flag "ddump-simpl-stats" (setDumpFlag Opt_D_dump_simpl_stats) - , Flag "ddump-bcos" (setDumpFlag Opt_D_dump_BCOs) - , Flag "dsource-stats" (setDumpFlag Opt_D_source_stats) - , Flag "dverbose-core2core" (NoArg (do { setVerbosity (Just 2) - ; setVerboseCore2Core })) - , Flag "dverbose-stg2stg" (setDumpFlag Opt_D_verbose_stg2stg) - , Flag "ddump-hi" (setDumpFlag Opt_D_dump_hi) - , Flag "ddump-minimal-imports" (setDumpFlag Opt_D_dump_minimal_imports) - , Flag "ddump-vect" (setDumpFlag Opt_D_dump_vect) - , Flag "ddump-hpc" (setDumpFlag Opt_D_dump_hpc) - , Flag "ddump-mod-cycles" (setDumpFlag Opt_D_dump_mod_cycles) - , Flag "ddump-view-pattern-commoning" (setDumpFlag Opt_D_dump_view_pattern_commoning) - , Flag "ddump-to-file" (setDumpFlag Opt_DumpToFile) - , Flag "ddump-hi-diffs" (setDumpFlag Opt_D_dump_hi_diffs) - , Flag "ddump-rtti" (setDumpFlag Opt_D_dump_rtti) - , Flag "dcore-lint" (NoArg (setDynFlag Opt_DoCoreLinting)) - , Flag "dstg-lint" (NoArg (setDynFlag Opt_DoStgLinting)) - , Flag "dcmm-lint" (NoArg (setDynFlag Opt_DoCmmLinting)) - , Flag "dasm-lint" (NoArg (setDynFlag Opt_DoAsmLinting)) - , Flag "dshow-passes" (NoArg (do forceRecompile - setVerbosity (Just 2))) - , Flag "dfaststring-stats" (NoArg (setDynFlag Opt_D_faststring_stats)) + , flagA "dstg-stats" (NoArg (setDynFlag Opt_StgStats)) + + , flagA "ddump-cmm" (setDumpFlag Opt_D_dump_cmm) + , flagA "ddump-raw-cmm" (setDumpFlag Opt_D_dump_raw_cmm) + , flagA "ddump-cmmz" (setDumpFlag Opt_D_dump_cmmz) + , flagA "ddump-cmmz-pretty" (setDumpFlag Opt_D_dump_cmmz_pretty) + , flagA "ddump-cmmz-cbe" (setDumpFlag Opt_D_dump_cmmz_cbe) + , flagA "ddump-cmmz-spills" (setDumpFlag Opt_D_dump_cmmz_spills) + , flagA "ddump-cmmz-proc" (setDumpFlag Opt_D_dump_cmmz_proc) + , flagA "ddump-cmmz-rewrite" (setDumpFlag Opt_D_dump_cmmz_rewrite) + , flagA "ddump-cmmz-dead" (setDumpFlag Opt_D_dump_cmmz_dead) + , flagA "ddump-cmmz-stub" (setDumpFlag Opt_D_dump_cmmz_stub) + , flagA "ddump-cmmz-sp" (setDumpFlag Opt_D_dump_cmmz_sp) + , flagA "ddump-cmmz-procmap" (setDumpFlag Opt_D_dump_cmmz_procmap) + , flagA "ddump-cmmz-split" (setDumpFlag Opt_D_dump_cmmz_split) + , flagA "ddump-cmmz-lower" (setDumpFlag Opt_D_dump_cmmz_lower) + , flagA "ddump-cmmz-info" (setDumpFlag Opt_D_dump_cmmz_info) + , flagA "ddump-cmmz-cafs" (setDumpFlag Opt_D_dump_cmmz_cafs) + , flagA "ddump-core-stats" (setDumpFlag Opt_D_dump_core_stats) + , flagA "ddump-cps-cmm" (setDumpFlag Opt_D_dump_cps_cmm) + , flagA "ddump-cvt-cmm" (setDumpFlag Opt_D_dump_cvt_cmm) + , flagA "ddump-asm" (setDumpFlag Opt_D_dump_asm) + , flagA "ddump-asm-native" (setDumpFlag Opt_D_dump_asm_native) + , flagA "ddump-asm-liveness" (setDumpFlag Opt_D_dump_asm_liveness) + , flagA "ddump-asm-coalesce" (setDumpFlag Opt_D_dump_asm_coalesce) + , flagA "ddump-asm-regalloc" (setDumpFlag Opt_D_dump_asm_regalloc) + , flagA "ddump-asm-conflicts" (setDumpFlag Opt_D_dump_asm_conflicts) + , flagA "ddump-asm-regalloc-stages" (setDumpFlag Opt_D_dump_asm_regalloc_stages) + , flagA "ddump-asm-stats" (setDumpFlag Opt_D_dump_asm_stats) + , flagA "ddump-asm-expanded" (setDumpFlag Opt_D_dump_asm_expanded) + , flagA "ddump-llvm" (NoArg (do { setObjTarget HscLlvm + ; setDumpFlag' Opt_D_dump_llvm})) + , flagA "ddump-cpranal" (setDumpFlag Opt_D_dump_cpranal) + , flagA "ddump-deriv" (setDumpFlag Opt_D_dump_deriv) + , flagA "ddump-ds" (setDumpFlag Opt_D_dump_ds) + , flagA "ddump-flatC" (setDumpFlag Opt_D_dump_flatC) + , flagA "ddump-foreign" (setDumpFlag Opt_D_dump_foreign) + , flagA "ddump-inlinings" (setDumpFlag Opt_D_dump_inlinings) + , flagA "ddump-rule-firings" (setDumpFlag Opt_D_dump_rule_firings) + , flagA "ddump-rule-rewrites" (setDumpFlag Opt_D_dump_rule_rewrites) + , flagA "ddump-occur-anal" (setDumpFlag Opt_D_dump_occur_anal) + , flagA "ddump-parsed" (setDumpFlag Opt_D_dump_parsed) + , flagA "ddump-rn" (setDumpFlag Opt_D_dump_rn) + , flagA "ddump-core-pipeline" (setDumpFlag Opt_D_dump_core_pipeline) + , flagA "ddump-simpl" (setDumpFlag Opt_D_dump_simpl) + , flagA "ddump-simpl-iterations" (setDumpFlag Opt_D_dump_simpl_iterations) + , flagA "ddump-simpl-phases" (OptPrefix setDumpSimplPhases) + , flagA "ddump-spec" (setDumpFlag Opt_D_dump_spec) + , flagA "ddump-prep" (setDumpFlag Opt_D_dump_prep) + , flagA "ddump-stg" (setDumpFlag Opt_D_dump_stg) + , flagA "ddump-stranal" (setDumpFlag Opt_D_dump_stranal) + , flagA "ddump-tc" (setDumpFlag Opt_D_dump_tc) + , flagA "ddump-types" (setDumpFlag Opt_D_dump_types) + , flagA "ddump-rules" (setDumpFlag Opt_D_dump_rules) + , flagA "ddump-cse" (setDumpFlag Opt_D_dump_cse) + , flagA "ddump-worker-wrapper" (setDumpFlag Opt_D_dump_worker_wrapper) + , flagA "ddump-rn-trace" (setDumpFlag Opt_D_dump_rn_trace) + , flagA "ddump-if-trace" (setDumpFlag Opt_D_dump_if_trace) + , flagA "ddump-cs-trace" (setDumpFlag Opt_D_dump_cs_trace) + , flagA "ddump-tc-trace" (setDumpFlag Opt_D_dump_tc_trace) + , flagA "ddump-vt-trace" (setDumpFlag Opt_D_dump_vt_trace) + , flagA "ddump-splices" (setDumpFlag Opt_D_dump_splices) + , flagA "ddump-rn-stats" (setDumpFlag Opt_D_dump_rn_stats) + , flagA "ddump-opt-cmm" (setDumpFlag Opt_D_dump_opt_cmm) + , flagA "ddump-simpl-stats" (setDumpFlag Opt_D_dump_simpl_stats) + , flagA "ddump-bcos" (setDumpFlag Opt_D_dump_BCOs) + , flagA "dsource-stats" (setDumpFlag Opt_D_source_stats) + , flagA "dverbose-core2core" (NoArg (do { setVerbosity (Just 2) + ; setVerboseCore2Core })) + , flagA "dverbose-stg2stg" (setDumpFlag Opt_D_verbose_stg2stg) + , flagA "ddump-hi" (setDumpFlag Opt_D_dump_hi) + , flagA "ddump-minimal-imports" (setDumpFlag Opt_D_dump_minimal_imports) + , flagA "ddump-vect" (setDumpFlag Opt_D_dump_vect) + , flagA "ddump-hpc" (setDumpFlag Opt_D_dump_hpc) + , flagA "ddump-mod-cycles" (setDumpFlag Opt_D_dump_mod_cycles) + , flagA "ddump-view-pattern-commoning" (setDumpFlag Opt_D_dump_view_pattern_commoning) + , flagA "ddump-to-file" (setDumpFlag Opt_DumpToFile) + , flagA "ddump-hi-diffs" (setDumpFlag Opt_D_dump_hi_diffs) + , flagA "ddump-rtti" (setDumpFlag Opt_D_dump_rtti) + , flagA "dcore-lint" (NoArg (setDynFlag Opt_DoCoreLinting)) + , flagA "dstg-lint" (NoArg (setDynFlag Opt_DoStgLinting)) + , flagA "dcmm-lint" (NoArg (setDynFlag Opt_DoCmmLinting)) + , flagA "dasm-lint" (NoArg (setDynFlag Opt_DoAsmLinting)) + , flagA "dshow-passes" (NoArg (do forceRecompile + setVerbosity (Just 2))) + , flagA "dfaststring-stats" (NoArg (setDynFlag Opt_D_faststring_stats)) ------ Machine dependant (-m<blah>) stuff --------------------------- - , Flag "monly-2-regs" (NoArg (addWarn "The -monly-2-regs flag does nothing; it will be removed in a future GHC release")) - , Flag "monly-3-regs" (NoArg (addWarn "The -monly-3-regs flag does nothing; it will be removed in a future GHC release")) - , Flag "monly-4-regs" (NoArg (addWarn "The -monly-4-regs flag does nothing; it will be removed in a future GHC release")) - , Flag "msse2" (NoArg (setDynFlag Opt_SSE2)) + , flagA "monly-2-regs" (NoArg (addWarn "The -monly-2-regs flag does nothing; it will be removed in a future GHC release")) + , flagA "monly-3-regs" (NoArg (addWarn "The -monly-3-regs flag does nothing; it will be removed in a future GHC release")) + , flagA "monly-4-regs" (NoArg (addWarn "The -monly-4-regs flag does nothing; it will be removed in a future GHC release")) + , flagA "msse2" (NoArg (setDynFlag Opt_SSE2)) ------ Warning opts ------------------------------------------------- - , Flag "W" (NoArg (mapM_ setDynFlag minusWOpts)) - , Flag "Werror" (NoArg (setDynFlag Opt_WarnIsError)) - , Flag "Wwarn" (NoArg (unSetDynFlag Opt_WarnIsError)) - , Flag "Wall" (NoArg (mapM_ setDynFlag minusWallOpts)) - , Flag "Wnot" (NoArg (do { mapM_ unSetDynFlag minusWallOpts + , flagA "W" (NoArg (mapM_ setDynFlag minusWOpts)) + , flagA "Werror" (NoArg (setDynFlag Opt_WarnIsError)) + , flagA "Wwarn" (NoArg (unSetDynFlag Opt_WarnIsError)) + , flagA "Wall" (NoArg (mapM_ setDynFlag minusWallOpts)) + , flagA "Wnot" (NoArg (do { mapM_ unSetDynFlag minusWallOpts ; deprecate "Use -w instead" })) - , Flag "w" (NoArg (mapM_ unSetDynFlag minuswRemovesOpts)) + , flagA "w" (NoArg (mapM_ unSetDynFlag minuswRemovesOpts)) ------ Plugin flags ------------------------------------------------ - , Flag "fplugin" (hasArg addPluginModuleName) - , Flag "fplugin-opt" (hasArg addPluginModuleNameOption) + , flagA "fplugin" (hasArg addPluginModuleName) + , flagA "fplugin-opt" (hasArg addPluginModuleNameOption) ------ Optimisation flags ------------------------------------------ - , Flag "O" (noArgM (setOptLevel 1)) - , Flag "Onot" (noArgM (\dflags -> do deprecate "Use -O0 instead" - setOptLevel 0 dflags)) - , Flag "Odph" (noArgM setDPHOpt) - , Flag "O" (optIntSuffixM (\mb_n -> setOptLevel (mb_n `orElse` 1))) + , flagA "O" (noArgM (setOptLevel 1)) + , flagA "Onot" (noArgM (\dflags -> do deprecate "Use -O0 instead" + setOptLevel 0 dflags)) + , flagA "Odph" (noArgM setDPHOpt) + , flagA "O" (optIntSuffixM (\mb_n -> setOptLevel (mb_n `orElse` 1))) -- If the number is missing, use 1 - , Flag "fsimplifier-phases" (intSuffix (\n d -> d{ simplPhases = n })) - , Flag "fmax-simplifier-iterations" (intSuffix (\n d -> d{ maxSimplIterations = n })) - , Flag "fspec-constr-threshold" (intSuffix (\n d -> d{ specConstrThreshold = Just n })) - , Flag "fno-spec-constr-threshold" (noArg (\d -> d{ specConstrThreshold = Nothing })) - , Flag "fspec-constr-count" (intSuffix (\n d -> d{ specConstrCount = Just n })) - , Flag "fno-spec-constr-count" (noArg (\d -> d{ specConstrCount = Nothing })) - , Flag "fliberate-case-threshold" (intSuffix (\n d -> d{ liberateCaseThreshold = Just n })) - , Flag "fno-liberate-case-threshold" (noArg (\d -> d{ liberateCaseThreshold = Nothing })) - , Flag "frule-check" (SepArg (\s -> upd (\d -> d{ ruleCheck = Just s }))) - , Flag "fcontext-stack" (intSuffix (\n d -> d{ ctxtStkDepth = n })) - , Flag "fstrictness-before" (intSuffix (\n d -> d{ strictnessBefore = n : strictnessBefore d })) - , Flag "ffloat-lam-args" (intSuffix (\n d -> d{ floatLamArgs = Just n })) - , Flag "ffloat-all-lams" (noArg (\d -> d{ floatLamArgs = Nothing })) + , flagA "fsimplifier-phases" (intSuffix (\n d -> d{ simplPhases = n })) + , flagA "fmax-simplifier-iterations" (intSuffix (\n d -> d{ maxSimplIterations = n })) + , flagA "fspec-constr-threshold" (intSuffix (\n d -> d{ specConstrThreshold = Just n })) + , flagA "fno-spec-constr-threshold" (noArg (\d -> d{ specConstrThreshold = Nothing })) + , flagA "fspec-constr-count" (intSuffix (\n d -> d{ specConstrCount = Just n })) + , flagA "fno-spec-constr-count" (noArg (\d -> d{ specConstrCount = Nothing })) + , flagA "fliberate-case-threshold" (intSuffix (\n d -> d{ liberateCaseThreshold = Just n })) + , flagA "fno-liberate-case-threshold" (noArg (\d -> d{ liberateCaseThreshold = Nothing })) + , flagA "frule-check" (SepArg (\s -> upd (\d -> d{ ruleCheck = Just s }))) + , flagA "fcontext-stack" (intSuffix (\n d -> d{ ctxtStkDepth = n })) + , flagA "fstrictness-before" (intSuffix (\n d -> d{ strictnessBefore = n : strictnessBefore d })) + , flagA "ffloat-lam-args" (intSuffix (\n d -> d{ floatLamArgs = Just n })) + , flagA "ffloat-all-lams" (noArg (\d -> d{ floatLamArgs = Nothing })) ------ Profiling ---------------------------------------------------- -- XXX Should the -f* flags be deprecated? -- They don't seem to be documented - , Flag "fauto-sccs-on-all-toplevs" (NoArg (setDynFlag Opt_AutoSccsOnAllToplevs)) - , Flag "auto-all" (NoArg (setDynFlag Opt_AutoSccsOnAllToplevs)) - , Flag "no-auto-all" (NoArg (unSetDynFlag Opt_AutoSccsOnAllToplevs)) - , Flag "fauto-sccs-on-exported-toplevs" (NoArg (setDynFlag Opt_AutoSccsOnExportedToplevs)) - , Flag "auto" (NoArg (setDynFlag Opt_AutoSccsOnExportedToplevs)) - , Flag "no-auto" (NoArg (unSetDynFlag Opt_AutoSccsOnExportedToplevs)) - , Flag "fauto-sccs-on-individual-cafs" (NoArg (setDynFlag Opt_AutoSccsOnIndividualCafs)) - , Flag "caf-all" (NoArg (setDynFlag Opt_AutoSccsOnIndividualCafs)) - , Flag "no-caf-all" (NoArg (unSetDynFlag Opt_AutoSccsOnIndividualCafs)) + , flagA "fauto-sccs-on-all-toplevs" (NoArg (setDynFlag Opt_AutoSccsOnAllToplevs)) + , flagA "auto-all" (NoArg (setDynFlag Opt_AutoSccsOnAllToplevs)) + , flagA "no-auto-all" (NoArg (unSetDynFlag Opt_AutoSccsOnAllToplevs)) + , flagA "fauto-sccs-on-exported-toplevs" (NoArg (setDynFlag Opt_AutoSccsOnExportedToplevs)) + , flagA "auto" (NoArg (setDynFlag Opt_AutoSccsOnExportedToplevs)) + , flagA "no-auto" (NoArg (unSetDynFlag Opt_AutoSccsOnExportedToplevs)) + , flagA "fauto-sccs-on-individual-cafs" (NoArg (setDynFlag Opt_AutoSccsOnIndividualCafs)) + , flagA "caf-all" (NoArg (setDynFlag Opt_AutoSccsOnIndividualCafs)) + , flagA "no-caf-all" (NoArg (unSetDynFlag Opt_AutoSccsOnIndividualCafs)) ------ DPH flags ---------------------------------------------------- - , Flag "fdph-seq" (NoArg (setDPHBackend DPHSeq)) - , Flag "fdph-par" (NoArg (setDPHBackend DPHPar)) - , Flag "fdph-this" (NoArg (setDPHBackend DPHThis)) - , Flag "fdph-none" (NoArg (setDPHBackend DPHNone)) + , flagA "fdph-seq" (NoArg (setDPHBackend DPHSeq)) + , flagA "fdph-par" (NoArg (setDPHBackend DPHPar)) + , flagA "fdph-this" (NoArg (setDPHBackend DPHThis)) + , flagA "fdph-none" (NoArg (setDPHBackend DPHNone)) ------ Compiler flags ----------------------------------------------- - , Flag "fasm" (NoArg (setObjTarget HscAsm)) - , Flag "fvia-c" (NoArg + , flagA "fasm" (NoArg (setObjTarget HscAsm)) + , flagA "fvia-c" (NoArg (addWarn "The -fvia-c flag does nothing; it will be removed in a future GHC release")) - , Flag "fvia-C" (NoArg + , flagA "fvia-C" (NoArg (addWarn "The -fvia-C flag does nothing; it will be removed in a future GHC release")) - , Flag "fllvm" (NoArg (setObjTarget HscLlvm)) - - , Flag "fno-code" (NoArg (do upd $ \d -> d{ ghcLink=NoLink } - setTarget HscNothing)) - , Flag "fbyte-code" (NoArg (setTarget HscInterpreted)) - , Flag "fobject-code" (NoArg (setTarget defaultHscTarget)) - , Flag "fglasgow-exts" (NoArg (enableGlasgowExts >> deprecate "Use individual extensions instead")) - , Flag "fno-glasgow-exts" (NoArg (disableGlasgowExts >> deprecate "Use individual extensions instead")) + , flagA "fllvm" (NoArg (setObjTarget HscLlvm)) + + , flagA "fno-code" (NoArg (do { upd $ \d -> d{ ghcLink=NoLink } + ; setTarget HscNothing })) + , flagA "fbyte-code" (NoArg (setTarget HscInterpreted)) + , flagA "fobject-code" (NoArg (setTarget defaultHscTarget)) + , flagA "fglasgow-exts" (NoArg (enableGlasgowExts >> deprecate "Use individual extensions instead")) + , flagA "fno-glasgow-exts" (NoArg (disableGlasgowExts >> deprecate "Use individual extensions instead")) ] ++ map (mkFlag turnOn "f" setDynFlag ) fFlags ++ map (mkFlag turnOff "fno-" unSetDynFlag) fFlags @@ -1548,16 +1662,16 @@ dynamic_flags = [ package_flags :: [Flag (CmdLineP DynFlags)] package_flags = [ ------- Packages ---------------------------------------------------- - Flag "package-conf" (HasArg extraPkgConf_) - , Flag "no-user-package-conf" (NoArg (unSetDynFlag Opt_ReadUserPackageConf)) - , Flag "package-name" (hasArg setPackageName) - , Flag "package-id" (HasArg exposePackageId) - , Flag "package" (HasArg exposePackage) - , Flag "hide-package" (HasArg hidePackage) - , Flag "hide-all-packages" (NoArg (setDynFlag Opt_HideAllPackages)) - , Flag "ignore-package" (HasArg ignorePackage) - , Flag "syslib" (HasArg (\s -> do { exposePackage s - ; deprecate "Use -package instead" })) + flagC "package-conf" (HasArg extraPkgConf_) + , flagC "no-user-package-conf" (NoArg (unSetDynFlag Opt_ReadUserPackageConf)) + , flagC "package-name" (hasArg setPackageName) + , flagC "package-id" (HasArg exposePackageId) + , flagC "package" (HasArg exposePackage) + , flagC "hide-package" (HasArg hidePackage) + , flagC "hide-all-packages" (NoArg (setDynFlag Opt_HideAllPackages)) + , flagC "ignore-package" (HasArg ignorePackage) + , flagC "syslib" (HasArg (\s -> do { exposePackage s + ; deprecate "Use -package instead" })) ] type TurnOnFlag = Bool -- True <=> we are turning the flag on @@ -1567,6 +1681,7 @@ turnOff :: TurnOnFlag; turnOff = False type FlagSpec flag = ( String -- Flag in string form + , FlagSafety , flag -- Flag in internal form , TurnOnFlag -> DynP ()) -- Extra action to run when the flag is found -- Typically, emit a warning or error @@ -1576,8 +1691,8 @@ mkFlag :: TurnOnFlag -- ^ True <=> it should be turned on -> (flag -> DynP ()) -- ^ What to do when the flag is found -> FlagSpec flag -- ^ Specification of this particular flag -> Flag (CmdLineP DynFlags) -mkFlag turn_on flagPrefix f (name, flag, extra_action) - = Flag (flagPrefix ++ name) (NoArg (f flag >> extra_action turn_on)) +mkFlag turn_on flagPrefix f (name, fsafe, flag, extra_action) + = Flag (flagPrefix ++ name) fsafe (NoArg (f flag >> extra_action turn_on)) deprecatedForExtension :: String -> TurnOnFlag -> DynP () deprecatedForExtension lang turn_on @@ -1598,135 +1713,135 @@ nop _ = return () -- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@ fFlags :: [FlagSpec DynFlag] fFlags = [ - ( "warn-dodgy-foreign-imports", Opt_WarnDodgyForeignImports, nop ), - ( "warn-dodgy-exports", Opt_WarnDodgyExports, nop ), - ( "warn-dodgy-imports", Opt_WarnDodgyImports, nop ), - ( "warn-duplicate-exports", Opt_WarnDuplicateExports, nop ), - ( "warn-hi-shadowing", Opt_WarnHiShadows, nop ), - ( "warn-implicit-prelude", Opt_WarnImplicitPrelude, nop ), - ( "warn-incomplete-patterns", Opt_WarnIncompletePatterns, nop ), - ( "warn-incomplete-uni-patterns", Opt_WarnIncompleteUniPatterns, nop ), - ( "warn-incomplete-record-updates", Opt_WarnIncompletePatternsRecUpd, nop ), - ( "warn-missing-fields", Opt_WarnMissingFields, nop ), - ( "warn-missing-import-lists", Opt_WarnMissingImportList, nop ), - ( "warn-missing-methods", Opt_WarnMissingMethods, nop ), - ( "warn-missing-signatures", Opt_WarnMissingSigs, nop ), - ( "warn-missing-local-sigs", Opt_WarnMissingLocalSigs, nop ), - ( "warn-name-shadowing", Opt_WarnNameShadowing, nop ), - ( "warn-overlapping-patterns", Opt_WarnOverlappingPatterns, nop ), - ( "warn-type-defaults", Opt_WarnTypeDefaults, nop ), - ( "warn-monomorphism-restriction", Opt_WarnMonomorphism, nop ), - ( "warn-unused-binds", Opt_WarnUnusedBinds, nop ), - ( "warn-unused-imports", Opt_WarnUnusedImports, nop ), - ( "warn-unused-matches", Opt_WarnUnusedMatches, nop ), - ( "warn-warnings-deprecations", Opt_WarnWarningsDeprecations, nop ), - ( "warn-deprecations", Opt_WarnWarningsDeprecations, nop ), - ( "warn-deprecated-flags", Opt_WarnDeprecatedFlags, nop ), - ( "warn-orphans", Opt_WarnOrphans, nop ), - ( "warn-identities", Opt_WarnIdentities, nop ), - ( "warn-auto-orphans", Opt_WarnAutoOrphans, nop ), - ( "warn-tabs", Opt_WarnTabs, nop ), - ( "warn-unrecognised-pragmas", Opt_WarnUnrecognisedPragmas, nop ), - ( "warn-lazy-unlifted-bindings", Opt_WarnLazyUnliftedBindings, nop), - ( "warn-unused-do-bind", Opt_WarnUnusedDoBind, nop ), - ( "warn-wrong-do-bind", Opt_WarnWrongDoBind, nop ), - ( "warn-alternative-layout-rule-transitional", Opt_WarnAlternativeLayoutRuleTransitional, nop ), - ( "print-explicit-foralls", Opt_PrintExplicitForalls, nop ), - ( "strictness", Opt_Strictness, nop ), - ( "specialise", Opt_Specialise, nop ), - ( "float-in", Opt_FloatIn, nop ), - ( "static-argument-transformation", Opt_StaticArgumentTransformation, nop ), - ( "full-laziness", Opt_FullLaziness, nop ), - ( "liberate-case", Opt_LiberateCase, nop ), - ( "spec-constr", Opt_SpecConstr, nop ), - ( "cse", Opt_CSE, nop ), - ( "ignore-interface-pragmas", Opt_IgnoreInterfacePragmas, nop ), - ( "omit-interface-pragmas", Opt_OmitInterfacePragmas, nop ), - ( "expose-all-unfoldings", Opt_ExposeAllUnfoldings, nop ), - ( "do-lambda-eta-expansion", Opt_DoLambdaEtaExpansion, nop ), - ( "ignore-asserts", Opt_IgnoreAsserts, nop ), - ( "do-eta-reduction", Opt_DoEtaReduction, nop ), - ( "case-merge", Opt_CaseMerge, nop ), - ( "unbox-strict-fields", Opt_UnboxStrictFields, nop ), - ( "method-sharing", Opt_MethodSharing, + ( "warn-dodgy-foreign-imports", AlwaysAllowed, Opt_WarnDodgyForeignImports, nop ), + ( "warn-dodgy-exports", AlwaysAllowed, Opt_WarnDodgyExports, nop ), + ( "warn-dodgy-imports", AlwaysAllowed, Opt_WarnDodgyImports, nop ), + ( "warn-duplicate-exports", AlwaysAllowed, Opt_WarnDuplicateExports, nop ), + ( "warn-hi-shadowing", AlwaysAllowed, Opt_WarnHiShadows, nop ), + ( "warn-implicit-prelude", AlwaysAllowed, Opt_WarnImplicitPrelude, nop ), + ( "warn-incomplete-patterns", AlwaysAllowed, Opt_WarnIncompletePatterns, nop ), + ( "warn-incomplete-uni-patterns", AlwaysAllowed, Opt_WarnIncompleteUniPatterns, nop ), + ( "warn-incomplete-record-updates", AlwaysAllowed, Opt_WarnIncompletePatternsRecUpd, nop ), + ( "warn-missing-fields", AlwaysAllowed, Opt_WarnMissingFields, nop ), + ( "warn-missing-import-lists", AlwaysAllowed, Opt_WarnMissingImportList, nop ), + ( "warn-missing-methods", AlwaysAllowed, Opt_WarnMissingMethods, nop ), + ( "warn-missing-signatures", AlwaysAllowed, Opt_WarnMissingSigs, nop ), + ( "warn-missing-local-sigs", AlwaysAllowed, Opt_WarnMissingLocalSigs, nop ), + ( "warn-name-shadowing", AlwaysAllowed, Opt_WarnNameShadowing, nop ), + ( "warn-overlapping-patterns", AlwaysAllowed, Opt_WarnOverlappingPatterns, nop ), + ( "warn-type-defaults", AlwaysAllowed, Opt_WarnTypeDefaults, nop ), + ( "warn-monomorphism-restriction", AlwaysAllowed, Opt_WarnMonomorphism, nop ), + ( "warn-unused-binds", AlwaysAllowed, Opt_WarnUnusedBinds, nop ), + ( "warn-unused-imports", AlwaysAllowed, Opt_WarnUnusedImports, nop ), + ( "warn-unused-matches", AlwaysAllowed, Opt_WarnUnusedMatches, nop ), + ( "warn-warnings-deprecations", AlwaysAllowed, Opt_WarnWarningsDeprecations, nop ), + ( "warn-deprecations", AlwaysAllowed, Opt_WarnWarningsDeprecations, nop ), + ( "warn-deprecated-flags", AlwaysAllowed, Opt_WarnDeprecatedFlags, nop ), + ( "warn-orphans", AlwaysAllowed, Opt_WarnOrphans, nop ), + ( "warn-identities", AlwaysAllowed, Opt_WarnIdentities, nop ), + ( "warn-auto-orphans", AlwaysAllowed, Opt_WarnAutoOrphans, nop ), + ( "warn-tabs", AlwaysAllowed, Opt_WarnTabs, nop ), + ( "warn-unrecognised-pragmas", AlwaysAllowed, Opt_WarnUnrecognisedPragmas, nop ), + ( "warn-lazy-unlifted-bindings", AlwaysAllowed, Opt_WarnLazyUnliftedBindings, nop), + ( "warn-unused-do-bind", AlwaysAllowed, Opt_WarnUnusedDoBind, nop ), + ( "warn-wrong-do-bind", AlwaysAllowed, Opt_WarnWrongDoBind, nop ), + ( "warn-alternative-layout-rule-transitional", AlwaysAllowed, Opt_WarnAlternativeLayoutRuleTransitional, nop ), + ( "print-explicit-foralls", AlwaysAllowed, Opt_PrintExplicitForalls, nop ), + ( "strictness", AlwaysAllowed, Opt_Strictness, nop ), + ( "specialise", AlwaysAllowed, Opt_Specialise, nop ), + ( "float-in", AlwaysAllowed, Opt_FloatIn, nop ), + ( "static-argument-transformation", AlwaysAllowed, Opt_StaticArgumentTransformation, nop ), + ( "full-laziness", AlwaysAllowed, Opt_FullLaziness, nop ), + ( "liberate-case", AlwaysAllowed, Opt_LiberateCase, nop ), + ( "spec-constr", AlwaysAllowed, Opt_SpecConstr, nop ), + ( "cse", AlwaysAllowed, Opt_CSE, nop ), + ( "ignore-interface-pragmas", AlwaysAllowed, Opt_IgnoreInterfacePragmas, nop ), + ( "omit-interface-pragmas", AlwaysAllowed, Opt_OmitInterfacePragmas, nop ), + ( "expose-all-unfoldings", AlwaysAllowed, Opt_ExposeAllUnfoldings, nop ), + ( "do-lambda-eta-expansion", AlwaysAllowed, Opt_DoLambdaEtaExpansion, nop ), + ( "ignore-asserts", AlwaysAllowed, Opt_IgnoreAsserts, nop ), + ( "do-eta-reduction", AlwaysAllowed, Opt_DoEtaReduction, nop ), + ( "case-merge", AlwaysAllowed, Opt_CaseMerge, nop ), + ( "unbox-strict-fields", AlwaysAllowed, Opt_UnboxStrictFields, nop ), + ( "method-sharing", AlwaysAllowed, Opt_MethodSharing, \_ -> deprecate "doesn't do anything any more"), -- Remove altogether in GHC 7.2 - ( "dicts-cheap", Opt_DictsCheap, nop ), - ( "excess-precision", Opt_ExcessPrecision, nop ), - ( "eager-blackholing", Opt_EagerBlackHoling, nop ), - ( "print-bind-result", Opt_PrintBindResult, nop ), - ( "force-recomp", Opt_ForceRecomp, nop ), - ( "hpc-no-auto", Opt_Hpc_No_Auto, nop ), - ( "rewrite-rules", Opt_EnableRewriteRules, useInstead "enable-rewrite-rules" ), - ( "enable-rewrite-rules", Opt_EnableRewriteRules, nop ), - ( "break-on-exception", Opt_BreakOnException, nop ), - ( "break-on-error", Opt_BreakOnError, nop ), - ( "print-evld-with-show", Opt_PrintEvldWithShow, nop ), - ( "print-bind-contents", Opt_PrintBindContents, nop ), - ( "run-cps", Opt_RunCPS, nop ), - ( "run-cpsz", Opt_RunCPSZ, nop ), - ( "new-codegen", Opt_TryNewCodeGen, nop ), - ( "convert-to-zipper-and-back", Opt_ConvertToZipCfgAndBack, nop ), - ( "vectorise", Opt_Vectorise, nop ), - ( "regs-graph", Opt_RegsGraph, nop ), - ( "regs-iterative", Opt_RegsIterative, nop ), - ( "gen-manifest", Opt_GenManifest, nop ), - ( "embed-manifest", Opt_EmbedManifest, nop ), - ( "ext-core", Opt_EmitExternalCore, nop ), - ( "shared-implib", Opt_SharedImplib, nop ), - ( "ghci-sandbox", Opt_GhciSandbox, nop ), - ( "helpful-errors", Opt_HelpfulErrors, nop ), - ( "building-cabal-package", Opt_BuildingCabalPackage, nop ), - ( "implicit-import-qualified", Opt_ImplicitImportQualified, nop ) + ( "dicts-cheap", AlwaysAllowed, Opt_DictsCheap, nop ), + ( "excess-precision", AlwaysAllowed, Opt_ExcessPrecision, nop ), + ( "eager-blackholing", AlwaysAllowed, Opt_EagerBlackHoling, nop ), + ( "print-bind-result", AlwaysAllowed, Opt_PrintBindResult, nop ), + ( "force-recomp", AlwaysAllowed, Opt_ForceRecomp, nop ), + ( "hpc-no-auto", AlwaysAllowed, Opt_Hpc_No_Auto, nop ), + ( "rewrite-rules", AlwaysAllowed, Opt_EnableRewriteRules, useInstead "enable-rewrite-rules" ), + ( "enable-rewrite-rules", AlwaysAllowed, Opt_EnableRewriteRules, nop ), + ( "break-on-exception", AlwaysAllowed, Opt_BreakOnException, nop ), + ( "break-on-error", AlwaysAllowed, Opt_BreakOnError, nop ), + ( "print-evld-with-show", AlwaysAllowed, Opt_PrintEvldWithShow, nop ), + ( "print-bind-contents", AlwaysAllowed, Opt_PrintBindContents, nop ), + ( "run-cps", AlwaysAllowed, Opt_RunCPS, nop ), + ( "run-cpsz", AlwaysAllowed, Opt_RunCPSZ, nop ), + ( "new-codegen", AlwaysAllowed, Opt_TryNewCodeGen, nop ), + ( "convert-to-zipper-and-back", AlwaysAllowed, Opt_ConvertToZipCfgAndBack, nop ), + ( "vectorise", AlwaysAllowed, Opt_Vectorise, nop ), + ( "regs-graph", AlwaysAllowed, Opt_RegsGraph, nop ), + ( "regs-iterative", AlwaysAllowed, Opt_RegsIterative, nop ), + ( "gen-manifest", AlwaysAllowed, Opt_GenManifest, nop ), + ( "embed-manifest", AlwaysAllowed, Opt_EmbedManifest, nop ), + ( "ext-core", AlwaysAllowed, Opt_EmitExternalCore, nop ), + ( "shared-implib", AlwaysAllowed, Opt_SharedImplib, nop ), + ( "ghci-sandbox", AlwaysAllowed, Opt_GhciSandbox, nop ), + ( "helpful-errors", AlwaysAllowed, Opt_HelpfulErrors, nop ), + ( "building-cabal-package", AlwaysAllowed, Opt_BuildingCabalPackage, nop ), + ( "implicit-import-qualified", AlwaysAllowed, Opt_ImplicitImportQualified, nop ) ] -- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@ fLangFlags :: [FlagSpec ExtensionFlag] fLangFlags = [ - ( "th", Opt_TemplateHaskell, + ( "th", CmdLineOnly, Opt_TemplateHaskell, deprecatedForExtension "TemplateHaskell" >> checkTemplateHaskellOk ), - ( "fi", Opt_ForeignFunctionInterface, + ( "fi", RestrictedFunction, Opt_ForeignFunctionInterface, deprecatedForExtension "ForeignFunctionInterface" ), - ( "ffi", Opt_ForeignFunctionInterface, + ( "ffi", RestrictedFunction, Opt_ForeignFunctionInterface, deprecatedForExtension "ForeignFunctionInterface" ), - ( "arrows", Opt_Arrows, + ( "arrows", AlwaysAllowed, Opt_Arrows, deprecatedForExtension "Arrows" ), - ( "generics", Opt_Generics, + ( "generics", AlwaysAllowed, Opt_Generics, deprecatedForExtension "Generics" ), - ( "implicit-prelude", Opt_ImplicitPrelude, + ( "implicit-prelude", AlwaysAllowed, Opt_ImplicitPrelude, deprecatedForExtension "ImplicitPrelude" ), - ( "bang-patterns", Opt_BangPatterns, + ( "bang-patterns", AlwaysAllowed, Opt_BangPatterns, deprecatedForExtension "BangPatterns" ), - ( "monomorphism-restriction", Opt_MonomorphismRestriction, + ( "monomorphism-restriction", AlwaysAllowed, Opt_MonomorphismRestriction, deprecatedForExtension "MonomorphismRestriction" ), - ( "mono-pat-binds", Opt_MonoPatBinds, + ( "mono-pat-binds", AlwaysAllowed, Opt_MonoPatBinds, deprecatedForExtension "MonoPatBinds" ), - ( "extended-default-rules", Opt_ExtendedDefaultRules, + ( "extended-default-rules", AlwaysAllowed, Opt_ExtendedDefaultRules, deprecatedForExtension "ExtendedDefaultRules" ), - ( "implicit-params", Opt_ImplicitParams, + ( "implicit-params", AlwaysAllowed, Opt_ImplicitParams, deprecatedForExtension "ImplicitParams" ), - ( "scoped-type-variables", Opt_ScopedTypeVariables, + ( "scoped-type-variables", AlwaysAllowed, Opt_ScopedTypeVariables, deprecatedForExtension "ScopedTypeVariables" ), - ( "parr", Opt_ParallelArrays, + ( "parr", AlwaysAllowed, Opt_ParallelArrays, deprecatedForExtension "ParallelArrays" ), - ( "PArr", Opt_ParallelArrays, + ( "PArr", AlwaysAllowed, Opt_ParallelArrays, deprecatedForExtension "ParallelArrays" ), - ( "allow-overlapping-instances", Opt_OverlappingInstances, + ( "allow-overlapping-instances", RestrictedFunction, Opt_OverlappingInstances, deprecatedForExtension "OverlappingInstances" ), - ( "allow-undecidable-instances", Opt_UndecidableInstances, + ( "allow-undecidable-instances", AlwaysAllowed, Opt_UndecidableInstances, deprecatedForExtension "UndecidableInstances" ), - ( "allow-incoherent-instances", Opt_IncoherentInstances, + ( "allow-incoherent-instances", AlwaysAllowed, Opt_IncoherentInstances, deprecatedForExtension "IncoherentInstances" ) ] supportedLanguages :: [String] -supportedLanguages = [ name | (name, _, _) <- languageFlags ] +supportedLanguages = [ name | (name, _, _, _) <- languageFlags ] supportedLanguageOverlays :: [String] -supportedLanguageOverlays = [ name | (name, _, _) <- safeHaskellFlags ] +supportedLanguageOverlays = [ name | (name, _, _, _) <- safeHaskellFlags ] supportedExtensions :: [String] -supportedExtensions = [ name' | (name, _, _) <- xFlags, name' <- [name, "No" ++ name] ] +supportedExtensions = [ name' | (name, _, _, _) <- xFlags, name' <- [name, "No" ++ name] ] supportedLanguagesAndExtensions :: [String] supportedLanguagesAndExtensions = @@ -1735,105 +1850,107 @@ supportedLanguagesAndExtensions = -- | These -X<blah> flags cannot be reversed with -XNo<blah> languageFlags :: [FlagSpec Language] languageFlags = [ - ( "Haskell98", Haskell98, nop ), - ( "Haskell2010", Haskell2010, nop ) + ( "Haskell98", AlwaysAllowed, Haskell98, nop ), + ( "Haskell2010", AlwaysAllowed, Haskell2010, nop ) ] -- | These -X<blah> flags cannot be reversed with -XNo<blah> -- They are used to place hard requirements on what GHC Haskell language -- features can be used. safeHaskellFlags :: [FlagSpec SafeHaskellMode] -safeHaskellFlags = map mkF [Sf_SafeImports, Sf_SafeLanguage, Sf_Trustworthy, Sf_Safe] - where mkF flag = (show flag, flag, nop) +safeHaskellFlags = [mkF Sf_SafeImports, mkF' Sf_SafeLanguage, + mkF Sf_Trustworthy, mkF' Sf_Safe] + where mkF flag = (show flag, AlwaysAllowed, flag, nop) + mkF' flag = (show flag, EnablesSafe, flag, nop) -- | These -X<blah> flags can all be reversed with -XNo<blah> xFlags :: [FlagSpec ExtensionFlag] xFlags = [ - ( "CPP", Opt_Cpp, nop ), - ( "PostfixOperators", Opt_PostfixOperators, nop ), - ( "TupleSections", Opt_TupleSections, nop ), - ( "PatternGuards", Opt_PatternGuards, nop ), - ( "UnicodeSyntax", Opt_UnicodeSyntax, nop ), - ( "MagicHash", Opt_MagicHash, nop ), - ( "PolymorphicComponents", Opt_PolymorphicComponents, nop ), - ( "ExistentialQuantification", Opt_ExistentialQuantification, nop ), - ( "KindSignatures", Opt_KindSignatures, nop ), - ( "EmptyDataDecls", Opt_EmptyDataDecls, nop ), - ( "ParallelListComp", Opt_ParallelListComp, nop ), - ( "TransformListComp", Opt_TransformListComp, nop ), - ( "MonadComprehensions", Opt_MonadComprehensions, nop), - ( "ForeignFunctionInterface", Opt_ForeignFunctionInterface, nop ), - ( "UnliftedFFITypes", Opt_UnliftedFFITypes, nop ), - ( "GHCForeignImportPrim", Opt_GHCForeignImportPrim, nop ), - ( "LiberalTypeSynonyms", Opt_LiberalTypeSynonyms, nop ), - ( "Rank2Types", Opt_Rank2Types, nop ), - ( "RankNTypes", Opt_RankNTypes, nop ), - ( "ImpredicativeTypes", Opt_ImpredicativeTypes, nop), - ( "TypeOperators", Opt_TypeOperators, nop ), - ( "RecursiveDo", Opt_RecursiveDo, -- Enables 'mdo' + ( "CPP", CmdLineOnly, Opt_Cpp, nop ), + ( "PostfixOperators", AlwaysAllowed, Opt_PostfixOperators, nop ), + ( "TupleSections", AlwaysAllowed, Opt_TupleSections, nop ), + ( "PatternGuards", AlwaysAllowed, Opt_PatternGuards, nop ), + ( "UnicodeSyntax", AlwaysAllowed, Opt_UnicodeSyntax, nop ), + ( "MagicHash", AlwaysAllowed, Opt_MagicHash, nop ), + ( "PolymorphicComponents", AlwaysAllowed, Opt_PolymorphicComponents, nop ), + ( "ExistentialQuantification", AlwaysAllowed, Opt_ExistentialQuantification, nop ), + ( "KindSignatures", AlwaysAllowed, Opt_KindSignatures, nop ), + ( "EmptyDataDecls", AlwaysAllowed, Opt_EmptyDataDecls, nop ), + ( "ParallelListComp", AlwaysAllowed, Opt_ParallelListComp, nop ), + ( "TransformListComp", AlwaysAllowed, Opt_TransformListComp, nop ), + ( "MonadComprehensions", AlwaysAllowed, Opt_MonadComprehensions, nop), + ( "ForeignFunctionInterface", RestrictedFunction, Opt_ForeignFunctionInterface, nop ), + ( "UnliftedFFITypes", AlwaysAllowed, Opt_UnliftedFFITypes, nop ), + ( "GHCForeignImportPrim", AlwaysAllowed, Opt_GHCForeignImportPrim, nop ), + ( "LiberalTypeSynonyms", AlwaysAllowed, Opt_LiberalTypeSynonyms, nop ), + ( "Rank2Types", AlwaysAllowed, Opt_Rank2Types, nop ), + ( "RankNTypes", AlwaysAllowed, Opt_RankNTypes, nop ), + ( "ImpredicativeTypes", AlwaysAllowed, Opt_ImpredicativeTypes, nop), + ( "TypeOperators", AlwaysAllowed, Opt_TypeOperators, nop ), + ( "RecursiveDo", AlwaysAllowed, Opt_RecursiveDo, -- Enables 'mdo' deprecatedForExtension "DoRec"), - ( "DoRec", Opt_DoRec, nop ), -- Enables 'rec' keyword - ( "Arrows", Opt_Arrows, nop ), - ( "ParallelArrays", Opt_ParallelArrays, nop ), - ( "TemplateHaskell", Opt_TemplateHaskell, checkTemplateHaskellOk ), - ( "QuasiQuotes", Opt_QuasiQuotes, nop ), - ( "Generics", Opt_Generics, + ( "DoRec", AlwaysAllowed, Opt_DoRec, nop ), -- Enables 'rec' keyword + ( "Arrows", AlwaysAllowed, Opt_Arrows, nop ), + ( "ParallelArrays", AlwaysAllowed, Opt_ParallelArrays, nop ), + ( "TemplateHaskell", NeverAllowed, Opt_TemplateHaskell, checkTemplateHaskellOk ), + ( "QuasiQuotes", AlwaysAllowed, Opt_QuasiQuotes, nop ), + ( "Generics", AlwaysAllowed, Opt_Generics, \ _ -> deprecate "it does nothing; look into -XDefaultSignatures and -XDeriveGeneric for generic programming support." ), - ( "ImplicitPrelude", Opt_ImplicitPrelude, nop ), - ( "RecordWildCards", Opt_RecordWildCards, nop ), - ( "NamedFieldPuns", Opt_RecordPuns, nop ), - ( "RecordPuns", Opt_RecordPuns, + ( "ImplicitPrelude", AlwaysAllowed, Opt_ImplicitPrelude, nop ), + ( "RecordWildCards", AlwaysAllowed, Opt_RecordWildCards, nop ), + ( "NamedFieldPuns", AlwaysAllowed, Opt_RecordPuns, nop ), + ( "RecordPuns", AlwaysAllowed, Opt_RecordPuns, deprecatedForExtension "NamedFieldPuns" ), - ( "DisambiguateRecordFields", Opt_DisambiguateRecordFields, nop ), - ( "OverloadedStrings", Opt_OverloadedStrings, nop ), - ( "GADTs", Opt_GADTs, nop ), - ( "GADTSyntax", Opt_GADTSyntax, nop ), - ( "ViewPatterns", Opt_ViewPatterns, nop ), - ( "TypeFamilies", Opt_TypeFamilies, nop ), - ( "BangPatterns", Opt_BangPatterns, nop ), - ( "MonomorphismRestriction", Opt_MonomorphismRestriction, nop ), - ( "NPlusKPatterns", Opt_NPlusKPatterns, nop ), - ( "DoAndIfThenElse", Opt_DoAndIfThenElse, nop ), - ( "RebindableSyntax", Opt_RebindableSyntax, nop ), - ( "MonoPatBinds", Opt_MonoPatBinds, nop ), - ( "ExplicitForAll", Opt_ExplicitForAll, nop ), - ( "AlternativeLayoutRule", Opt_AlternativeLayoutRule, nop ), - ( "AlternativeLayoutRuleTransitional",Opt_AlternativeLayoutRuleTransitional, nop ), - ( "DatatypeContexts", Opt_DatatypeContexts, + ( "DisambiguateRecordFields", AlwaysAllowed, Opt_DisambiguateRecordFields, nop ), + ( "OverloadedStrings", AlwaysAllowed, Opt_OverloadedStrings, nop ), + ( "GADTs", AlwaysAllowed, Opt_GADTs, nop ), + ( "GADTSyntax", AlwaysAllowed, Opt_GADTSyntax, nop ), + ( "ViewPatterns", AlwaysAllowed, Opt_ViewPatterns, nop ), + ( "TypeFamilies", AlwaysAllowed, Opt_TypeFamilies, nop ), + ( "BangPatterns", AlwaysAllowed, Opt_BangPatterns, nop ), + ( "MonomorphismRestriction", AlwaysAllowed, Opt_MonomorphismRestriction, nop ), + ( "NPlusKPatterns", AlwaysAllowed, Opt_NPlusKPatterns, nop ), + ( "DoAndIfThenElse", AlwaysAllowed, Opt_DoAndIfThenElse, nop ), + ( "RebindableSyntax", AlwaysAllowed, Opt_RebindableSyntax, nop ), + ( "MonoPatBinds", AlwaysAllowed, Opt_MonoPatBinds, nop ), + ( "ExplicitForAll", AlwaysAllowed, Opt_ExplicitForAll, nop ), + ( "AlternativeLayoutRule", AlwaysAllowed, Opt_AlternativeLayoutRule, nop ), + ( "AlternativeLayoutRuleTransitional",AlwaysAllowed, Opt_AlternativeLayoutRuleTransitional, nop ), + ( "DatatypeContexts", AlwaysAllowed, Opt_DatatypeContexts, \ turn_on -> when turn_on $ deprecate "It was widely considered a misfeature, and has been removed from the Haskell language." ), - ( "NondecreasingIndentation", Opt_NondecreasingIndentation, nop ), - ( "RelaxedLayout", Opt_RelaxedLayout, nop ), - ( "MonoLocalBinds", Opt_MonoLocalBinds, nop ), - ( "RelaxedPolyRec", Opt_RelaxedPolyRec, + ( "NondecreasingIndentation", AlwaysAllowed, Opt_NondecreasingIndentation, nop ), + ( "RelaxedLayout", AlwaysAllowed, Opt_RelaxedLayout, nop ), + ( "MonoLocalBinds", AlwaysAllowed, Opt_MonoLocalBinds, nop ), + ( "RelaxedPolyRec", AlwaysAllowed, Opt_RelaxedPolyRec, \ turn_on -> if not turn_on then deprecate "You can't turn off RelaxedPolyRec any more" else return () ), - ( "ExtendedDefaultRules", Opt_ExtendedDefaultRules, nop ), - ( "ImplicitParams", Opt_ImplicitParams, nop ), - ( "ScopedTypeVariables", Opt_ScopedTypeVariables, nop ), + ( "ExtendedDefaultRules", AlwaysAllowed, Opt_ExtendedDefaultRules, nop ), + ( "ImplicitParams", AlwaysAllowed, Opt_ImplicitParams, nop ), + ( "ScopedTypeVariables", AlwaysAllowed, Opt_ScopedTypeVariables, nop ), - ( "PatternSignatures", Opt_ScopedTypeVariables, + ( "PatternSignatures", AlwaysAllowed, Opt_ScopedTypeVariables, deprecatedForExtension "ScopedTypeVariables" ), - ( "UnboxedTuples", Opt_UnboxedTuples, nop ), - ( "StandaloneDeriving", Opt_StandaloneDeriving, nop ), - ( "DeriveDataTypeable", Opt_DeriveDataTypeable, nop ), - ( "DeriveFunctor", Opt_DeriveFunctor, nop ), - ( "DeriveTraversable", Opt_DeriveTraversable, nop ), - ( "DeriveFoldable", Opt_DeriveFoldable, nop ), - ( "DeriveGeneric", Opt_DeriveGeneric, nop ), - ( "DefaultSignatures", Opt_DefaultSignatures, nop ), - ( "TypeSynonymInstances", Opt_TypeSynonymInstances, nop ), - ( "FlexibleContexts", Opt_FlexibleContexts, nop ), - ( "FlexibleInstances", Opt_FlexibleInstances, nop ), - ( "ConstrainedClassMethods", Opt_ConstrainedClassMethods, nop ), - ( "MultiParamTypeClasses", Opt_MultiParamTypeClasses, nop ), - ( "FunctionalDependencies", Opt_FunctionalDependencies, nop ), - ( "GeneralizedNewtypeDeriving", Opt_GeneralizedNewtypeDeriving, nop ), - ( "OverlappingInstances", Opt_OverlappingInstances, nop ), - ( "UndecidableInstances", Opt_UndecidableInstances, nop ), - ( "IncoherentInstances", Opt_IncoherentInstances, nop ), - ( "PackageImports", Opt_PackageImports, nop ) + ( "UnboxedTuples", AlwaysAllowed, Opt_UnboxedTuples, nop ), + ( "StandaloneDeriving", AlwaysAllowed, Opt_StandaloneDeriving, nop ), + ( "DeriveDataTypeable", AlwaysAllowed, Opt_DeriveDataTypeable, nop ), + ( "DeriveFunctor", AlwaysAllowed, Opt_DeriveFunctor, nop ), + ( "DeriveTraversable", AlwaysAllowed, Opt_DeriveTraversable, nop ), + ( "DeriveFoldable", AlwaysAllowed, Opt_DeriveFoldable, nop ), + ( "DeriveGeneric", AlwaysAllowed, Opt_DeriveGeneric, nop ), + ( "DefaultSignatures", AlwaysAllowed, Opt_DefaultSignatures, nop ), + ( "TypeSynonymInstances", AlwaysAllowed, Opt_TypeSynonymInstances, nop ), + ( "FlexibleContexts", AlwaysAllowed, Opt_FlexibleContexts, nop ), + ( "FlexibleInstances", AlwaysAllowed, Opt_FlexibleInstances, nop ), + ( "ConstrainedClassMethods", AlwaysAllowed, Opt_ConstrainedClassMethods, nop ), + ( "MultiParamTypeClasses", AlwaysAllowed, Opt_MultiParamTypeClasses, nop ), + ( "FunctionalDependencies", AlwaysAllowed, Opt_FunctionalDependencies, nop ), + ( "GeneralizedNewtypeDeriving", AlwaysAllowed, Opt_GeneralizedNewtypeDeriving, nop ), + ( "OverlappingInstances", RestrictedFunction, Opt_OverlappingInstances, nop ), + ( "UndecidableInstances", AlwaysAllowed, Opt_UndecidableInstances, nop ), + ( "IncoherentInstances", AlwaysAllowed, Opt_IncoherentInstances, nop ), + ( "PackageImports", AlwaysAllowed, Opt_PackageImports, nop ) ] defaultFlags :: [DynFlag] diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 5f7139cbf6..dc297a0051 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -460,6 +460,11 @@ setSessionDynFlags dflags = do return preload +parseDynamicFlags :: Monad m => + DynFlags -> [Located String] + -> m (DynFlags, [Located String], [Located String]) +parseDynamicFlags = parseDynamicFlagsCmdLine + -- %************************************************************************ -- %* * diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index 5df0e13e87..8ccf0a5a81 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -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 diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index 3fd9916c1e..b07601bc0f 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -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") diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index a120926717..24f610f836 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -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 diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 9988d1d700..5ff71077f5 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -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 () diff --git a/compiler/main/StaticFlagParser.hs b/compiler/main/StaticFlagParser.hs index 5767a52552..c63f070608 100644 --- a/compiler/main/StaticFlagParser.hs +++ b/compiler/main/StaticFlagParser.hs @@ -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 () |