Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Shayne Fletcher
Glasgow Haskell Compiler
Commits
a6f2d598
Commit
a6f2d598
authored
Sep 18, 2010
by
Ian Lynagh
Browse files
Add separate functions for querying DynFlag and ExtensionFlag options
and remove the temporary DOpt class workaround.
parent
896135d0
Changes
31
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, if
D
OptM, 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)
; if
D
OptM 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
if
D
OptM 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
(
d
opt
Opt_Cpp
dflags1'
)
then
do
if
not
(
x
opt
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
l
opt
::
ExtensionFlag
->
DynFlags
->
Bool
l
opt
f
dflags
=
case
extensionFlags
dflags
of
x
opt
::
ExtensionFlag
->
DynFlags
->
Bool
x
opt
f
dflags
=
case
extensionFlags
dflags
of
Left
_
->
panic
(
"Testing for extension flag "
++
show
f
++
" before flattening"
)
Right
flags
->
f
`
elem
`
flags
-- | Set a 'ExtensionFlag'
l
opt_set
::
DynFlags
->
ExtensionFlag
->
DynFlags
l
opt_set
dfs
f
=
case
extensionFlags
dfs
of
x
opt_set
::
DynFlags
->
ExtensionFlag
->
DynFlags
x
opt_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'
l
opt_set_flattened
::
DynFlags
->
ExtensionFlag
->
DynFlags
l
opt_set_flattened
dfs
f
=
case
extensionFlags
dfs
of
x
opt_set_flattened
::
DynFlags
->
ExtensionFlag
->
DynFlags
x
opt_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'
l
opt_unset
::
DynFlags
->
ExtensionFlag
->
DynFlags
l
opt_unset
dfs
f
=
case
extensionFlags
dfs
of
x
opt_unset
::
DynFlags
->
ExtensionFlag
->
DynFlags
x
opt_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'
l
opt_unset_flattened
::
DynFlags
->
ExtensionFlag
->
DynFlags
l
opt_unset_flattened
dfs
f
=
case
extensionFlags
dfs
of
x
opt_unset_flattened
::
DynFlags
->
ExtensionFlag
->
DynFlags
x
opt_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
->
l
opt_set
dfs
f
)
setExtensionFlag
f
=
do
{
upd
(
\
dfs
->
x
opt_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
->
l
opt_unset
dfs
f
)
unSetExtensionFlag
f
=
upd
(
\
dfs
->
x
opt_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
|
d
opt
Opt_Cpp
dflags'
=
True
|
x
opt
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
(
d
opt
Opt_TemplateHaskell
.
ms_hspp_opts
)
ms
any
(
x
opt
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
=
d
opt
Opt_ImplicitPrelude
dflags
implicit_prelude
=
x
opt
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 =
d
opt Opt_TemplateHaskell dflags
; th =
x
opt 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`
d
opt Opt_Generics flags
.|. ffiBit `setBitIf`
d
opt Opt_ForeignFunctionInterface flags
.|. parrBit `setBitIf`
d
opt Opt_PArr flags
.|. arrowsBit `setBitIf`
d
opt Opt_Arrows flags
.|. thBit `setBitIf`
d
opt Opt_TemplateHaskell flags
.|. qqBit `setBitIf`
d
opt Opt_QuasiQuotes flags
.|. ipBit `setBitIf`
d
opt Opt_ImplicitParams flags
.|. explicitForallBit `setBitIf`
d
opt Opt_ExplicitForAll flags
.|. bangPatBit `setBitIf`
d
opt Opt_BangPatterns flags
.|. tyFamBit `setBitIf`
d
opt Opt_TypeFamilies flags
bitmap = genericsBit `setBitIf`
x
opt Opt_Generics flags
.|. ffiBit `setBitIf`
x
opt Opt_ForeignFunctionInterface flags
.|. parrBit `setBitIf`
x
opt Opt_PArr flags
.|. arrowsBit `setBitIf`
x
opt Opt_Arrows flags
.|. thBit `setBitIf`
x
opt Opt_TemplateHaskell flags
.|. qqBit `setBitIf`
x
opt Opt_QuasiQuotes flags
.|. ipBit `setBitIf`
x
opt Opt_ImplicitParams flags
.|. explicitForallBit `setBitIf`
x
opt Opt_ExplicitForAll flags
.|. bangPatBit `setBitIf`
x
opt Opt_BangPatterns flags
.|. tyFamBit `setBitIf`
x
opt Opt_TypeFamilies flags
.|. haddockBit `setBitIf` dopt Opt_Haddock flags
.|. magicHashBit `setBitIf`
d
opt Opt_MagicHash flags
.|. kindSigsBit `setBitIf`
d
opt Opt_KindSignatures flags
.|. recursiveDoBit `setBitIf`
d
opt Opt_RecursiveDo flags
.|. recBit `setBitIf`
d
opt Opt_DoRec flags
.|. recBit `setBitIf`
d
opt Opt_Arrows flags
.|. unicodeSyntaxBit `setBitIf`
d
opt Opt_UnicodeSyntax flags
.|. unboxedTuplesBit `setBitIf`
d
opt Opt_UnboxedTuples flags
.|. datatypeContextsBit `setBitIf`
d
opt Opt_DatatypeContexts flags
.|. transformComprehensionsBit `setBitIf`
d
opt Opt_TransformListComp flags
.|. magicHashBit `setBitIf`
x
opt Opt_MagicHash flags
.|. kindSigsBit `setBitIf`
x
opt Opt_KindSignatures flags
.|. recursiveDoBit `setBitIf`
x
opt Opt_RecursiveDo flags
.|. recBit `setBitIf`
x
opt Opt_DoRec flags
.|. recBit `setBitIf`
x
opt Opt_Arrows flags
.|. unicodeSyntaxBit `setBitIf`
x
opt Opt_UnicodeSyntax flags
.|. unboxedTuplesBit `setBitIf`
x
opt Opt_UnboxedTuples flags
.|. datatypeContextsBit `setBitIf`
x
opt Opt_DatatypeContexts flags
.|. transformComprehensionsBit `setBitIf`
x
opt Opt_TransformListComp flags
.|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags
.|. newQualOpsBit `setBitIf`
d
opt Opt_NewQualifiedOperators flags
.|. alternativeLayoutRuleBit `setBitIf`
d
opt Opt_AlternativeLayoutRule flags
.|. newQualOpsBit `setBitIf`
x
opt Opt_NewQualifiedOperators flags
.|. alternativeLayoutRuleBit `setBitIf`
x
opt 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 =
d
opt Opt_AlternativeLayoutRuleTransitional dflags
let transitional =
x
opt 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 {}})))
|
d
opt Opt_NPlusKPatterns dynflags && (plus == plus_RDR)
|
x
opt 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 (
d
opt Opt_DoAndIfThenElse (dflags pState)) $ do
unless (
x
opt 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 <-
d
optM Opt_PatternGuards
= do { pattern_guards_allowed <-
x
optM 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 <-
d
optM Opt_TypeOperators
(do { op_ok <-
x
optM 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
=
d
optM Opt_ImplicitPrelude `thenM` \ implicit_prelude ->
=
x
optM 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
=
d
optM Opt_ImplicitPrelude `thenM` \ implicit_prelude ->
=
x
optM 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 <-
d
optM Opt_KindSignatures
do { kind_sigs_ok <-
x
optM 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 <-
d
optM Opt_ScopedTypeVariables
= do { scoped_tyvars <-
x
optM 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 <-
d
optM Opt_ScopedTypeVariables
= do { scoped_tyvars <-
x
optM 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 $
= if
D
OptM 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 (
d
opt Opt_RecordPuns dflags ||
d
opt Opt_RecordWildCards dflags)
; if (
x
opt Opt_RecordPuns dflags ||
x
opt 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
= if
D
OptM 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))
= if
D
OptM 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 <-
d
optM Opt_OverloadedStrings
opt_OverloadedStrings <-
x
optM 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 <-
d
optM Opt_ParallelListComp
= do { parallel_list_comp <-
x
optM 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 <-
d
optM Opt_TransformListComp
= do { transform_list_comp <-
x
optM 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 <-
d
optM Opt_TupleSections
= do { tuple_section <-
x
optM 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 <-
d
optM Opt_ImplicitPrelude
implicit_prelude <-
x
optM 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 (
if
D
OptM 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 <-
d
optM Opt_PackageImports
pkg_imports <-
x
optM 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))
if
D
OptM 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 (
if
D
OptM 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 <-
d
optM Opt_TypeFamilies
opt_typeFamilies <-
x
optM 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))
= if
D
OptM 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 <-
d
optM Opt_ImplicitPrelude
= do { implicit_prelude <-
x
optM 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 <-
d
optM Opt_TypeFamilies
optTyFam <-
x
optM 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 $
; if
D
OptM 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 $
; if
D
OptM Opt_WarnUnusedImports $
mapM_ warnUnusedImport usage
; ifOptM Opt_D_dump_minimal_imports $
; if
D
OptM 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 (
d
optM Opt_ScopedTypeVariables)
= do { patsigs <- liftCps (
x
optM 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 (
d
optM Opt_OverloadedStrings)
= do { ovlStr <- liftCps (
x
optM 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 <-
d
optM Opt_ViewPatterns
= do { liftCps $ do { vp_flag <-
x
optM 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 <-
d
optM Opt_RecordPuns
; disambig_ok <-
d
optM Opt_DisambiguateRecordFields
= do { pun_ok <-
x
optM Opt_RecordPuns
; disambig_ok <-
x
optM 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 <-
d
optM Opt_RecordWildCards
; dd_flag <-
x
optM 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 <-
d
optM Opt_ScopedTypeVariables
= do { scoped_tvs <-
x
optM 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 <-
d
optM Opt_StandaloneDeriving
= do { standalone_deriv_ok <-
x
optM 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 <-
d
optM Opt_TemplateHaskell
Implicit -> do { th_on <-
x
optM 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 <-
d
optM Opt_TypeOperators
do { ops_ok <-
x
optM 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 <-
d
optM Opt_KindSignatures
= do { kind_sigs_ok <-
x
optM 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 $
= if
D
OptM 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 =
d
opt Opt_OverlappingInstances dflags
incoherent_ok =
d
opt Opt_IncoherentInstances dflags
; let overlap_ok =
x
opt Opt_OverlappingInstances dflags
incoherent_ok =
x
opt 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
| (
d
opt Opt_MonoLocalBinds dflags
| (
x
opt 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 =
d
opt Opt_MonoPatBinds dflags
mono_pat_binds =
x
opt Opt_MonoPatBinds dflags