diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for pollock +## 0.1.0.1 -- 2024-05-19 + +* Internal changes to support GHC 9.10 + ## 0.1.0.0 -- YYYY-mm-dd * First version. Released on an unsuspecting world. diff --git a/pollock.cabal b/pollock.cabal --- a/pollock.cabal +++ b/pollock.cabal @@ -20,7 +20,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.1.0.0 +version: 0.1.0.1 synopsis: Functionality to help examine Haddock information of a module. description: Pollock is functionality to examine various bits of information about documentation as exposed from a Haskell module. This is designed to be used as part of a GHC plugin. @@ -28,10 +28,10 @@ license-file: LICENSE author: Trevis Elser maintainer: trevis@flipstone.com -copyright: (c) 2023 Trevis Elser +copyright: (c) 2023-2024 Trevis Elser category: Development, documentation, library build-type: Simple -tested-with: GHC == 9.4.7, GHC == 9.6.3, GHC == 9.8.1 +tested-with: GHC == 9.4.8, GHC == 9.6.5, GHC == 9.8.2, GHC == 9.10.1 -- Extra doc files to be distributed with the package, such as a CHANGELOG or a README. extra-doc-files: CHANGELOG.md @@ -64,7 +64,15 @@ if impl (ghc >= 9.8) ghc-options: -Wincomplete-export-warnings + -Wimplicit-rhs-quantification -Wterm-variable-capture + -Winconsistent-flags + if impl (ghc >= 9.10) + ghc-options: + -Wdeprecated-type-abstractions + -Wbadly-staged-types + -Wdata-kinds-tc + -Wdefaulted-exception-context flag ci description: @@ -102,7 +110,7 @@ build-depends: attoparsec >=0.14.4 && <0.15 , base >=4.17.1.0 && <5 , containers >=0.6 && < 0.8 - , ghc >=9.4 && <9.9 + , ghc >=9.4 && <9.11 , text >=2.0 && <2.2 hs-source-dirs: src diff --git a/src/Pollock/CompatGHC.hs b/src/Pollock/CompatGHC.hs --- a/src/Pollock/CompatGHC.hs +++ b/src/Pollock/CompatGHC.hs @@ -10,7 +10,6 @@ , tcg_th_docs , tcg_semantic_mod , tcg_rdr_env - , tcg_doc_hdr , tcg_rn_imports , tcg_rn_decls , tcg_rn_exports @@ -61,7 +60,6 @@ , ideclImportList , ImportListInterpretation (Exactly, EverythingBut) , CollectFlag (CollNoDictBinders) - , SrcSpanAnn' (SrcSpanAnn) , RealSrcSpan , SrcSpan (RealSrcSpan) , DocDecl (DocCommentNamed, DocGroup) @@ -86,16 +84,21 @@ -- compatability shims defined here , processWarnSome , mapWarningTxtMsg + , getHeaderInfo -- helpers defined here , nonDetEltUniqMapToMap , insertEnumSet , stringLiteralToString ) where +-- The following are library and non-reexorted imports import qualified Control.Arrow as Arrow import qualified Control.Monad as M import qualified Data.Map.Strict as Map import qualified Data.Maybe as Maybe +import qualified GHC.Data.EnumSet as EnumSet +import qualified GHC.Tc.Types as TcTypes +import qualified GHC.Types.Unique.Map as UniqMap import GHC ( CollectFlag (CollNoDictBinders) @@ -121,7 +124,6 @@ , NamedThing (getName) , RealSrcSpan , SrcSpan (RealSrcSpan) - , SrcSpanAnn' (SrcSpanAnn) , SrcSpanAnnA , TyFamInstDecl (TyFamInstDecl) , WithHsDocIdentifiers (hsDocString) @@ -131,6 +133,17 @@ , renderHsDocString , unLoc ) +import GHC.HsToCore.Docs + ( declTypeDocs + , extractTHDocs + , getInstLoc + , getMainDeclBinder + , isValD + , nubByName + , subordinates + , topDecls + ) +import GHC.IORef (readIORef) import GHC.Plugins ( GlobalRdrElt , GlobalRdrEnv @@ -145,23 +158,9 @@ , nameIsLocalOrFrom , unpackFS ) - -import qualified GHC.Data.EnumSet as EnumSet -import GHC.HsToCore.Docs - ( declTypeDocs - , extractTHDocs - , getInstLoc - , getMainDeclBinder - , isValD - , nubByName - , subordinates - , topDecls - ) -import GHC.IORef (readIORef) import GHC.Tc.Types ( TcGblEnv - ( tcg_doc_hdr - , tcg_exports + ( tcg_exports , tcg_fam_insts , tcg_insts , tcg_rdr_env @@ -174,12 +173,12 @@ ) ) import GHC.Types.SourceText (StringLiteral, sl_fs) -import qualified GHC.Types.Unique.Map as UniqMap import GHC.Unit.Module.Warnings (WarningTxt (DeprecatedTxt, WarningTxt), Warnings (WarnSome)) -#if __GLASGOW_HASKELL__ == 908 +#if __GLASGOW_HASKELL__ == 910 import GHC (ImportDecl, ideclImportList, ideclAs, ideclName, ImportListInterpretation (Exactly, EverythingBut)) import GHC.Plugins (GlobalRdrEltX, greName) +import qualified GHC.Parser.Annotation as Annotation import GHC.Types.Avail ( AvailInfo , Avails @@ -192,6 +191,21 @@ ) import GHC.Types.Unique.Map (nonDetUniqMapToList) +#elif __GLASGOW_HASKELL__ == 908 +import GHC (ImportDecl, ideclImportList, ideclAs, ideclName, ImportListInterpretation (Exactly, EverythingBut)) +import GHC.Plugins (GlobalRdrEltX, greName) +import GHC.Types.Avail + ( AvailInfo + , Avails + , availExportsDecl + , availName + , availNames + , availSubordinateNames + , availsToNameEnv + , nubAvails + ) +import GHC.Types.Unique.Map (nonDetUniqMapToList) + #elif __GLASGOW_HASKELL__ == 906 import GHC (ImportDecl, ideclImportList, ideclAs, ideclName, ImportListInterpretation (Exactly, EverythingBut)) import GHC.Plugins (greMangledName) @@ -206,7 +220,6 @@ , greNameMangledName , nubAvails ) -import GHC.Types.Unique.Map (nonDetEltsUniqMap) #elif __GLASGOW_HASKELL__ == 904 import GHC (ImportDecl(ideclHiding, ideclAs, ideclName), XRec) @@ -222,10 +235,13 @@ , greNameMangledName , nubAvails ) -import GHC.Types.Unique.Map (nonDetEltsUniqMap) #endif -#if __GLASGOW_HASKELL__ == 908 +#if __GLASGOW_HASKELL__ == 910 +-- | Compatibility helper to ease development against multiple version +getHeaderInfo :: TcGblEnv -> Maybe HsDocString +getHeaderInfo = fmap (hsDocString . unLoc) . fst . TcTypes.tcg_hdr_info + lookupOccName :: OccEnv [GlobalRdrEltX info] -> OccName -> [Name] lookupOccName env = fmap greName . lookupOcc env @@ -248,6 +264,44 @@ mempty -- | Compatability helper to let us get at the deprecated and warning messages consistently +mapWarningTxtMsg :: ([Annotation.LocatedE + (WithHsDocIdentifiers StringLiteral pass)] -> t) + -> ([Annotation.LocatedE + (WithHsDocIdentifiers StringLiteral pass)] -> t) + -> WarningTxt pass + -> t +mapWarningTxtMsg deprecatedFn warnFn warnTxt = + case warnTxt of + DeprecatedTxt _ msgs -> deprecatedFn msgs + WarningTxt _ _ msgs -> warnFn msgs + +#elif __GLASGOW_HASKELL__ == 908 +-- | Helper for using the GHC 9.10 api +getHeaderInfo :: TcGblEnv -> Maybe HsDocString +getHeaderInfo = fmap (hsDocString . unLoc) . TcTypes.tcg_doc_hdr + +lookupOccName :: OccEnv [GlobalRdrEltX info] -> OccName -> [Name] +lookupOccName env = fmap greName . lookupOcc env + +processWarnSome :: Warnings pass -> OccEnv [GlobalRdrElt] -> [Name] -> [(Name, WarningTxt pass)] +processWarnSome warnings gre names = + case warnings of + WarnSome ws exports -> + let + keepByName :: [(Name,b)] -> [(Name,b)] + keepByName = filter (\x -> (fst x) `elem` names) + + keepOnlyKnownNameWarnings = keepByName . mappend exports . M.join . fmap (explodeSnd . Arrow.first (lookupOccName gre)) + + explodeSnd :: Functor f => (f a, b) -> f (a, b) + explodeSnd (as,b) = fmap ((flip (,) b)) as + in + keepOnlyKnownNameWarnings ws + _ -> + -- Note we want to catch all here so we can limit imports that vary for different GHC versions. + mempty + +-- | Compatability helper to let us get at the deprecated and warning messages consistently mapWarningTxtMsg :: ([Located (WithHsDocIdentifiers StringLiteral pass)] -> t) -> ([Located (WithHsDocIdentifiers StringLiteral pass)] -> t) @@ -259,7 +313,11 @@ WarningTxt _ _ msgs -> warnFn msgs #elif __GLASGOW_HASKELL__ == 906 --- | Shim for using the GHC 9.8 api +-- | Helper for using the GHC 9.10 api +getHeaderInfo :: TcGblEnv -> Maybe HsDocString +getHeaderInfo = fmap (hsDocString . unLoc) . TcTypes.tcg_doc_hdr + +-- | Shim for using the GHC 9.8+ api availSubordinateNames :: AvailInfo -> [Name] availSubordinateNames = fmap greNameMangledName . availSubordinateGreNames @@ -285,10 +343,10 @@ -- Note we want to catch all here so we can limit imports that vary for different GHC versions. mempty --- | Shim for using the GHC 9.8 api, note the previous name was somewhat confusing as it does result +-- | Shim for using the GHC 9.8+ api, note the previous name was somewhat confusing as it does result -- in a list not a map! nonDetUniqMapToList :: UniqMap.UniqMap k a -> [(k, a)] -nonDetUniqMapToList = nonDetEltsUniqMap +nonDetUniqMapToList = UniqMap.nonDetEltsUniqMap -- | Compatability helper to let us get at the deprecated and warning messages consistently mapWarningTxtMsg :: @@ -302,6 +360,9 @@ WarningTxt _ msgs -> warnFn msgs #elif __GLASGOW_HASKELL__ == 904 +-- | Helper for using the GHC 9.10 api +getHeaderInfo :: TcGblEnv -> Maybe HsDocString +getHeaderInfo = fmap (hsDocString . unLoc) . TcTypes.tcg_doc_hdr -- | Compatibility shim as this datatype was added in GHC 9.6, along with 'ideclImportList' data ImportListInterpretation = Exactly | EverythingBut @@ -319,7 +380,7 @@ availNames :: AvailInfo -> [Name] availNames = availNamesWithSelectors --- | Shim for using the GHC 9.8 api +-- | Shim for using the GHC 9.8+ api availSubordinateNames :: AvailInfo -> [Name] availSubordinateNames = fmap greNameMangledName . availSubordinateGreNames @@ -332,7 +393,7 @@ WarnSome ws -> let keepByName :: [(Name,b)] -> [(Name,b)] - keepByName = filter (\x -> (fst x) `elem` names) + keepByName = filter (\x -> fst x `elem` names) keepOnlyKnownNameWarnings :: [(OccName, b)] -> [(Name, b)] keepOnlyKnownNameWarnings = keepByName . M.join . fmap (explodeSnd . Arrow.first (lookupOccName gre)) @@ -345,10 +406,10 @@ -- Note we want to catch all here so we can limit imports that vary for different GHC versions. mempty --- | Shim for using the GHC 9.8 api, note the previous name was somewhat confusing as it does result +-- | Shim for using the GHC 9.8+ api, note the previous name was somewhat confusing as it does result -- in a list not a map! nonDetUniqMapToList :: UniqMap.UniqMap k a -> [(k, a)] -nonDetUniqMapToList = nonDetEltsUniqMap +nonDetUniqMapToList = UniqMap.nonDetEltsUniqMap -- | Compatability helper to let us get at the deprecated and warning messages consistently mapWarningTxtMsg :: diff --git a/src/Pollock/ProcessModule.hs b/src/Pollock/ProcessModule.hs --- a/src/Pollock/ProcessModule.hs +++ b/src/Pollock/ProcessModule.hs @@ -24,11 +24,6 @@ import qualified Pollock.Documentation as Documentation import Pollock.ModuleInfo (ModuleInfo, buildModuleInfo) -{- | Read a module from a 'TcGblEnv' to determine information about the Haddock as seen with -'ModuleInfo'. - -@since 0.1.0.0 --} processModule :: (MIO.MonadIO m) => CompatGHC.TcGblEnv @@ -55,7 +50,7 @@ -- Process the top-level module header documentation. let mbHeaderStr = fmap CompatGHC.hsDocString (CompatGHC.ethd_mod_header thDocs) - Applicative.<|> (CompatGHC.hsDocString . CompatGHC.unLoc <$> CompatGHC.tcg_doc_hdr tcGblEnv) + Applicative.<|> CompatGHC.getHeaderInfo tcGblEnv decls = maybe mempty CompatGHC.topDecls $ CompatGHC.tcg_rn_decls tcGblEnv maps = mkMaps localInstances decls thDocs @@ -113,12 +108,7 @@ -> [(CompatGHC.ModuleName, [CompatGHC.ImportDecl CompatGHC.GhcRn])] moduleMapping idecl = pure (CompatGHC.unLoc (CompatGHC.ideclName idecl), pure idecl) - <> ( case CompatGHC.ideclAs idecl of - Just modName -> - pure (CompatGHC.unLoc modName, pure idecl) - _ -> - mempty - ) + <> maybe mempty (\modName -> pure (CompatGHC.unLoc modName, pure idecl)) (CompatGHC.ideclAs idecl) isInteresting :: CompatGHC.ImportDecl CompatGHC.GhcRn -> Bool isInteresting idecl = @@ -155,26 +145,23 @@ . Documentation.parseText . T.pack - foldMsgs :: - (Foldable t) => - t (CompatGHC.Located (CompatGHC.WithHsDocIdentifiers CompatGHC.StringLiteral pass)) - -> String - foldMsgs = - foldMap (CompatGHC.stringLiteralToString . CompatGHC.hsDocString . CompatGHC.unLoc) - formatDeprecated :: - (Foldable t) => - t (CompatGHC.Located (CompatGHC.WithHsDocIdentifiers CompatGHC.StringLiteral pass)) + [ CompatGHC.GenLocated + l + (CompatGHC.WithHsDocIdentifiers CompatGHC.StringLiteral pass) + ] -> Documentation.Doc formatDeprecated = - format "Deprecated: " . foldMsgs + format "Deprecated: " . foldMap (CompatGHC.stringLiteralToString . CompatGHC.hsDocString . CompatGHC.unLoc) formatWarning :: - (Foldable t) => - t (CompatGHC.Located (CompatGHC.WithHsDocIdentifiers CompatGHC.StringLiteral pass)) + [ CompatGHC.GenLocated + l + (CompatGHC.WithHsDocIdentifiers CompatGHC.StringLiteral pass) + ] -> Documentation.Doc formatWarning = - format "Warning: " . foldMsgs + format "Warning: " . foldMap (CompatGHC.stringLiteralToString . CompatGHC.hsDocString . CompatGHC.unLoc) in CompatGHC.mapWarningTxtMsg formatDeprecated formatWarning w @@ -227,7 +214,7 @@ , [(CompatGHC.Name, IM.IntMap Documentation.MetaAndDoc)] , [(CompatGHC.Name, [CompatGHC.HsDecl CompatGHC.GhcRn])] ) -nonTHMappings instances (CompatGHC.L (CompatGHC.SrcSpanAnn _ (CompatGHC.RealSrcSpan l _)) decl, hs_docStrs) = +nonTHMappings instances (CompatGHC.L _ decl, hs_docStrs) = let args :: IM.IntMap Documentation.MetaAndDoc args = fmap mkMetaAndDoc (CompatGHC.declTypeDocs decl) @@ -240,7 +227,7 @@ unzip3 . fmap processSubordinates $ CompatGHC.subordinates CompatGHC.emptyOccEnv instanceMap decl - names = getAssociatedNames l decl instanceMap + names = getAssociatedNames decl instanceMap docMapping = Maybe.catMaybes subDocs @@ -254,7 +241,6 @@ declMapping :: [(CompatGHC.Name, [CompatGHC.HsDecl CompatGHC.GhcRn])] declMapping = fmap (\x -> (x, pure decl)) $ names <> subNs in (docMapping, argMapping, declMapping) -nonTHMappings _ _ = mempty processSubordinates :: (a, [CompatGHC.HsDoc CompatGHC.GhcRn], IM.IntMap (CompatGHC.HsDoc CompatGHC.GhcRn)) @@ -273,11 +259,10 @@ _ -> accum getAssociatedNames :: - CompatGHC.RealSrcSpan - -> CompatGHC.HsDecl CompatGHC.GhcRn + CompatGHC.HsDecl CompatGHC.GhcRn -> Map.Map CompatGHC.RealSrcSpan CompatGHC.Name -> [CompatGHC.Name] -getAssociatedNames _ (CompatGHC.InstD _ d) instanceMap = +getAssociatedNames (CompatGHC.InstD _ d) instanceMap = let loc = case d of @@ -288,9 +273,7 @@ _ -> CompatGHC.getInstLoc d in Maybe.maybeToList (CompatGHC.lookupSrcSpan loc instanceMap) -- See note [2]. -getAssociatedNames l (CompatGHC.DerivD{}) instanceMap = - Maybe.maybeToList (Map.lookup l instanceMap) -- See note [2]. -getAssociatedNames _ decl _ = +getAssociatedNames decl _ = CompatGHC.getMainDeclBinder CompatGHC.emptyOccEnv decl {- | Unions together two 'ArgDocMaps' (or ArgMaps in haddock-api), such that two