Commit a6f2d598 authored by Ian Lynagh's avatar Ian Lynagh

Add separate functions for querying DynFlag and ExtensionFlag options

and remove the temporary DOpt class workaround.
parent 896135d0
......@@ -9,7 +9,7 @@
module DsMonad (
DsM, mapM, mapAndUnzipM,
initDs, initDsTc, fixDs,
foldlM, foldrM, ifOptM, unsetOptM,
foldlM, foldrM, ifDOptM, unsetOptM,
Applicative(..),(<$>),
newLocalName,
......
......@@ -293,7 +293,7 @@ match vars@(v:_) ty eqns
; let grouped = groupEquations tidy_eqns
-- print the view patterns that are commoned up to help debug
; ifOptM Opt_D_dump_view_pattern_commoning (debug grouped)
; ifDOptM Opt_D_dump_view_pattern_commoning (debug grouped)
; match_results <- mapM match_group grouped
; return (adjustMatchResult (foldr1 (.) aux_binds) $
......
......@@ -1075,7 +1075,7 @@ tcPragExpr name expr
core_expr' <- tcIfaceExpr expr
-- Check for type consistency in the unfolding
ifOptM Opt_DoCoreLinting $ do
ifDOptM Opt_DoCoreLinting $ do
in_scope <- get_in_scope_ids
case lintUnfolding noSrcLoc in_scope core_expr' of
Nothing -> return ()
......
......@@ -707,7 +707,7 @@ runPhase (Cpp sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
checkProcessArgsResult unhandled_flags
let dflags1' = flattenExtensionFlags dflags1
if not (dopt 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
......
......@@ -14,14 +14,19 @@
-- flags. Dynamic flags can also be set at the prompt in GHCi.
module DynFlags (
-- * Dynamic flags and associated configuration types
DOpt(..),
DynFlag(..),
ExtensionFlag(..),
glasgowExtsFlags,
flattenExtensionFlags,
ensureFlattenedExtensionFlags,
lopt_set_flattened,
lopt_unset_flattened,
dopt,
dopt_set,
dopt_unset,
xopt,
xopt_set,
xopt_unset,
xopt_set_flattened,
xopt_unset_flattened,
DynFlags(..),
RtsOptsEnabled(..),
HscTarget(..), isObjectTarget, defaultObjectTarget,
......@@ -814,64 +819,47 @@ languageExtensions (Just Haskell2010)
Opt_DoAndIfThenElse,
Opt_RelaxedPolyRec]
-- The DOpt class is a temporary workaround, to avoid having to do
-- a mass-renaming dopt->lopt at the moment
class DOpt a where
dopt :: a -> DynFlags -> Bool
dopt_set :: DynFlags -> a -> DynFlags
dopt_unset :: DynFlags -> a -> DynFlags
instance DOpt DynFlag where
dopt = dopt'
dopt_set = dopt_set'
dopt_unset = dopt_unset'
instance DOpt ExtensionFlag where
dopt = lopt
dopt_set = lopt_set
dopt_unset = lopt_unset
-- | Test whether a 'DynFlag' is set
dopt' :: DynFlag -> DynFlags -> Bool
dopt' f dflags = f `elem` (flags dflags)
dopt :: DynFlag -> DynFlags -> Bool
dopt f dflags = f `elem` (flags dflags)
-- | Set a 'DynFlag'
dopt_set' :: DynFlags -> DynFlag -> DynFlags
dopt_set' dfs f = dfs{ flags = f : flags dfs }
dopt_set :: DynFlags -> DynFlag -> DynFlags
dopt_set dfs f = dfs{ flags = f : flags dfs }
-- | Unset a 'DynFlag'
dopt_unset' :: DynFlags -> DynFlag -> DynFlags
dopt_unset' dfs f = dfs{ flags = filter (/= f) (flags dfs) }
dopt_unset :: DynFlags -> DynFlag -> DynFlags
dopt_unset dfs f = dfs{ flags = filter (/= f) (flags dfs) }
-- | Test whether a 'ExtensionFlag' is set
lopt :: ExtensionFlag -> DynFlags -> Bool
lopt f dflags = case extensionFlags dflags of
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
-- | Set a 'ExtensionFlag'
lopt_set :: DynFlags -> ExtensionFlag -> DynFlags
lopt_set dfs f = case extensionFlags dfs of
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'
lopt_set_flattened :: DynFlags -> ExtensionFlag -> DynFlags
lopt_set_flattened dfs f = case extensionFlags dfs of
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) }
-- | Unset a 'ExtensionFlag'
lopt_unset :: DynFlags -> ExtensionFlag -> DynFlags
lopt_unset dfs f = case extensionFlags dfs of
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")
-- | Unset a 'ExtensionFlag'
lopt_unset_flattened :: DynFlags -> ExtensionFlag -> DynFlags
lopt_unset_flattened dfs f = case extensionFlags dfs of
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 ->
......@@ -1883,7 +1871,7 @@ setLanguage l = upd (\dfs -> dfs { language = Just l })
--------------------------
setExtensionFlag, unSetExtensionFlag :: ExtensionFlag -> DynP ()
setExtensionFlag f = do { upd (\dfs -> lopt_set dfs f)
setExtensionFlag f = do { upd (\dfs -> xopt_set dfs f)
; mapM_ setExtensionFlag deps }
where
deps = [ d | (f', d) <- impliedFlags, f' == f ]
......@@ -1893,7 +1881,7 @@ setExtensionFlag f = do { upd (\dfs -> lopt_set dfs f)
-- When you un-set f, however, we don't un-set the things it implies
-- (except for -fno-glasgow-exts, which is treated specially)
unSetExtensionFlag f = upd (\dfs -> lopt_unset dfs f)
unSetExtensionFlag f = upd (\dfs -> xopt_unset dfs f)
--------------------------
setDumpFlag' :: DynFlag -> DynP ()
......
......@@ -2289,7 +2289,7 @@ preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
| Just (Unlit _) <- mb_phase = True
| Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True
-- note: local_opts is only required if there's no Unlit phase
| dopt Opt_Cpp dflags' = True
| xopt Opt_Cpp dflags' = True
| dopt Opt_Pp dflags' = True
| otherwise = False
......@@ -2372,7 +2372,7 @@ getModuleGraph = liftM hsc_mod_graph getSession
-- have Template Haskell enabled whether it is actually needed or not.
needsTemplateHaskell :: ModuleGraph -> Bool
needsTemplateHaskell ms =
any (dopt Opt_TemplateHaskell . ms_hspp_opts) ms
any (xopt Opt_TemplateHaskell . ms_hspp_opts) ms
-- | Return @True@ <==> module is loaded.
isLoaded :: GhcMonad m => ModuleName -> m Bool
......
......@@ -79,7 +79,7 @@ getImports dflags buf filename source_filename = do
ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)
ord_idecls
implicit_prelude = dopt Opt_ImplicitPrelude dflags
implicit_prelude = xopt Opt_ImplicitPrelude dflags
implicit_imports = mkPrelImports (unLoc mod) implicit_prelude imps
in
return (src_idecls, implicit_imports ++ ordinary_imps, mod)
......
......@@ -300,7 +300,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports,
= do { let { dflags = hsc_dflags hsc_env
; omit_prags = dopt Opt_OmitInterfacePragmas dflags
; expose_all = dopt Opt_ExposeAllUnfoldings dflags
; th = dopt Opt_TemplateHaskell dflags
; th = xopt Opt_TemplateHaskell dflags
}
; showPass dflags CoreTidy
......
......@@ -1826,29 +1826,29 @@ mkPState flags buf loc =
alr_justClosedExplicitLetBlock = False
}
where
bitmap = genericsBit `setBitIf` dopt Opt_Generics flags
.|. ffiBit `setBitIf` dopt Opt_ForeignFunctionInterface flags
.|. parrBit `setBitIf` dopt Opt_PArr flags
.|. arrowsBit `setBitIf` dopt Opt_Arrows flags
.|. thBit `setBitIf` dopt Opt_TemplateHaskell flags
.|. qqBit `setBitIf` dopt Opt_QuasiQuotes flags
.|. ipBit `setBitIf` dopt Opt_ImplicitParams flags
.|. explicitForallBit `setBitIf` dopt Opt_ExplicitForAll flags
.|. bangPatBit `setBitIf` dopt Opt_BangPatterns flags
.|. tyFamBit `setBitIf` dopt Opt_TypeFamilies flags
bitmap = genericsBit `setBitIf` xopt Opt_Generics flags
.|. ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags
.|. parrBit `setBitIf` xopt Opt_PArr flags
.|. arrowsBit `setBitIf` xopt Opt_Arrows flags
.|. thBit `setBitIf` xopt Opt_TemplateHaskell flags
.|. qqBit `setBitIf` xopt Opt_QuasiQuotes flags
.|. ipBit `setBitIf` xopt Opt_ImplicitParams flags
.|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags
.|. bangPatBit `setBitIf` xopt Opt_BangPatterns flags
.|. tyFamBit `setBitIf` xopt Opt_TypeFamilies flags
.|. haddockBit `setBitIf` dopt Opt_Haddock flags
.|. magicHashBit `setBitIf` dopt Opt_MagicHash flags
.|. kindSigsBit `setBitIf` dopt Opt_KindSignatures flags
.|. recursiveDoBit `setBitIf` dopt Opt_RecursiveDo flags
.|. recBit `setBitIf` dopt Opt_DoRec flags
.|. recBit `setBitIf` dopt Opt_Arrows flags
.|. unicodeSyntaxBit `setBitIf` dopt Opt_UnicodeSyntax flags
.|. unboxedTuplesBit `setBitIf` dopt Opt_UnboxedTuples flags
.|. datatypeContextsBit `setBitIf` dopt Opt_DatatypeContexts flags
.|. transformComprehensionsBit `setBitIf` dopt Opt_TransformListComp flags
.|. magicHashBit `setBitIf` xopt Opt_MagicHash flags
.|. kindSigsBit `setBitIf` xopt Opt_KindSignatures flags
.|. recursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags
.|. recBit `setBitIf` xopt Opt_DoRec flags
.|. recBit `setBitIf` xopt Opt_Arrows flags
.|. unicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags
.|. unboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags
.|. datatypeContextsBit `setBitIf` xopt Opt_DatatypeContexts flags
.|. transformComprehensionsBit `setBitIf` xopt Opt_TransformListComp flags
.|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags
.|. newQualOpsBit `setBitIf` dopt Opt_NewQualifiedOperators flags
.|. alternativeLayoutRuleBit `setBitIf` dopt Opt_AlternativeLayoutRule flags
.|. newQualOpsBit `setBitIf` xopt Opt_NewQualifiedOperators flags
.|. alternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags
--
setBitIf :: Int -> Bool -> Int
b `setBitIf` cond | cond = bit b
......@@ -1966,7 +1966,7 @@ alternativeLayoutRuleToken t
justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock
setJustClosedExplicitLetBlock False
dflags <- getDynFlags
let transitional = dopt Opt_AlternativeLayoutRuleTransitional dflags
let transitional = xopt Opt_AlternativeLayoutRuleTransitional dflags
thisLoc = getLoc t
thisCol = srcSpanStartCol thisLoc
newLine = (lastLoc == noSrcSpan)
......
......@@ -707,7 +707,7 @@ checkAPat dynflags loc e0 = case e0 of
-- n+k patterns
OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
(L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
| dopt Opt_NPlusKPatterns dynflags && (plus == plus_RDR)
| xopt Opt_NPlusKPatterns dynflags && (plus == plus_RDR)
-> return (mkNPlusKPat (L nloc n) lit)
OpApp l op _fix r -> do l <- checkLPat l
......@@ -833,7 +833,7 @@ checkDoAndIfThenElse :: LHsExpr RdrName
checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
| semiThen || semiElse
= do pState <- getPState
unless (dopt Opt_DoAndIfThenElse (dflags pState)) $ do
unless (xopt Opt_DoAndIfThenElse (dflags pState)) $ do
parseErrorSDoc (combineLocs guardExpr elseExpr)
(text "Unexpected semi-colons in conditional:"
$$ nest 4 expr
......
......@@ -750,7 +750,7 @@ rnGRHS ctxt = wrapLocFstM (rnGRHS' ctxt)
rnGRHS' :: HsMatchContext Name -> GRHS RdrName -> RnM (GRHS Name, FreeVars)
rnGRHS' ctxt (GRHS guards rhs)
= do { pattern_guards_allowed <- doptM Opt_PatternGuards
= do { pattern_guards_allowed <- xoptM Opt_PatternGuards
; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) guards $
rnLExpr rhs
......
......@@ -207,7 +207,7 @@ lookupTopBndrRn_maybe rdr_name
-- See Note [Type and class operator definitions]
let occ = rdrNameOcc rdr_name
; when (isTcOcc occ && isSymOcc occ)
(do { op_ok <- doptM Opt_TypeOperators
(do { op_ok <- xoptM Opt_TypeOperators
; unless op_ok (addErr (opDeclErr rdr_name)) })
; mb_gre <- lookupGreLocalRn rdr_name
......@@ -764,7 +764,7 @@ checks the type of the user thing against the type of the standard thing.
lookupSyntaxName :: Name -- The standard name
-> RnM (SyntaxExpr Name, FreeVars) -- Possibly a non-standard name
lookupSyntaxName std_name
= doptM Opt_ImplicitPrelude `thenM` \ implicit_prelude ->
= xoptM Opt_ImplicitPrelude `thenM` \ implicit_prelude ->
if implicit_prelude then normal_case
else
-- Get the similarly named thing from the local environment
......@@ -776,7 +776,7 @@ lookupSyntaxName std_name
lookupSyntaxTable :: [Name] -- Standard names
-> RnM (SyntaxTable Name, FreeVars) -- See comments with HsExpr.ReboundNames
lookupSyntaxTable std_names
= doptM Opt_ImplicitPrelude `thenM` \ implicit_prelude ->
= xoptM Opt_ImplicitPrelude `thenM` \ implicit_prelude ->
if implicit_prelude then normal_case
else
-- Get the similarly named thing from the local environment
......@@ -866,7 +866,7 @@ bindTyVarsRn :: [LHsTyVarBndr RdrName]
-- Haskell-98 binding of type variables; e.g. within a data type decl
bindTyVarsRn tyvar_names enclosed_scope
= bindLocatedLocalsRn located_tyvars $ \ names ->
do { kind_sigs_ok <- doptM Opt_KindSignatures
do { kind_sigs_ok <- xoptM Opt_KindSignatures
; unless (null kinded_tyvars || kind_sigs_ok)
(mapM_ (addErr . kindSigErr) kinded_tyvars)
; enclosed_scope (zipWith replace tyvar_names names) }
......@@ -879,7 +879,7 @@ bindPatSigTyVars :: [LHsType RdrName] -> ([Name] -> RnM a) -> RnM a
-- Find the type variables in the pattern type
-- signatures that must be brought into scope
bindPatSigTyVars tys thing_inside
= do { scoped_tyvars <- doptM Opt_ScopedTypeVariables
= do { scoped_tyvars <- xoptM Opt_ScopedTypeVariables
; if not scoped_tyvars then
thing_inside []
else
......@@ -906,7 +906,7 @@ bindSigTyVarsFV :: [Name]
-> RnM (a, FreeVars)
-> RnM (a, FreeVars)
bindSigTyVarsFV tvs thing_inside
= do { scoped_tyvars <- doptM Opt_ScopedTypeVariables
= do { scoped_tyvars <- xoptM Opt_ScopedTypeVariables
; if not scoped_tyvars then
thing_inside
else
......@@ -950,7 +950,7 @@ checkDupAndShadowedNames envs names
-------------------------------------
checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv) -> [(SrcSpan,OccName)] -> RnM ()
checkShadowedOccs (global_env,local_env) loc_occs
= ifOptM Opt_WarnNameShadowing $
= ifDOptM Opt_WarnNameShadowing $
do { traceRn (text "shadow" <+> ppr loc_occs)
; mapM_ check_shadow loc_occs }
where
......@@ -973,7 +973,7 @@ checkShadowedOccs (global_env,local_env) loc_occs
-- punning or wild-cards are on (cf Trac #2723)
is_shadowed_gre gre@(GRE { gre_par = ParentIs _ })
= do { dflags <- getDOpts
; if (dopt Opt_RecordPuns dflags || dopt Opt_RecordWildCards dflags)
; if (xopt Opt_RecordPuns dflags || xopt Opt_RecordWildCards dflags)
then do { is_fld <- is_rec_fld gre; return (not is_fld) }
else return True }
is_shadowed_gre _other = return True
......@@ -1029,7 +1029,7 @@ mapFvRnCPS f (x:xs) cont = f x $ \ x' ->
\begin{code}
warnUnusedTopBinds :: [GlobalRdrElt] -> RnM ()
warnUnusedTopBinds gres
= ifOptM Opt_WarnUnusedBinds
= ifDOptM Opt_WarnUnusedBinds
$ do isBoot <- tcIsHsBoot
let noParent gre = case gre_par gre of
NoParent -> True
......@@ -1047,7 +1047,7 @@ warnUnusedMatches = check_unused Opt_WarnUnusedMatches
check_unused :: DynFlag -> [Name] -> FreeVars -> RnM ()
check_unused flag bound_names used_names
= ifOptM flag (warnUnusedLocals (filterOut (`elemNameSet` used_names) bound_names))
= ifDOptM flag (warnUnusedLocals (filterOut (`elemNameSet` used_names) bound_names))
-------------------------
-- Helpers
......
......@@ -110,7 +110,7 @@ rnExpr (HsIPVar v)
rnExpr (HsLit lit@(HsString s))
= do {
opt_OverloadedStrings <- doptM Opt_OverloadedStrings
opt_OverloadedStrings <- xoptM Opt_OverloadedStrings
; if opt_OverloadedStrings then
rnExpr (HsOverLit (mkHsIsString s placeHolderType))
else -- Same as below
......@@ -1175,7 +1175,7 @@ checkRecStmt ctxt = addErr msg
---------
checkParStmt :: HsStmtContext Name -> RnM ()
checkParStmt _
= do { parallel_list_comp <- doptM Opt_ParallelListComp
= do { parallel_list_comp <- xoptM Opt_ParallelListComp
; checkErr parallel_list_comp msg }
where
msg = ptext (sLit "Illegal parallel list comprehension: use -XParallelListComp")
......@@ -1184,7 +1184,7 @@ checkParStmt _
checkTransformStmt :: HsStmtContext Name -> RnM ()
checkTransformStmt ListComp -- Ensure we are really within a list comprehension because otherwise the
-- desugarer will break when we come to operate on a parallel array
= do { transform_list_comp <- doptM Opt_TransformListComp
= do { transform_list_comp <- xoptM Opt_TransformListComp
; checkErr transform_list_comp msg }
where
msg = ptext (sLit "Illegal transform or grouping list comprehension: use -XTransformListComp")
......@@ -1197,7 +1197,7 @@ checkTransformStmt ctxt = addErr msg
---------
checkTupleSection :: [HsTupArg RdrName] -> RnM ()
checkTupleSection args
= do { tuple_section <- doptM Opt_TupleSections
= do { tuple_section <- xoptM Opt_TupleSections
; checkErr (all tupArgPresent args || tuple_section) msg }
where
msg = ptext (sLit "Illegal tuple section: use -XTupleSections")
......
......@@ -62,12 +62,12 @@ rnImports imports
-- Do the non {- SOURCE -} ones first, so that we get a helpful
-- warning for {- SOURCE -} ones that are unnecessary
= do this_mod <- getModule
implicit_prelude <- doptM Opt_ImplicitPrelude
implicit_prelude <- xoptM Opt_ImplicitPrelude
let prel_imports = mkPrelImports (moduleName this_mod) implicit_prelude imports
(source, ordinary) = partition is_source_import imports
is_source_import (L _ (ImportDecl _ _ is_boot _ _ _)) = is_boot
ifOptM Opt_WarnImplicitPrelude (
ifDOptM Opt_WarnImplicitPrelude (
when (notNull prel_imports) $ addWarn (implicitPreludeWarn)
)
......@@ -99,7 +99,7 @@ rnImportDecl this_mod implicit_prelude
= setSrcSpan loc $ do
when (isJust mb_pkg) $ do
pkg_imports <- doptM Opt_PackageImports
pkg_imports <- xoptM Opt_PackageImports
when (not pkg_imports) $ addErr packageImportErr
-- If there's an error in loadInterface, (e.g. interface
......@@ -117,7 +117,7 @@ rnImportDecl this_mod implicit_prelude
return ()
_ ->
unless implicit_prelude $
ifOptM Opt_WarnMissingImportList (addWarn (missingImportListWarn imp_mod_name))
ifDOptM Opt_WarnMissingImportList (addWarn (missingImportListWarn imp_mod_name))
iface <- loadSrcInterface doc imp_mod_name want_boot mb_pkg
......@@ -229,7 +229,7 @@ rnImportDecl this_mod implicit_prelude
}
-- Complain if we import a deprecated module
ifOptM Opt_WarnWarningsDeprecations (
ifDOptM Opt_WarnWarningsDeprecations (
case warns of
WarnAll txt -> addWarn (moduleWarn imp_mod_name txt)
_ -> return ()
......@@ -525,7 +525,7 @@ filterImports _ decl_spec Nothing all_avails
filterImports iface decl_spec (Just (want_hiding, import_items)) all_avails
= do -- check for errors, convert RdrNames to Names
opt_typeFamilies <- doptM Opt_TypeFamilies
opt_typeFamilies <- xoptM Opt_TypeFamilies
items1 <- mapM (lookup_lie opt_typeFamilies) import_items
let items2 :: [(LIE Name, AvailInfo)]
......@@ -586,7 +586,7 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) all_avails
-- Warn when importing T(..) if T was exported abstractly
checkDodgyImport stuff
| IEThingAll n <- ieRdr, (_, AvailTC _ [_]):_ <- stuff
= ifOptM Opt_WarnDodgyImports (addWarn (dodgyImportWarn n))
= ifDOptM Opt_WarnDodgyImports (addWarn (dodgyImportWarn n))
-- NB. use the RdrName for reporting the warning
checkDodgyImport _
= return ()
......@@ -918,7 +918,7 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod
return acc }
| otherwise
= do { implicit_prelude <- doptM Opt_ImplicitPrelude
= do { implicit_prelude <- xoptM Opt_ImplicitPrelude
; warnDodgyExports <- doptM Opt_WarnDodgyExports
; let { exportValid = (mod `elem` imported_modules)
|| (moduleName this_mod == mod)
......@@ -1004,7 +1004,7 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod
then do addErr (exportItemErr ie)
return (IEThingWith name [], AvailTC name [name])
else do let names = catMaybes mb_names
optTyFam <- doptM Opt_TypeFamilies
optTyFam <- xoptM Opt_TypeFamilies
when (not optTyFam && any isTyConName names) $
addErr (typeItemErr ( head
. filter isTyConName
......@@ -1088,7 +1088,7 @@ finishWarnings :: DynFlags -> Maybe WarningTxt
-- All this happens only once per module
finishWarnings dflags mod_warn tcg_env
= do { (eps,hpt) <- getEpsAndHpt
; ifOptM Opt_WarnWarningsDeprecations $
; ifDOptM Opt_WarnWarningsDeprecations $
mapM_ (check hpt (eps_PIT eps)) all_gres
-- By this time, typechecking is complete,
-- so the PIT is fully populated
......@@ -1242,10 +1242,10 @@ warnUnusedImportDecls gbl_env
; let usage :: [ImportDeclUsage]
usage = findImportUsage imports rdr_env (Set.elems uses)
; ifOptM Opt_WarnUnusedImports $
; ifDOptM Opt_WarnUnusedImports $
mapM_ warnUnusedImport usage
; ifOptM Opt_D_dump_minimal_imports $
; ifDOptM Opt_D_dump_minimal_imports $
printMinimalImports usage }
where
explicit_import (L loc _) = isGoodSrcSpan loc
......
......@@ -299,7 +299,7 @@ rnPatAndThen mk (VarPat rdr) = do { loc <- liftCps getSrcSpanM
-- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple)
rnPatAndThen mk (SigPatIn pat ty)
= do { patsigs <- liftCps (doptM Opt_ScopedTypeVariables)
= do { patsigs <- liftCps (xoptM Opt_ScopedTypeVariables)
; if patsigs
then do { pat' <- rnLPatAndThen mk pat
; ty' <- liftCpsFV (rnHsTypeFVs tvdoc ty)
......@@ -311,7 +311,7 @@ rnPatAndThen mk (SigPatIn pat ty)
rnPatAndThen mk (LitPat lit)
| HsString s <- lit
= do { ovlStr <- liftCps (doptM Opt_OverloadedStrings)
= do { ovlStr <- liftCps (xoptM Opt_OverloadedStrings)
; if ovlStr
then rnPatAndThen mk (mkNPat (mkHsIsString s placeHolderType) Nothing)
else normal_lit }
......@@ -342,7 +342,7 @@ rnPatAndThen mk (AsPat rdr pat)
; return (AsPat (L (nameSrcSpan new_name) new_name) pat') }
rnPatAndThen mk p@(ViewPat expr pat ty)
= do { liftCps $ do { vp_flag <- doptM Opt_ViewPatterns
= do { liftCps $ do { vp_flag <- xoptM Opt_ViewPatterns
; checkErr vp_flag (badViewPat p) }
-- Because of the way we're arranging the recursive calls,
-- this will be in the right context
......@@ -453,8 +453,8 @@ rnHsRecFields1
-- of each x=e binding
rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
= do { pun_ok <- doptM Opt_RecordPuns
; disambig_ok <- doptM Opt_DisambiguateRecordFields
= do { pun_ok <- xoptM Opt_RecordPuns
; disambig_ok <- xoptM Opt_DisambiguateRecordFields
; parent <- check_disambiguation disambig_ok mb_con
; flds1 <- mapM (rn_fld pun_ok parent) flds
; mapM_ (addErr . dupFieldErr ctxt) dup_flds
......@@ -490,7 +490,7 @@ rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }
rn_dotdot (Just n) (Just con) flds -- ".." on record con/pat
= ASSERT( n == length flds )
do { loc <- getSrcSpanM -- Rather approximate
; dd_flag <- doptM Opt_RecordWildCards
; dd_flag <- xoptM Opt_RecordWildCards
; checkErr dd_flag (needFlagDotDot ctxt)
; con_fields <- lookupConstructorFields con
......
......@@ -524,7 +524,7 @@ extendTyVarEnvForMethodBinds :: [LHsTyVarBndr Name]
-> RnM (Bag (LHsBind Name), FreeVars)
-> RnM (Bag (LHsBind Name), FreeVars)
extendTyVarEnvForMethodBinds tyvars thing_inside
= do { scoped_tvs <- doptM Opt_ScopedTypeVariables
= do { scoped_tvs <- xoptM Opt_ScopedTypeVariables
; if scoped_tvs then
extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside
else
......@@ -540,7 +540,7 @@ extendTyVarEnvForMethodBinds tyvars thing_inside
\begin{code}
rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
rnSrcDerivDecl (DerivDecl ty)
= do { standalone_deriv_ok <- doptM Opt_StandaloneDeriving
= do { standalone_deriv_ok <- xoptM Opt_StandaloneDeriving
; unless standalone_deriv_ok (addErr standaloneDerivErr)
; ty' <- rnLHsType (text "a deriving decl") ty
; let fvs = extractHsTyNames ty'
......@@ -1126,7 +1126,7 @@ add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds
-- (i.e. a naked top level expression)
case flag of
Explicit -> return ()
Implicit -> do { th_on <- doptM Opt_TemplateHaskell
Implicit -> do { th_on <- xoptM Opt_TemplateHaskell
; unless th_on $ setSrcSpan loc $
failWith badImplicitSplice }
......
......@@ -116,7 +116,7 @@ rnHsType _ (HsTyVar tyvar) = do
-- Hence the jiggery pokery with ty1
rnHsType doc ty@(HsOpTy ty1 (L loc op) ty2)
= setSrcSpan loc $
do { ops_ok <- doptM Opt_TypeOperators
do { ops_ok <- xoptM Opt_TypeOperators
; op' <- if ops_ok
then lookupOccRn op
else do { addErr (opTyErr op ty)
......@@ -161,7 +161,7 @@ rnHsType doc (HsListTy ty) = do
return (HsListTy ty')
rnHsType doc (HsKindSig ty k)
= do { kind_sigs_ok <- doptM Opt_KindSignatures
= do { kind_sigs_ok <- xoptM Opt_KindSignatures
; unless kind_sigs_ok (addErr (kindSigErr ty))
; ty' <- rnLHsType doc ty
; return (HsKindSig ty' k) }
......@@ -570,7 +570,7 @@ ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
forAllWarn :: SDoc -> LHsType RdrName -> Located RdrName
-> TcRnIf TcGblEnv TcLclEnv ()
forAllWarn doc ty (L loc tyvar)
= ifOptM Opt_WarnUnusedMatches $
= ifDOptM Opt_WarnUnusedMatches $
addWarnAt loc (sep [ptext (sLit "The universally quantified type variable") <+> quotes (ppr tyvar),
nest 4 (ptext (sLit "does not appear in the type") <+> quotes (ppr ty))]
$$
......
......@@ -372,8 +372,8 @@ syntaxNameCtxt name orig ty tidy_env = do
getOverlapFlag :: TcM OverlapFlag
getOverlapFlag
= do { dflags <- getDOpts
; let overlap_ok = dopt Opt_OverlappingInstances dflags
incoherent_ok = dopt Opt_IncoherentInstances dflags
; let overlap_ok = xopt Opt_OverlappingInstances dflags
incoherent_ok = xopt Opt_IncoherentInstances dflags
overlap_flag | incoherent_ok = Incoherent
| overlap_ok = OverlapOk
| otherwise = NoOverlap
......
......@@ -1082,7 +1082,7 @@ decideGeneralisationPlan dflags top_lvl _bndrs binds sig_fn
| Just sig <- one_funbind_with_sig binds = if null (sig_tvs sig) && null (sig_theta sig)
then NoGen -- Optimise common case
else CheckGen sig
| (dopt Opt_MonoLocalBinds dflags
| (xopt Opt_MonoLocalBinds dflags
&& isNotTopLevel top_lvl) = NoGen
| otherwise = InferGen mono_restriction
......@@ -1090,10 +1090,10 @@ decideGeneralisationPlan dflags top_lvl _bndrs binds sig_fn
-- | otherwise = NoGen -- A mixture of function
-- -- and pattern bindings
where
mono_pat_binds = dopt Opt_MonoPatBinds dflags
mono_pat_binds = xopt Opt_MonoPatBinds dflags
&& any (is_pat_bind . unLoc) binds
mono_restriction = dopt Opt_MonomorphismRestriction dflags
mono_restriction = xopt Opt_MonomorphismRestriction dflags
&& any (restricted . unLoc) binds
no_sig n = isNothing (sig_fn n)
......
......@@ -47,7 +47,7 @@ tcDefaults [L _ (DefaultDecl [])]
tcDefaults [L locn (DefaultDecl mono_tys)]
= setSrcSpan locn $
addErrCtxt defaultDeclCtxt $
do { ovl_str <- doptM Opt_OverloadedStrings
do { ovl_str <- xoptM Opt_OverloadedStrings
; num_class <- tcLookupClass numClassName
; is_str_class <- tcLookupClass isStringClassName
; let deflt_clss | ovl_str = [num_class, is_str_class]
......
......@@ -928,7 +928,7 @@ cond_functorOK :: Bool -> Condition
-- (d) optionally: don't use function types
-- (e) no "stupid context" on data type
cond_functorOK allowFunctions (dflags, rep_tc)
| not (dopt Opt_DeriveFunctor dflags)
| not (xopt Opt_DeriveFunctor dflags)
= Just (ptext (sLit "You need -XDeriveFunctor to derive an instance for this class"))
| null tc_tvs
......@@ -971,7 +971,7 @@ cond_functorOK allowFunctions (dflags, rep_tc)