X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FDynFlags.hs;h=513c97faf7ee2db97e9d53a74a58ca86ec41f11d;hb=0656c72a8f4fda30c348bdf40449d105e4ce00ce;hp=056f36757b23f4dd73f47223e3bfecda64b659ee;hpb=781fd68db0abe2ebca2481a149442ee3ff8d99b7;p=ghc-hetmet.git diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 056f367..513c97f 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -17,16 +17,12 @@ module DynFlags ( DynFlag(..), ExtensionFlag(..), glasgowExtsFlags, - flattenExtensionFlags, - ensureFlattenedExtensionFlags, dopt, dopt_set, dopt_unset, xopt, xopt_set, xopt_unset, - xopt_set_flattened, - xopt_unset_flattened, DynFlags(..), RtsOptsEnabled(..), HscTarget(..), isObjectTarget, defaultObjectTarget, @@ -203,6 +199,7 @@ data DynFlag | Opt_WarnDodgyImports | Opt_WarnOrphans | Opt_WarnAutoOrphans + | Opt_WarnIdentities | Opt_WarnTabs | Opt_WarnUnrecognisedPragmas | Opt_WarnDodgyForeignImports @@ -227,7 +224,7 @@ data DynFlag | Opt_DoEtaReduction | Opt_CaseMerge | Opt_UnboxStrictFields - | Opt_MethodSharing + | Opt_MethodSharing -- Now a no-op; remove in GHC 7.2 | Opt_DictsCheap | Opt_EnableRewriteRules -- Apply rewrite rules during simplification | Opt_Vectorise @@ -270,6 +267,7 @@ data DynFlag | Opt_SharedImplib | Opt_BuildingCabalPackage | Opt_SSE2 + | Opt_GhciSandbox -- temporary flags | Opt_RunCPS @@ -324,6 +322,7 @@ data ExtensionFlag | Opt_GADTs | Opt_NPlusKPatterns | Opt_DoAndIfThenElse + | Opt_RebindableSyntax | Opt_StandaloneDeriving | Opt_DeriveDataTypeable @@ -499,9 +498,13 @@ data DynFlags = DynFlags { -- hsc dynamic flags flags :: [DynFlag], + -- Don't change this without updating extensionFlags: language :: Maybe Language, - extensionFlags :: Either [OnOff ExtensionFlag] - [ExtensionFlag], + -- Don't change this without updating extensionFlags: + extensions :: [OnOff ExtensionFlag], + -- extensionFlags should always be equal to + -- flattenExtensionFlags language extensions + extensionFlags :: [ExtensionFlag], -- | Message output action: use "ErrUtils" instead of this if you can log_action :: Severity -> SrcSpan -> PprStyle -> Message -> IO (), @@ -739,7 +742,8 @@ defaultDynFlags = haddockOptions = Nothing, flags = defaultFlags, language = Nothing, - extensionFlags = Left [], + extensions = [], + extensionFlags = flattenExtensionFlags Nothing [], log_action = \severity srcSpan style msg -> case severity of @@ -768,37 +772,19 @@ Note [Verbosity levels] data OnOff a = On a | Off a -flattenExtensionFlags :: DynFlags -> DynFlags -flattenExtensionFlags dflags - = case extensionFlags dflags of - Left onoffs -> - dflags { - extensionFlags = Right $ flattenExtensionFlags' (language dflags) onoffs - } - Right _ -> - panic "Flattening already-flattened extension flags" - -ensureFlattenedExtensionFlags :: DynFlags -> DynFlags -ensureFlattenedExtensionFlags dflags - = case extensionFlags dflags of - Left onoffs -> - dflags { - extensionFlags = Right $ flattenExtensionFlags' (language dflags) onoffs - } - Right _ -> - dflags - -- OnOffs accumulate in reverse order, so we use foldr in order to -- process them in the right order -flattenExtensionFlags' :: Maybe Language -> [OnOff ExtensionFlag] - -> [ExtensionFlag] -flattenExtensionFlags' ml = foldr f defaultExtensionFlags +flattenExtensionFlags :: Maybe Language -> [OnOff ExtensionFlag] + -> [ExtensionFlag] +flattenExtensionFlags ml = foldr f defaultExtensionFlags where f (On f) flags = f : delete f flags f (Off f) flags = delete f flags defaultExtensionFlags = languageExtensions ml languageExtensions :: Maybe Language -> [ExtensionFlag] + languageExtensions Nothing + -- Nothing => the default case = Opt_MonoPatBinds -- Experimentally, I'm making this non-standard -- behaviour the default, to see if anyone notices -- SLPJ July 06 @@ -806,11 +792,13 @@ languageExtensions Nothing -- But NB it's implied by GADTs etc -- SLPJ September 2010 : languageExtensions (Just Haskell2010) + languageExtensions (Just Haskell98) = [Opt_ImplicitPrelude, Opt_MonomorphismRestriction, Opt_NPlusKPatterns, Opt_DatatypeContexts] + languageExtensions (Just Haskell2010) = [Opt_ImplicitPrelude, Opt_MonomorphismRestriction, @@ -835,37 +823,30 @@ dopt_unset dfs f = dfs{ flags = filter (/= f) (flags dfs) } -- | Test whether a 'ExtensionFlag' is set 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 +xopt f dflags = f `elem` extensionFlags dflags -- | Set a 'ExtensionFlag' 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' -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) } +xopt_set dfs f + = let onoffs = On f : extensions dfs + in dfs { extensions = onoffs, + extensionFlags = flattenExtensionFlags (language dfs) onoffs } -- | Unset a 'ExtensionFlag' 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") +xopt_unset dfs f + = let onoffs = Off f : extensions dfs + in dfs { extensions = onoffs, + extensionFlags = flattenExtensionFlags (language dfs) onoffs } --- | Unset a 'ExtensionFlag' -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 -> - dfs { extensionFlags = Right (delete f flags) } +setLanguage :: Language -> DynP () +setLanguage l = upd f + where f dfs = let mLang = Just l + oneoffs = extensions dfs + in dfs { + language = mLang, + extensionFlags = flattenExtensionFlags mLang oneoffs + } -- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order getOpts :: DynFlags -- ^ 'DynFlags' to retrieve the options from @@ -1442,6 +1423,7 @@ fFlags = [ ( "warn-deprecations", Opt_WarnWarningsDeprecations, nop ), ( "warn-deprecated-flags", Opt_WarnDeprecatedFlags, nop ), ( "warn-orphans", Opt_WarnOrphans, nop ), + ( "warn-identities", Opt_WarnIdentities, nop ), ( "warn-auto-orphans", Opt_WarnAutoOrphans, nop ), ( "warn-tabs", Opt_WarnTabs, nop ), ( "warn-unrecognised-pragmas", Opt_WarnUnrecognisedPragmas, nop ), @@ -1466,7 +1448,9 @@ fFlags = [ ( "do-eta-reduction", Opt_DoEtaReduction, nop ), ( "case-merge", Opt_CaseMerge, nop ), ( "unbox-strict-fields", Opt_UnboxStrictFields, nop ), - ( "method-sharing", Opt_MethodSharing, nop ), + ( "method-sharing", Opt_MethodSharing, + \_ -> deprecate "doesn't do anything any more"), + -- Remove altogether in GHC 7.2 ( "dicts-cheap", Opt_DictsCheap, nop ), ( "excess-precision", Opt_ExcessPrecision, nop ), ( "eager-blackholing", Opt_EagerBlackHoling, nop ), @@ -1491,6 +1475,7 @@ fFlags = [ ( "embed-manifest", Opt_EmbedManifest, nop ), ( "ext-core", Opt_EmitExternalCore, nop ), ( "shared-implib", Opt_SharedImplib, nop ), + ( "ghci-sandbox", Opt_GhciSandbox, nop ), ( "building-cabal-package", Opt_BuildingCabalPackage, nop ), ( "implicit-import-qualified", Opt_ImplicitImportQualified, nop ) ] @@ -1593,6 +1578,7 @@ xFlags = [ ( "MonomorphismRestriction", Opt_MonomorphismRestriction, nop ), ( "NPlusKPatterns", Opt_NPlusKPatterns, nop ), ( "DoAndIfThenElse", Opt_DoAndIfThenElse, nop ), + ( "RebindableSyntax", Opt_RebindableSyntax, nop ), ( "MonoPatBinds", Opt_MonoPatBinds, nop ), ( "ExplicitForAll", Opt_ExplicitForAll, nop ), ( "AlternativeLayoutRule", Opt_AlternativeLayoutRule, nop ), @@ -1636,15 +1622,14 @@ defaultFlags = [ Opt_AutoLinkPackages, Opt_ReadUserPackageConf, - Opt_MethodSharing, - Opt_DoAsmMangling, Opt_SharedImplib, Opt_GenManifest, Opt_EmbedManifest, - Opt_PrintBindContents + Opt_PrintBindContents, + Opt_GhciSandbox ] ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns] @@ -1661,6 +1646,8 @@ impliedFlags , (Opt_ExistentialQuantification, Opt_ExplicitForAll) , (Opt_PolymorphicComponents, Opt_ExplicitForAll) + , (Opt_RebindableSyntax, Opt_ImplicitPrelude) + , (Opt_GADTs, Opt_MonoLocalBinds) , (Opt_TypeFamilies, Opt_MonoLocalBinds) @@ -1750,7 +1737,8 @@ minusWallOpts Opt_WarnMissingSigs, Opt_WarnHiShadows, Opt_WarnOrphans, - Opt_WarnUnusedDoBind + Opt_WarnUnusedDoBind, + Opt_WarnIdentities ] -- minuswRemovesOpts should be every warning option @@ -1865,10 +1853,6 @@ setDynFlag f = upd (\dfs -> dopt_set dfs f) unSetDynFlag f = upd (\dfs -> dopt_unset dfs f) -------------------------- -setLanguage :: Language -> DynP () -setLanguage l = upd (\dfs -> dfs { language = Just l }) - --------------------------- setExtensionFlag, unSetExtensionFlag :: ExtensionFlag -> DynP () setExtensionFlag f = do { upd (\dfs -> xopt_set dfs f) ; mapM_ setExtensionFlag deps } @@ -1988,7 +1972,6 @@ setDPHOpt dflags = setOptLevel 2 (dflags { maxSimplIterations = 20 , specConstrCount = Nothing }) `dopt_set` Opt_DictsCheap - `dopt_unset` Opt_MethodSharing data DPHBackend = DPHPar | DPHSeq