[Git][ghc/ghc][wip/T24477] WIP
Jade (@Jade)
gitlab at gitlab.haskell.org
Fri Apr 5 23:19:29 UTC 2024
Jade pushed to branch wip/T24477 at Glasgow Haskell Compiler / GHC
Commits:
25c852b9 by Jade at 2024-04-06T01:24:05+02:00
WIP
- - - - -
4 changed files:
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Types/Hint/Ppr.hs
- testsuite/tests/ghci/should_run/T10857a.stdout
Changes:
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -42,6 +42,8 @@ module GHC.Driver.Flags
, Deprecation(..)
, extensionDeprecation
, deprecation
+ , extensionNames
+ , extensionName
)
where
@@ -93,22 +95,36 @@ deprecation :: ExtensionDeprecation -> Deprecation
deprecation ExtensionNotDeprecated = NotDeprecated
deprecation _ = Deprecated
-extensionDeprecation :: String -> ExtensionDeprecation
+extensionDeprecation :: LangExt.Extension -> ExtensionDeprecation
extensionDeprecation = \case
- "TypeInType" -> ExtensionDeprecatedFor [LangExt.DataKinds, LangExt.PolyKinds]
- "RecordPuns" -> ExtensionDeprecatedFor [LangExt.NamedFieldPuns]
- "PatternSignatures" -> ExtensionDeprecatedFor [LangExt.ScopedTypeVariables]
- "NullaryTypeClasses" -> ExtensionDeprecatedFor [LangExt.MultiParamTypeClasses]
- "DoRec" -> ExtensionDeprecatedFor [LangExt.RecursiveDo]
- "RelaxedPolyRec" -> ExtensionFlagDeprecatedCond turnOff
+ LangExt.TypeInType -> ExtensionDeprecatedFor [LangExt.DataKinds, LangExt.PolyKinds]
+ LangExt.NullaryTypeClasses -> ExtensionDeprecatedFor [LangExt.MultiParamTypeClasses]
+ LangExt.RelaxedPolyRec -> ExtensionFlagDeprecatedCond turnOff
"You can't turn off RelaxedPolyRec any more"
- "DatatypeContexts" -> ExtensionFlagDeprecatedCond turnOn
+ LangExt.DatatypeContexts -> ExtensionFlagDeprecatedCond turnOn
"It was widely considered a misfeature, and has been removed from the Haskell language."
- "AutoDeriveTypeable" -> ExtensionFlagDeprecatedCond turnOn
+ LangExt.AutoDeriveTypeable -> ExtensionFlagDeprecatedCond turnOn
"Typeable instances are created automatically for all types since GHC 8.2."
- "OverlappingInstances" -> ExtensionFlagDeprecated
+ LangExt.OverlappingInstances -> ExtensionFlagDeprecated
"instead use per-instance pragmas OVERLAPPING/OVERLAPPABLE/OVERLAPS"
- _ -> ExtensionNotDeprecated
+ _ -> ExtensionNotDeprecated
+
+
+extensionName :: LangExt.Extension -> String
+extensionName LangExt.Cpp = "CPP"
+extensionName ext = show ext
+
+-- | Is this extension known by any other names? For example
+-- -XGeneralizedNewtypeDeriving is accepted
+extensionAlternateNames :: LangExt.Extension -> [String]
+extensionAlternateNames = \case
+ LangExt.GeneralizedNewtypeDeriving -> ["GeneralisedNewtypeDeriving"]
+ LangExt.RankNTypes -> ["Rank2Types", "PolymorphicComponents"]
+ _ -> []
+
+-- | All the names by which an extension is known.
+extensionNames :: LangExt.Extension -> [String]
+extensionNames ext = extensionName ext : extensionAlternateNames ext
impliedXFlags :: [(LangExt.Extension, TurnOnFlag, LangExt.Extension)]
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -2608,15 +2608,33 @@ safeHaskellFlagsDeps = [mkF Sf_Unsafe, mkF Sf_Trustworthy, mkF Sf_Safe]
xFlags :: [FlagSpec LangExt.Extension]
xFlags = map snd xFlagsDeps
-makeExtensionFlag :: (String, LangExt.Extension) -> (Deprecation, FlagSpec LangExt.Extension)
-makeExtensionFlag (name, ext) = (deprecation depr, spec)
- where depr = extensionDeprecation name
+makeExtensionFlags :: LangExt.Extension -> [(Deprecation, FlagSpec LangExt.Extension)]
+makeExtensionFlags ext = [ makeExtensionFlag name ext | name <- extensionNames ext ]
+
+-- We save lots of lines here by getting rid of all the boilerplate (String, Extension) pairs! Almost all flags are uniform so we can just treat the special cases specially.
+xFlagsDeps :: [(Deprecation, FlagSpec LangExt.Extension)]
+xFlagsDeps = concatMap makeExtensionFlags [minBound .. maxBound] ++ xFlagsDepsSpecialCases
+
+-- | These are deprecated extension flags that do not correspond to a proper Extension.
+xFlagsDepsSpecialCases :: [(Deprecation, FlagSpec LangExt.Extension)]
+xFlagsDepsSpecialCases =
+ [ depXFlagSpec "DoRec" LangExt.RecursiveDo
+ , depXFlagSpec "RecordPuns" LangExt.NamedFieldPuns
+ , depXFlagSpec "PatternSignatures" LangExt.ScopedTypeVariables
+ ]
+
+depXFlagSpec :: String -> LangExt.Extension -> (Deprecation, FlagSpec LangExt.Extension)
+depXFlagSpec s ext = depFlagSpec' s ext (deprecatedForExtension $ extensionName ext)
+
+makeExtensionFlag :: String -> LangExt.Extension -> (Deprecation, FlagSpec LangExt.Extension)
+makeExtensionFlag name ext = (deprecation depr, spec)
+ where depr = extensionDeprecation ext
effect = extensionEffect ext
spec = FlagSpec name ext (\f -> effect f >> act f) AllModes
act = case depr of
ExtensionNotDeprecated -> nop
ExtensionDeprecatedFor xs
- -> deprecate . deprecatedForExtensions (map show xs) -- JADE_TODO
+ -> deprecate . deprecatedForExtensions (map extensionName xs)
ExtensionFlagDeprecatedCond cond str
-> \f -> when (f == cond) (deprecate str)
ExtensionFlagDeprecated str
@@ -2636,148 +2654,6 @@ extensionEffect = \case
-> setDeriveVia
_ -> nop
-xFlagsDeps :: [(Deprecation, FlagSpec LangExt.Extension)]
-xFlagsDeps = map makeExtensionFlag
- [ ("AllowAmbiguousTypes", LangExt.AllowAmbiguousTypes)
- , ("AlternativeLayoutRule", LangExt.AlternativeLayoutRule)
- , ("AlternativeLayoutRuleTransitional", LangExt.AlternativeLayoutRuleTransitional)
- , ("Arrows", LangExt.Arrows)
- , ("AutoDeriveTypeable", LangExt.AutoDeriveTypeable)
- , ("BangPatterns", LangExt.BangPatterns)
- , ("BinaryLiterals", LangExt.BinaryLiterals)
- , ("CApiFFI", LangExt.CApiFFI)
- , ("CPP", LangExt.Cpp)
- , ("CUSKs", LangExt.CUSKs)
- , ("ConstrainedClassMethods", LangExt.ConstrainedClassMethods)
- , ("ConstraintKinds", LangExt.ConstraintKinds)
- , ("DataKinds", LangExt.DataKinds)
- , ("DatatypeContexts", LangExt.DatatypeContexts)
- , ("DefaultSignatures", LangExt.DefaultSignatures)
- , ("DeriveAnyClass", LangExt.DeriveAnyClass)
- , ("DeriveDataTypeable", LangExt.DeriveDataTypeable)
- , ("DeriveFoldable", LangExt.DeriveFoldable)
- , ("DeriveFunctor", LangExt.DeriveFunctor)
- , ("DeriveGeneric", LangExt.DeriveGeneric)
- , ("DeriveLift", LangExt.DeriveLift)
- , ("DeriveTraversable", LangExt.DeriveTraversable)
- , ("DerivingStrategies", LangExt.DerivingStrategies)
- , ("DerivingVia", LangExt.DerivingVia)
- , ("DisambiguateRecordFields", LangExt.DisambiguateRecordFields)
- , ("DoAndIfThenElse", LangExt.DoAndIfThenElse)
- , ("BlockArguments", LangExt.BlockArguments)
- , ("DoRec", LangExt.RecursiveDo)
- , ("DuplicateRecordFields", LangExt.DuplicateRecordFields)
- , ("FieldSelectors", LangExt.FieldSelectors)
- , ("EmptyCase", LangExt.EmptyCase)
- , ("EmptyDataDecls", LangExt.EmptyDataDecls)
- , ("EmptyDataDeriving", LangExt.EmptyDataDeriving)
- , ("ExistentialQuantification", LangExt.ExistentialQuantification)
- , ("ExplicitForAll", LangExt.ExplicitForAll)
- , ("ExplicitNamespaces", LangExt.ExplicitNamespaces)
- , ("ExtendedDefaultRules", LangExt.ExtendedDefaultRules)
- , ("ExtendedLiterals", LangExt.ExtendedLiterals)
- , ("FlexibleContexts", LangExt.FlexibleContexts)
- , ("FlexibleInstances", LangExt.FlexibleInstances)
- , ("ForeignFunctionInterface", LangExt.ForeignFunctionInterface)
- , ("FunctionalDependencies", LangExt.FunctionalDependencies)
- , ("GADTSyntax", LangExt.GADTSyntax)
- , ("GADTs", LangExt.GADTs)
- , ("GHCForeignImportPrim", LangExt.GHCForeignImportPrim)
- , ("GeneralizedNewtypeDeriving", LangExt.GeneralizedNewtypeDeriving)
- , ("GeneralisedNewtypeDeriving", LangExt.GeneralizedNewtypeDeriving)
- , ("ImplicitParams", LangExt.ImplicitParams)
- , ("ImplicitPrelude", LangExt.ImplicitPrelude)
- , ("ImportQualifiedPost", LangExt.ImportQualifiedPost)
- , ("ImpredicativeTypes", LangExt.ImpredicativeTypes)
- , ("IncoherentInstances", LangExt.IncoherentInstances)
- , ("TypeFamilyDependencies", LangExt.TypeFamilyDependencies)
- , ("InstanceSigs", LangExt.InstanceSigs)
- , ("ApplicativeDo", LangExt.ApplicativeDo)
- , ("InterruptibleFFI", LangExt.InterruptibleFFI)
- , ("JavaScriptFFI", LangExt.JavaScriptFFI)
- , ("KindSignatures", LangExt.KindSignatures)
- , ("LambdaCase", LangExt.LambdaCase)
- , ("LexicalNegation", LangExt.LexicalNegation)
- , ("LiberalTypeSynonyms", LangExt.LiberalTypeSynonyms)
- , ("LinearTypes", LangExt.LinearTypes)
- , ("ListTuplePuns", LangExt.ListTuplePuns)
- , ("MagicHash", LangExt.MagicHash)
- , ("MonadComprehensions", LangExt.MonadComprehensions)
- , ("MonoLocalBinds", LangExt.MonoLocalBinds)
- , ("DeepSubsumption", LangExt.DeepSubsumption)
- , ("MonomorphismRestriction", LangExt.MonomorphismRestriction)
- , ("MultiParamTypeClasses", LangExt.MultiParamTypeClasses)
- , ("MultiWayIf", LangExt.MultiWayIf)
- , ("NumericUnderscores", LangExt.NumericUnderscores)
- , ("NPlusKPatterns", LangExt.NPlusKPatterns)
- , ("NamedFieldPuns", LangExt.NamedFieldPuns)
- , ("NamedWildCards", LangExt.NamedWildCards)
- , ("NegativeLiterals", LangExt.NegativeLiterals)
- , ("HexFloatLiterals", LangExt.HexFloatLiterals)
- , ("NondecreasingIndentation", LangExt.NondecreasingIndentation)
- , ("NullaryTypeClasses", LangExt.NullaryTypeClasses)
- , ("NumDecimals", LangExt.NumDecimals)
- , ("OverlappingInstances", LangExt.OverlappingInstances)
- , ("OverloadedLabels", LangExt.OverloadedLabels)
- , ("OverloadedLists", LangExt.OverloadedLists)
- , ("OverloadedStrings", LangExt.OverloadedStrings)
- , ("PackageImports", LangExt.PackageImports)
- , ("ParallelArrays", LangExt.ParallelArrays)
- , ("ParallelListComp", LangExt.ParallelListComp)
- , ("PartialTypeSignatures", LangExt.PartialTypeSignatures)
- , ("PatternGuards", LangExt.PatternGuards)
- , ("PatternSignatures", LangExt.ScopedTypeVariables)
- , ("PatternSynonyms", LangExt.PatternSynonyms)
- , ("PolyKinds", LangExt.PolyKinds)
- , ("PolymorphicComponents", LangExt.RankNTypes)
- , ("QuantifiedConstraints", LangExt.QuantifiedConstraints)
- , ("PostfixOperators", LangExt.PostfixOperators)
- , ("QuasiQuotes", LangExt.QuasiQuotes)
- , ("QualifiedDo", LangExt.QualifiedDo)
- , ("Rank2Types", LangExt.RankNTypes)
- , ("RankNTypes", LangExt.RankNTypes)
- , ("RebindableSyntax", LangExt.RebindableSyntax)
- , ("OverloadedRecordDot", LangExt.OverloadedRecordDot)
- , ("OverloadedRecordUpdate", LangExt.OverloadedRecordUpdate)
- , ("RecordPuns", LangExt.NamedFieldPuns)
- , ("RecordWildCards", LangExt.RecordWildCards)
- , ("RecursiveDo", LangExt.RecursiveDo)
- , ("RelaxedLayout", LangExt.RelaxedLayout)
- , ("RelaxedPolyRec", LangExt.RelaxedPolyRec)
- , ("RequiredTypeArguments", LangExt.RequiredTypeArguments)
- , ("RoleAnnotations", LangExt.RoleAnnotations)
- , ("ScopedTypeVariables", LangExt.ScopedTypeVariables)
- , ("StandaloneDeriving", LangExt.StandaloneDeriving)
- , ("StarIsType", LangExt.StarIsType)
- , ("StaticPointers", LangExt.StaticPointers)
- , ("Strict", LangExt.Strict)
- , ("StrictData", LangExt.StrictData)
- , ("TemplateHaskell", LangExt.TemplateHaskell)
- , ("TemplateHaskellQuotes", LangExt.TemplateHaskellQuotes)
- , ("StandaloneKindSignatures", LangExt.StandaloneKindSignatures)
- , ("TraditionalRecordSyntax", LangExt.TraditionalRecordSyntax)
- , ("TransformListComp", LangExt.TransformListComp)
- , ("TupleSections", LangExt.TupleSections)
- , ("TypeAbstractions", LangExt.TypeAbstractions)
- , ("TypeApplications", LangExt.TypeApplications)
- , ("TypeData", LangExt.TypeData)
- , ("TypeInType", LangExt.TypeInType)
- , ("TypeFamilies", LangExt.TypeFamilies)
- , ("TypeOperators", LangExt.TypeOperators)
- , ("TypeSynonymInstances", LangExt.TypeSynonymInstances)
- , ("UnboxedTuples", LangExt.UnboxedTuples)
- , ("UnboxedSums", LangExt.UnboxedSums)
- , ("UndecidableInstances", LangExt.UndecidableInstances)
- , ("UndecidableSuperClasses", LangExt.UndecidableSuperClasses)
- , ("UnicodeSyntax", LangExt.UnicodeSyntax)
- , ("UnliftedDatatypes", LangExt.UnliftedDatatypes)
- , ("UnliftedFFITypes", LangExt.UnliftedFFITypes)
- , ("UnliftedNewtypes", LangExt.UnliftedNewtypes)
- , ("ViewPatterns", LangExt.ViewPatterns)
- ]
-
-
-
-- | Things you get with `-dlint`.
enableDLint :: DynP ()
enableDLint = do
=====================================
compiler/GHC/Types/Hint/Ppr.hs
=====================================
@@ -383,7 +383,7 @@ pprImpliedExtensions extension = case implied of
[] -> empty
xs -> parens $ "implied by" <+> unquotedListWith "and" xs
where implied = map ppr
- . filter (\ext -> extensionDeprecation (show ext) == ExtensionNotDeprecated)
+ . filter (\ext -> extensionDeprecation ext == ExtensionNotDeprecated)
. map (\(impl, _, _) -> impl)
. filter (\(_, t, orig) -> orig == extension && t == turnOn)
$ impliedXFlags
=====================================
testsuite/tests/ghci/should_run/T10857a.stdout
=====================================
@@ -1,4 +1,4 @@
base language is: GHC2021
with the following modifiers:
- -XExtendedDefaultRules
-XNoMonomorphismRestriction
+ -XExtendedDefaultRules
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/25c852b96be168ee6cc68b20e7ea81504cec2f34
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/25c852b96be168ee6cc68b20e7ea81504cec2f34
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/20240405/ddc5dc65/attachment-0001.html>
More information about the ghc-commits
mailing list