[Git][ghc/ghc][master] Refactoring: Use `OnOff` more consistently for `Extension`
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Nov 25 08:57:16 UTC 2024
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
a05e4a9b by Simon Hengel at 2024-11-25T03:56:33-05:00
Refactoring: Use `OnOff` more consistently for `Extension`
- - - - -
4 changed files:
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Types/Hint/Ppr.hs
Changes:
=====================================
compiler/GHC/Driver/DynFlags.hs
=====================================
@@ -729,16 +729,6 @@ newtype FlushOut = FlushOut (IO ())
defaultFlushOut :: FlushOut
defaultFlushOut = FlushOut $ hFlush stdout
-
-
-data OnOff a = On a
- | Off a
- deriving (Eq, Show)
-
-instance Outputable a => Outputable (OnOff a) where
- ppr (On x) = text "On" <+> ppr x
- ppr (Off x) = text "Off" <+> ppr x
-
-- OnOffs accumulate in reverse order, so we use foldr in order to
-- process them in the right order
flattenExtensionFlags :: Maybe Language -> [OnOff LangExt.Extension] -> EnumSet LangExt.Extension
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -29,6 +29,7 @@ module GHC.Driver.Flags
, minusWcompatOpts
, unusedBindsFlags
+ , OnOff(..)
, TurnOnFlag
, turnOn
, turnOff
@@ -77,6 +78,14 @@ instance Binary Language where
instance NFData Language where
rnf x = x `seq` ()
+data OnOff a = On a
+ | Off a
+ deriving (Eq, Show)
+
+instance Outputable a => Outputable (OnOff a) where
+ ppr (On x) = text "On" <+> ppr x
+ ppr (Off x) = text "Off" <+> ppr x
+
type TurnOnFlag = Bool -- True <=> we are turning the flag on
-- False <=> we are turning the flag off
turnOn :: TurnOnFlag; turnOn = True
@@ -269,78 +278,77 @@ extensionNames ext = mk (extensionDeprecation ext) (extensionName ext : exte
++ mk (ExtensionDeprecatedFor [ext]) (extensionDeprecatedNames ext)
where mk depr = map (\name -> (depr, name))
-
-impliedXFlags :: [(LangExt.Extension, TurnOnFlag, LangExt.Extension)]
+impliedXFlags :: [(LangExt.Extension, OnOff LangExt.Extension)]
impliedXFlags
-- See Note [Updating flag description in the User's Guide]
- = [ (LangExt.RankNTypes, turnOn, LangExt.ExplicitForAll)
- , (LangExt.QuantifiedConstraints, turnOn, LangExt.ExplicitForAll)
- , (LangExt.ScopedTypeVariables, turnOn, LangExt.ExplicitForAll)
- , (LangExt.LiberalTypeSynonyms, turnOn, LangExt.ExplicitForAll)
- , (LangExt.ExistentialQuantification, turnOn, LangExt.ExplicitForAll)
- , (LangExt.FlexibleInstances, turnOn, LangExt.TypeSynonymInstances)
- , (LangExt.FunctionalDependencies, turnOn, LangExt.MultiParamTypeClasses)
- , (LangExt.MultiParamTypeClasses, turnOn, LangExt.ConstrainedClassMethods) -- c.f. #7854
- , (LangExt.TypeFamilyDependencies, turnOn, LangExt.TypeFamilies)
+ = [ (LangExt.RankNTypes, On LangExt.ExplicitForAll)
+ , (LangExt.QuantifiedConstraints, On LangExt.ExplicitForAll)
+ , (LangExt.ScopedTypeVariables, On LangExt.ExplicitForAll)
+ , (LangExt.LiberalTypeSynonyms, On LangExt.ExplicitForAll)
+ , (LangExt.ExistentialQuantification, On LangExt.ExplicitForAll)
+ , (LangExt.FlexibleInstances, On LangExt.TypeSynonymInstances)
+ , (LangExt.FunctionalDependencies, On LangExt.MultiParamTypeClasses)
+ , (LangExt.MultiParamTypeClasses, On LangExt.ConstrainedClassMethods) -- c.f. #7854
+ , (LangExt.TypeFamilyDependencies, On LangExt.TypeFamilies)
- , (LangExt.RebindableSyntax, turnOff, LangExt.ImplicitPrelude) -- NB: turn off!
+ , (LangExt.RebindableSyntax, Off LangExt.ImplicitPrelude) -- NB: turn off!
- , (LangExt.DerivingVia, turnOn, LangExt.DerivingStrategies)
+ , (LangExt.DerivingVia, On LangExt.DerivingStrategies)
- , (LangExt.GADTs, turnOn, LangExt.GADTSyntax)
- , (LangExt.GADTs, turnOn, LangExt.MonoLocalBinds)
- , (LangExt.TypeFamilies, turnOn, LangExt.MonoLocalBinds)
+ , (LangExt.GADTs, On LangExt.GADTSyntax)
+ , (LangExt.GADTs, On LangExt.MonoLocalBinds)
+ , (LangExt.TypeFamilies, On LangExt.MonoLocalBinds)
- , (LangExt.TypeFamilies, turnOn, LangExt.KindSignatures) -- Type families use kind signatures
- , (LangExt.PolyKinds, turnOn, LangExt.KindSignatures) -- Ditto polymorphic kinds
+ , (LangExt.TypeFamilies, On LangExt.KindSignatures) -- Type families use kind signatures
+ , (LangExt.PolyKinds, On LangExt.KindSignatures) -- Ditto polymorphic kinds
-- TypeInType is now just a synonym for a couple of other extensions.
- , (LangExt.TypeInType, turnOn, LangExt.DataKinds)
- , (LangExt.TypeInType, turnOn, LangExt.PolyKinds)
- , (LangExt.TypeInType, turnOn, LangExt.KindSignatures)
+ , (LangExt.TypeInType, On LangExt.DataKinds)
+ , (LangExt.TypeInType, On LangExt.PolyKinds)
+ , (LangExt.TypeInType, On LangExt.KindSignatures)
-- Standalone kind signatures are a replacement for CUSKs.
- , (LangExt.StandaloneKindSignatures, turnOff, LangExt.CUSKs)
+ , (LangExt.StandaloneKindSignatures, Off LangExt.CUSKs)
-- AutoDeriveTypeable is not very useful without DeriveDataTypeable
- , (LangExt.AutoDeriveTypeable, turnOn, LangExt.DeriveDataTypeable)
+ , (LangExt.AutoDeriveTypeable, On LangExt.DeriveDataTypeable)
-- We turn this on so that we can export associated type
-- type synonyms in subordinates (e.g. MyClass(type AssocType))
- , (LangExt.TypeFamilies, turnOn, LangExt.ExplicitNamespaces)
- , (LangExt.TypeOperators, turnOn, LangExt.ExplicitNamespaces)
+ , (LangExt.TypeFamilies, On LangExt.ExplicitNamespaces)
+ , (LangExt.TypeOperators, On LangExt.ExplicitNamespaces)
- , (LangExt.ImpredicativeTypes, turnOn, LangExt.RankNTypes)
+ , (LangExt.ImpredicativeTypes, On LangExt.RankNTypes)
-- Record wild-cards implies field disambiguation
-- Otherwise if you write (C {..}) you may well get
-- stuff like " 'a' not in scope ", which is a bit silly
-- if the compiler has just filled in field 'a' of constructor 'C'
- , (LangExt.RecordWildCards, turnOn, LangExt.DisambiguateRecordFields)
+ , (LangExt.RecordWildCards, On LangExt.DisambiguateRecordFields)
- , (LangExt.ParallelArrays, turnOn, LangExt.ParallelListComp)
+ , (LangExt.ParallelArrays, On LangExt.ParallelListComp)
- , (LangExt.JavaScriptFFI, turnOn, LangExt.InterruptibleFFI)
+ , (LangExt.JavaScriptFFI, On LangExt.InterruptibleFFI)
- , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFunctor)
- , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFoldable)
+ , (LangExt.DeriveTraversable, On LangExt.DeriveFunctor)
+ , (LangExt.DeriveTraversable, On LangExt.DeriveFoldable)
-- Duplicate record fields require field disambiguation
- , (LangExt.DuplicateRecordFields, turnOn, LangExt.DisambiguateRecordFields)
+ , (LangExt.DuplicateRecordFields, On LangExt.DisambiguateRecordFields)
- , (LangExt.TemplateHaskell, turnOn, LangExt.TemplateHaskellQuotes)
- , (LangExt.Strict, turnOn, LangExt.StrictData)
+ , (LangExt.TemplateHaskell, On LangExt.TemplateHaskellQuotes)
+ , (LangExt.Strict, On LangExt.StrictData)
-- Historically only UnboxedTuples was required for unboxed sums to work.
-- To avoid breaking code, we make UnboxedTuples imply UnboxedSums.
- , (LangExt.UnboxedTuples, turnOn, LangExt.UnboxedSums)
+ , (LangExt.UnboxedTuples, On LangExt.UnboxedSums)
-- The extensions needed to declare an H98 unlifted data type
- , (LangExt.UnliftedDatatypes, turnOn, LangExt.DataKinds)
- , (LangExt.UnliftedDatatypes, turnOn, LangExt.StandaloneKindSignatures)
+ , (LangExt.UnliftedDatatypes, On LangExt.DataKinds)
+ , (LangExt.UnliftedDatatypes, On LangExt.StandaloneKindSignatures)
-- See Note [Non-variable pattern bindings aren't linear] in GHC.Tc.Gen.Bind
- , (LangExt.LinearTypes, turnOn, LangExt.MonoLocalBinds)
+ , (LangExt.LinearTypes, On LangExt.MonoLocalBinds)
]
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -2925,13 +2925,18 @@ unSetExtensionFlag f = upd (unSetExtensionFlag' f)
setExtensionFlag', unSetExtensionFlag' :: LangExt.Extension -> DynFlags -> DynFlags
setExtensionFlag' f dflags = foldr ($) (xopt_set dflags f) deps
where
- deps = [ if turn_on then setExtensionFlag' d
- else unSetExtensionFlag' d
- | (f', turn_on, d) <- impliedXFlags, f' == f ]
+ deps :: [DynFlags -> DynFlags]
+ deps = [ setExtension d
+ | (f', d) <- impliedXFlags, f' == f ]
-- When you set f, set the ones it implies
-- NB: use setExtensionFlag recursively, in case the implied flags
-- implies further flags
+ setExtension :: OnOff LangExt.Extension -> DynFlags -> DynFlags
+ setExtension = \ case
+ On extension -> setExtensionFlag' extension
+ Off extension -> unSetExtensionFlag' extension
+
unSetExtensionFlag' f dflags = xopt_unset dflags 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)
=====================================
compiler/GHC/Types/Hint/Ppr.hs
=====================================
@@ -403,9 +403,7 @@ pprImpliedExtensions extension = case implied of
xs -> parens $ "implied by" <+> unquotedListWith "and" xs
where implied = map (quotes . ppr)
. filter (\ext -> extensionDeprecation ext == ExtensionNotDeprecated)
- . map (\(impl, _, _) -> impl)
- . filter (\(_, t, orig) -> orig == extension && t == turnOn)
- $ impliedXFlags
+ $ [impl | (impl, On orig) <- impliedXFlags, orig == extension]
pprPrefixUnqual :: Name -> SDoc
pprPrefixUnqual name =
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a05e4a9b04a3a43c2172f4d68471d5b4053ad367
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a05e4a9b04a3a43c2172f4d68471d5b4053ad367
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20241125/3c243951/attachment-0001.html>
More information about the ghc-commits
mailing list