Skip to content

GitLab

Commit a6f2d598 authored by Ian Lynagh's avatar Ian Lynagh
Browse files

Add separate functions for querying DynFlag and ExtensionFlag options 

and remove the temporary DOpt class workaround.
parent 896135d0
Hide whitespace changes
Inline Side-by-side
compiler/deSugar/DsMonad.lhs
View file @ a6f2d598
......@@ -9,7 +9,7 @@
module DsMonad (
DsM, mapM, mapAndUnzipM,
initDs, initDsTc, fixDs,
foldlM, foldrM, ifOptM, unsetOptM,
foldlM, foldrM, ifDOptM, unsetOptM,
Applicative(..),(<$>),
newLocalName,
......
compiler/deSugar/Match.lhs
View file @ a6f2d598
......@@ -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) $
......
compiler/iface/TcIface.lhs
View file @ a6f2d598
......@@ -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 ()
......
compiler/main/DriverPipeline.hs
View file @ a6f2d598
......@@ -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
......
compiler/main/DynFlags.hs
View file @ a6f2d598
......@@ -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 ()
......
compiler/main/GHC.hs
View file @ a6f2d598
......@@ -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
......
compiler/main/HeaderInfo.hs
View file @ a6f2d598
......@@ -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)
......
compiler/main/TidyPgm.lhs
View file @ a6f2d598
......@@ -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
......
compiler/parser/Lexer.x
View file @ a6f2d598
......@@ -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)
......
compiler/parser/RdrHsSyn.lhs
View file @ a6f2d598
......@@ -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
......
compiler/rename/RnBinds.lhs
View file @ a6f2d598
......@@ -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
......
compiler/rename/RnEnv.lhs
View file @ a6f2d598
......@@ -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
......
compiler/rename/RnExpr.lhs
View file @ a6f2d598
......@@ -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")
......
compiler/rename/RnNames.lhs
View file @ a6f2d598
......@@ -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
......
compiler/rename/RnPat.lhs
View file @ a6f2d598
......@@ -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
......
compiler/rename/RnSource.lhs
View file @ a6f2d598
......@@ -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 }
......
compiler/rename/RnTypes.lhs
View file @ a6f2d598
......@@ -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))]
$$
......
compiler/typecheck/Inst.lhs
View file @ a6f2d598
......@@ -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
......
compiler/typecheck/TcBinds.lhs
View file @ a6f2d598
......@@ -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