and remove the temporary DOpt class workaround.
31 files changed:
module DsMonad (
DsM, mapM, mapAndUnzipM,
initDs, initDsTc, fixDs,
module DsMonad (
DsM, mapM, mapAndUnzipM,
initDs, initDsTc, fixDs,
- foldlM, foldrM, ifOptM, unsetOptM,
+ foldlM, foldrM, ifDOptM, unsetOptM,
Applicative(..),(<$>),
newLocalName,
Applicative(..),(<$>),
newLocalName,
; let grouped = groupEquations tidy_eqns
-- print the view patterns that are commoned up to help debug
; 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) $
; match_results <- mapM match_group grouped
; return (adjustMatchResult (foldr1 (.) aux_binds) $
core_expr' <- tcIfaceExpr expr
-- Check for type consistency in the unfolding
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 ()
in_scope <- get_in_scope_ids
case lintUnfolding noSrcLoc in_scope core_expr' of
Nothing -> return ()
checkProcessArgsResult unhandled_flags
let dflags1' = flattenExtensionFlags dflags1
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
-- we have to be careful to emit warnings only once.
unless (dopt Opt_Pp dflags1') $ handleFlagWarnings dflags1' warns
-- flags. Dynamic flags can also be set at the prompt in GHCi.
module DynFlags (
-- * Dynamic flags and associated configuration types
-- flags. Dynamic flags can also be set at the prompt in GHCi.
module DynFlags (
-- * Dynamic flags and associated configuration types
DynFlag(..),
ExtensionFlag(..),
glasgowExtsFlags,
flattenExtensionFlags,
ensureFlattenedExtensionFlags,
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,
DynFlags(..),
RtsOptsEnabled(..),
HscTarget(..), isObjectTarget, defaultObjectTarget,
Opt_DoAndIfThenElse,
Opt_RelaxedPolyRec]
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
-- | 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)
-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 }
-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
-- | 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'
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'
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'
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'
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 ->
Left _ ->
panic ("Unsetting extension flag " ++ show f ++ " before flattening, but expected flattened")
Right flags ->
--------------------------
setExtensionFlag, unSetExtensionFlag :: ExtensionFlag -> DynP ()
--------------------------
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 ]
; mapM_ setExtensionFlag deps }
where
deps = [ d | (f', d) <- impliedFlags, f' == 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)
-- 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 ()
--------------------------
setDumpFlag' :: DynFlag -> DynP ()
| 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
| 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
| dopt Opt_Pp dflags' = True
| otherwise = False
-- have Template Haskell enabled whether it is actually needed or not.
needsTemplateHaskell :: ModuleGraph -> Bool
needsTemplateHaskell ms =
-- 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
-- | Return @True@ <==> module is loaded.
isLoaded :: GhcMonad m => ModuleName -> m Bool
ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)
ord_idecls
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)
implicit_imports = mkPrelImports (unLoc mod) implicit_prelude imps
in
return (src_idecls, implicit_imports ++ ordinary_imps, mod)
= do { let { dflags = hsc_dflags hsc_env
; omit_prags = dopt Opt_OmitInterfacePragmas dflags
; expose_all = dopt Opt_ExposeAllUnfoldings dflags
= 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
}
; showPass dflags CoreTidy
alr_justClosedExplicitLetBlock = False
}
where
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
.|. 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
.|. 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
--
setBitIf :: Int -> Bool -> Int
b `setBitIf` cond | cond = bit b
justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock
setJustClosedExplicitLetBlock False
dflags <- getDynFlags
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)
thisLoc = getLoc t
thisCol = srcSpanStartCol thisLoc
newLine = (lastLoc == noSrcSpan)
-- n+k patterns
OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
(L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
-- 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
-> return (mkNPlusKPat (L nloc n) lit)
OpApp l op _fix r -> do l <- checkLPat l
checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
| semiThen || semiElse
= do pState <- getPState
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
parseErrorSDoc (combineLocs guardExpr elseExpr)
(text "Unexpected semi-colons in conditional:"
$$ nest 4 expr
rnGRHS' :: HsMatchContext Name -> GRHS RdrName -> RnM (GRHS Name, FreeVars)
rnGRHS' ctxt (GRHS guards rhs)
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
; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) guards $
rnLExpr rhs
-- See Note [Type and class operator definitions]
let occ = rdrNameOcc rdr_name
; when (isTcOcc occ && isSymOcc occ)
-- 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
; unless op_ok (addErr (opDeclErr rdr_name)) })
; mb_gre <- lookupGreLocalRn rdr_name
lookupSyntaxName :: Name -- The standard name
-> RnM (SyntaxExpr Name, FreeVars) -- Possibly a non-standard name
lookupSyntaxName std_name
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
if implicit_prelude then normal_case
else
-- Get the similarly named thing from the local environment
lookupSyntaxTable :: [Name] -- Standard names
-> RnM (SyntaxTable Name, FreeVars) -- See comments with HsExpr.ReboundNames
lookupSyntaxTable std_names
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
if implicit_prelude then normal_case
else
-- Get the similarly named thing from the local environment
-- Haskell-98 binding of type variables; e.g. within a data type decl
bindTyVarsRn tyvar_names enclosed_scope
= bindLocatedLocalsRn located_tyvars $ \ names ->
-- 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) }
; unless (null kinded_tyvars || kind_sigs_ok)
(mapM_ (addErr . kindSigErr) kinded_tyvars)
; enclosed_scope (zipWith replace tyvar_names names) }
-- Find the type variables in the pattern type
-- signatures that must be brought into scope
bindPatSigTyVars tys thing_inside
-- 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
; if not scoped_tyvars then
thing_inside []
else
-> RnM (a, FreeVars)
-> RnM (a, FreeVars)
bindSigTyVarsFV tvs thing_inside
-> 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
; if not scoped_tyvars then
thing_inside
else
-------------------------------------
checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv) -> [(SrcSpan,OccName)] -> RnM ()
checkShadowedOccs (global_env,local_env) loc_occs
-------------------------------------
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
do { traceRn (text "shadow" <+> ppr loc_occs)
; mapM_ check_shadow loc_occs }
where
-- punning or wild-cards are on (cf Trac #2723)
is_shadowed_gre gre@(GRE { gre_par = ParentIs _ })
= do { dflags <- getDOpts
-- 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
then do { is_fld <- is_rec_fld gre; return (not is_fld) }
else return True }
is_shadowed_gre _other = return True
\begin{code}
warnUnusedTopBinds :: [GlobalRdrElt] -> RnM ()
warnUnusedTopBinds gres
\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
$ do isBoot <- tcIsHsBoot
let noParent gre = case gre_par gre of
NoParent -> True
check_unused :: DynFlag -> [Name] -> FreeVars -> RnM ()
check_unused flag bound_names used_names
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
-------------------------
-- Helpers
rnExpr (HsLit lit@(HsString s))
= do {
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
; if opt_OverloadedStrings then
rnExpr (HsOverLit (mkHsIsString s placeHolderType))
else -- Same as below
---------
checkParStmt :: HsStmtContext Name -> RnM ()
checkParStmt _
---------
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")
; checkErr parallel_list_comp msg }
where
msg = ptext (sLit "Illegal parallel list comprehension: use -XParallelListComp")
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
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")
; checkErr transform_list_comp msg }
where
msg = ptext (sLit "Illegal transform or grouping list comprehension: use -XTransformListComp")
---------
checkTupleSection :: [HsTupArg RdrName] -> RnM ()
checkTupleSection args
---------
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")
; checkErr (all tupArgPresent args || tuple_section) msg }
where
msg = ptext (sLit "Illegal tuple section: use -XTupleSections")
-- Do the non {- SOURCE -} ones first, so that we get a helpful
-- warning for {- SOURCE -} ones that are unnecessary
= do this_mod <- getModule
-- 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
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)
)
when (notNull prel_imports) $ addWarn (implicitPreludeWarn)
)
= setSrcSpan loc $ do
when (isJust mb_pkg) $ do
= 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
when (not pkg_imports) $ addErr packageImportErr
-- If there's an error in loadInterface, (e.g. interface
return ()
_ ->
unless 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
iface <- loadSrcInterface doc imp_mod_name want_boot mb_pkg
}
-- Complain if we import a deprecated module
}
-- 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 ()
case warns of
WarnAll txt -> addWarn (moduleWarn imp_mod_name txt)
_ -> return ()
filterImports iface decl_spec (Just (want_hiding, import_items)) all_avails
= do -- check for errors, convert RdrNames to Names
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)]
items1 <- mapM (lookup_lie opt_typeFamilies) import_items
let items2 :: [(LIE Name, AvailInfo)]
-- Warn when importing T(..) if T was exported abstractly
checkDodgyImport stuff
| IEThingAll n <- ieRdr, (_, AvailTC _ [_]):_ <- stuff
-- 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 ()
-- NB. use the RdrName for reporting the warning
checkDodgyImport _
= return ()
- = 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)
; warnDodgyExports <- doptM Opt_WarnDodgyExports
; let { exportValid = (mod `elem` imported_modules)
|| (moduleName this_mod == mod)
then do addErr (exportItemErr ie)
return (IEThingWith name [], AvailTC name [name])
else do let names = catMaybes mb_names
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
when (not optTyFam && any isTyConName names) $
addErr (typeItemErr ( head
. filter isTyConName
-- All this happens only once per module
finishWarnings dflags mod_warn tcg_env
= do { (eps,hpt) <- getEpsAndHpt
-- 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
mapM_ (check hpt (eps_PIT eps)) all_gres
-- By this time, typechecking is complete,
-- so the PIT is fully populated
; let usage :: [ImportDeclUsage]
usage = findImportUsage imports rdr_env (Set.elems uses)
; let usage :: [ImportDeclUsage]
usage = findImportUsage imports rdr_env (Set.elems uses)
- ; ifOptM Opt_WarnUnusedImports $
+ ; ifDOptM Opt_WarnUnusedImports $
mapM_ warnUnusedImport usage
mapM_ warnUnusedImport usage
- ; ifOptM Opt_D_dump_minimal_imports $
+ ; ifDOptM Opt_D_dump_minimal_imports $
printMinimalImports usage }
where
explicit_import (L loc _) = isGoodSrcSpan loc
printMinimalImports usage }
where
explicit_import (L loc _) = isGoodSrcSpan loc
-- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple)
rnPatAndThen mk (SigPatIn pat ty)
-- (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)
; if patsigs
then do { pat' <- rnLPatAndThen mk pat
; ty' <- liftCpsFV (rnHsTypeFVs tvdoc ty)
rnPatAndThen mk (LitPat lit)
| HsString s <- lit
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 }
; if ovlStr
then rnPatAndThen mk (mkNPat (mkHsIsString s placeHolderType) Nothing)
else normal_lit }
; return (AsPat (L (nameSrcSpan new_name) new_name) pat') }
rnPatAndThen mk p@(ViewPat expr pat ty)
; 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
; checkErr vp_flag (badViewPat p) }
-- Because of the way we're arranging the recursive calls,
-- this will be in the right context
-- of each x=e binding
rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
-- 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
; parent <- check_disambiguation disambig_ok mb_con
; flds1 <- mapM (rn_fld pun_ok parent) flds
; mapM_ (addErr . dupFieldErr ctxt) dup_flds
rn_dotdot (Just n) (Just con) flds -- ".." on record con/pat
= ASSERT( n == length flds )
do { loc <- getSrcSpanM -- Rather approximate
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
; checkErr dd_flag (needFlagDotDot ctxt)
; con_fields <- lookupConstructorFields con
-> RnM (Bag (LHsBind Name), FreeVars)
-> RnM (Bag (LHsBind Name), FreeVars)
extendTyVarEnvForMethodBinds tyvars thing_inside
-> 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
; if scoped_tvs then
extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside
else
\begin{code}
rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
rnSrcDerivDecl (DerivDecl ty)
\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'
; unless standalone_deriv_ok (addErr standaloneDerivErr)
; ty' <- rnLHsType (text "a deriving decl") ty
; let fvs = extractHsTyNames ty'
-- (i.e. a naked top level expression)
case flag of
Explicit -> return ()
-- (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 }
; unless th_on $ setSrcSpan loc $
failWith badImplicitSplice }
-- Hence the jiggery pokery with ty1
rnHsType doc ty@(HsOpTy ty1 (L loc op) ty2)
= setSrcSpan loc $
-- 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)
; op' <- if ops_ok
then lookupOccRn op
else do { addErr (opTyErr op ty)
return (HsListTy ty')
rnHsType doc (HsKindSig ty k)
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) }
; unless kind_sigs_ok (addErr (kindSigErr ty))
; ty' <- rnLHsType doc ty
; return (HsKindSig ty' k) }
forAllWarn :: SDoc -> LHsType RdrName -> Located RdrName
-> TcRnIf TcGblEnv TcLclEnv ()
forAllWarn doc ty (L loc tyvar)
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))]
$$
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))]
$$
getOverlapFlag :: TcM OverlapFlag
getOverlapFlag
= do { dflags <- getDOpts
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
overlap_flag | incoherent_ok = Incoherent
| overlap_ok = OverlapOk
| otherwise = NoOverlap
| Just sig <- one_funbind_with_sig binds = if null (sig_tvs sig) && null (sig_theta sig)
then NoGen -- Optimise common case
else CheckGen sig
| 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
&& isNotTopLevel top_lvl) = NoGen
| otherwise = InferGen mono_restriction
-- | otherwise = NoGen -- A mixture of function
-- -- and pattern bindings
where
-- | 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
&& 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)
&& any (restricted . unLoc) binds
no_sig n = isNothing (sig_fn n)
tcDefaults [L locn (DefaultDecl mono_tys)]
= setSrcSpan locn $
addErrCtxt defaultDeclCtxt $
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]
; num_class <- tcLookupClass numClassName
; is_str_class <- tcLookupClass isStringClassName
; let deflt_clss | ovl_str = [num_class, is_str_class]
-- (d) optionally: don't use function types
-- (e) no "stupid context" on data type
cond_functorOK allowFunctions (dflags, rep_tc)
-- (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
= Just (ptext (sLit "You need -XDeriveFunctor to derive an instance for this class"))
| null tc_tvs
checkFlag :: ExtensionFlag -> Condition
checkFlag flag (dflags, _)
checkFlag :: ExtensionFlag -> Condition
checkFlag flag (dflags, _)
- | dopt flag dflags = Nothing
+ | xopt flag dflags = Nothing
| otherwise = Just why
where
why = ptext (sLit "You need -X") <> text flag_str
| otherwise = Just why
where
why = ptext (sLit "You need -X") <> text flag_str
| can_derive_via_isomorphism -> bale_out (non_std $$ suggest_nd) -- Try newtype deriving!
| otherwise -> bale_out non_std
where
| can_derive_via_isomorphism -> bale_out (non_std $$ suggest_nd) -- Try newtype deriving!
| otherwise -> bale_out non_std
where
- newtype_deriving = dopt Opt_GeneralizedNewtypeDeriving dflags
+ newtype_deriving = xopt Opt_GeneralizedNewtypeDeriving dflags
go_for_it = mk_data_eqn orig tvs cls tycon tc_args rep_tycon rep_tc_args mtheta
bale_out msg = failWithTc (derivingThingErr newtype_deriving cls cls_tys inst_ty msg)
go_for_it = mk_data_eqn orig tvs cls tycon tc_args rep_tycon rep_tc_args mtheta
bale_out msg = failWithTc (derivingThingErr newtype_deriving cls cls_tys inst_ty msg)
Bool)) -- True <=> Use extended defaulting rules
tcGetDefaultTys interactive
= do { dflags <- getDOpts
Bool)) -- True <=> Use extended defaulting rules
tcGetDefaultTys interactive
= do { dflags <- getDOpts
- ; let ovl_strings = dopt Opt_OverloadedStrings dflags
+ ; let ovl_strings = xopt Opt_OverloadedStrings dflags
extended_defaults = interactive
extended_defaults = interactive
- || dopt Opt_ExtendedDefaultRules dflags
+ || xopt Opt_ExtendedDefaultRules dflags
-- See also Trac #1974
flags = (ovl_strings, extended_defaults)
-- See also Trac #1974
flags = (ovl_strings, extended_defaults)
monomorphism_fix dflags
= ptext (sLit "Probable fix:") <+> vcat
[ptext (sLit "give these definition(s) an explicit type signature"),
monomorphism_fix dflags
= ptext (sLit "Probable fix:") <+> vcat
[ptext (sLit "give these definition(s) an explicit type signature"),
- if dopt Opt_MonomorphismRestriction dflags
+ if xopt Opt_MonomorphismRestriction dflags
then ptext (sLit "or use -XNoMonomorphismRestriction")
else empty] -- Only suggest adding "-XNoMonomorphismRestriction"
-- if it is not already set!
then ptext (sLit "or use -XNoMonomorphismRestriction")
else empty] -- Only suggest adding "-XNoMonomorphismRestriction"
-- if it is not already set!
tcExpr (SectionL arg1 op) res_ty
= do { (op', op_ty) <- tcInferFun op
; dflags <- getDOpts -- Note [Left sections]
tcExpr (SectionL arg1 op) res_ty
= do { (op', op_ty) <- tcInferFun op
; dflags <- getDOpts -- Note [Left sections]
- ; let n_reqd_args | dopt Opt_PostfixOperators dflags = 1
+ ; let n_reqd_args | xopt Opt_PostfixOperators dflags = 1
| otherwise = 2
; (co_fn, (arg1_ty:arg_tys), op_res_ty) <- unifyOpFunTys op n_reqd_args op_ty
| otherwise = 2
; (co_fn, (arg1_ty:arg_tys), op_res_ty) <- unifyOpFunTys op n_reqd_args op_ty
return idecl
| cconv == PrimCallConv = do
dflags <- getDOpts
return idecl
| cconv == PrimCallConv = do
dflags <- getDOpts
- check (dopt Opt_GHCForeignImportPrim dflags)
+ check (xopt Opt_GHCForeignImportPrim dflags)
(text "Use -XGHCForeignImportPrim to allow `foreign import prim'.")
checkCg (checkCOrAsmOrLlvmOrDotNetOrInterp)
checkCTarget target
(text "Use -XGHCForeignImportPrim to allow `foreign import prim'.")
checkCg (checkCOrAsmOrLlvmOrDotNetOrInterp)
checkCTarget target
-- Checks that the type is valid for the given context
checkValidType ctxt ty = do
traceTc "checkValidType" (ppr ty)
-- Checks that the type is valid for the given context
checkValidType ctxt ty = do
traceTc "checkValidType" (ppr ty)
- unboxed <- doptM Opt_UnboxedTuples
- rank2 <- doptM Opt_Rank2Types
- rankn <- doptM Opt_RankNTypes
- polycomp <- doptM Opt_PolymorphicComponents
+ unboxed <- xoptM Opt_UnboxedTuples
+ rank2 <- xoptM Opt_Rank2Types
+ rankn <- xoptM Opt_RankNTypes
+ polycomp <- xoptM Opt_PolymorphicComponents
let
gen_rank n | rankn = ArbitraryRank
| rank2 = Rank 2
let
gen_rank n | rankn = ArbitraryRank
| rank2 = Rank 2
checkTc (tyConArity tc <= length tys) arity_msg
-- See Note [Liberal type synonyms]
checkTc (tyConArity tc <= length tys) arity_msg
-- See Note [Liberal type synonyms]
- ; liberal <- doptM Opt_LiberalTypeSynonyms
+ ; liberal <- xoptM Opt_LiberalTypeSynonyms
; if not liberal || isSynFamilyTyCon tc then
-- For H98 and synonym families, do check the type args
mapM_ (check_mono_type SynArgMonoType) tys
; if not liberal || isSynFamilyTyCon tc then
-- For H98 and synonym families, do check the type args
mapM_ (check_mono_type SynArgMonoType) tys
}
| isUnboxedTupleTyCon tc
}
| isUnboxedTupleTyCon tc
- = do { ub_tuples_allowed <- doptM Opt_UnboxedTuples
+ = do { ub_tuples_allowed <- xoptM Opt_UnboxedTuples
; checkTc (ubx_tup_ok ub_tuples_allowed) ubx_tup_msg
; checkTc (ubx_tup_ok ub_tuples_allowed) ubx_tup_msg
- ; impred <- doptM Opt_ImpredicativeTypes
+ ; impred <- xoptM Opt_ImpredicativeTypes
; let rank' = if impred then ArbitraryRank else TyConArgMonoType
-- c.f. check_arg_type
-- However, args are allowed to be unlifted, or
; let rank' = if impred then ArbitraryRank else TyConArgMonoType
-- c.f. check_arg_type
-- However, args are allowed to be unlifted, or
-- Anyway, they are dealt with by a special case in check_tau_type
check_arg_type rank ty
-- Anyway, they are dealt with by a special case in check_tau_type
check_arg_type rank ty
- = do { impred <- doptM Opt_ImpredicativeTypes
+ = do { impred <- xoptM Opt_ImpredicativeTypes
; let rank' = case rank of -- Predictive => must be monotype
MustBeMonoType -> MustBeMonoType -- Monotype, regardless
_other | impred -> ArbitraryRank
; let rank' = case rank of -- Predictive => must be monotype
MustBeMonoType -> MustBeMonoType -- Monotype, regardless
_other | impred -> ArbitraryRank
check_pred_ty dflags _ pred@(EqPred ty1 ty2)
= do { -- Equational constraints are valid in all contexts if type
-- families are permitted
check_pred_ty dflags _ pred@(EqPred ty1 ty2)
= do { -- Equational constraints are valid in all contexts if type
-- families are permitted
- ; checkTc (dopt Opt_TypeFamilies dflags) (eqPredTyErr pred)
+ ; checkTc (xopt Opt_TypeFamilies dflags) (eqPredTyErr pred)
-- Check the form of the argument types
; checkValidMonoType ty1
-- Check the form of the argument types
; checkValidMonoType ty1
-- checkInstTermination
_ -> flexible_contexts || all tyvar_head tys
where
-- checkInstTermination
_ -> flexible_contexts || all tyvar_head tys
where
- flexible_contexts = dopt Opt_FlexibleContexts dflags
- undecidable_ok = dopt Opt_UndecidableInstances dflags
+ flexible_contexts = xopt Opt_FlexibleContexts dflags
+ undecidable_ok = xopt Opt_UndecidableInstances dflags
-------------------------
tyvar_head :: Type -> Bool
-------------------------
tyvar_head :: Type -> Bool
check_inst_head :: DynFlags -> Class -> [Type] -> TcM ()
check_inst_head dflags clas tys
= do { -- If GlasgowExts then check at least one isn't a type variable
check_inst_head :: DynFlags -> Class -> [Type] -> TcM ()
check_inst_head dflags clas tys
= do { -- If GlasgowExts then check at least one isn't a type variable
- ; checkTc (dopt Opt_TypeSynonymInstances dflags ||
+ ; checkTc (xopt Opt_TypeSynonymInstances dflags ||
all tcInstHeadTyNotSynonym tys)
(instTypeErr (pprClassPred clas tys) head_type_synonym_msg)
all tcInstHeadTyNotSynonym tys)
(instTypeErr (pprClassPred clas tys) head_type_synonym_msg)
- ; checkTc (dopt Opt_FlexibleInstances dflags ||
+ ; checkTc (xopt Opt_FlexibleInstances dflags ||
all tcInstHeadTyAppAllTyVars tys)
(instTypeErr (pprClassPred clas tys) head_type_args_tyvars_msg)
all tcInstHeadTyAppAllTyVars tys)
(instTypeErr (pprClassPred clas tys) head_type_args_tyvars_msg)
- ; checkTc (dopt Opt_MultiParamTypeClasses dflags ||
+ ; checkTc (xopt Opt_MultiParamTypeClasses dflags ||
isSingleton tys)
(instTypeErr (pprClassPred clas tys) head_one_type_msg)
-- May not contain type family applications
isSingleton tys)
(instTypeErr (pprClassPred clas tys) head_one_type_msg)
-- May not contain type family applications
do { (clas, inst_tys) <- setSrcSpan head_loc $
checkValidInstHead tau
do { (clas, inst_tys) <- setSrcSpan head_loc $
checkValidInstHead tau
- ; undecidable_ok <- doptM Opt_UndecidableInstances
+ ; undecidable_ok <- xoptM Opt_UndecidableInstances
; checkValidTheta InstThetaCtxt theta
; checkAmbiguity tyvars theta (tyVarsOfTypes inst_tys)
; checkValidTheta InstThetaCtxt theta
; checkAmbiguity tyvars theta (tyVarsOfTypes inst_tys)
; checkValidMonoType rhs
-- we have a decidable instance unless otherwise permitted
; checkValidMonoType rhs
-- we have a decidable instance unless otherwise permitted
- ; undecidable_ok <- doptM Opt_UndecidableInstances
+ ; undecidable_ok <- xoptM Opt_UndecidableInstances
; unless undecidable_ok $
mapM_ addErrTc (checkFamInst typats (tyFamInsts rhs))
}
; unless undecidable_ok $
mapM_ addErrTc (checkFamInst typats (tyFamInsts rhs))
}
-- dictionary binders from theta'
no_equalities = not (any isEqPred theta')
-- dictionary binders from theta'
no_equalities = not (any isEqPred theta')
- ; gadts_on <- doptM Opt_GADTs
+ ; gadts_on <- xoptM Opt_GADTs
; checkTc (no_equalities || gadts_on)
(ptext (sLit "A pattern match on a GADT requires -XGADTs"))
-- Trac #2905 decided that a *pattern-match* of a GADT
; checkTc (no_equalities || gadts_on)
(ptext (sLit "A pattern match on a GADT requires -XGADTs"))
-- Trac #2905 decided that a *pattern-match* of a GADT
getDOpts :: TcRnIf gbl lcl DynFlags
getDOpts = do { env <- getTopEnv; return (hsc_dflags env) }
getDOpts :: TcRnIf gbl lcl DynFlags
getDOpts = do { env <- getTopEnv; return (hsc_dflags env) }
-doptM :: DOpt d => d -> TcRnIf gbl lcl Bool
+xoptM :: ExtensionFlag -> TcRnIf gbl lcl Bool
+xoptM flag = do { dflags <- getDOpts; return (xopt flag dflags) }
+
+doptM :: DynFlag -> TcRnIf gbl lcl Bool
doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) }
-- XXX setOptM and unsetOptM operate on different types. One should be renamed.
setOptM :: ExtensionFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setOptM flag = updEnv (\ env@(Env { env_top = top }) ->
doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) }
-- XXX setOptM and unsetOptM operate on different types. One should be renamed.
setOptM :: ExtensionFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setOptM flag = updEnv (\ env@(Env { env_top = top }) ->
- env { env_top = top { hsc_dflags = lopt_set_flattened (hsc_dflags top) flag}} )
+ env { env_top = top { hsc_dflags = xopt_set_flattened (hsc_dflags top) flag}} )
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}} )
-- | Do it flag is true
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}} )
-- | Do it flag is true
-ifOptM :: DOpt d => d -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
-ifOptM flag thing_inside = do { b <- doptM flag;
+ifDOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
+ifDOptM flag thing_inside = do { b <- doptM flag;
+ if b then thing_inside else return () }
+
+ifXOptM :: ExtensionFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
+ifXOptM flag thing_inside = do { b <- xoptM flag;
if b then thing_inside else return () }
getGhcMode :: TcRnIf gbl lcl GhcMode
if b then thing_inside else return () }
getGhcMode :: TcRnIf gbl lcl GhcMode
traceOptIf :: DynFlag -> SDoc -> TcRnIf m n () -- No RdrEnv available, so qualify everything
traceOptIf :: DynFlag -> SDoc -> TcRnIf m n () -- No RdrEnv available, so qualify everything
-traceOptIf flag doc = ifOptM flag $
+traceOptIf flag doc = ifDOptM flag $
liftIO (printForUser stderr alwaysQualify doc)
traceOptTcRn :: DynFlag -> SDoc -> TcRn ()
-- Output the message, with current location if opt_PprStyle_Debug
liftIO (printForUser stderr alwaysQualify doc)
traceOptTcRn :: DynFlag -> SDoc -> TcRn ()
-- Output the message, with current location if opt_PprStyle_Debug
-traceOptTcRn flag doc = ifOptM flag $ do
+traceOptTcRn flag doc = ifDOptM flag $ do
{ loc <- getSrcSpanM
; let real_doc
| opt_PprStyle_Debug = mkLocMessage loc doc
{ loc <- getSrcSpanM
; let real_doc
| opt_PprStyle_Debug = mkLocMessage loc doc
| otherwise = dumpTcRn doc
dumpOptTcRn :: DynFlag -> SDoc -> TcRn ()
| otherwise = dumpTcRn doc
dumpOptTcRn :: DynFlag -> SDoc -> TcRn ()
-dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc)
+dumpOptTcRn flag doc = ifDOptM flag (dumpTcRn doc)
-- Bleat about errors in the forked thread, if -ddump-if-trace is on
-- Otherwise we silently discard errors. Errors can legitimately
-- happen when compiling interface signatures (see tcInterfaceSigs)
-- Bleat about errors in the forked thread, if -ddump-if-trace is on
-- Otherwise we silently discard errors. Errors can legitimately
-- happen when compiling interface signatures (see tcInterfaceSigs)
- ifOptM Opt_D_dump_if_trace
+ ifDOptM Opt_D_dump_if_trace
(print_errs (hang (text "forkM failed:" <+> doc)
2 (text (show exn))))
(print_errs (hang (text "forkM failed:" <+> doc)
2 (text (show exn))))
tcAddDeclCtxt decl $
do { -- type family instances require -XTypeFamilies
-- and can't (currently) be in an hs-boot file
tcAddDeclCtxt decl $
do { -- type family instances require -XTypeFamilies
-- and can't (currently) be in an hs-boot file
- ; type_families <- doptM Opt_TypeFamilies
+ ; type_families <- xoptM Opt_TypeFamilies
; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
; checkTc type_families $ badFamInstDecl (tcdLName decl)
; checkTc (not is_boot) $ badBootFamInstDeclErr
; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
; checkTc type_families $ badFamInstDecl (tcdLName decl)
; checkTc (not is_boot) $ badBootFamInstDeclErr
; mapM_ checkTyFamFreeness t_typats
-- Check that we don't use GADT syntax in H98 world
; mapM_ checkTyFamFreeness t_typats
-- Check that we don't use GADT syntax in H98 world
- ; gadt_ok <- doptM Opt_GADTs
+ ; gadt_ok <- xoptM Opt_GADTs
; checkTc (gadt_ok || consUseH98Syntax cons) (badGadtDecl tc_name)
-- (b) a newtype has exactly one constructor
; checkTc (gadt_ok || consUseH98Syntax cons) (badGadtDecl tc_name)
-- (b) a newtype has exactly one constructor
{ traceTc "type family:" (ppr tc_name)
-- Check that we don't use families without -XTypeFamilies
{ traceTc "type family:" (ppr tc_name)
-- Check that we don't use families without -XTypeFamilies
- ; idx_tys <- doptM Opt_TypeFamilies
+ ; idx_tys <- xoptM Opt_TypeFamilies
; checkTc idx_tys $ badFamInstDecl tc_name
; tycon <- buildSynTyCon tc_name tvs' SynFamilyTyCon kind parent Nothing
; checkTc idx_tys $ badFamInstDecl tc_name
; tycon <- buildSynTyCon tc_name tvs' SynFamilyTyCon kind parent Nothing
-- Check that we don't use families without -XTypeFamilies
-- Check that we don't use families without -XTypeFamilies
- ; idx_tys <- doptM Opt_TypeFamilies
+ ; idx_tys <- xoptM Opt_TypeFamilies
; checkTc idx_tys $ badFamInstDecl tc_name
; tycon <- buildAlgTyCon tc_name final_tvs []
; checkTc idx_tys $ badFamInstDecl tc_name
; tycon <- buildAlgTyCon tc_name final_tvs []
{ extra_tvs <- tcDataKindSig mb_ksig
; let final_tvs = tvs' ++ extra_tvs
; stupid_theta <- tcHsKindedContext ctxt
{ extra_tvs <- tcDataKindSig mb_ksig
; let final_tvs = tvs' ++ extra_tvs
; stupid_theta <- tcHsKindedContext ctxt
- ; want_generic <- doptM Opt_Generics
+ ; want_generic <- xoptM Opt_Generics
; unbox_strict <- doptM Opt_UnboxStrictFields
; unbox_strict <- doptM Opt_UnboxStrictFields
- ; empty_data_decls <- doptM Opt_EmptyDataDecls
- ; kind_signatures <- doptM Opt_KindSignatures
- ; existential_ok <- doptM Opt_ExistentialQuantification
- ; gadt_ok <- doptM Opt_GADTs
+ ; empty_data_decls <- xoptM Opt_EmptyDataDecls
+ ; kind_signatures <- xoptM Opt_KindSignatures
+ ; existential_ok <- xoptM Opt_ExistentialQuantification
+ ; gadt_ok <- xoptM Opt_GADTs
; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
; let ex_ok = existential_ok || gadt_ok -- Data cons can have existential context
; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
; let ex_ok = existential_ok || gadt_ok -- Data cons can have existential context
-------------------------------
checkValidClass :: Class -> TcM ()
checkValidClass cls
-------------------------------
checkValidClass :: Class -> TcM ()
checkValidClass cls
- = do { constrained_class_methods <- doptM Opt_ConstrainedClassMethods
- ; multi_param_type_classes <- doptM Opt_MultiParamTypeClasses
- ; fundep_classes <- doptM Opt_FunctionalDependencies
+ = do { constrained_class_methods <- xoptM Opt_ConstrainedClassMethods
+ ; multi_param_type_classes <- xoptM Opt_MultiParamTypeClasses
+ ; fundep_classes <- xoptM Opt_FunctionalDependencies
-- Check that the class is unary, unless GlaExs
; checkTc (notNull tyvars) (nullaryClassErr cls)
-- Check that the class is unary, unless GlaExs
; checkTc (notNull tyvars) (nullaryClassErr cls)
marshalableTyCon :: DynFlags -> TyCon -> Bool
marshalableTyCon dflags tc
marshalableTyCon :: DynFlags -> TyCon -> Bool
marshalableTyCon dflags tc
- = (dopt Opt_UnliftedFFITypes dflags
+ = (xopt Opt_UnliftedFFITypes dflags
&& isUnLiftedTyCon tc
&& not (isUnboxedTupleTyCon tc)
&& case tyConPrimRep tc of -- Note [Marshalling VoidRep]
&& isUnLiftedTyCon tc
&& not (isUnboxedTupleTyCon tc)
&& case tyConPrimRep tc of -- Note [Marshalling VoidRep]
-- Strictly speaking it is unnecessary to ban unboxed tuples here since
-- currently they're of the wrong kind to use in function args anyway.
legalFIPrimArgTyCon dflags tc
-- Strictly speaking it is unnecessary to ban unboxed tuples here since
-- currently they're of the wrong kind to use in function args anyway.
legalFIPrimArgTyCon dflags tc
- = dopt Opt_UnliftedFFITypes dflags
+ = xopt Opt_UnliftedFFITypes dflags
&& isUnLiftedTyCon tc
&& not (isUnboxedTupleTyCon tc)
&& isUnLiftedTyCon tc
&& not (isUnboxedTupleTyCon tc)
-- Check result type of 'foreign import prim'. Allow simple unlifted
-- types and also unboxed tuple result types '... -> (# , , #)'
legalFIPrimResultTyCon dflags tc
-- Check result type of 'foreign import prim'. Allow simple unlifted
-- types and also unboxed tuple result types '... -> (# , , #)'
legalFIPrimResultTyCon dflags tc
- = dopt Opt_UnliftedFFITypes dflags
+ = xopt Opt_UnliftedFFITypes dflags
&& isUnLiftedTyCon tc
&& (isUnboxedTupleTyCon tc
|| case tyConPrimRep tc of -- Note [Marshalling VoidRep]
&& isUnLiftedTyCon tc
&& (isUnboxedTupleTyCon tc
|| case tyConPrimRep tc of -- Note [Marshalling VoidRep]
dflags <- getDynFlags
io $ putStrLn $ showSDoc $ vcat $
text "active language flags:" :
dflags <- getDynFlags
io $ putStrLn $ showSDoc $ vcat $
text "active language flags:" :
- [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, dopt f dflags]
+ [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, xopt f dflags]
-- -----------------------------------------------------------------------------
-- Completion
-- -----------------------------------------------------------------------------
-- Completion
projects / ghc-hetmet.git / commitdiff