Commit 1c536211 authored by dterei's avatar dterei

Make the GHC API a little more powerful.

parent e5ca5c7f
......@@ -83,7 +83,13 @@ module DynFlags (
-- ** Parsing DynFlags
parseDynamicFlagsCmdLine,
parseDynamicFilePragma,
parseDynamicFlagsFull,
-- ** Available DynFlags
allFlags,
flagsAll,
flagsDynamic,
flagsPackage,
supportedLanguagesAndExtensions,
......@@ -1392,31 +1398,39 @@ getStgToDo dflags
-- -----------------------------------------------------------------------------
-- Parsing the dynamic flags.
-- | 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).
parseDynamicFlagsCmdLine :: Monad m =>
DynFlags -> [Located String]
-> m (DynFlags, [Located String], [Located String])
-- ^ Updated 'DynFlags', left-over arguments, and
-- list of warnings.
parseDynamicFlagsCmdLine dflags args = parseDynamicFlags dflags args True
parseDynamicFlagsCmdLine :: Monad m => DynFlags -> [Located String]
-> m (DynFlags, [Located String], [Located String])
-- ^ Updated 'DynFlags', left-over arguments, and
-- list of warnings.
parseDynamicFlagsCmdLine = parseDynamicFlagsFull flagsAll True
-- | Like 'parseDynamicFlagsCmdLine' but does not allow the package flags
-- (-package, -hide-package, -ignore-package, -hide-all-packages, -package-db).
-- Used to parse flags set in a modules pragma.
parseDynamicFilePragma :: Monad m =>
DynFlags -> [Located String]
parseDynamicFilePragma :: Monad m => DynFlags -> [Located String]
-> m (DynFlags, [Located String], [Located String])
-- ^ Updated 'DynFlags', left-over arguments, and
-- list of warnings.
parseDynamicFilePragma = parseDynamicFlagsFull flagsDynamic False
-- | Parses the dynamically set flags for GHC. This is the most general form of
-- the dynamic flag parser that the other methods simply wrap. It allows
-- saying which flags are valid flags and indicating if we are parsing
-- arguments from the command line or from a file pragma.
parseDynamicFlagsFull :: Monad m
=> [Flag (CmdLineP DynFlags)] -- ^ valid flags to match against
-> Bool -- ^ are the arguments from the command line?
-> DynFlags -- ^ current dynamic flags
-> [Located String] -- ^ arguments to parse
-> m (DynFlags, [Located String], [Located String])
-- ^ Updated 'DynFlags', left-over arguments, and
-- list of warnings.
parseDynamicFilePragma dflags args = parseDynamicFlags dflags args False
parseDynamicFlags :: Monad m =>
DynFlags -> [Located String] -> Bool
-> m (DynFlags, [Located String], [Located String])
parseDynamicFlags dflags0 args cmdline = do
parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
-- XXX Legacy support code
-- We used to accept things like
-- optdep-f -optdepdepend
......@@ -1429,12 +1443,8 @@ parseDynamicFlags dflags0 args cmdline = do
f xs = xs
args' = f args
-- Note: -ignore-package (package_flags) must precede -i* (dynamic_flags)
flag_spec | cmdline = package_flags ++ dynamic_flags
| otherwise = dynamic_flags
let ((leftover, errs, warns), dflags1)
= runCmdLine (processArgs flag_spec args') dflags0
= runCmdLine (processArgs activeFlags args') dflags0
when (not (null errs)) $ ghcError $ errorsToGhcException errs
-- check for disabled flags in safe haskell
......@@ -1442,8 +1452,12 @@ parseDynamicFlags dflags0 args cmdline = do
return (dflags2, leftover, sh_warns ++ warns)
-- | Check (and potentially disable) any extensions that aren't allowed
-- in safe mode.
--
-- The bool is to indicate if we are parsing command line flags (false means
-- file pragma). This allows us to generate better warnings.
safeFlagCheck :: Bool -> DynFlags -> (DynFlags, [Located String])
safeFlagCheck _ dflags | not (safeLanguageOn dflags || safeInferOn dflags)
= (dflags, [])
......@@ -1489,6 +1503,8 @@ safeFlagCheck cmdl dflags =
%* *
%********************************************************************* -}
-- | All dynamic flags option strings. These are the user facing strings for
-- enabling and disabling options.
allFlags :: [String]
allFlags = map ('-':) $
[ flagName flag | flag <- dynamic_flags ++ package_flags, ok (flagOptKind flag) ] ++
......@@ -1502,6 +1518,23 @@ allFlags = map ('-':) $
fflags1 = [ name | (name, _, _) <- fWarningFlags ]
fflags2 = [ name | (name, _, _) <- fLangFlags ]
{-
- Below we export user facing symbols for GHC dynamic flags for use with the
- GHC API.
-}
-- All dynamic flags present in GHC.
flagsAll :: [Flag (CmdLineP DynFlags)]
flagsAll = package_flags ++ dynamic_flags
-- All dynamic flags, minus package flags, present in GHC.
flagsDynamic :: [Flag (CmdLineP DynFlags)]
flagsDynamic = dynamic_flags
-- ALl package flags present in GHC.
flagsPackage :: [Flag (CmdLineP DynFlags)]
flagsPackage = package_flags
--------------- The main flags themselves ------------------
dynamic_flags :: [Flag (CmdLineP DynFlags)]
dynamic_flags = [
......
......@@ -9,7 +9,11 @@
--
-----------------------------------------------------------------------------
module StaticFlagParser (parseStaticFlags) where
module StaticFlagParser (
parseStaticFlags,
parseStaticFlagsFull,
flagsStatic
) where
#include "HsVersions.h"
......@@ -46,11 +50,18 @@ import Data.List
-- XXX: can we add an auto-generated list of static flags here?
--
parseStaticFlags :: [Located String] -> IO ([Located String], [Located String])
parseStaticFlags args = do
parseStaticFlags = parseStaticFlagsFull flagsStatic
-- | Parse GHC's static flags as @parseStaticFlags@ does. However it also
-- takes a list of available static flags, such that certain flags can be
-- enabled or disabled through this argument.
parseStaticFlagsFull :: [Flag IO] -> [Located String]
-> IO ([Located String], [Located String])
parseStaticFlagsFull flagsAvailable 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 flagsAvailable args
when (not (null errs)) $ ghcError $ errorsToGhcException errs
-- deal with the way flags: the way (eg. prof) gives rise to
......@@ -62,8 +73,10 @@ parseStaticFlags args = do
let unreg_flags | cGhcUnregisterised == "YES" = unregFlags
| otherwise = []
-- as these are GHC generated flags, we parse them with all static flags
-- in scope, regardless of what availableFlags are passed in.
(more_leftover, errs, warns2) <-
processArgs static_flags (unreg_flags ++ way_flags')
processArgs flagsStatic (unreg_flags ++ way_flags')
-- see sanity code in staticOpts
writeIORef v_opt_C_ready True
......@@ -88,7 +101,7 @@ parseStaticFlags args = do
return (excess_prec ++ cg_flags ++ more_leftover ++ leftover,
warns1 ++ warns2)
static_flags :: [Flag IO]
flagsStatic :: [Flag IO]
-- All the static flags should appear in this list. It describes how each
-- static flag should be processed. Two main purposes:
-- (a) if a command-line flag doesn't appear in the list, GHC can complain
......@@ -102,7 +115,7 @@ static_flags :: [Flag IO]
-- is a prefix flag (i.e. HasArg, Prefix, OptPrefix, AnySuffix) will override
-- flags further down the list with the same prefix.
static_flags = [
flagsStatic = [
------- ways --------------------------------------------------------
Flag "prof" (NoArg (addWay WayProf))
, Flag "eventlog" (NoArg (addWay WayEventLog))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment