Skip to content

GitLab

Commit 27286cf2 authored by Ian Lynagh's avatar Ian Lynagh
Browse files

Separate the language flags from the other DynFlag's

parent 793bde8a
Hide whitespace changes
Inline Side-by-side
Showing with 181 additions and 130 deletions
compiler/main/DynFlags.hs
View file @ 27286cf2
......@@ -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\<blah\>@ flags can all be reversed with @-fno-\<blah\>@
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<blah> flags can all be reversed with -XNo<blah>
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
......
compiler/rename/RnBinds.lhs
View file @ 27286cf2
......@@ -28,7 +28,7 @@ import RnPat (rnPats, rnBindPat,
)
import RnEnv
import DynFlags ( DynFlag(..) )
import DynFlags
import Name
import NameEnv
import NameSet
......
compiler/rename/RnExpr.lhs
View file @ 27286cf2
......@@ -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
......
compiler/rename/RnPat.lhs
View file @ 27286cf2
......@@ -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
......
compiler/rename/RnSource.lhs
View file @ 27286cf2
......@@ -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 )
......
compiler/typecheck/TcDeriv.lhs
View file @ 27286cf2
......@@ -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
......
compiler/typecheck/TcPat.lhs
View file @ 27286cf2
......@@ -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
......
compiler/typecheck/TcRnMonad.lhs
View file @ 27286cf2
......@@ -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 () }
......
ghc/InteractiveUI.hs
View file @ 27286cf2
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment