From a6f2d598e1e7760d334d1b5ea0b7745e66835e11 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Sat, 18 Sep 2010 16:38:15 +0000 Subject: [PATCH] Add separate functions for querying DynFlag and ExtensionFlag options and remove the temporary DOpt class workaround. --- compiler/deSugar/DsMonad.lhs | 2 +- compiler/deSugar/Match.lhs | 2 +- compiler/iface/TcIface.lhs | 2 +- compiler/main/DriverPipeline.hs | 2 +- compiler/main/DynFlags.hs | 64 ++++++++++++++--------------------- compiler/main/GHC.hs | 4 +-- compiler/main/HeaderInfo.hs | 2 +- compiler/main/TidyPgm.lhs | 2 +- compiler/parser/Lexer.x | 44 ++++++++++++------------ compiler/parser/RdrHsSyn.lhs | 4 +-- compiler/rename/RnBinds.lhs | 2 +- compiler/rename/RnEnv.lhs | 20 +++++------ compiler/rename/RnExpr.lhs | 8 ++--- compiler/rename/RnNames.lhs | 24 ++++++------- compiler/rename/RnPat.lhs | 12 +++---- compiler/rename/RnSource.lhs | 6 ++-- compiler/rename/RnTypes.lhs | 6 ++-- compiler/typecheck/Inst.lhs | 4 +-- compiler/typecheck/TcBinds.lhs | 6 ++-- compiler/typecheck/TcDefaults.lhs | 2 +- compiler/typecheck/TcDeriv.lhs | 6 ++-- compiler/typecheck/TcEnv.lhs | 4 +-- compiler/typecheck/TcErrors.lhs | 2 +- compiler/typecheck/TcExpr.lhs | 2 +- compiler/typecheck/TcForeign.lhs | 2 +- compiler/typecheck/TcMType.lhs | 32 +++++++++--------- compiler/typecheck/TcPat.lhs | 2 +- compiler/typecheck/TcRnMonad.lhs | 23 ++++++++----- compiler/typecheck/TcTyClsDecls.lhs | 24 ++++++------- compiler/typecheck/TcType.lhs | 6 ++-- ghc/InteractiveUI.hs | 2 +- 31 files changed, 159 insertions(+), 164 deletions(-) diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs index 5245eaa..d6d33da 100644 --- a/compiler/deSugar/DsMonad.lhs +++ b/compiler/deSugar/DsMonad.lhs @@ -9,7 +9,7 @@ module DsMonad ( DsM, mapM, mapAndUnzipM, initDs, initDsTc, fixDs, - foldlM, foldrM, ifOptM, unsetOptM, + foldlM, foldrM, ifDOptM, unsetOptM, Applicative(..),(<$>), newLocalName, diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index 649b2f1..2c9aa0b 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -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) $ diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 07b0b72..45cc6ca 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -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 () diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 6b50811..08d568f 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -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 diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 47d9f6d..b90753b 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -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 () diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index c3aa832..82a5adc 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -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 diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index d21eeac..0f0798b 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -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) diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 7d04563..c0952d6 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -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 diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index b418280..2e17b8f 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -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) diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 548b111..47abf23 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -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 diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index fd5695b..b76e6db 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -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 diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index feea0c5..9f6a96a 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -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 diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index a369835..de7760e 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -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") diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index f893235..720cadf 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -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 diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index 01f621b..d8bcb22 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -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 diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 9e16379..91bc78f 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -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 } diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index a818135..138ffa2 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -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))] $$ diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index cee4b89..eefc424 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -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 diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 368ede4..5d966f9 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -1082,7 +1082,7 @@ decideGeneralisationPlan dflags top_lvl _bndrs binds sig_fn | Just sig <- one_funbind_with_sig binds = if null (sig_tvs sig) && null (sig_theta sig) then NoGen -- Optimise common case else CheckGen sig - | (dopt Opt_MonoLocalBinds dflags + | (xopt Opt_MonoLocalBinds dflags && isNotTopLevel top_lvl) = NoGen | otherwise = InferGen mono_restriction @@ -1090,10 +1090,10 @@ decideGeneralisationPlan dflags top_lvl _bndrs binds sig_fn -- | otherwise = NoGen -- A mixture of function -- -- and pattern bindings where - mono_pat_binds = dopt Opt_MonoPatBinds dflags + mono_pat_binds = xopt Opt_MonoPatBinds dflags && any (is_pat_bind . unLoc) binds - mono_restriction = dopt Opt_MonomorphismRestriction dflags + mono_restriction = xopt Opt_MonomorphismRestriction dflags && any (restricted . unLoc) binds no_sig n = isNothing (sig_fn n) diff --git a/compiler/typecheck/TcDefaults.lhs b/compiler/typecheck/TcDefaults.lhs index 97d51a1..50b5767 100644 --- a/compiler/typecheck/TcDefaults.lhs +++ b/compiler/typecheck/TcDefaults.lhs @@ -47,7 +47,7 @@ tcDefaults [L _ (DefaultDecl [])] tcDefaults [L locn (DefaultDecl mono_tys)] = setSrcSpan locn $ addErrCtxt defaultDeclCtxt $ - do { ovl_str <- doptM Opt_OverloadedStrings + do { ovl_str <- xoptM Opt_OverloadedStrings ; num_class <- tcLookupClass numClassName ; is_str_class <- tcLookupClass isStringClassName ; let deflt_clss | ovl_str = [num_class, is_str_class] diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 86194c0..e2ddc9d 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -928,7 +928,7 @@ cond_functorOK :: Bool -> Condition -- (d) optionally: don't use function types -- (e) no "stupid context" on data type cond_functorOK allowFunctions (dflags, rep_tc) - | not (dopt Opt_DeriveFunctor dflags) + | not (xopt Opt_DeriveFunctor dflags) = Just (ptext (sLit "You need -XDeriveFunctor to derive an instance for this class")) | null tc_tvs @@ -971,7 +971,7 @@ cond_functorOK allowFunctions (dflags, rep_tc) 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 @@ -1074,7 +1074,7 @@ mkNewTypeEqn orig dflags tvs | 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) diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index d6177b4..b69163c 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -548,9 +548,9 @@ tcGetDefaultTys :: Bool -- True <=> interactive context 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 - || dopt Opt_ExtendedDefaultRules dflags + || xopt Opt_ExtendedDefaultRules dflags -- See also Trac #1974 flags = (ovl_strings, extended_defaults) diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index 30a0530..db21659 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -560,7 +560,7 @@ monomorphism_fix :: DynFlags -> SDoc 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! diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 03e0687..531b1b0 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -311,7 +311,7 @@ tcExpr (SectionR op arg2) res_ty 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 diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index 782ce3f..d42b372 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -132,7 +132,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar 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 diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index 8a81b48..a3484a9 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -817,10 +817,10 @@ checkValidType :: UserTypeCtxt -> Type -> TcM () -- 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 @@ -950,7 +950,7 @@ check_type rank ubx_tup ty@(TyConApp tc tys) 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 @@ -962,10 +962,10 @@ check_type rank ubx_tup ty@(TyConApp tc tys) } | 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 - ; 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 @@ -1009,7 +1009,7 @@ check_arg_type :: Rank -> Type -> TcM () -- 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 @@ -1142,7 +1142,7 @@ check_pred_ty dflags ctxt pred@(ClassP cls tys) 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 @@ -1173,8 +1173,8 @@ check_class_pred_tys dflags ctxt tys -- 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 @@ -1355,13 +1355,13 @@ checkValidInstHead ty -- Should be a source type 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) - ; checkTc (dopt Opt_FlexibleInstances dflags || + ; checkTc (xopt Opt_FlexibleInstances dflags || 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 @@ -1412,7 +1412,7 @@ checkValidInstance hs_type tyvars theta 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) @@ -1513,7 +1513,7 @@ checkValidTypeInst typats rhs ; 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)) } diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index 78ad69a..49d0c8a 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -689,7 +689,7 @@ tcConPat penv (L con_span con_name) pat_ty arg_pats thing_inside -- 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 diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 37d4e62..77d7374 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -239,22 +239,29 @@ Command-line flags 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 }) -> - 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 -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 @@ -393,12 +400,12 @@ traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs 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 -traceOptTcRn flag doc = ifOptM flag $ do +traceOptTcRn flag doc = ifDOptM flag $ do { loc <- getSrcSpanM ; let real_doc | opt_PprStyle_Debug = mkLocMessage loc doc @@ -416,7 +423,7 @@ debugDumpTcRn doc | opt_NoDebugOutput = return () | otherwise = dumpTcRn doc dumpOptTcRn :: DynFlag -> SDoc -> TcRn () -dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc) +dumpOptTcRn flag doc = ifDOptM flag (dumpTcRn doc) \end{code} @@ -1131,7 +1138,7 @@ forkM_maybe doc thing_inside -- 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)))) diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index f009637..393f4ff 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -256,7 +256,7 @@ tcFamInstDecl top_lvl (L loc decl) 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 @@ -350,7 +350,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, ; 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 @@ -711,7 +711,7 @@ tcTyClDecl1 parent _calc_isrec { 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 @@ -729,7 +729,7 @@ tcTyClDecl1 parent _calc_isrec -- 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 [] @@ -747,12 +747,12 @@ tcTyClDecl1 parent calc_isrec { 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 - ; 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 @@ -1180,9 +1180,9 @@ checkNewDataCon con ------------------------------- 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) diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index 0025a5e..dcc51ef 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -1416,7 +1416,7 @@ legalFFITyCon 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] @@ -1442,7 +1442,7 @@ legalFIPrimArgTyCon :: DynFlags -> TyCon -> Bool -- 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) @@ -1450,7 +1450,7 @@ legalFIPrimResultTyCon :: DynFlags -> TyCon -> Bool -- 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] diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index f127735..d4757cc 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -1660,7 +1660,7 @@ showLanguages = do 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 -- 1.7.10.4