pollock 0.1.0.0 → 0.1.0.1
raw patch · 4 files changed
+124/−68 lines, 4 filesdep ~ghc
Dependency ranges changed: ghc
Files
- CHANGELOG.md +4/−0
- pollock.cabal +12/−4
- src/Pollock/CompatGHC.hs +91/−30
- src/Pollock/ProcessModule.hs +17/−34
CHANGELOG.md view
@@ -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.
pollock.cabal view
@@ -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
src/Pollock/CompatGHC.hs view
@@ -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 ::
src/Pollock/ProcessModule.hs view
@@ -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