From: Ian Lynagh Date: Sat, 24 Jul 2010 13:31:03 +0000 (+0000) Subject: Separate the language flags from the other DynFlag's X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=27286cf2ce6733cbbf008972c6bea30ea2e562ee Separate the language flags from the other DynFlag's --- diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 88bf5f5..3f5c4f1 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -11,7 +11,9 @@ -- flags. Dynamic flags can also be set at the prompt in GHCi. module DynFlags ( -- * Dynamic flags and associated configuration types + DOpt(..), DynFlag(..), + LanguageFlag(..), DynFlags(..), HscTarget(..), isObjectTarget, defaultObjectTarget, GhcMode(..), isOneShot, @@ -19,7 +21,7 @@ module DynFlags ( PackageFlag(..), Option(..), showOpt, DynLibLoader(..), - fFlags, xFlags, + fFlags, fLangFlags, xFlags, dphPackage, wayNames, @@ -27,8 +29,6 @@ module DynFlags ( defaultDynFlags, -- DynFlags initDynFlags, -- DynFlags -> IO DynFlags - dopt, -- DynFlag -> DynFlags -> Bool - dopt_set, dopt_unset, -- DynFlags -> DynFlag -> DynFlags getOpts, -- DynFlags -> (DynFlags -> [a]) -> [a] getVerbFlag, updOptLevel, @@ -188,76 +188,6 @@ data DynFlag | Opt_WarnWrongDoBind | Opt_WarnAlternativeLayoutRuleTransitional - - -- language opts - | Opt_OverlappingInstances - | Opt_UndecidableInstances - | Opt_IncoherentInstances - | Opt_MonomorphismRestriction - | Opt_MonoPatBinds - | Opt_MonoLocalBinds - | Opt_ExtendedDefaultRules -- Use GHC's extended rules for defaulting - | Opt_ForeignFunctionInterface - | Opt_UnliftedFFITypes - | Opt_GHCForeignImportPrim - | Opt_PArr -- Syntactic support for parallel arrays - | Opt_Arrows -- Arrow-notation syntax - | Opt_TemplateHaskell - | Opt_QuasiQuotes - | Opt_ImplicitParams - | Opt_Generics -- "Derivable type classes" - | Opt_ImplicitPrelude - | Opt_ScopedTypeVariables - | Opt_UnboxedTuples - | Opt_BangPatterns - | Opt_TypeFamilies - | Opt_OverloadedStrings - | Opt_DisambiguateRecordFields - | Opt_RecordWildCards - | Opt_RecordPuns - | Opt_ViewPatterns - | Opt_GADTs - | Opt_RelaxedPolyRec - | Opt_NPlusKPatterns - - | Opt_StandaloneDeriving - | Opt_DeriveDataTypeable - | Opt_DeriveFunctor - | Opt_DeriveTraversable - | Opt_DeriveFoldable - - | Opt_TypeSynonymInstances - | Opt_FlexibleContexts - | Opt_FlexibleInstances - | Opt_ConstrainedClassMethods - | Opt_MultiParamTypeClasses - | Opt_FunctionalDependencies - | Opt_UnicodeSyntax - | Opt_PolymorphicComponents - | Opt_ExistentialQuantification - | Opt_MagicHash - | Opt_EmptyDataDecls - | Opt_KindSignatures - | Opt_ParallelListComp - | Opt_TransformListComp - | Opt_GeneralizedNewtypeDeriving - | Opt_RecursiveDo - | Opt_DoRec - | Opt_PostfixOperators - | Opt_TupleSections - | Opt_PatternGuards - | Opt_LiberalTypeSynonyms - | Opt_Rank2Types - | Opt_RankNTypes - | Opt_ImpredicativeTypes - | Opt_TypeOperators - | Opt_PackageImports - | Opt_NewQualifiedOperators - | Opt_ExplicitForAll - | Opt_AlternativeLayoutRule - | Opt_AlternativeLayoutRuleTransitional - | Opt_DatatypeContexts - | Opt_PrintExplicitForalls -- optimisation opts @@ -292,7 +222,6 @@ data DynFlag | Opt_AutoSccsOnIndividualCafs -- misc opts - | Opt_Cpp | Opt_Pp | Opt_ForceRecomp | Opt_DryRun @@ -339,6 +268,77 @@ data DynFlag deriving (Eq, Show) +data LanguageFlag + = Opt_Cpp + | Opt_OverlappingInstances + | Opt_UndecidableInstances + | Opt_IncoherentInstances + | Opt_MonomorphismRestriction + | Opt_MonoPatBinds + | Opt_MonoLocalBinds + | Opt_ExtendedDefaultRules -- Use GHC's extended rules for defaulting + | Opt_ForeignFunctionInterface + | Opt_UnliftedFFITypes + | Opt_GHCForeignImportPrim + | Opt_PArr -- Syntactic support for parallel arrays + | Opt_Arrows -- Arrow-notation syntax + | Opt_TemplateHaskell + | Opt_QuasiQuotes + | Opt_ImplicitParams + | Opt_Generics -- "Derivable type classes" + | Opt_ImplicitPrelude + | Opt_ScopedTypeVariables + | Opt_UnboxedTuples + | Opt_BangPatterns + | Opt_TypeFamilies + | Opt_OverloadedStrings + | Opt_DisambiguateRecordFields + | Opt_RecordWildCards + | Opt_RecordPuns + | Opt_ViewPatterns + | Opt_GADTs + | Opt_RelaxedPolyRec + | Opt_NPlusKPatterns + + | Opt_StandaloneDeriving + | Opt_DeriveDataTypeable + | Opt_DeriveFunctor + | Opt_DeriveTraversable + | Opt_DeriveFoldable + + | Opt_TypeSynonymInstances + | Opt_FlexibleContexts + | Opt_FlexibleInstances + | Opt_ConstrainedClassMethods + | Opt_MultiParamTypeClasses + | Opt_FunctionalDependencies + | Opt_UnicodeSyntax + | Opt_PolymorphicComponents + | Opt_ExistentialQuantification + | Opt_MagicHash + | Opt_EmptyDataDecls + | Opt_KindSignatures + | Opt_ParallelListComp + | Opt_TransformListComp + | Opt_GeneralizedNewtypeDeriving + | Opt_RecursiveDo + | Opt_DoRec + | Opt_PostfixOperators + | Opt_TupleSections + | Opt_PatternGuards + | Opt_LiberalTypeSynonyms + | Opt_Rank2Types + | Opt_RankNTypes + | Opt_ImpredicativeTypes + | Opt_TypeOperators + | Opt_PackageImports + | Opt_NewQualifiedOperators + | Opt_ExplicitForAll + | Opt_AlternativeLayoutRule + | Opt_AlternativeLayoutRuleTransitional + | Opt_DatatypeContexts + deriving (Eq, Show) + -- | Contains not only a collection of 'DynFlag's but also a plethora of -- information relating to the compilation of a single file or GHC session data DynFlags = DynFlags { @@ -473,6 +473,7 @@ data DynFlags = DynFlags { -- hsc dynamic flags flags :: [DynFlag], + languageFlags :: [LanguageFlag], -- | Message output action: use "ErrUtils" instead of this if you can log_action :: Severity -> SrcSpan -> PprStyle -> Message -> IO (), @@ -710,15 +711,6 @@ defaultDynFlags = Opt_AutoLinkPackages, Opt_ReadUserPackageConf, - Opt_MonoPatBinds, -- Experimentally, I'm making this non-standard - -- behaviour the default, to see if anyone notices - -- SLPJ July 06 - - Opt_ImplicitPrelude, - Opt_MonomorphismRestriction, - Opt_NPlusKPatterns, - Opt_DatatypeContexts, - Opt_MethodSharing, Opt_DoAsmMangling, @@ -733,6 +725,17 @@ defaultDynFlags = -- The default -O0 options ++ standardWarnings, + languageFlags = [ + Opt_MonoPatBinds, -- Experimentally, I'm making this non-standard + -- behaviour the default, to see if anyone notices + -- SLPJ July 06 + + Opt_ImplicitPrelude, + Opt_MonomorphismRestriction, + Opt_NPlusKPatterns, + Opt_DatatypeContexts + ], + log_action = \severity srcSpan style msg -> case severity of SevInfo -> printErrs (msg style) @@ -756,17 +759,46 @@ Note [Verbosity levels] 5 | "ghc -v -ddump-all" -} +-- 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 LanguageFlag 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 'LanguageFlag' is set +lopt :: LanguageFlag -> DynFlags -> Bool +lopt f dflags = f `elem` languageFlags dflags + +-- | Set a 'LanguageFlag' +lopt_set :: DynFlags -> LanguageFlag -> DynFlags +lopt_set dfs f = dfs{ languageFlags = f : languageFlags dfs } + +-- | Unset a 'LanguageFlag' +lopt_unset :: DynFlags -> LanguageFlag -> DynFlags +lopt_unset dfs f = dfs{ languageFlags = filter (/= f) (languageFlags dfs) } -- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order getOpts :: DynFlags -- ^ 'DynFlags' to retrieve the options from @@ -1023,15 +1055,17 @@ allFlags = map ('-':) $ [ flagName flag | flag <- dynamic_flags, ok (flagOptKind flag) ] ++ map ("fno-"++) flags ++ map ("f"++) flags ++ + map ("f"++) flags' ++ map ("X"++) supportedLanguages where ok (PrefixPred _ _) = False ok _ = True flags = [ name | (name, _, _) <- fFlags ] + flags' = [ name | (name, _, _) <- fLangFlags ] dynamic_flags :: [Flag DynP] dynamic_flags = [ Flag "n" (NoArg (setDynFlag Opt_DryRun)) Supported - , Flag "cpp" (NoArg (setDynFlag Opt_Cpp)) Supported + , Flag "cpp" (NoArg (setLanguageFlag Opt_Cpp)) Supported , Flag "F" (NoArg (setDynFlag Opt_Pp)) Supported , Flag "#include" (HasArg (addCmdlineHCInclude)) (DeprecatedFullText "-#include and INCLUDE pragmas are deprecated: They no longer have any effect") @@ -1427,15 +1461,17 @@ dynamic_flags = [ , Flag "fbyte-code" (NoArg (setTarget HscInterpreted)) Supported , Flag "fobject-code" (NoArg (setTarget defaultHscTarget)) Supported - , Flag "fglasgow-exts" (NoArg (mapM_ setDynFlag glasgowExtsFlags)) + , Flag "fglasgow-exts" (NoArg enableGlasgowExts) Supported - , Flag "fno-glasgow-exts" (NoArg (mapM_ unSetDynFlag glasgowExtsFlags)) + , Flag "fno-glasgow-exts" (NoArg disableGlasgowExts) Supported ] ++ map (mkFlag True "f" setDynFlag ) fFlags ++ map (mkFlag False "fno-" unSetDynFlag) fFlags - ++ map (mkFlag True "X" setDynFlag ) xFlags - ++ map (mkFlag False "XNo" unSetDynFlag) xFlags + ++ map (mkFlag True "f" setLanguageFlag ) fLangFlags + ++ map (mkFlag False "fno-" unSetLanguageFlag) fLangFlags + ++ map (mkFlag True "X" setLanguageFlag ) xFlags + ++ map (mkFlag False "XNo" unSetLanguageFlag) xFlags package_flags :: [Flag DynP] package_flags = [ @@ -1457,11 +1493,11 @@ package_flags = [ mkFlag :: Bool -- ^ True <=> it should be turned on -> String -- ^ The flag prefix - -> (DynFlag -> DynP ()) - -> (String, DynFlag, Bool -> Deprecated) + -> (flag -> DynP ()) + -> (String, flag, Bool -> Deprecated) -> Flag DynP -mkFlag turnOn flagPrefix f (name, dynflag, deprecated) - = Flag (flagPrefix ++ name) (NoArg (f dynflag)) (deprecated turnOn) +mkFlag turnOn flagPrefix f (name, flag, deprecated) + = Flag (flagPrefix ++ name) (NoArg (f flag)) (deprecated turnOn) deprecatedForLanguage :: String -> Bool -> Deprecated deprecatedForLanguage lang turn_on @@ -1548,6 +1584,17 @@ fFlags = [ ( "vectorise", Opt_Vectorise, const Supported ), ( "regs-graph", Opt_RegsGraph, const Supported ), ( "regs-iterative", Opt_RegsIterative, const Supported ), + ( "gen-manifest", Opt_GenManifest, const Supported ), + ( "embed-manifest", Opt_EmbedManifest, const Supported ), + ( "ext-core", Opt_EmitExternalCore, const Supported ), + ( "shared-implib", Opt_SharedImplib, const Supported ), + ( "building-cabal-package", Opt_BuildingCabalPackage, const Supported ), + ( "implicit-import-qualified", Opt_ImplicitImportQualified, const Supported ) + ] + +-- | These @-f\@ flags can all be reversed with @-fno-\@ +fLangFlags :: [(String, LanguageFlag, Bool -> Deprecated)] +fLangFlags = [ ( "th", Opt_TemplateHaskell, deprecatedForLanguage "TemplateHaskell" ), ( "fi", Opt_ForeignFunctionInterface, @@ -1579,24 +1626,18 @@ fFlags = [ ( "allow-undecidable-instances", Opt_UndecidableInstances, deprecatedForLanguage "UndecidableInstances" ), ( "allow-incoherent-instances", Opt_IncoherentInstances, - deprecatedForLanguage "IncoherentInstances" ), - ( "gen-manifest", Opt_GenManifest, const Supported ), - ( "embed-manifest", Opt_EmbedManifest, const Supported ), - ( "ext-core", Opt_EmitExternalCore, const Supported ), - ( "shared-implib", Opt_SharedImplib, const Supported ), - ( "building-cabal-package", Opt_BuildingCabalPackage, const Supported ), - ( "implicit-import-qualified", Opt_ImplicitImportQualified, const Supported ) + deprecatedForLanguage "IncoherentInstances" ) ] supportedLanguages :: [String] supportedLanguages = [ name' | (name, _, _) <- xFlags, name' <- [name, "No" ++ name] ] -- This may contain duplicates -languageOptions :: [DynFlag] -languageOptions = [ dynFlag | (_, dynFlag, _) <- xFlags ] +languageOptions :: [LanguageFlag] +languageOptions = [ langFlag | (_, langFlag, _) <- xFlags ] -- | These -X flags can all be reversed with -XNo -xFlags :: [(String, DynFlag, Bool -> Deprecated)] +xFlags :: [(String, LanguageFlag, Bool -> Deprecated)] xFlags = [ ( "CPP", Opt_Cpp, const Supported ), ( "PostfixOperators", Opt_PostfixOperators, const Supported ), @@ -1680,7 +1721,7 @@ xFlags = [ const $ Deprecated "The new qualified operator syntax was rejected by Haskell'" ) ] -impliedFlags :: [(DynFlag, DynFlag)] +impliedFlags :: [(LanguageFlag, LanguageFlag)] impliedFlags = [ (Opt_RankNTypes, Opt_ExplicitForAll) , (Opt_Rank2Types, Opt_ExplicitForAll) @@ -1707,10 +1748,17 @@ impliedFlags , (Opt_RecordWildCards, Opt_DisambiguateRecordFields) ] -glasgowExtsFlags :: [DynFlag] +enableGlasgowExts :: DynP () +enableGlasgowExts = do setDynFlag Opt_PrintExplicitForalls + mapM_ setLanguageFlag glasgowExtsFlags + +disableGlasgowExts :: DynP () +disableGlasgowExts = do unSetDynFlag Opt_PrintExplicitForalls + mapM_ unSetLanguageFlag glasgowExtsFlags + +glasgowExtsFlags :: [LanguageFlag] glasgowExtsFlags = [ - Opt_PrintExplicitForalls - , Opt_ForeignFunctionInterface + Opt_ForeignFunctionInterface , Opt_UnliftedFFITypes , Opt_GADTs , Opt_ImplicitParams @@ -1813,17 +1861,22 @@ upd f = do -------------------------- setDynFlag, unSetDynFlag :: DynFlag -> DynP () -setDynFlag f = do { upd (\dfs -> dopt_set dfs f) - ; mapM_ setDynFlag deps } +setDynFlag f = upd (\dfs -> dopt_set dfs f) +unSetDynFlag f = upd (\dfs -> dopt_unset dfs f) + +-------------------------- +setLanguageFlag, unSetLanguageFlag :: LanguageFlag -> DynP () +setLanguageFlag f = do { upd (\dfs -> lopt_set dfs f) + ; mapM_ setLanguageFlag deps } where deps = [ d | (f', d) <- impliedFlags, f' == f ] -- When you set f, set the ones it implies - -- NB: use setDynFlag recursively, in case the implied flags - -- implies further flags + -- NB: use setLanguageFlag recursively, in case the implied flags + -- implies further flags -- When you un-set f, however, we don't un-set the things it implies -- (except for -fno-glasgow-exts, which is treated specially) -unSetDynFlag f = upd (\dfs -> dopt_unset dfs f) +unSetLanguageFlag f = upd (\dfs -> lopt_unset dfs f) -------------------------- setDumpFlag :: DynFlag -> OptKind DynP diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 2afd04d..9efe64e 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -28,7 +28,7 @@ import RnPat (rnPats, rnBindPat, ) import RnEnv -import DynFlags ( DynFlag(..) ) +import DynFlags import Name import NameEnv import NameSet diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 620b1fe..a369835 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -30,7 +30,7 @@ import RnEnv import RnTypes ( rnHsTypeFVs, rnSplice, checkTH, mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec) import RnPat -import DynFlags ( DynFlag(..) ) +import DynFlags import BasicTypes ( FixityDirection(..) ) import PrelNames diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index fffd80f..01f621b 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -40,7 +40,7 @@ import TcRnMonad import TcHsSyn ( hsOverLitName ) import RnEnv import RnTypes -import DynFlags ( DynFlag(..) ) +import DynFlags import PrelNames import Constants ( mAX_TUPLE_SIZE ) import Name diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 9b04da0..e362a12 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -46,7 +46,7 @@ import Bag import FastString import Util ( filterOut ) import SrcLoc -import DynFlags ( DynFlag(..), DynFlags, thisPackage ) +import DynFlags import HscTypes ( HscEnv, hsc_dflags ) import BasicTypes ( Boxity(..) ) import ListSetOps ( findDupsEq ) diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 135f18d..5fcb45c 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -977,7 +977,7 @@ cond_functorOK allowFunctions (dflags, rep_tc) functions = ptext (sLit "contains function types") wrong_arg = ptext (sLit "uses the type variable in an argument other than the last") -checkFlag :: DynFlag -> Condition +checkFlag :: LanguageFlag -> Condition checkFlag flag (dflags, _) | dopt flag dflags = Nothing | otherwise = Just why diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index 5592b80..022796e 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -36,7 +36,7 @@ import TyCon import DataCon import PrelNames import BasicTypes hiding (SuccessFlag(..)) -import DynFlags ( DynFlag( Opt_GADTs ) ) +import DynFlags import SrcLoc import ErrUtils import Util diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index aa3ae5d..06f08a3 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -230,19 +230,19 @@ Command-line flags getDOpts :: TcRnIf gbl lcl DynFlags getDOpts = do { env <- getTopEnv; return (hsc_dflags env) } -doptM :: DynFlag -> TcRnIf gbl lcl Bool +doptM :: DOpt d => d -> TcRnIf gbl lcl Bool doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) } -setOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +setOptM :: DOpt d => d -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a setOptM flag = updEnv (\ env@(Env { env_top = top }) -> env { env_top = top { hsc_dflags = dopt_set (hsc_dflags top) flag}} ) -unsetOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +unsetOptM :: DOpt d => d -> 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 :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () +ifOptM :: DOpt d => d -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () ifOptM flag thing_inside = do { b <- doptM flag; if b then thing_inside else return () } diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 6b8f984..8669f94 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -1403,15 +1403,13 @@ setCmd "" )) io $ putStrLn (showSDoc ( vcat (text "other dynamic, non-language, flag settings:" - :map (flagSetting dflags) nonLanguageDynFlags) + :map (flagSetting dflags) others) )) where flagSetting dflags (str, f, _) | dopt f dflags = text " " <> text "-f" <> text str | otherwise = text " " <> text "-fno-" <> text str (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flags) DynFlags.fFlags - nonLanguageDynFlags = filterOut (\(_, f, _) -> f `elem` languageOptions) - others flags = [Opt_PrintExplicitForalls ,Opt_PrintBindResult ,Opt_BreakOnException