runPhase (Cpp sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
= do let dflags0 = hsc_dflags hsc_env
- let dflags0' = flattenExtensionFlags dflags0
- src_opts <- liftIO $ getOptionsFromFile dflags0' input_fn
+ src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn
(dflags1, unhandled_flags, warns)
<- liftIO $ parseDynamicNoPackageFlags dflags0 src_opts
checkProcessArgsResult unhandled_flags
- let dflags1' = flattenExtensionFlags dflags1
- if not (xopt Opt_Cpp dflags1') then do
+ if not (xopt Opt_Cpp dflags1) then do
-- we have to be careful to emit warnings only once.
- unless (dopt Opt_Pp dflags1') $ handleFlagWarnings dflags1' warns
+ unless (dopt Opt_Pp dflags1) $ handleFlagWarnings dflags1 warns
-- no need to preprocess CPP, just pass input file along
-- to the next phase of the pipeline.
return (HsPp sf, dflags1, maybe_loc, input_fn)
else do
- output_fn <- liftIO $ get_output_fn dflags1' (HsPp sf) maybe_loc
- liftIO $ doCpp dflags1' True{-raw-} False{-no CC opts-} input_fn output_fn
+ output_fn <- liftIO $ get_output_fn dflags1 (HsPp sf) maybe_loc
+ liftIO $ doCpp dflags1 True{-raw-} False{-no CC opts-} input_fn output_fn
-- re-read the pragmas now that we've preprocessed the file
-- See #2464,#3457
- src_opts <- liftIO $ getOptionsFromFile dflags0' output_fn
+ src_opts <- liftIO $ getOptionsFromFile dflags0 output_fn
(dflags2, unhandled_flags, warns)
<- liftIO $ parseDynamicNoPackageFlags dflags0 src_opts
- let dflags2' = flattenExtensionFlags dflags2
- unless (dopt Opt_Pp dflags2') $ handleFlagWarnings dflags2' warns
+ unless (dopt Opt_Pp dflags2) $ handleFlagWarnings dflags2 warns
-- the HsPp pass below will emit warnings
checkProcessArgsResult unhandled_flags
runPhase (HsPp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc
= do let dflags = hsc_dflags hsc_env
- dflags' = flattenExtensionFlags dflags
if not (dopt Opt_Pp dflags) then
-- no need to preprocess, just pass input file along
-- to the next phase of the pipeline.
- return (Hsc sf, dflags', maybe_loc, input_fn)
+ return (Hsc sf, dflags, maybe_loc, input_fn)
else do
let hspp_opts = getOpts dflags opt_F
let orig_fn = basename <.> suff
)
-- re-read pragmas now that we've parsed the file (see #3674)
- src_opts <- liftIO $ getOptionsFromFile dflags' output_fn
+ src_opts <- liftIO $ getOptionsFromFile dflags output_fn
(dflags1, unhandled_flags, warns)
<- liftIO $ parseDynamicNoPackageFlags dflags src_opts
- let dflags1' = flattenExtensionFlags dflags1
- handleFlagWarnings dflags1' warns
+ handleFlagWarnings dflags1 warns
checkProcessArgsResult unhandled_flags
- return (Hsc sf, dflags1', maybe_loc, output_fn)
+ return (Hsc sf, dflags1, maybe_loc, output_fn)
-----------------------------------------------------------------------------
-- Hsc phase
runPhase CmmCpp _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
= do
let dflags = hsc_dflags hsc_env
- dflags' = flattenExtensionFlags dflags
- output_fn <- liftIO $ get_output_fn dflags' Cmm maybe_loc
- liftIO $ doCpp dflags' False{-not raw-} True{-include CC opts-} input_fn output_fn
- return (Cmm, dflags', maybe_loc, output_fn)
+ output_fn <- liftIO $ get_output_fn dflags Cmm maybe_loc
+ liftIO $ doCpp dflags False{-not raw-} True{-include CC opts-} input_fn output_fn
+ return (Cmm, dflags, maybe_loc, output_fn)
runPhase Cmm stop hsc_env basename _ input_fn get_output_fn maybe_loc
= do
- let dflags = ensureFlattenedExtensionFlags $ hsc_dflags hsc_env
+ let dflags = hsc_dflags hsc_env
let hsc_lang = hscMaybeAdjustTarget dflags stop HsSrcFile (hscTarget dflags)
let next_phase = hscNextPhase dflags HsSrcFile hsc_lang
output_fn <- liftIO $ get_output_fn dflags next_phase maybe_loc
DynFlag(..),
ExtensionFlag(..),
glasgowExtsFlags,
- flattenExtensionFlags,
- ensureFlattenedExtensionFlags,
dopt,
dopt_set,
dopt_unset,
xopt,
xopt_set,
xopt_unset,
- xopt_set_flattened,
- xopt_unset_flattened,
DynFlags(..),
RtsOptsEnabled(..),
HscTarget(..), isObjectTarget, defaultObjectTarget,
-- hsc dynamic flags
flags :: [DynFlag],
+ -- Don't change this without updating extensionFlags:
language :: Maybe Language,
- extensionFlags :: Either [OnOff ExtensionFlag]
- [ExtensionFlag],
+ -- Don't change this without updating extensionFlags:
+ extensions :: [OnOff ExtensionFlag],
+ -- extensionFlags should always be equal to
+ -- flattenExtensionFlags language extensions
+ extensionFlags :: [ExtensionFlag],
-- | Message output action: use "ErrUtils" instead of this if you can
log_action :: Severity -> SrcSpan -> PprStyle -> Message -> IO (),
haddockOptions = Nothing,
flags = defaultFlags,
language = Nothing,
- extensionFlags = Left [],
+ extensions = [],
+ extensionFlags = flattenExtensionFlags Nothing [],
log_action = \severity srcSpan style msg ->
case severity of
data OnOff a = On a
| Off a
-flattenExtensionFlags :: DynFlags -> DynFlags
-flattenExtensionFlags dflags
- = case extensionFlags dflags of
- Left onoffs ->
- dflags {
- extensionFlags = Right $ flattenExtensionFlags' (language dflags) onoffs
- }
- Right _ ->
- panic "Flattening already-flattened extension flags"
-
-ensureFlattenedExtensionFlags :: DynFlags -> DynFlags
-ensureFlattenedExtensionFlags dflags
- = case extensionFlags dflags of
- Left onoffs ->
- dflags {
- extensionFlags = Right $ flattenExtensionFlags' (language dflags) onoffs
- }
- Right _ ->
- dflags
-
-- OnOffs accumulate in reverse order, so we use foldr in order to
-- process them in the right order
-flattenExtensionFlags' :: Maybe Language -> [OnOff ExtensionFlag]
- -> [ExtensionFlag]
-flattenExtensionFlags' ml = foldr f defaultExtensionFlags
+flattenExtensionFlags :: Maybe Language -> [OnOff ExtensionFlag]
+ -> [ExtensionFlag]
+flattenExtensionFlags ml = foldr f defaultExtensionFlags
where f (On f) flags = f : delete f flags
f (Off f) flags = delete f flags
defaultExtensionFlags = languageExtensions ml
-- | Test whether a 'ExtensionFlag' is set
xopt :: ExtensionFlag -> DynFlags -> Bool
-xopt f dflags = case extensionFlags dflags of
- Left _ -> panic ("Testing for extension flag " ++ show f ++ " before flattening")
- Right flags -> f `elem` flags
+xopt f dflags = f `elem` extensionFlags dflags
-- | Set a 'ExtensionFlag'
xopt_set :: DynFlags -> ExtensionFlag -> DynFlags
-xopt_set dfs f = case extensionFlags dfs of
- Left onoffs -> dfs { extensionFlags = Left (On f : onoffs) }
- Right _ -> panic ("Setting extension flag " ++ show f ++ " after flattening")
-
--- | Set a 'ExtensionFlag'
-xopt_set_flattened :: DynFlags -> ExtensionFlag -> DynFlags
-xopt_set_flattened dfs f = case extensionFlags dfs of
- Left _ ->
- panic ("Setting extension flag " ++ show f ++ " before flattening, but expected flattened")
- Right flags ->
- dfs { extensionFlags = Right (f : delete f flags) }
+xopt_set dfs f
+ = let onoffs = On f : extensions dfs
+ in dfs { extensions = onoffs,
+ extensionFlags = flattenExtensionFlags (language dfs) onoffs }
-- | Unset a 'ExtensionFlag'
xopt_unset :: DynFlags -> ExtensionFlag -> DynFlags
-xopt_unset dfs f = case extensionFlags dfs of
- Left onoffs -> dfs { extensionFlags = Left (Off f : onoffs) }
- Right _ -> panic ("Unsetting extension flag " ++ show f ++ " after flattening")
+xopt_unset dfs f
+ = let onoffs = Off f : extensions dfs
+ in dfs { extensions = onoffs,
+ extensionFlags = flattenExtensionFlags (language dfs) onoffs }
--- | Unset a 'ExtensionFlag'
-xopt_unset_flattened :: DynFlags -> ExtensionFlag -> DynFlags
-xopt_unset_flattened dfs f = case extensionFlags dfs of
- Left _ ->
- panic ("Unsetting extension flag " ++ show f ++ " before flattening, but expected flattened")
- Right flags ->
- dfs { extensionFlags = Right (delete f flags) }
+setLanguage :: Language -> DynP ()
+setLanguage l = upd f
+ where f dfs = let mLang = Just l
+ oneoffs = extensions dfs
+ in dfs {
+ language = mLang,
+ extensionFlags = flattenExtensionFlags mLang oneoffs
+ }
-- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order
getOpts :: DynFlags -- ^ 'DynFlags' to retrieve the options from
unSetDynFlag f = upd (\dfs -> dopt_unset dfs f)
--------------------------
-setLanguage :: Language -> DynP ()
-setLanguage l = upd (\dfs -> dfs { language = Just l })
-
---------------------------
setExtensionFlag, unSetExtensionFlag :: ExtensionFlag -> DynP ()
setExtensionFlag f = do { upd (\dfs -> xopt_set dfs f)
; mapM_ setExtensionFlag deps }
setOptM :: ExtensionFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setOptM flag = updEnv (\ env@(Env { env_top = top }) ->
- env { env_top = top { hsc_dflags = xopt_set_flattened (hsc_dflags top) flag}} )
+ env { env_top = top { hsc_dflags = xopt_set (hsc_dflags top) flag}} )
unsetOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetOptM flag = updEnv (\ env@(Env { env_top = top }) ->
withFlattenedDynflags :: GHC.GhcMonad m => m a -> m a
withFlattenedDynflags m
= do dflags <- GHC.getSessionDynFlags
- gbracket (GHC.setSessionDynFlags (ensureFlattenedExtensionFlags dflags))
+ gbracket (GHC.setSessionDynFlags dflags)
(\_ -> GHC.setSessionDynFlags dflags)
(\_ -> m)
projects / ghc-hetmet.git / commitdiff