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
+ let dflags0' = flattenLanguageFlags dflags0
+ src_opts <- liftIO $ getOptionsFromFile dflags0' input_fn
(dflags1, unhandled_flags, warns)
<- liftIO $ parseDynamicNoPackageFlags dflags0 src_opts
checkProcessArgsResult unhandled_flags
+ let dflags1' = flattenLanguageFlags dflags1
- if not (dopt Opt_Cpp dflags1) then do
+ if not (dopt 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
- unless (dopt Opt_Pp dflags2) $ handleFlagWarnings dflags2 warns
+ let dflags2' = flattenLanguageFlags dflags2
+ 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' = flattenLanguageFlags 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
- handleFlagWarnings dflags1 warns
+ let dflags1' = flattenLanguageFlags dflags1
+ 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
- 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)
+ dflags' = flattenLanguageFlags 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)
runPhase Cmm stop hsc_env basename _ input_fn get_output_fn maybe_loc
= do
DOpt(..),
DynFlag(..),
LanguageFlag(..),
+ flattenLanguageFlags,
+ ensureFlattenedLanguageFlags,
+ lopt_set_flattened,
+ lopt_unset_flattened,
DynFlags(..),
HscTarget(..), isObjectTarget, defaultObjectTarget,
GhcMode(..), isOneShot,
-- hsc dynamic flags
flags :: [DynFlag],
- languageFlags :: [LanguageFlag],
+ languageFlags :: Either [OnOff LanguageFlag]
+ [LanguageFlag],
-- | Message output action: use "ErrUtils" instead of this if you can
log_action :: Severity -> SrcSpan -> PprStyle -> Message -> IO (),
-- The default -O0 options
++ standardWarnings,
- languageFlags = [
- Opt_MonoPatBinds, -- Experimentally, I'm making this non-standard
- -- behaviour the default, to see if anyone notices
- -- SLPJ July 06
-
- Opt_ImplicitPrelude,
- Opt_MonomorphismRestriction,
- Opt_NPlusKPatterns,
- Opt_DatatypeContexts
- ],
+ languageFlags = Left [],
log_action = \severity srcSpan style msg ->
case severity of
5 | "ghc -v -ddump-all"
-}
+data OnOff a = On a
+ | Off a
+
+flattenLanguageFlags :: DynFlags -> DynFlags
+flattenLanguageFlags dflags
+ = case languageFlags dflags of
+ Left onoffs ->
+ dflags {
+ languageFlags = Right $ flattenLanguageFlags' onoffs
+ }
+ Right _ ->
+ panic "Flattening already-flattened language flags"
+
+ensureFlattenedLanguageFlags :: DynFlags -> DynFlags
+ensureFlattenedLanguageFlags dflags
+ = case languageFlags dflags of
+ Left onoffs ->
+ dflags {
+ languageFlags = Right $ flattenLanguageFlags' onoffs
+ }
+ Right _ ->
+ dflags
+
+-- OnOffs accumulate in reverse order, so we use foldr in order to
+-- process them in the right order
+flattenLanguageFlags' :: [OnOff LanguageFlag] -> [LanguageFlag]
+flattenLanguageFlags' = foldr f defaultLanguageFlags
+ where f (On f) flags = f : delete f flags
+ f (Off f) flags = delete f flags
+ defaultLanguageFlags = [
+ Opt_MonoPatBinds, -- Experimentally, I'm making this non-standard
+ -- behaviour the default, to see if anyone notices
+ -- SLPJ July 06
+
+ Opt_ImplicitPrelude,
+ Opt_MonomorphismRestriction,
+ Opt_NPlusKPatterns,
+ Opt_DatatypeContexts
+ ]
+
-- The DOpt class is a temporary workaround, to avoid having to do
-- a mass-renaming dopt->lopt at the moment
class DOpt a where
-- | Test whether a 'LanguageFlag' is set
lopt :: LanguageFlag -> DynFlags -> Bool
-lopt f dflags = f `elem` languageFlags dflags
+lopt f dflags = case languageFlags dflags of
+ Left _ -> panic ("Testing for language flag " ++ show f ++ " before flattening")
+ Right flags -> f `elem` flags
-- | Set a 'LanguageFlag'
lopt_set :: DynFlags -> LanguageFlag -> DynFlags
-lopt_set dfs f = dfs{ languageFlags = f : languageFlags dfs }
+lopt_set dfs f = case languageFlags dfs of
+ Left onoffs -> dfs { languageFlags = Left (On f : onoffs) }
+ Right _ -> panic ("Setting language flag " ++ show f ++ " after flattening")
+
+-- | Set a 'LanguageFlag'
+lopt_set_flattened :: DynFlags -> LanguageFlag -> DynFlags
+lopt_set_flattened dfs f = case languageFlags dfs of
+ Left _ ->
+ panic ("Setting language flag " ++ show f ++ " before flattening, but expected flattened")
+ Right flags ->
+ dfs { languageFlags = Right (f : delete f flags) }
-- | Unset a 'LanguageFlag'
lopt_unset :: DynFlags -> LanguageFlag -> DynFlags
-lopt_unset dfs f = dfs{ languageFlags = filter (/= f) (languageFlags dfs) }
+lopt_unset dfs f = case languageFlags dfs of
+ Left onoffs -> dfs { languageFlags = Left (Off f : onoffs) }
+ Right _ -> panic ("Unsetting language flag " ++ show f ++ " after flattening")
+
+-- | Unset a 'LanguageFlag'
+lopt_unset_flattened :: DynFlags -> LanguageFlag -> DynFlags
+lopt_unset_flattened dfs f = case languageFlags dfs of
+ Left _ ->
+ panic ("Unsetting language flag " ++ show f ++ " before flattening, but expected flattened")
+ Right flags ->
+ dfs { languageFlags = Right (delete f flags) }
-- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order
getOpts :: DynFlags -- ^ 'DynFlags' to retrieve the options from
doptM :: DOpt d => d -> TcRnIf gbl lcl Bool
doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) }
-setOptM :: DOpt d => d -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+-- XXX setOptM and unsetOptM operate on different types. One should be renamed.
+
+setOptM :: LanguageFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setOptM flag = updEnv (\ env@(Env { env_top = top }) ->
- env { env_top = top { hsc_dflags = dopt_set (hsc_dflags top) flag}} )
+ env { env_top = top { hsc_dflags = lopt_set_flattened (hsc_dflags top) flag}} )
-unsetOptM :: DOpt d => d -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+unsetOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetOptM flag = updEnv (\ env@(Env { env_top = top }) ->
env { env_top = top { hsc_dflags = dopt_unset (hsc_dflags top) flag}} )
-- a file, otherwise the read buffer can't be flushed).
_ <- liftIO $ IO.try $ hFlushAll stdin
#endif
- result <- GhciMonad.runStmt stmt step
+ result <- withFlattenedDynflags $ GhciMonad.runStmt stmt step
afterRunStmt (const True) result
--afterRunStmt :: GHC.RunResult -> GHCi Bool
info :: String -> InputT GHCi ()
info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
-info s = handleSourceError GHC.printExceptionAndWarnings $ do
+info s = handleSourceError GHC.printExceptionAndWarnings $
+ withFlattenedDynflags $ do
{ let names = words s
; dflags <- getDynFlags
; let pefas = dopt Opt_PrintExplicitForalls dflags
runMain s = case toArgs s of
Left err -> io (hPutStrLn stderr err)
Right args ->
- do dflags <- getDynFlags
+ withFlattenedDynflags $ do
+ dflags <- getDynFlags
case mainFunIs dflags of
Nothing -> doWithArgs args "main"
Just f -> doWithArgs args f
let new_expr = '(' : definition ++ ") :: String -> IO String"
-- compile the expression
- handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
+ handleSourceError (\e -> GHC.printExceptionAndWarnings e) $
+ withFlattenedDynflags $ do
hv <- GHC.compileExpr new_expr
io (writeIORef macros_ref --
(filtered ++ [(macro_name, lift . runMacro hv, noCompletion)]))
cmdCmd :: String -> GHCi ()
cmdCmd str = do
let expr = '(' : str ++ ") :: IO String"
- handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
+ handleSourceError (\e -> GHC.printExceptionAndWarnings e) $
+ withFlattenedDynflags $ do
hv <- GHC.compileExpr expr
cmds <- io $ (unsafeCoerce# hv :: IO String)
enqueueCommands (lines cmds)
loaded_mod_names = map GHC.moduleName loaded_mods
modulesLoadedMsg ok loaded_mod_names
- lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries
+ withFlattenedDynflags $ lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries
setContextAfterLoad :: ([Module],[(Module, Maybe (ImportDecl RdrName))]) -> Bool -> [GHC.ModSummary] -> GHCi ()
typeOfExpr :: String -> InputT GHCi ()
typeOfExpr str
- = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
+ = handleSourceError (\e -> GHC.printExceptionAndWarnings e)
+ $ withFlattenedDynflags
+ $ do
ty <- GHC.exprType str
dflags <- getDynFlags
let pefas = dopt Opt_PrintExplicitForalls dflags
kindOfType :: String -> InputT GHCi ()
kindOfType str
- = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
+ = handleSourceError (\e -> GHC.printExceptionAndWarnings e)
+ $ withFlattenedDynflags
+ $ do
ty <- GHC.typeKind str
printForUser $ text str <+> dcolon <+> ppr ty
shellEscape :: String -> GHCi Bool
shellEscape str = io (system str >> return False)
+withFlattenedDynflags :: GHC.GhcMonad m => m a -> m a
+withFlattenedDynflags m
+ = do dflags <- GHC.getSessionDynFlags
+ gbracket (GHC.setSessionDynFlags (ensureFlattenedLanguageFlags dflags))
+ (\_ -> GHC.setSessionDynFlags dflags)
+ (\_ -> m)
+
-----------------------------------------------------------------------------
-- Browsing a module's contents
-- indicate import modules, to aid qualifying unqualified names
-- with sorted, sort items alphabetically
browseModule :: Bool -> Module -> Bool -> InputT GHCi ()
-browseModule bang modl exports_only = do
+browseModule bang modl exports_only = withFlattenedDynflags $ do
-- :browse! reports qualifiers wrt current context
current_unqual <- GHC.getPrintUnqual
-- Temporarily set the context to the module we're interested in,
playCtxtCmd:: Bool -> CtxtCmd -> GHCi ()
playCtxtCmd fail cmd = do
+ withFlattenedDynflags $ do
(prev_as,prev_bs) <- GHC.getContext
case cmd of
SetContext as bs -> do
pprintCommand :: Bool -> Bool -> String -> GHCi ()
pprintCommand bind force str = do
- pprintClosureCommand bind force str
+ withFlattenedDynflags $ pprintClosureCommand bind force str
stepCmd :: String -> GHCi ()
stepCmd [] = doContinue (const True) GHC.SingleStep
-- handle the "break" command
breakCmd :: String -> GHCi ()
breakCmd argLine = do
- breakSwitch $ words argLine
+ withFlattenedDynflags $ breakSwitch $ words argLine
breakSwitch :: [String] -> GHCi ()
breakSwitch [] = do
end_bold = "\ESC[0m"
listCmd :: String -> InputT GHCi ()
-listCmd "" = do
+listCmd c = withFlattenedDynflags $ listCmd' c
+
+listCmd' :: String -> InputT GHCi ()
+listCmd' "" = do
mb_span <- lift getCurrentBreakSpan
case mb_span of
Nothing ->
printForUser (text "Unable to list source for" <+>
ppr span
$$ text "Try" <+> doWhat)
-listCmd str = list2 (words str)
+listCmd' str = list2 (words str)
list2 :: [String] -> InputT GHCi ()
list2 [arg] | all isDigit arg = do
-- GHC's command-line interface
main :: IO ()
-main =
- GHC.defaultErrorHandler defaultDynFlags $ do
+main = do
+ hSetBuffering stdout NoBuffering
+ GHC.defaultErrorHandler defaultDynFlags $ do
-- 1. extract the -B flag from the args
argv0 <- getArgs
projects / ghc-hetmet.git / commitdiff