X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FDynFlags.hs;h=58bf18cf2e50e877fe86987c89c4fa19bb98aea6;hb=8c8dc051ba58e394650ae3579a7d2eb67189b297;hp=557dfb47ff013e6a4e7dfb6b0b5fe10768038883;hpb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516;p=ghc-hetmet.git diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 557dfb4..58bf18c 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, @@ -88,7 +93,6 @@ import Util import Maybes ( orElse ) import SrcLoc import FastString -import FiniteMap import Outputable import Foreign.C ( CInt ) import {-# SOURCE #-} ErrUtils ( Severity(..), Message, mkLocMessage ) @@ -99,6 +103,8 @@ import Control.Monad ( when ) import Data.Char import Data.List +import Data.Map (Map) +import qualified Data.Map as Map import System.FilePath import System.IO ( stderr, hPutChar ) @@ -183,9 +189,9 @@ data DynFlag | Opt_WarnMissingImportList | Opt_WarnMissingMethods | Opt_WarnMissingSigs + | Opt_WarnMissingLocalSigs | Opt_WarnNameShadowing | Opt_WarnOverlappingPatterns - | Opt_WarnSimplePatterns | Opt_WarnTypeDefaults | Opt_WarnMonomorphism | Opt_WarnUnusedBinds @@ -488,7 +494,7 @@ data DynFlags = DynFlags { -- These have to be IORefs, because the defaultCleanupHandler needs to -- know what to clean when an exception happens filesToClean :: IORef [FilePath], - dirsToClean :: IORef (FiniteMap FilePath FilePath), + dirsToClean :: IORef (Map FilePath FilePath), -- hsc dynamic flags flags :: [DynFlag], @@ -612,7 +618,7 @@ initDynFlags dflags = do -- someday these will be dynamic flags ways <- readIORef v_Ways refFilesToClean <- newIORef [] - refDirsToClean <- newIORef emptyFM + refDirsToClean <- newIORef Map.empty return dflags{ ways = ways, buildTag = mkBuildTag (filter (not . wayRTSOnly) ways), @@ -732,7 +738,7 @@ defaultDynFlags = haddockOptions = Nothing, flags = defaultFlags, language = Nothing, - extensionFlags = Left defaultExtensionFlags, + extensionFlags = Left [], log_action = \severity srcSpan style msg -> case severity of @@ -795,6 +801,8 @@ languageExtensions Nothing = Opt_MonoPatBinds -- Experimentally, I'm making this non-standard -- behaviour the default, to see if anyone notices -- SLPJ July 06 + -- In due course I'd like Opt_MonoLocalBinds to be on by default + -- SLPJ September 2010 : languageExtensions (Just Haskell2010) languageExtensions (Just Haskell98) = [Opt_ImplicitPrelude, @@ -811,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 -> @@ -1437,9 +1428,9 @@ fFlags = [ ( "warn-missing-import-lists", Opt_WarnMissingImportList, nop ), ( "warn-missing-methods", Opt_WarnMissingMethods, nop ), ( "warn-missing-signatures", Opt_WarnMissingSigs, nop ), + ( "warn-missing-local-sigs", Opt_WarnMissingLocalSigs, nop ), ( "warn-name-shadowing", Opt_WarnNameShadowing, nop ), ( "warn-overlapping-patterns", Opt_WarnOverlappingPatterns, nop ), - ( "warn-simple-patterns", Opt_WarnSimplePatterns, nop ), ( "warn-type-defaults", Opt_WarnTypeDefaults, nop ), ( "warn-monomorphism-restriction", Opt_WarnMonomorphism, nop ), ( "warn-unused-binds", Opt_WarnUnusedBinds, nop ), @@ -1575,8 +1566,7 @@ xFlags = [ ( "LiberalTypeSynonyms", Opt_LiberalTypeSynonyms, nop ), ( "Rank2Types", Opt_Rank2Types, nop ), ( "RankNTypes", Opt_RankNTypes, nop ), - ( "ImpredicativeTypes", Opt_ImpredicativeTypes, - \_ -> deprecate "impredicative polymorphism will be simplified or removed in GHC 6.14" ), + ( "ImpredicativeTypes", Opt_ImpredicativeTypes, nop), ( "TypeOperators", Opt_TypeOperators, nop ), ( "RecursiveDo", Opt_RecursiveDo, deprecatedForExtension "DoRec"), @@ -1659,10 +1649,6 @@ defaultFlags ++ standardWarnings -defaultExtensionFlags :: [OnOff ExtensionFlag] -defaultExtensionFlags - = [] -- In due course I'd like Opt_MonoLocalBinds to be on by default - impliedFlags :: [(ExtensionFlag, ExtensionFlag)] impliedFlags = [ (Opt_RankNTypes, Opt_ExplicitForAll) @@ -1674,7 +1660,6 @@ impliedFlags , (Opt_GADTs, Opt_MonoLocalBinds) , (Opt_TypeFamilies, Opt_MonoLocalBinds) - , (Opt_FunctionalDependencies, Opt_MonoLocalBinds) , (Opt_TypeFamilies, Opt_KindSignatures) -- Type families use kind signatures -- all over the place @@ -1771,7 +1756,6 @@ minuswRemovesOpts = minusWallOpts ++ [Opt_WarnImplicitPrelude, Opt_WarnIncompletePatternsRecUpd, - Opt_WarnSimplePatterns, Opt_WarnMonomorphism, Opt_WarnUnrecognisedPragmas, Opt_WarnTabs @@ -1884,7 +1868,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 ] @@ -1894,7 +1878,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 () @@ -2299,6 +2283,7 @@ compilerInfo = [("Project name", String cProjectName), ("Object splitting", String cSplitObjs), ("Have native code generator", String cGhcWithNativeCodeGen), ("Have llvm code generator", String cGhcWithLlvmCodeGen), + ("Use archives for ghci", String (show cUseArchivesForGhci)), ("Support SMP", String cGhcWithSMP), ("Unregisterised", String cGhcUnregisterised), ("Tables next to code", String cGhcEnableTablesNextToCode),