From c43cb4926f213a5cdaf42c790456313f696228bb Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Tue, 23 Sep 2008 17:39:04 +0000 Subject: [PATCH] Disallow package flags in OPTIONS_GHC pragmas (#2499) --- compiler/main/DriverPipeline.hs | 2 +- compiler/main/DynFlags.hs | 56 +++++++++++++++++++++++++++------------ compiler/main/GHC.hs | 2 +- 3 files changed, 41 insertions(+), 19 deletions(-) diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 5355d8f..818a00c 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -665,7 +665,7 @@ runPhase (Cpp sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc = do let dflags0 = hsc_dflags hsc_env src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn (dflags, unhandled_flags, warns) - <- liftIO $ parseDynamicFlags dflags0 src_opts + <- liftIO $ parseDynamicNoPackageFlags dflags0 src_opts liftIO $ handleFlagWarnings dflags warns -- XXX: may exit the program liftIO $ checkProcessArgsResult unhandled_flags -- XXX: may throw program error diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index bf6d11a..bdca05f 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -38,6 +38,7 @@ module DynFlags ( -- ** Parsing DynFlags parseDynamicFlags, + parseDynamicNoPackageFlags, allFlags, supportedLanguages, languageOptions, @@ -1225,20 +1226,6 @@ dynamic_flags = [ , Flag "no-recomp" (NoArg (setDynFlag Opt_ForceRecomp)) (Deprecated "Use -fforce-recomp instead") - ------- Packages ---------------------------------------------------- - , Flag "package-conf" (HasArg extraPkgConf_) Supported - , Flag "no-user-package-conf" (NoArg (unSetDynFlag Opt_ReadUserPackageConf)) - Supported - , Flag "package-name" (HasArg (upd . setPackageName)) Supported - , Flag "package" (HasArg exposePackage) Supported - , Flag "hide-package" (HasArg hidePackage) Supported - , Flag "hide-all-packages" (NoArg (setDynFlag Opt_HideAllPackages)) - Supported - , Flag "ignore-package" (HasArg ignorePackage) - Supported - , Flag "syslib" (HasArg exposePackage) - (Deprecated "Use -package instead") - ------ HsCpp opts --------------------------------------------------- , Flag "D" (AnySuffix (upd . addOptP)) Supported , Flag "U" (AnySuffix (upd . addOptP)) Supported @@ -1474,6 +1461,23 @@ dynamic_flags = [ ++ map (mkFlag True "X" setDynFlag ) xFlags ++ map (mkFlag False "XNo" unSetDynFlag) xFlags +package_flags :: [Flag DynP] +package_flags = [ + ------- Packages ---------------------------------------------------- + Flag "package-conf" (HasArg extraPkgConf_) Supported + , Flag "no-user-package-conf" (NoArg (unSetDynFlag Opt_ReadUserPackageConf)) + Supported + , Flag "package-name" (HasArg (upd . setPackageName)) Supported + , Flag "package" (HasArg exposePackage) Supported + , Flag "hide-package" (HasArg hidePackage) Supported + , Flag "hide-all-packages" (NoArg (setDynFlag Opt_HideAllPackages)) + Supported + , Flag "ignore-package" (HasArg ignorePackage) + Supported + , Flag "syslib" (HasArg exposePackage) + (Deprecated "Use -package instead") + ] + mkFlag :: Bool -- ^ True <=> it should be turned on -> String -- ^ The flag prefix -> (DynFlag -> DynP ()) @@ -1712,7 +1716,7 @@ glasgowExtsFlags = [ -- ----------------------------------------------------------------------------- -- Parsing the dynamic flags. --- | Parse dynamic flags from a list of command line argument. Returns the +-- | Parse dynamic flags from a list of command line arguments. Returns the -- 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). @@ -1721,7 +1725,21 @@ parseDynamicFlags :: Monad m => -> m (DynFlags, [Located String], [Located String]) -- ^ Updated 'DynFlags', left-over arguments, and -- list of warnings. -parseDynamicFlags dflags args = do +parseDynamicFlags 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 => + 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 + +parseDynamicFlags_ :: Monad m => + DynFlags -> [Located String] -> Bool + -> m (DynFlags, [Located String], [Located String]) +parseDynamicFlags_ dflags args pkg_flags = do -- XXX Legacy support code -- We used to accept things like -- optdep-f -optdepdepend @@ -1733,8 +1751,12 @@ parseDynamicFlags dflags args = do f (x : xs) = x : f xs f xs = xs args' = f args + + flag_spec | pkg_flags = dynamic_flags ++ package_flags + | otherwise = dynamic_flags + let ((leftover, errs, warns), dflags') - = runCmdLine (processArgs dynamic_flags args') dflags + = runCmdLine (processArgs flag_spec args') dflags when (not (null errs)) $ ghcError $ errorsToGhcException errs return (dflags', leftover, warns) diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 3d6ce01..5256fe4 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -2188,7 +2188,7 @@ preprocessFile hsc_env src_fn mb_phase (Just (buf, _time)) local_opts = getOptions dflags buf src_fn -- (dflags', leftovers, warns) - <- parseDynamicFlags dflags local_opts + <- parseDynamicNoPackageFlags dflags local_opts liftIO $ checkProcessArgsResult leftovers -- XXX: throws exceptions liftIO $ handleFlagWarnings dflags' warns -- XXX: throws exceptions -- 1.7.10.4