recursion-ninja pushed to branch wip/fix-26636 at Glasgow Haskell Compiler / GHC Commits: 2c2a3ef3 by Cheng Shao at 2025-12-15T11:51:53-05:00 docs: drop obsolete warning about -fexternal-interpreter on windows This patch drops an obsolete warning about -fexternal-interpreter not supported on windows; it is supported since a long time ago, including the profiled way. - - - - - 68573aa5 by Marc Scholten at 2025-12-15T11:53:00-05:00 haddock: Drop Haddock.Backends.HaddockDB as it's unused - - - - - 966b38e1 by Recursion Ninja at 2025-12-16T10:26:16-05:00 Removing the 'Data' instance for 'InstEnv'. The 'Data' instance is blocking work on Trees that Grow, and the 'Data' instance seem to have been added without a clear purpose. - - - - - d9ed19cf by Recursion Ninja at 2025-12-16T10:26:40-05:00 'Decouple Language.Haskell.Syntax.Decls' from 'GHC.Unit.Module.Warnings' - - - - - 26 changed files: - compiler/GHC/Builtin/Utils.hs - compiler/GHC/Core/InstEnv.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Warnings.hs - compiler/GHC/Parser.y - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Tc/Deriv.hs - compiler/GHC/Tc/Deriv/Utils.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Instantiate.hs - compiler/GHC/Types/DefaultEnv.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Unit/Module/Warnings.hs - compiler/Language/Haskell/Syntax/Decls.hs - compiler/Language/Haskell/Syntax/Extension.hs - docs/users_guide/ghci.rst - testsuite/tests/diagnostic-codes/codes.stdout - utils/check-exact/ExactPrint.hs - utils/haddock/haddock-api/haddock-api.cabal - − utils/haddock/haddock-api/src/Haddock/Backends/HaddockDB.hs - utils/haddock/haddock-api/src/Haddock/Interface/Create.hs Changes: ===================================== compiler/GHC/Builtin/Utils.hs ===================================== @@ -79,6 +79,7 @@ import GHC.Utils.Panic import GHC.Utils.Constants (debugIsOn) import GHC.Parser.Annotation import GHC.Hs.Doc +import GHC.Hs.Extension (GhcPass) import GHC.Unit.Module.ModIface (IfaceExport) import GHC.Unit.Module.Warnings @@ -263,7 +264,7 @@ ghcPrimNames ] -- See Note [GHC.Prim Deprecations] -ghcPrimWarns :: Warnings a +ghcPrimWarns :: Warnings (GhcPass p) ghcPrimWarns = WarnSome -- declaration warnings (map mk_decl_dep primOpDeprecations) ===================================== compiler/GHC/Core/InstEnv.hs ===================================== @@ -7,7 +7,7 @@ The bits common to GHC.Tc.TyCl.Instance and GHC.Tc.Deriv. -} -{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} module GHC.Core.InstEnv ( DFunId, InstMatch, ClsInstLookupResult, @@ -55,7 +55,6 @@ import GHC.Types.Name.Set import GHC.Types.Basic import GHC.Types.Id import GHC.Generics (Generic) -import Data.Data ( Data ) import Data.List.NonEmpty ( NonEmpty (..), nonEmpty ) import qualified Data.List.NonEmpty as NE import Data.Maybe ( isJust ) @@ -114,7 +113,6 @@ data ClsInst -- See Note [Implementation of deprecated instances] -- in GHC.Tc.Solver.Dict } - deriving Data -- | A fuzzy comparison function for class instances, intended for sorting -- instances before displaying them to the user. ===================================== compiler/GHC/Hs/Decls.hs ===================================== @@ -1391,7 +1391,6 @@ type instance XXWarnDecls (GhcPass _) = DataConCantHappen type instance XWarning (GhcPass _) = (NamespaceSpecifier, (EpToken "[", EpToken "]")) type instance XXWarnDecl (GhcPass _) = DataConCantHappen - instance OutputableBndrId p => Outputable (WarnDecls (GhcPass p)) where ppr (Warnings ext decls) @@ -1411,7 +1410,7 @@ instance OutputableBndrId p <+> ppr txt where ppr_category = case txt of - WarningTxt (Just cat) _ _ -> ppr cat + WarningTxt _ (Just cat) _ -> ppr cat _ -> empty {- ===================================== compiler/GHC/Hs/Instances.hs ===================================== @@ -35,6 +35,7 @@ import GHC.Hs.ImpExp import GHC.Parser.Annotation import GHC.Types.Name.Reader (WithUserRdr(..)) import GHC.Data.BooleanFormula (BooleanFormula(..)) +import Language.Haskell.Syntax.Decls import Language.Haskell.Syntax.Extension (Anno) -- --------------------------------------------------------------------- @@ -276,6 +277,14 @@ deriving instance Data (WarnDecl GhcPs) deriving instance Data (WarnDecl GhcRn) deriving instance Data (WarnDecl GhcTc) +deriving instance Data (WarningTxt GhcPs) +deriving instance Data (WarningTxt GhcRn) +deriving instance Data (WarningTxt GhcTc) + +deriving instance Data (InWarningCategory GhcPs) +deriving instance Data (InWarningCategory GhcRn) +deriving instance Data (InWarningCategory GhcTc) + -- deriving instance (DataIdLR p p) => Data (AnnDecl p) deriving instance Data (AnnProvenance GhcPs) deriving instance Data (AnnProvenance GhcRn) ===================================== compiler/GHC/Iface/Syntax.hs ===================================== @@ -424,8 +424,8 @@ data IfaceWarnings [(IfExtName, IfaceWarningTxt)] data IfaceWarningTxt - = IfWarningTxt (Maybe WarningCategory) SourceText [(IfaceStringLiteral, [IfExtName])] - | IfDeprecatedTxt SourceText [(IfaceStringLiteral, [IfExtName])] + = IfWarningTxt SourceText (Maybe WarningCategory) [(IfaceStringLiteral, [IfExtName])] + | IfDeprecatedTxt SourceText [(IfaceStringLiteral, [IfExtName])] data IfaceStringLiteral = IfStringLiteral SourceText FastString @@ -664,7 +664,7 @@ fromIfaceWarnings = \case fromIfaceWarningTxt :: IfaceWarningTxt -> WarningTxt GhcRn fromIfaceWarningTxt = \case - IfWarningTxt mb_cat src strs -> WarningTxt (noLocA . fromWarningCategory <$> mb_cat) src (noLocA <$> map fromIfaceStringLiteralWithNames strs) + IfWarningTxt src mb_cat strs -> WarningTxt src (noLocA . fromWarningCategory <$> mb_cat) (noLocA <$> map fromIfaceStringLiteralWithNames strs) IfDeprecatedTxt src strs -> DeprecatedTxt src (noLocA <$> map fromIfaceStringLiteralWithNames strs) fromIfaceStringLiteralWithNames :: (IfaceStringLiteral, [IfExtName]) -> WithHsDocIdentifiers StringLiteral GhcRn ===================================== compiler/GHC/Iface/Warnings.hs ===================================== @@ -23,7 +23,7 @@ toIfaceWarnings (WarnSome vs ds) = IfWarnSome vs' ds' ds' = [(occ, toIfaceWarningTxt txt) | (occ, txt) <- ds] toIfaceWarningTxt :: WarningTxt GhcRn -> IfaceWarningTxt -toIfaceWarningTxt (WarningTxt mb_cat src strs) = IfWarningTxt (unLoc . iwc_wc . unLoc <$> mb_cat) src (map (toIfaceStringLiteralWithNames . unLoc) strs) +toIfaceWarningTxt (WarningTxt src mb_cat strs) = IfWarningTxt src (unLoc . iwc_wc . unLoc <$> mb_cat) (map (toIfaceStringLiteralWithNames . unLoc) strs) toIfaceWarningTxt (DeprecatedTxt src strs) = IfDeprecatedTxt src (map (toIfaceStringLiteralWithNames . unLoc) strs) toIfaceStringLiteralWithNames :: WithHsDocIdentifiers StringLiteral GhcRn -> (IfaceStringLiteral, [IfExtName]) ===================================== compiler/GHC/Parser.y ===================================== @@ -2053,12 +2053,12 @@ maybe_warning_pragma :: { Maybe (LWarningTxt GhcPs) } {% fmap Just $ amsr (sLL $1 $> $ DeprecatedTxt (getDEPRECATED_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $2)) (AnnPragma (glR $1) (epTok $3) (fst $ unLoc $2) noAnn noAnn noAnn noAnn) } | '{-# WARNING' warning_category strings '#-}' - {% fmap Just $ amsr (sLL $1 $> $ WarningTxt $2 (getWARNING_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $3)) + {% fmap Just $ amsr (sLL $1 $> $ WarningTxt (getWARNING_PRAGs $1) $2 (map stringLiteralToHsDocWst $ snd $ unLoc $3)) (AnnPragma (glR $1) (epTok $4) (fst $ unLoc $3) noAnn noAnn noAnn noAnn)} | {- empty -} { Nothing } -warning_category :: { Maybe (LocatedE InWarningCategory) } - : 'in' STRING { Just (reLoc $ sLL $1 $> $ InWarningCategory (epTok $1) (getSTRINGs $2) +warning_category :: { Maybe (LocatedE (InWarningCategory GhcPs)) } + : 'in' STRING { Just (reLoc $ sLL $1 $> $ InWarningCategory (epTok $1, getSTRINGs $2) (reLoc $ sL1 $2 $ mkWarningCategory (getSTRING $2))) } | {- empty -} { Nothing } @@ -2083,7 +2083,7 @@ warning :: { OrdList (LWarnDecl GhcPs) } : warning_category namespace_spec namelist strings {% fmap unitOL $ amsA' (L (comb4 $1 $2 $3 $4) (Warning (unLoc $2, fst $ unLoc $4) (unLoc $3) - (WarningTxt $1 NoSourceText $ map stringLiteralToHsDocWst $ snd $ unLoc $4))) } + (WarningTxt NoSourceText $1 (map stringLiteralToHsDocWst $ snd $ unLoc $4)))) } namespace_spec :: { Located NamespaceSpecifier } : 'type' { sL1 $1 $ TypeNamespaceSpecifier (epTok $1) } ===================================== compiler/GHC/Rename/Module.hs ===================================== @@ -320,12 +320,16 @@ rnSrcWarnDecls bndr_set decls' rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y)) rnWarningTxt :: WarningTxt GhcPs -> RnM (WarningTxt GhcRn) -rnWarningTxt (WarningTxt mb_cat st wst) = do - forM_ mb_cat $ \(L _ (InWarningCategory _ _ (L loc cat))) -> - unless (validWarningCategory cat) $ - addErrAt (locA loc) (TcRnInvalidWarningCategory cat) +rnWarningTxt (WarningTxt st mb_cat wst) = do + mb_cat' <- case mb_cat of + Nothing -> pure Nothing + Just (L x (InWarningCategory y (L loc cat))) -> do + unless (validWarningCategory cat) $ + addErrAt (locA loc) (TcRnInvalidWarningCategory cat) + pure . Just $ L x (InWarningCategory y (L loc cat)) wst' <- traverse (traverse rnHsDoc) wst - pure (WarningTxt mb_cat st wst') + pure (WarningTxt st mb_cat' wst') + rnWarningTxt (DeprecatedTxt st wst) = do wst' <- traverse (traverse rnHsDoc) wst pure (DeprecatedTxt st wst') ===================================== compiler/GHC/Rename/Utils.hs ===================================== @@ -69,7 +69,6 @@ import GHC.Data.Bag ( mapBagM, headMaybe ) import Control.Monad import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE ) import GHC.Unit.Module -import GHC.Unit.Module.Warnings ( WarningTxt(..) ) import GHC.Iface.Load import qualified GHC.LanguageExtensions as LangExt ===================================== compiler/GHC/Tc/Deriv.hs ===================================== @@ -57,7 +57,6 @@ import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.SrcLoc -import GHC.Unit.Module.Warnings import GHC.Builtin.Names import GHC.Utils.Error ===================================== compiler/GHC/Tc/Deriv/Utils.hs ===================================== @@ -52,7 +52,6 @@ import GHC.Core.Type import GHC.Hs import GHC.Driver.Session import GHC.Unit.Module (getModule) -import GHC.Unit.Module.Warnings import GHC.Unit.Module.ModIface (mi_fix) import GHC.Iface.Load (loadInterfaceForName) ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -1841,7 +1841,7 @@ instance Diagnostic TcRnMessage where nest 2 (vcat (map (ppr . hsDocString . unLoc) msg)) ] where (extra, msg) = case txt of - WarningTxt _ _ msg -> ("", msg) + WarningTxt _ _ msg -> ("", msg) DeprecatedTxt _ msg -> (" is deprecated", msg) TcRnRedundantSourceImport mod_name -> mkSimpleDecorated $ ===================================== compiler/GHC/Tc/Errors/Types.hs ===================================== @@ -221,7 +221,6 @@ import GHC.Types.DefaultEnv (ClassDefaults) import GHC.Unit.Types (Module) import GHC.Unit.State (UnitState) -import GHC.Unit.Module.Warnings (WarningCategory, WarningTxt) import GHC.Unit.Module.ModIface (ModIface) import GHC.Utils.Outputable ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -67,7 +67,6 @@ import GHC.Core.PatSyn import GHC.Core.Multiplicity ( scaledThing ) import GHC.Unit.Module -import GHC.Unit.Module.Warnings import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Reader ===================================== compiler/GHC/Tc/Utils/Instantiate.hs ===================================== @@ -91,7 +91,6 @@ import GHC.Utils.Unique (sameUnique) import GHC.Unit.State import GHC.Unit.External -import GHC.Unit.Module.Warnings import Data.List ( mapAccumL ) import qualified Data.List.NonEmpty as NE ===================================== compiler/GHC/Types/DefaultEnv.hs ===================================== @@ -21,13 +21,12 @@ where import GHC.Core.Class (Class (className)) import GHC.Prelude -import GHC.Hs.Extension (GhcRn) +import GHC.Hs import GHC.Tc.Utils.TcType (Type) import GHC.Types.Name (Name, nameUnique, stableNameCmp) import GHC.Types.Name.Env import GHC.Types.Unique.FM (lookupUFM_Directly) import GHC.Types.SrcLoc (SrcSpan) -import GHC.Unit.Module.Warnings (WarningTxt) import GHC.Unit.Types (Module) import GHC.Utils.Outputable ===================================== compiler/GHC/Types/Error/Codes.hs ===================================== @@ -768,6 +768,7 @@ type family GhcDiagnosticCode c = n | n -> c where -- TcRnPragmaWarning GhcDiagnosticCode "WarningTxt" = 63394 GhcDiagnosticCode "DeprecatedTxt" = 68441 + GhcDiagnosticCode "XWarningTxt" = 68077 -- TcRnRunSliceFailure/ConversionFail GhcDiagnosticCode "IllegalOccName" = 55017 ===================================== compiler/GHC/Unit/Module/Warnings.hs ===================================== @@ -11,6 +11,9 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-} +-- Eq instances for WarningTxt, InWarningCategory +{-# OPTIONS_GHC -fno-warn-orphans #-} + -- | Warnings for a module module GHC.Unit.Module.Warnings ( WarningCategory(..) @@ -48,7 +51,7 @@ where import GHC.Prelude -import GHC.Data.FastString (FastString, mkFastString, unpackFS) +import GHC.Data.FastString (mkFastString, unpackFS) import GHC.Types.SourceText import GHC.Types.Name.Occurrence import GHC.Types.Name.Env @@ -65,77 +68,15 @@ import GHC.Utils.Binary import GHC.Unicode import Language.Haskell.Syntax.Extension +import Language.Haskell.Syntax.Decls -import Data.Data import Data.List (isPrefixOf) -import GHC.Generics ( Generic ) -import Control.DeepSeq - - -{- -Note [Warning categories] -~~~~~~~~~~~~~~~~~~~~~~~~~ -See GHC Proposal 541 for the design of the warning categories feature: -https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0541-wa... - -A WARNING pragma may be annotated with a category such as "x-partial" written -after the 'in' keyword, like this: - - {-# WARNING in "x-partial" head "This function is partial..." #-} - -This is represented by the 'Maybe (Located WarningCategory)' field in -'WarningTxt'. The parser will accept an arbitrary string as the category name, -then the renamer (in 'rnWarningTxt') will check it contains only valid -characters, so we can generate a nicer error message than a parse error. - -The corresponding warnings can then be controlled with the -Wx-partial, --Wno-x-partial, -Werror=x-partial and -Wwarn=x-partial flags. Such a flag is -distinguished from an 'unrecognisedWarning' by the flag parser testing -'validWarningCategory'. The 'x-' prefix means we can still usually report an -unrecognised warning where the user has made a mistake. - -A DEPRECATED pragma may not have a user-defined category, and is always treated -as belonging to the special category 'deprecations'. Similarly, a WARNING -pragma without a category belongs to the 'deprecations' category. -Thus the '-Wdeprecations' flag will enable all of the following: - - {-# WARNING in "deprecations" foo "This function is deprecated..." #-} - {-# WARNING foo "This function is deprecated..." #-} - {-# DEPRECATED foo "This function is deprecated..." #-} - -The '-Wwarnings-deprecations' flag is supported for backwards compatibility -purposes as being equivalent to '-Wdeprecations'. - -The '-Wextended-warnings' warning group collects together all warnings with -user-defined categories, so they can be enabled or disabled -collectively. Moreover they are treated as being part of other warning groups -such as '-Wdefault' (see 'warningGroupIncludesExtendedWarnings'). - -'DynFlags' and 'DiagOpts' each contain a set of enabled and a set of fatal -warning categories, just as they do for the finite enumeration of 'WarningFlag's -built in to GHC. These are represented as 'WarningCategorySet's to allow for -the possibility of them being infinite. - --} -data InWarningCategory - = InWarningCategory - { iwc_in :: !(EpToken "in"), - iwc_st :: !SourceText, - iwc_wc :: (LocatedE WarningCategory) - } deriving Data -fromWarningCategory :: WarningCategory -> InWarningCategory -fromWarningCategory wc = InWarningCategory noAnn NoSourceText (noLocA wc) - - --- See Note [Warning categories] -newtype WarningCategory = WarningCategory FastString - deriving stock Data - deriving newtype (Binary, Eq, Outputable, Show, Uniquable, NFData) - -mkWarningCategory :: FastString -> WarningCategory -mkWarningCategory = WarningCategory +fromWarningCategory :: + HasAnnotation (Anno WarningCategory) => + WarningCategory -> InWarningCategory (GhcPass p) +fromWarningCategory wc = InWarningCategory (noAnn, NoSourceText) (noLocA wc) -- | The @deprecations@ category is used for all DEPRECATED pragmas and for -- WARNING pragmas that do not specify a category. @@ -153,7 +94,6 @@ validWarningCategory cat@(WarningCategory c) = s = unpackFS c is_allowed c = isAlphaNum c || c == '\'' || c == '-' - -- | A finite or infinite set of warning categories. -- -- Unlike 'WarningFlag', there are (in principle) infinitely many warning @@ -198,66 +138,74 @@ deleteWarningCategorySet c (CofiniteWarningCategorySet s) = CofiniteWarningCateg type LWarningTxt pass = XRec pass (WarningTxt pass) --- | Warning Text --- --- reason/explanation from a WARNING or DEPRECATED pragma -data WarningTxt pass - = WarningTxt - (Maybe (LocatedE InWarningCategory)) - -- ^ Warning category attached to this WARNING pragma, if any; - -- see Note [Warning categories] - SourceText - [LocatedE (WithHsDocIdentifiers StringLiteral pass)] - | DeprecatedTxt - SourceText - [LocatedE (WithHsDocIdentifiers StringLiteral pass)] - deriving Generic - -- | To which warning category does this WARNING or DEPRECATED pragma belong? -- See Note [Warning categories]. -warningTxtCategory :: WarningTxt pass -> WarningCategory -warningTxtCategory (WarningTxt (Just (L _ (InWarningCategory _ _ (L _ cat)))) _ _) = cat +warningTxtCategory :: WarningTxt (GhcPass p) -> WarningCategory +warningTxtCategory (WarningTxt _ (Just (L _ (InWarningCategory _ (L _ cat)))) _) = cat warningTxtCategory _ = defaultWarningCategory + -- | The message that the WarningTxt was specified to output -warningTxtMessage :: WarningTxt p -> [LocatedE (WithHsDocIdentifiers StringLiteral p)] -warningTxtMessage (WarningTxt _ _ m) = m +warningTxtMessage :: WarningTxt (GhcPass p) -> [LocatedE (WithHsDocIdentifiers StringLiteral (GhcPass p))] +warningTxtMessage (WarningTxt _ _ m) = m warningTxtMessage (DeprecatedTxt _ m) = m -- | True if the 2 WarningTxts have the same category and messages -warningTxtSame :: WarningTxt p1 -> WarningTxt p2 -> Bool +warningTxtSame :: WarningTxt (GhcPass p) -> WarningTxt (GhcPass p) -> Bool warningTxtSame w1 w2 = warningTxtCategory w1 == warningTxtCategory w2 && literal_message w1 == literal_message w2 && same_type where - literal_message :: WarningTxt p -> [StringLiteral] + literal_message :: WarningTxt (GhcPass p) -> [StringLiteral] literal_message = map (hsDocString . unLoc) . warningTxtMessage same_type | DeprecatedTxt {} <- w1, DeprecatedTxt {} <- w2 = True - | WarningTxt {} <- w1, WarningTxt {} <- w2 = True + | WarningTxt {} <- w1, WarningTxt {} <- w2 = True | otherwise = False -deriving instance Eq InWarningCategory +instance Outputable (InWarningCategory (GhcPass pass)) where + ppr (InWarningCategory _ wt) = text "in" <+> doubleQuotes (ppr wt) -deriving instance (Eq (IdP pass)) => Eq (WarningTxt pass) -deriving instance (Data pass, Data (IdP pass)) => Data (WarningTxt pass) +type instance XDeprecatedTxt (GhcPass _) = SourceText +type instance XWarningTxt (GhcPass _) = SourceText +type instance XXWarningTxt (GhcPass _) = DataConCantHappen +type instance XInWarningCategory (GhcPass _) = (EpToken "in", SourceText) +type instance XXInWarningCategory (GhcPass _) = DataConCantHappen +type instance Anno (WithHsDocIdentifiers StringLiteral pass) = EpaLocation +type instance Anno (InWarningCategory (GhcPass pass)) = EpaLocation +type instance Anno (WarningCategory) = EpaLocation type instance Anno (WarningTxt (GhcPass pass)) = SrcSpanAnnP -instance Outputable InWarningCategory where - ppr (InWarningCategory _ _ wt) = text "in" <+> doubleQuotes (ppr wt) +deriving stock instance Eq (WarningTxt GhcPs) +deriving stock instance Eq (WarningTxt GhcRn) +deriving stock instance Eq (WarningTxt GhcTc) + +deriving stock instance Eq (InWarningCategory GhcPs) +deriving stock instance Eq (InWarningCategory GhcRn) +deriving stock instance Eq (InWarningCategory GhcTc) + +-- TODO: Move to respecitive type-class definition modules after removing +-- the Language.Haskell.Syntax.Decls module's dependency on GHC.Hs.Doc. +-- Subsequently, create a Language.Haskell.Syntax.Decls.Warnings sub-module +-- with the "warning declaration" types and have Language.Haskell.Syntax.Decls +-- re-export Language.Haskell.Syntax.Decls.Warnings. This will prevent cyclic +-- import, but it will only work once GHC.Hs.Doc is no longer a GHC dependency. +deriving instance Binary WarningCategory +deriving instance Outputable WarningCategory -instance Outputable (WarningTxt pass) where - ppr (WarningTxt mcat lsrc ws) +deriving instance Uniquable WarningCategory + +instance Outputable (WarningTxt (GhcPass pass)) where + ppr (WarningTxt lsrc mcat ws) = case lsrc of NoSourceText -> pp_ws ws SourceText src -> ftext src <+> ctg_doc <+> pp_ws ws <+> text "#-}" where ctg_doc = maybe empty (\ctg -> ppr ctg) mcat - - ppr (DeprecatedTxt lsrc ds) + ppr (DeprecatedTxt lsrc ds) = case lsrc of NoSourceText -> pp_ws ds SourceText src -> ftext src <+> pp_ws ds <+> text "#-}" @@ -270,7 +218,7 @@ pp_ws ws <+> text "]" -pprWarningTxtForMsg :: WarningTxt p -> SDoc +pprWarningTxtForMsg :: WarningTxt (GhcPass pass) -> SDoc pprWarningTxtForMsg (WarningTxt _ _ ws) = doubleQuotes (vcat (map (ftext . sl_fs . hsDocString . unLoc) ws)) pprWarningTxtForMsg (DeprecatedTxt _ ds) @@ -316,8 +264,6 @@ type DeclWarnOccNames pass = [(OccName, WarningTxt pass)] -- | Names that are deprecated as exports type ExportWarnNames pass = [(Name, WarningTxt pass)] -deriving instance Eq (IdP pass) => Eq (Warnings pass) - emptyWarn :: Warnings p emptyWarn = WarnSome [] [] ===================================== compiler/Language/Haskell/Syntax/Decls.hs ===================================== @@ -1,10 +1,11 @@ - {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -83,7 +84,18 @@ module Language.Haskell.Syntax.Decls ( FamilyResultSig(..), LFamilyResultSig, InjectivityAnn(..), LInjectivityAnn, -- * Grouping - HsGroup(..) + HsGroup(..), + + -- * Warnings + WarningTxt(..), + WarningCategory(..), + mkWarningCategory, + InWarningCategory(..), + -- ** Extension + XDeprecatedTxt, + XWarningTxt, + XXWarningTxt, + XInWarningCategory, ) where -- friends: @@ -101,12 +113,14 @@ import GHC.Types.Basic (TopLevelFlag, OverlapMode, RuleName, Activation ,TyConFlavour(..), TypeOrData(..), NewOrData(..)) import GHC.Types.ForeignCall (CType, CCallConv, Safety, Header, CLabelString, CCallTarget, CExportSpec) -import GHC.Unit.Module.Warnings (WarningTxt) - +import GHC.Data.FastString (FastString) import GHC.Hs.Doc (LHsDoc) -- ROMES:TODO Discuss in #21592 whether this is parsed AST or base AST +import GHC.Hs.Doc (WithHsDocIdentifiers) +import GHC.Types.SourceText (StringLiteral) -import Control.Monad +import Control.DeepSeq import Control.Exception (assert) +import Control.Monad import Data.Data hiding (TyCon, Fixity, Infix) import Data.Maybe import Data.String @@ -117,6 +131,8 @@ import Prelude (Show) import Data.Foldable import Data.Traversable import Data.List.NonEmpty (NonEmpty (..)) +import GHC.Generics ( Generic ) + {- ************************************************************************ @@ -1589,3 +1605,85 @@ data RoleAnnotDecl pass (LIdP pass) -- type constructor [XRec pass (Maybe Role)] -- optional annotations | XRoleAnnotDecl !(XXRoleAnnotDecl pass) + +{- +************************************************************************ +* * +\subsection[WarnAnnot]{Warning annotations} +* * +************************************************************************ +-} + +-- | Warning Text +-- +-- reason/explanation from a WARNING or DEPRECATED pragma +data WarningTxt pass + = DeprecatedTxt + (XDeprecatedTxt pass) + [XRec pass (WithHsDocIdentifiers StringLiteral pass)] + | WarningTxt + (XWarningTxt pass) + (Maybe (XRec pass (InWarningCategory pass))) + -- ^ Warning category attached to this WARNING pragma, if any; + -- see Note [Warning categories] + [XRec pass (WithHsDocIdentifiers StringLiteral pass)] + | XWarningTxt !(XXWarningTxt pass) + deriving Generic + +{- +Note [Warning categories] +~~~~~~~~~~~~~~~~~~~~~~~~~ +See GHC Proposal 541 for the design of the warning categories feature: +https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0541-wa... + +A WARNING pragma may be annotated with a category such as "x-partial" written +after the 'in' keyword, like this: + + {-# WARNING in "x-partial" head "This function is partial..." #-} + +This is represented by the 'Maybe (Located WarningCategory)' field in +'WarningTxt'. The parser will accept an arbitrary string as the category name, +then the renamer (in 'rnWarningTxt') will check it contains only valid +characters, so we can generate a nicer error message than a parse error. + +The corresponding warnings can then be controlled with the -Wx-partial, +-Wno-x-partial, -Werror=x-partial and -Wwarn=x-partial flags. Such a flag is +distinguished from an 'unrecognisedWarning' by the flag parser testing +'validWarningCategory'. The 'x-' prefix means we can still usually report an +unrecognised warning where the user has made a mistake. + +A DEPRECATED pragma may not have a user-defined category, and is always treated +as belonging to the special category 'deprecations'. Similarly, a WARNING +pragma without a category belongs to the 'deprecations' category. +Thus the '-Wdeprecations' flag will enable all of the following: + + {-# WARNING in "deprecations" foo "This function is deprecated..." #-} + {-# WARNING foo "This function is deprecated..." #-} + {-# DEPRECATED foo "This function is deprecated..." #-} +The '-Wwarnings-deprecations' flag is supported for backwards compatibility +purposes as being equivalent to '-Wdeprecations'. + +The '-Wextended-warnings' warning group collects together all warnings with +user-defined categories, so they can be enabled or disabled +collectively. Moreover they are treated as being part of other warning groups +such as '-Wdefault' (see 'warningGroupIncludesExtendedWarnings'). + +'DynFlags' and 'DiagOpts' each contain a set of enabled and a set of fatal +warning categories, just as they do for the finite enumeration of 'WarningFlag's +built in to GHC. These are represented as 'WarningCategorySet's to allow for +the possibility of them being infinite. + +-} +data InWarningCategory pass + = InWarningCategory + { iwc_st :: (XInWarningCategory pass), + iwc_wc :: (XRec pass WarningCategory) + } + | XInWarningCategory !(XXInWarningCategory pass) + +newtype WarningCategory = WarningCategory FastString + deriving stock (Data) + deriving newtype (Eq, Show, NFData) + +mkWarningCategory :: FastString -> WarningCategory +mkWarningCategory = WarningCategory ===================================== compiler/Language/Haskell/Syntax/Extension.hs ===================================== @@ -421,6 +421,17 @@ type family XXWarnDecls x type family XWarning x type family XXWarnDecl x +-- ------------------------------------- +-- WarningTxt type families +type family XDeprecatedTxt x +type family XWarningTxt x +type family XXWarningTxt x + +-- ------------------------------------- +-- InWarningCategory type families +type family XInWarningCategory x +type family XXInWarningCategory x + -- ------------------------------------- -- AnnDecl type families type family XHsAnnotation x ===================================== docs/users_guide/ghci.rst ===================================== @@ -1216,10 +1216,6 @@ Stack Traces in GHCi .. index:: simple: stack trace; in GHCi -[ This is an experimental feature enabled by the new -``-fexternal-interpreter`` flag that was introduced in GHC 8.0.1. It -is currently not supported on Windows.] - GHCi can use the profiling system to collect stack trace information when running interpreted code. To gain access to stack traces, start GHCi like this: ===================================== testsuite/tests/diagnostic-codes/codes.stdout ===================================== @@ -70,6 +70,7 @@ [GHC-99991] is untested (constructor = TyVarMissingInEnv) [GHC-92834] is untested (constructor = BadCoercionRole) [GHC-93008] is untested (constructor = HsigShapeSortMismatch) +[GHC-68077] is untested (constructor = XWarningTxt) [GHC-68444] is untested (constructor = SumAltArityExceeded) [GHC-63966] is untested (constructor = IllegalSumAlt) [GHC-28709] is untested (constructor = MalformedType) ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -53,7 +53,6 @@ import GHC.Types.PkgQual import GHC.Types.SourceText import GHC.Types.SrcLoc import GHC.Types.Var -import GHC.Unit.Module.Warnings import GHC.Utils.Misc import GHC.Utils.Outputable hiding ( (<>) ) import GHC.Utils.Panic @@ -1570,14 +1569,14 @@ instance ExactPrint (LocatedP (WarningTxt GhcPs)) where getAnnotationEntry = entryFromLocatedA setAnnotationAnchor = setAnchorAn - exact (L (EpAnn l (AnnPragma o c (os,cs) l1 l2 t m) css) (WarningTxt mb_cat src ws)) = do + exact (L (EpAnn l (AnnPragma o c (os,cs) l1 l2 t m) css) (WarningTxt src mb_cat ws)) = do o' <- markAnnOpen'' o src "{-# WARNING" mb_cat' <- markAnnotated mb_cat os' <- markEpToken os ws' <- markAnnotated ws cs' <- markEpToken cs c' <- markEpToken c - return (L (EpAnn l (AnnPragma o' c' (os',cs') l1 l2 t m) css) (WarningTxt mb_cat' src ws')) + return (L (EpAnn l (AnnPragma o' c' (os',cs') l1 l2 t m) css) (WarningTxt src mb_cat' ws')) exact (L (EpAnn l (AnnPragma o c (os,cs) l1 l2 t m) css) (DeprecatedTxt src ws)) = do o' <- markAnnOpen'' o src "{-# DEPRECATED" @@ -1587,14 +1586,14 @@ instance ExactPrint (LocatedP (WarningTxt GhcPs)) where c' <- markEpToken c return (L (EpAnn l (AnnPragma o' c' (os',cs') l1 l2 t m) css) (DeprecatedTxt src ws')) -instance ExactPrint InWarningCategory where +instance Typeable p => ExactPrint (InWarningCategory (GhcPass p)) where getAnnotationEntry _ = NoEntryVal setAnnotationAnchor a _ _ _ = a - exact (InWarningCategory tkIn source (L l wc)) = do + exact (InWarningCategory (tkIn, source) (L l wc)) = do tkIn' <- markEpToken tkIn L l' (_,wc') <- markAnnotated (L l (source, wc)) - return (InWarningCategory tkIn' source (L l' wc')) + return (InWarningCategory (tkIn', source) (L l' wc')) instance ExactPrint (SourceText, WarningCategory) where getAnnotationEntry _ = NoEntryVal @@ -1935,14 +1934,14 @@ instance ExactPrint (WarnDecl GhcPs) where getAnnotationEntry _ = NoEntryVal setAnnotationAnchor a _ _ _ = a - exact (Warning (ns_spec, (o,c)) lns (WarningTxt mb_cat src ls )) = do + exact (Warning (ns_spec, (o,c)) lns (WarningTxt src mb_cat ls )) = do mb_cat' <- markAnnotated mb_cat ns_spec' <- exactNsSpec ns_spec lns' <- markAnnotated lns o' <- markEpToken o ls' <- markAnnotated ls c' <- markEpToken c - return (Warning (ns_spec', (o',c')) lns' (WarningTxt mb_cat' src ls')) + return (Warning (ns_spec', (o',c')) lns' (WarningTxt src mb_cat' ls')) exact (Warning (ns_spec, (o,c)) lns (DeprecatedTxt src ls)) = do ns_spec' <- exactNsSpec ns_spec ===================================== utils/haddock/haddock-api/haddock-api.cabal ===================================== @@ -139,7 +139,6 @@ library Haddock.Backends.Xhtml.Types Haddock.Backends.Xhtml.Utils Haddock.Backends.LaTeX - Haddock.Backends.HaddockDB Haddock.Backends.Hoogle Haddock.Backends.Hyperlinker Haddock.Backends.Hyperlinker.Parser ===================================== utils/haddock/haddock-api/src/Haddock/Backends/HaddockDB.hs deleted ===================================== @@ -1,178 +0,0 @@ ------------------------------------------------------------------------------ - ------------------------------------------------------------------------------ - --- | --- Module : Haddock.Backends.HaddockDB --- Copyright : (c) Simon Marlow 2003 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable -module Haddock.Backends.HaddockDB (ppDocBook) where - -{- -import HaddockTypes -import HaddockUtil -import HsSyn2 - -import Text.PrettyPrint --} - ------------------------------------------------------------------------------ --- Printing the results in DocBook format - -ppDocBook :: a -ppDocBook = error "not working" - -{- -ppDocBook :: FilePath -> [(Module, Interface)] -> String -ppDocBook odir mods = render (ppIfaces mods) - -ppIfaces mods - = text "<!DOCTYPE BOOK PUBLIC \"-//OASIS//DTD DocBook V3.1//EN\" [" - $$ text "]>" - $$ text "<book>" - $$ text "<bookinfo>" - $$ text "<author><othername>HaskellDoc version 0.0</othername></author>" - $$ text "</bookinfo>" - $$ text "<article>" - $$ vcat (map do_mod mods) - $$ text "</article></book>" - where - do_mod (Module mod, iface) - = text " text mod <> text "\">" - $$ text "<title><literal>" - <> text mod - <> text "</literal></title>" - $$ text "<indexterm><primary><literal>" - <> text mod - <> text "</literal></primary></indexterm>" - $$ text "<variablelist>" - $$ vcat (map (do_export mod) (eltsFM (iface_decls iface))) - $$ text "</variablelist>" - $$ text "</sect1>" - - do_export mod decl | (nm:_) <- declBinders decl - = text " do_decl decl - <> text "</literal></term>" - $$ text "<listitem>" - $$ text "<para>" - $$ text "</para>" - $$ text "</listitem>" - $$ text "</varlistentry>" - do_export _ _ = empty - - do_decl (HsTypeSig _ [nm] ty _) - = ppHsName nm <> text " :: " <> ppHsType ty - do_decl (HsTypeDecl _ nm args ty _) - = hsep ([text "type", ppHsName nm ] - ++ map ppHsName args - ++ [equals, ppHsType ty]) - do_decl (HsNewTypeDecl loc ctx nm args con drv _) - = hsep ([text "data", ppHsName nm] -- data, not newtype - ++ map ppHsName args - ) <+> equals <+> ppHsConstr con -- ToDo: derivings - do_decl (HsDataDecl loc ctx nm args cons drv _) - = hsep ([text "data", {-ToDo: context-}ppHsName nm] - ++ map ppHsName args) - <+> vcat (zipWith (<+>) (equals : repeat (char '|')) - (map ppHsConstr cons)) - do_decl (HsClassDecl loc ty fds decl _) - = hsep [text "class", ppHsType ty] - do_decl decl - = empty - -ppHsConstr :: HsConDecl -> Doc -ppHsConstr (HsRecDecl pos name tvs ctxt fieldList maybe_doc) = - ppHsName name - <> (braces . hsep . punctuate comma . map ppField $ fieldList) -ppHsConstr (HsConDecl pos name tvs ctxt typeList maybe_doc) = - hsep (ppHsName name : map ppHsBangType typeList) - -ppField (HsFieldDecl ns ty doc) - = hsep (punctuate comma (map ppHsName ns) ++ - [text "::", ppHsBangType ty]) - -ppHsBangType :: HsBangType -> Doc -ppHsBangType (HsBangedTy ty) = char '!' <> ppHsType ty -ppHsBangType (HsUnBangedTy ty) = ppHsType ty - -ppHsContext :: HsContext -> Doc -ppHsContext [] = empty -ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+> - hsep (map ppHsAType b)) context) - -ppHsType :: HsType -> Doc -ppHsType (HsForAllType _ Nothing context htype) = - hsep [ ppHsContext context, text "=>", ppHsType htype] -ppHsType (HsForAllType fvf (Just tvs) [] htype) = - hsep (text "forall" : map ppHsName tvs ++ pprHsForAllSeparator fvf : - [ppHsType htype]) -ppHsType (HsForAllType fvf (Just tvs) context htype) = - hsep (text "forall" : map ppHsName tvs ++ pprHsForAllSeparator fvf : - ppHsContext context : text "=>" : [ppHsType htype]) -ppHsType (HsTyFun a b) = fsep [ppHsBType a, text "->", ppHsType b] -ppHsType (HsTyIP n t) = fsep [(char '?' <> ppHsName n), text "::", ppHsType t] -ppHsType t = ppHsBType t - -ppHsForAllSeparator :: ForallVisFlag -> Doc -ppHsForAllSeparator ForallVis = text "->" -ppHsForAllSeparator ForallInvis = text "." - -ppHsBType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b ) - = brackets $ ppHsType b -ppHsBType (HsTyApp a b) = fsep [ppHsBType a, ppHsAType b] -ppHsBType t = ppHsAType t - -ppHsAType :: HsType -> Doc -ppHsAType (HsTyTuple True l) = parenList . map ppHsType $ l -ppHsAType (HsTyTuple False l) = ubxParenList . map ppHsType $ l --- special case -ppHsAType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b ) - = brackets $ ppHsType b -ppHsAType (HsTyVar name) = ppHsName name -ppHsAType (HsTyCon name) = ppHsQName name -ppHsAType t = parens $ ppHsType t - -ppHsQName :: HsQName -> Doc -ppHsQName (UnQual str) = ppHsName str -ppHsQName n@(Qual (Module mod) str) - | n == unit_con_name = ppHsName str - | isSpecial str = ppHsName str - | otherwise - = text " Doc -ppHsName (HsTyClsName id) = ppHsIdentifier id -ppHsName (HsVarName id) = ppHsIdentifier id - -ppHsIdentifier :: HsIdentifier -> Doc -ppHsIdentifier (HsIdent str) = text str -ppHsIdentifier (HsSymbol str) = text str -ppHsIdentifier (HsSpecial str) = text str - -ppLinkId :: String -> HsName -> Doc -ppLinkId mod str - = hcat [char '\"', text mod, char '.', ppHsName str, char '\"'] - --- ----------------------------------------------------------------------------- --- * Misc - -parenList :: [Doc] -> Doc -parenList = parens . fsep . punctuate comma - -ubxParenList :: [Doc] -> Doc -ubxParenList = ubxparens . fsep . punctuate comma - -ubxparens p = text "(#" <> p <> text "#)" --} ===================================== utils/haddock/haddock-api/src/Haddock/Interface/Create.hs ===================================== @@ -354,7 +354,7 @@ parseWarning -> IfM m (Doc Name) parseWarning parserOpts sDocContext w = case w of IfDeprecatedTxt _ msg -> format "Deprecated: " (map dstToDoc msg) - IfWarningTxt _ _ msg -> format "Warning: " (map dstToDoc msg) + IfWarningTxt _ _ msg -> format "Warning: " (map dstToDoc msg) where dstToDoc :: (IfaceStringLiteral, [Name]) -> HsDoc GhcRn dstToDoc ((IfStringLiteral _ fs), ids) = WithHsDocIdentifiers (fsToDoc fs) (map noLoc ids) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5c130f568485b98ca4827343607b0e1... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5c130f568485b98ca4827343607b0e1... You're receiving this email because of your account on gitlab.haskell.org.