X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FDynFlags.hs;h=c147b15e7972a3dba37e1d0950ec905545536da1;hb=792671a8f112d8a750d8c293bb036100467129ba;hp=2c8f5da9fadac73b853a6aad966f3ebead2e9ef5;hpb=027bfeb550029829bf94e4e78d23fad1638e2756;p=ghc-hetmet.git diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 2c8f5da..c147b15 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -83,7 +83,7 @@ import Panic import UniqFM ( UniqFM ) import Util import Maybes ( orElse ) -import SrcLoc ( SrcSpan ) +import SrcLoc import FastString import Outputable import {-# SOURCE #-} ErrUtils ( Severity(..), Message, mkLocMessage ) @@ -202,7 +202,7 @@ data DynFlag | Opt_TemplateHaskell | Opt_QuasiQuotes | Opt_ImplicitParams - | Opt_Generics + | Opt_Generics -- "Derivable type classes" | Opt_ImplicitPrelude | Opt_ScopedTypeVariables | Opt_UnboxedTuples @@ -229,7 +229,6 @@ data DynFlag | Opt_MagicHash | Opt_EmptyDataDecls | Opt_KindSignatures - | Opt_PatternSignatures | Opt_ParallelListComp | Opt_TransformListComp | Opt_GeneralizedNewtypeDeriving @@ -261,7 +260,7 @@ data DynFlag | Opt_UnboxStrictFields | Opt_MethodSharing | Opt_DictsCheap - | Opt_RewriteRules + | Opt_EnableRewriteRules -- Apply rewrite rules during simplification | Opt_Vectorise | Opt_RegsGraph -- do graph coloring register allocation | Opt_RegsIterative -- do iterative coalescing graph coloring register allocation @@ -311,7 +310,7 @@ data DynFlags = DynFlags { stgToDo :: Maybe [StgToDo], -- similarly hscTarget :: HscTarget, hscOutName :: String, -- ^ Name of the output file - extCoreName :: String, -- ^ Name of the .core output file + extCoreName :: String, -- ^ Name of the .hcr output file verbosity :: Int, -- ^ Verbosity level: see "DynFlags#verbosity_levels" optLevel :: Int, -- ^ Optimisation level simplPhases :: Int, -- ^ Number of simplifier phases @@ -579,7 +578,7 @@ defaultDynFlags = ghcUsagePath = panic "defaultDynFlags: No ghciUsagePath", ghciUsagePath = panic "defaultDynFlags: No ghciUsagePath", topDir = panic "defaultDynFlags: No topDir", - systemPackageConfig = panic "defaultDynFlags: No systemPackageConfig", + systemPackageConfig = panic "no systemPackageConfig: call GHC.setSessionDynFlags", pgm_L = panic "defaultDynFlags: No pgm_L", pgm_P = panic "defaultDynFlags: No pgm_P", pgm_F = panic "defaultDynFlags: No pgm_F", @@ -794,8 +793,8 @@ optLevelFlags , ([0], Opt_OmitInterfacePragmas) , ([1,2], Opt_IgnoreAsserts) - , ([1,2], Opt_RewriteRules) -- Off for -O0; see Note [Scoping for Builtin rules] - -- in PrelRules + , ([1,2], Opt_EnableRewriteRules) -- Off for -O0; see Note [Scoping for Builtin rules] + -- in PrelRules , ([1,2], Opt_DoEtaReduction) , ([1,2], Opt_CaseMerge) , ([1,2], Opt_Strictness) @@ -1470,6 +1469,12 @@ deprecatedForLanguage lang turn_on flag | turn_on = lang | otherwise = "No"++lang +useInstead :: String -> Bool -> Deprecated +useInstead flag turn_on + = Deprecated ("Use -f" ++ no ++ flag ++ " instead") + where + no = if turn_on then "" else "no-" + -- | These @-f\@ flags can all be reversed with @-fno-\@ fFlags :: [(String, DynFlag, Bool -> Deprecated)] fFlags = [ @@ -1492,6 +1497,7 @@ fFlags = [ ( "warn-unused-imports", Opt_WarnUnusedImports, const Supported ), ( "warn-unused-matches", Opt_WarnUnusedMatches, const Supported ), ( "warn-warnings-deprecations", Opt_WarnWarningsDeprecations, const Supported ), + ( "warn-deprecations", Opt_WarnWarningsDeprecations, const Supported ), ( "warn-deprecated-flags", Opt_WarnDeprecatedFlags, const Supported ), ( "warn-orphans", Opt_WarnOrphans, const Supported ), ( "warn-tabs", Opt_WarnTabs, const Supported ), @@ -1517,7 +1523,8 @@ fFlags = [ ( "print-bind-result", Opt_PrintBindResult, const Supported ), ( "force-recomp", Opt_ForceRecomp, const Supported ), ( "hpc-no-auto", Opt_Hpc_No_Auto, const Supported ), - ( "rewrite-rules", Opt_RewriteRules, const Supported ), + ( "rewrite-rules", Opt_EnableRewriteRules, useInstead "enable-rewrite-rules" ), + ( "enable-rewrite-rules", Opt_EnableRewriteRules, const Supported ), ( "break-on-exception", Opt_BreakOnException, const Supported ), ( "break-on-error", Opt_BreakOnError, const Supported ), ( "print-evld-with-show", Opt_PrintEvldWithShow, const Supported ), @@ -1582,7 +1589,6 @@ xFlags = [ ( "PolymorphicComponents", Opt_PolymorphicComponents, const Supported ), ( "ExistentialQuantification", Opt_ExistentialQuantification, const Supported ), ( "KindSignatures", Opt_KindSignatures, const Supported ), - ( "PatternSignatures", Opt_PatternSignatures, const Supported ), ( "EmptyDataDecls", Opt_EmptyDataDecls, const Supported ), ( "ParallelListComp", Opt_ParallelListComp, const Supported ), ( "TransformListComp", Opt_TransformListComp, const Supported ), @@ -1619,6 +1625,10 @@ xFlags = [ ( "ExtendedDefaultRules", Opt_ExtendedDefaultRules, const Supported ), ( "ImplicitParams", Opt_ImplicitParams, const Supported ), ( "ScopedTypeVariables", Opt_ScopedTypeVariables, const Supported ), + + ( "PatternSignatures", Opt_ScopedTypeVariables, + deprecatedForLanguage "ScopedTypeVariables" ), + ( "UnboxedTuples", Opt_UnboxedTuples, const Supported ), ( "StandaloneDeriving", Opt_StandaloneDeriving, const Supported ), ( "DeriveDataTypeable", Opt_DeriveDataTypeable, const Supported ), @@ -1635,12 +1645,13 @@ xFlags = [ ( "PackageImports", Opt_PackageImports, const Supported ) ] -impliedFlags :: [(DynFlag, [DynFlag])] -impliedFlags = [ - ( Opt_GADTs, [Opt_RelaxedPolyRec] ) -- We want type-sig variables to - -- be completely rigid for GADTs - , ( Opt_ScopedTypeVariables, [Opt_RelaxedPolyRec] ) -- Ditto for scoped type variables; see - -- Note [Scoped tyvars] in TcBinds +impliedFlags :: [(DynFlag, DynFlag)] +impliedFlags + = [ (Opt_GADTs, Opt_RelaxedPolyRec) -- We want type-sig variables to + -- be completely rigid for GADTs + + , (Opt_ScopedTypeVariables, Opt_RelaxedPolyRec) -- Ditto for scoped type variables; see + -- Note [Scoped tyvars] in TcBinds ] glasgowExtsFlags :: [DynFlag] @@ -1674,14 +1685,14 @@ glasgowExtsFlags = [ , Opt_ParallelListComp , Opt_EmptyDataDecls , Opt_KindSignatures - , Opt_PatternSignatures , Opt_GeneralizedNewtypeDeriving , Opt_TypeFamilies ] -- ----------------------------------------------------------------------------- -- Parsing the dynamic flags. -parseDynamicFlags :: DynFlags -> [String] -> IO (DynFlags, [String], [String]) +parseDynamicFlags :: DynFlags -> [Located String] + -> IO (DynFlags, [Located String], [Located String]) parseDynamicFlags dflags args = do -- XXX Legacy support code -- We used to accept things like @@ -1690,14 +1701,13 @@ parseDynamicFlags dflags args = do -- optdep -f -optdepdepend -- optdep -f -optdep depend -- but the spaces trip up proper argument handling. So get rid of them. - let f ("-optdep" : x : xs) = ("-optdep" ++ x) : f xs + let f (L p "-optdep" : L _ x : xs) = (L p ("-optdep" ++ x)) : f xs f (x : xs) = x : f xs f xs = xs args' = f args let ((leftover, errs, warns), dflags') = runCmdLine (processArgs dynamic_flags args') dflags - when (not (null errs)) $ do - ghcError (UsageError (unlines errs)) + when (not (null errs)) $ ghcError $ errorsToGhcException errs return (dflags', leftover, warns) type DynP = CmdLineP DynFlags @@ -1709,10 +1719,13 @@ upd f = do -------------------------- setDynFlag, unSetDynFlag :: DynFlag -> DynP () -setDynFlag f = upd (\dfs -> foldl dopt_set (dopt_set dfs f) deps) +setDynFlag f = do { upd (\dfs -> dopt_set dfs f) + ; mapM_ setDynFlag deps } where - deps = [ d | (f', ds) <- impliedFlags, f' == f, d <- ds ] + 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 -- When you un-set f, however, we don't un-set the things it implies -- (except for -fno-glasgow-exts, which is treated specially)