packages feed

pollock (empty) → 0.1.0.0

raw patch · 17 files changed

+1927/−0 lines, 17 filesdep +attoparsecdep +basedep +containers

Dependencies added: attoparsec, base, containers, ghc, text

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for pollock++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2023 Trevis Elser++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ pollock.cabal view
@@ -0,0 +1,110 @@+cabal-version:   3.4++-- The cabal-version field refers to the version of the .cabal specification,+-- and can be different from the cabal-install (the tool) version and the+-- Cabal (the library) version you are using. As such, the Cabal (the library)+-- version used must be equal or greater than the version stated in this field.+-- Starting from the specification version 2.2, the cabal-version field must be+-- the first thing in the cabal file.++-- Initial package description 'pollock' generated by+-- 'cabal init'. For further documentation, see:+--   http://haskell.org/cabal/users-guide/+--+name:            pollock++-- The package version.+-- See the Haskell package versioning policy (PVP) for standards+-- guiding when and how versions should be incremented.+-- https://pvp.haskell.org+-- PVP summary:     +-+------- breaking API changes+--                  | | +----- non-breaking API additions+--                  | | | +--- code changes with no API change+version:         0.1.0.0++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.+license:         MIT+license-file:    LICENSE+author:          Trevis Elser+maintainer:      trevis@flipstone.com+copyright:       (c) 2023 Trevis Elser+category:        Development, documentation, library+build-type:      Simple+tested-with:     GHC == 9.4.7, GHC == 9.6.3, GHC == 9.8.1++-- Extra doc files to be distributed with the package, such as a CHANGELOG or a README.+extra-doc-files: CHANGELOG.md++-- Extra source files to be distributed with the package, such as examples, or a tutorial module.+-- extra-source-files:++common warnings+  ghc-options: -Wall++common ci-warnings+  ghc-options:+    -Wall+    -Wcompat+    -Werror+    -Wmissing-import-lists+    -Wmissing-home-modules+    -Wmissed-specialisations+    -Wmonomorphism-restriction+    -Wcompat-unqualified-imports+    -Wpartial-fields+    -Wcpp-undef+    -Wredundant-constraints+    -Woperator-whitespace+    -Winvalid-haddock+    -Wunused-packages+    -Wunused-type-patterns+    -fwrite-ide-info+    -haddock+  if impl (ghc >= 9.8)+    ghc-options:+      -Wincomplete-export-warnings+      -Wterm-variable-capture++flag ci+  description:+    More strict ghc options used for development and ci, not intended for end-use.+  manual:      True+  default:     False++library+  import:           warnings+  -- Import ci-warnings when we set the flag+  if flag(ci)+    import: ci-warnings++  ghc-options: -funbox-strict-fields+               -O2++  exposed-modules: Pollock+  other-modules: Pollock.CompatGHC+                 Pollock.Documentation+                 Pollock.Documentation.Doc+                 Pollock.Documentation.DocumentationForDecl+                 Pollock.Documentation.ExportItem+                 Pollock.Documentation.Metadata+                 Pollock.Documentation.MetadataAndDoc+                 Pollock.Documentation.Parser+                 Pollock.DriverPlugin+                 Pollock.ModuleInfo+                 Pollock.ModuleInfo.ModuleInfo+                 Pollock.ModuleInfo.ModuleHeader+                 Pollock.ProcessModule++  other-extensions: CPP+                    ScopedTypeVariables++  build-depends: attoparsec  >=0.14.4   && <0.15+               , base        >=4.17.1.0 && <5+               , containers  >=0.6      && < 0.8+               , ghc         >=9.4      && <9.9+               , text        >=2.0      && <2.2++  hs-source-dirs:   src++  default-language: Haskell2010
+ src/Pollock.hs view
@@ -0,0 +1,39 @@+{- |+Module: Pollock+Copyright: (c) Trevis Elser 2023+License: MIT++Maintainer: trevis@flipstone.com+Stability: experimental+-}+module Pollock+  ( processModule+  , ModuleHeader (..)+  , ModuleInfo (..)+  , ensureHaddockIsOn+  ) where++import Pollock.DriverPlugin (ensureHaddockIsOn)+import Pollock.ModuleInfo+  ( ModuleHeader+      ( ModuleHeader+      , copyright+      , description+      , license+      , maintainer+      , portability+      , stability+      )+  , ModuleInfo+    ( ModuleInfo+    , haddockableExports+    , haddockedExports+    , moduleHeader+    , numWithCodeBlock+    , numWithExample+    , numWithProperty+    , numWithSince+    , numWithWarning+    )+  )+import Pollock.ProcessModule (processModule)
+ src/Pollock/CompatGHC.hs view
@@ -0,0 +1,380 @@+{-# LANGUAGE CPP #-}++module Pollock.CompatGHC+  ( readIORef+  , TcGblEnv+    ( tcg_exports+    , tcg_insts+    , tcg_fam_insts+    , tcg_warns+    , tcg_th_docs+    , tcg_semantic_mod+    , tcg_rdr_env+    , tcg_doc_hdr+    , tcg_rn_imports+    , tcg_rn_decls+    , tcg_rn_exports+    )+  , getSrcSpan+  , nameIsLocalOrFrom+  , emptyOccEnv+  , lookupNameEnv+  , GlobalRdrEnv+  , Warnings+  , WarningTxt+  , declTypeDocs+  , extractTHDocs+  , getInstLoc+  , getMainDeclBinder+  , isValD+  , nubByName+  , subordinates+  , topDecls+  -- GHC+  , DynFlags (generalFlags)+  , GenLocated (L)+  , HsDocString+  , Name+  , renderHsDocString+  , GhcRn+  , IdP+  , LHsDecl+  , Module+  , HsDecl (InstD, DerivD, ValD, SigD, DocD)+  , feqn_tycon+  , InstDecl+    ( TyFamInstD+    )+  , TyFamInstDecl (TyFamInstDecl)+  , ModuleName+  , SrcSpanAnnA+  , collectHsBindBinders+  , getLocA+  , nameModule+  , ExtractedTHDocs (ExtractedTHDocs, ethd_mod_header)+  , HsDoc+  , WithHsDocIdentifiers (hsDocString)+  , IE (IEModuleContents, IEGroup, IEDoc, IEDocNamed)+  , ImportDecl+  , ideclName+  , ideclAs+  , ideclImportList+  , ImportListInterpretation (Exactly, EverythingBut)+  , CollectFlag (CollNoDictBinders)+  , SrcSpanAnn' (SrcSpanAnn)+  , RealSrcSpan+  , SrcSpan (RealSrcSpan)+  , DocDecl (DocCommentNamed, DocGroup)+  , Located+  , HscEnv (hsc_dflags)+  -- GHC.Plugins+  , GeneralFlag (Opt_Haddock)+  , lookupSrcSpan+  , getName+  , unLoc+  -- GHC.Types.Avail+  , AvailInfo+  , Avails+  , availExportsDecl+  , availName+  , availNames+  , availSubordinateNames+  , availsToNameEnv+  , nubAvails+  -- GHC.Types.SourceText+  , StringLiteral+  -- compatability shims defined here+  , processWarnSome+  , mapWarningTxtMsg+  -- helpers defined here+  , nonDetEltUniqMapToMap+  , insertEnumSet+  , stringLiteralToString+  ) where++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 GHC+  ( CollectFlag (CollNoDictBinders)+  , DocDecl (DocCommentNamed, DocGroup)+  , DynFlags (generalFlags)+  , ExtractedTHDocs (ExtractedTHDocs, ethd_mod_header)+  , FamEqn (feqn_tycon)+  , GenLocated (L)+  , GeneralFlag (Opt_Haddock)+  , GhcRn+  , HsDecl (DerivD, DocD, InstD, SigD, ValD)+  , HsDoc+  , HsDocString+  , HscEnv+  , IE (IEDoc, IEDocNamed, IEGroup, IEModuleContents)+  , IdP+  , InstDecl (TyFamInstD)+  , LHsDecl+  , Located+  , Module+  , ModuleName+  , Name+  , NamedThing (getName)+  , RealSrcSpan+  , SrcSpan (RealSrcSpan)+  , SrcSpanAnn' (SrcSpanAnn)+  , SrcSpanAnnA+  , TyFamInstDecl (TyFamInstDecl)+  , WithHsDocIdentifiers (hsDocString)+  , collectHsBindBinders+  , getLocA+  , nameModule+  , renderHsDocString+  , unLoc+  )+import GHC.Plugins+  ( GlobalRdrElt+  , GlobalRdrEnv+  , HscEnv (hsc_dflags)+  , OccEnv+  , OccName+  , emptyOccEnv+  , getSrcSpan+  , lookupNameEnv+  , lookupOccEnv+  , lookupSrcSpan+  , 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_fam_insts+      , tcg_insts+      , tcg_rdr_env+      , tcg_rn_decls+      , tcg_rn_exports+      , tcg_rn_imports+      , tcg_semantic_mod+      , tcg_th_docs+      , tcg_warns+      )+  )+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+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)+import GHC.Types.Avail+  ( AvailInfo+  , Avails+  , availExportsDecl+  , availName+  , availNames+  , availSubordinateGreNames+  , availsToNameEnv+  , greNameMangledName+  , nubAvails+  )+import GHC.Types.Unique.Map (nonDetEltsUniqMap)++#elif __GLASGOW_HASKELL__ == 904+import GHC (ImportDecl(ideclHiding, ideclAs, ideclName),       XRec)+import GHC.Plugins (greMangledName)+import GHC.Types.Avail+  ( AvailInfo+  , Avails+  , availExportsDecl+  , availName+  , availNamesWithSelectors+  , availSubordinateGreNames+  , availsToNameEnv+  , greNameMangledName+  , nubAvails+  )+import GHC.Types.Unique.Map (nonDetEltsUniqMap)+#endif++#if __GLASGOW_HASKELL__ == 908+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)+  -> WarningTxt pass+  -> t+mapWarningTxtMsg deprecatedFn warnFn warnTxt =+  case warnTxt of+    DeprecatedTxt _ msgs -> deprecatedFn msgs+    WarningTxt _ _ msgs -> warnFn msgs++#elif __GLASGOW_HASKELL__ == 906+-- | Shim for using the GHC 9.8 api+availSubordinateNames :: AvailInfo -> [Name]+availSubordinateNames = fmap greNameMangledName . availSubordinateGreNames++lookupOccName :: OccEnv [GlobalRdrElt] -> OccName -> [Name]+lookupOccName env = fmap greMangledName . lookupOcc env++processWarnSome :: Warnings pass -> OccEnv [GlobalRdrElt] -> [Name] -> [(Name, WarningTxt pass)]+processWarnSome warnings gre names =+  case warnings of+    WarnSome ws ->+      let+        keepByName :: [(Name,b)] -> [(Name,b)]+        keepByName = filter (\x -> (fst x) `elem` names)++        keepOnlyKnownNameWarnings :: [(OccName, b)] -> [(Name, b)]+        keepOnlyKnownNameWarnings = keepByName . 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++-- | 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++-- | Compatability helper to let us get at the deprecated and warning messages consistently+mapWarningTxtMsg ::+  ([Located (WithHsDocIdentifiers StringLiteral pass)] -> t)+  -> ([Located (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__ == 904++-- | Compatibility shim as this datatype was added in GHC 9.6, along with 'ideclImportList'+data ImportListInterpretation = Exactly | EverythingBut++-- | Compatibility shim as GHC 9.4 used 'ideclHiding', but later changed to 'ideclImportList'.+ideclImportList :: ImportDecl pass -> Maybe (ImportListInterpretation, XRec pass [XRec pass (IE pass)])+ideclImportList idecl =+  case ideclHiding idecl of+    Nothing -> Nothing+    Just (True, n) -> Just (EverythingBut,n)+    Just (False,n) -> Just (Exactly,n)++-- | availNames was changed to include the selectors, it would seem, so we create a shim for 9.4 to+-- have an api more like later versions+availNames :: AvailInfo -> [Name]+availNames = availNamesWithSelectors++-- | Shim for using the GHC 9.8 api+availSubordinateNames :: AvailInfo -> [Name]+availSubordinateNames = fmap greNameMangledName . availSubordinateGreNames++lookupOccName :: OccEnv [GlobalRdrElt] -> OccName -> [Name]+lookupOccName env = fmap greMangledName . lookupOcc env++processWarnSome :: Warnings pass -> OccEnv [GlobalRdrElt] -> [Name] -> [(Name, WarningTxt pass)]+processWarnSome warnings gre names =+  case warnings of+    WarnSome ws ->+      let+        keepByName :: [(Name,b)] -> [(Name,b)]+        keepByName = filter (\x -> (fst x) `elem` names)++        keepOnlyKnownNameWarnings :: [(OccName, b)] -> [(Name, b)]+        keepOnlyKnownNameWarnings = keepByName . 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++-- | 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++-- | Compatability helper to let us get at the deprecated and warning messages consistently+mapWarningTxtMsg ::+  ([Located (WithHsDocIdentifiers StringLiteral pass)] -> t)+  -> ([Located (WithHsDocIdentifiers StringLiteral pass)] -> t)+  -> WarningTxt pass+  -> t+mapWarningTxtMsg deprecatedFn warnFn warnTxt =+  case warnTxt of+    DeprecatedTxt _ msgs -> deprecatedFn msgs+    WarningTxt _ msgs -> warnFn msgs++#endif++-- | Simple helper used above but definable consistently across GHC versions.+lookupOcc :: OccEnv [a] -> OccName -> [a]+lookupOcc env =+  Maybe.fromMaybe mempty . lookupOccEnv env++-- | Helper to convert from UniqMap to Map in a consistent fashion.+nonDetEltUniqMapToMap :: (Ord k) => UniqMap.UniqMap k a -> Map.Map k a+nonDetEltUniqMapToMap = Map.fromList . nonDetUniqMapToList++-- | A Helper to keep the interface clean avoiding any potential conflicts with 'insert'.+insertEnumSet :: (Enum a) => a -> EnumSet.EnumSet a -> EnumSet.EnumSet a+insertEnumSet = EnumSet.insert++stringLiteralToString :: StringLiteral -> String+stringLiteralToString = unpackFS . sl_fs
+ src/Pollock/Documentation.hs view
@@ -0,0 +1,22 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++{- |+Module: Pollock.Documentation+Copyright: (c) Trevis Elser 2023+License: MIT+Maintainer: trevis@flipstone.com+Stability: experimental+Portability: non-portable++Core types and functionality related to a model of haddock documentation.+-}+module Pollock.Documentation+  ( module Export+  )+where++import Pollock.Documentation.Doc as Export+import Pollock.Documentation.DocumentationForDecl as Export+import Pollock.Documentation.ExportItem as Export+import Pollock.Documentation.MetadataAndDoc as Export+import Pollock.Documentation.Parser as Export
+ src/Pollock/Documentation/Doc.hs view
@@ -0,0 +1,112 @@+{- |+Module:  Pollock.Documentation.Doc+Copyright: (c) Trevis Elser 2023+License:  MIT++Maintainer: trevis@flipstone.com+Stability: experimental+Portability: portable+-}+module Pollock.Documentation.Doc+  ( Doc (..)+  , docAppend+  , Example (..)+  , docHasWarning+  , docHasCodeBlock+  , docHasProperty+  , docHasExamples+  ) where++{- | A simplified model for haddock documentation. Note this diverges from haddock itself as many of+the complexities, particularly around display, are not needed for this use case.+-}+data Doc+  = DocEmpty+  | DocAppend !Doc !Doc+  | DocString !String+  | DocParagraph !Doc+  | DocWarning !Doc+  | DocCodeBlock !Doc+  | DocProperty !String+  | DocExamples ![Example]++docAppend :: Doc -> Doc -> Doc+docAppend DocEmpty d = d+docAppend d DocEmpty = d+docAppend (DocString s1) (DocString s2) = DocString (s1 <> s2)+docAppend (DocAppend d (DocString s1)) (DocString s2) = DocAppend d (DocString (s1 <> s2))+docAppend (DocString s1) (DocAppend (DocString s2) d) = DocAppend (DocString (s1 <> s2)) d+docAppend d1 d2 = DocAppend d1 d2++data Example = Example+  { exampleExpression :: !String+  , exampleResult :: ![String]+  }++docHasWarning :: Doc -> Bool+docHasWarning =+  let+    go doc =+      case doc of+        DocWarning _ -> True+        DocEmpty -> False+        DocString _ -> False+        DocProperty _ -> False+        DocExamples _ -> False+        DocParagraph d -> go d+        DocCodeBlock d -> go d+        DocAppend d1 d2 ->+          go d1 || go d2+   in+    go++docHasCodeBlock :: Doc -> Bool+docHasCodeBlock =+  let+    go doc =+      case doc of+        DocCodeBlock _ -> True+        DocEmpty -> False+        DocString _ -> False+        DocProperty _ -> False+        DocExamples _ -> False+        DocWarning d -> go d+        DocParagraph d -> go d+        DocAppend d1 d2 ->+          go d1 || go d2+   in+    go++docHasProperty :: Doc -> Bool+docHasProperty =+  let+    go doc =+      case doc of+        DocProperty _ -> True+        DocEmpty -> False+        DocString _ -> False+        DocExamples _ -> False+        DocCodeBlock d -> go d+        DocWarning d -> go d+        DocParagraph d -> go d+        DocAppend d1 d2 ->+          go d1 || go d2+   in+    go++docHasExamples :: Doc -> Bool+docHasExamples =+  let+    go doc =+      case doc of+        DocExamples _ -> True+        DocEmpty -> False+        DocString _ -> False+        DocProperty _ -> False+        DocCodeBlock d -> go d+        DocWarning d -> go d+        DocParagraph d -> go d+        DocAppend d1 d2 ->+          go d1 || go d2+   in+    go
+ src/Pollock/Documentation/DocumentationForDecl.hs view
@@ -0,0 +1,31 @@+{- |+Module: Pollock.Documentation.DocumentationForDecl+Copyright: (c) Trevis Elser 2023+License: MIT++Maintainer: trevis@flipstone.com+Stability: experimental+Portability: non-portable++Type and functionality related to documentation for a declaration.+-}+module Pollock.Documentation.DocumentationForDecl+  ( DocumentationForDecl (..)+  , FnArgsDoc+  )+where++import qualified Data.IntMap.Strict as IM++import Pollock.Documentation.Doc (Doc)+import Pollock.Documentation.MetadataAndDoc (MetaAndDoc)++-- | Represent the documentation for a declaration, optionally including a warning as well as any function arguments.+data DocumentationForDecl = DocumentationForDecl+  { documentationDoc :: !(Maybe MetaAndDoc)+  , documentationWarning :: !(Maybe Doc)+  , documentationFunctionArgDoc :: !FnArgsDoc+  }++-- | Arguments are indexed by Int, zero-based from the left.+type FnArgsDoc = IM.IntMap MetaAndDoc
+ src/Pollock/Documentation/ExportItem.hs view
@@ -0,0 +1,83 @@+{- |+Module:  Pollock.Documentation.ExportItem+Copyright: (c) Trevis Elser 2023+License:  MIT++Maintainer: trevis@flipstone.com+Stability: experimental+Portability: portable+-}+module Pollock.Documentation.ExportItem+  ( ExportItem (..)+  , mkExportDoc+  , ExportDecl (..)+  , exportItemHasSinceVersion+  , exportItemHasCodeBlock+  , exportItemHasExample+  , exportItemHasProperty+  , exportItemHasWarning+  ) where++import Pollock.Documentation.Doc+  ( docHasCodeBlock+  , docHasExamples+  , docHasProperty+  , docHasWarning+  )+import Pollock.Documentation.DocumentationForDecl+  ( DocumentationForDecl+  , documentationDoc+  )+import Pollock.Documentation.Metadata (metadataHasSinceVersion)+import Pollock.Documentation.MetadataAndDoc (MetaAndDoc, doc, meta)++data ExportItem+  = ExportItemDecl {-# UNPACK #-} !ExportDecl+  | ExportItemDoc !MetaAndDoc++mkExportDoc :: MetaAndDoc -> ExportItem+mkExportDoc = ExportItemDoc++newtype ExportDecl = ExportDecl+  { expItemMbDoc :: DocumentationForDecl+  }++exportItemHasSinceVersion :: ExportItem -> Bool+exportItemHasSinceVersion (ExportItemDoc md) =+  metadataHasSinceVersion $ meta md+exportItemHasSinceVersion (ExportItemDecl decl) =+  case documentationDoc $ expItemMbDoc decl of+    Nothing -> False+    Just md -> metadataHasSinceVersion $ meta md++exportItemHasWarning :: ExportItem -> Bool+exportItemHasWarning (ExportItemDoc md) =+  docHasWarning $ doc md+exportItemHasWarning (ExportItemDecl decl) =+  case documentationDoc $ expItemMbDoc decl of+    Nothing -> False+    Just md -> docHasWarning $ doc md++exportItemHasProperty :: ExportItem -> Bool+exportItemHasProperty (ExportItemDoc md) =+  docHasProperty $ doc md+exportItemHasProperty (ExportItemDecl decl) =+  case documentationDoc $ expItemMbDoc decl of+    Nothing -> False+    Just md -> docHasProperty $ doc md++exportItemHasExample :: ExportItem -> Bool+exportItemHasExample (ExportItemDoc md) =+  docHasExamples $ doc md+exportItemHasExample (ExportItemDecl decl) =+  case documentationDoc $ expItemMbDoc decl of+    Nothing -> False+    Just md -> docHasExamples $ doc md++exportItemHasCodeBlock :: ExportItem -> Bool+exportItemHasCodeBlock (ExportItemDoc md) =+  docHasCodeBlock $ doc md+exportItemHasCodeBlock (ExportItemDecl decl) =+  case documentationDoc $ expItemMbDoc decl of+    Nothing -> False+    Just md -> docHasCodeBlock $ doc md
+ src/Pollock/Documentation/Metadata.hs view
@@ -0,0 +1,36 @@+{- |+Module: Pollock.Documentation.Metadata+Copyright: (c) Trevis Elser 2023+License: MIT+Maintainer: trevis@flipstone.com+Stability: experimental+Portability: portable+-}+module Pollock.Documentation.Metadata+  ( Metadata (..)+  , emptyMetadata+  , metaAppend+  , metadataHasSinceVersion+  ) where++import Control.Applicative ((<|>))++newtype Metadata = Metadata+  { version :: Maybe SinceVersion+  }++emptyMetadata :: Metadata+emptyMetadata =+  Metadata+    { version = Nothing+    }++-- | This is not a monoidal append, it uses '<|>' for the 'version'.+metaAppend :: Metadata -> Metadata -> Metadata+metaAppend (Metadata v1) (Metadata v2) = Metadata (v1 <|> v2)++metadataHasSinceVersion :: Metadata -> Bool+metadataHasSinceVersion (Metadata Nothing) = False+metadataHasSinceVersion (Metadata (Just vs)) = not $ null vs++type SinceVersion = [Int]
+ src/Pollock/Documentation/MetadataAndDoc.hs view
@@ -0,0 +1,46 @@+{- |+Module: Pollock.Documentation.MetadataAndDoc+Copyright: (c) Trevis Elser 2023+License: MIT+Maintainer: trevis@flipstone.com+Stability: experimental+-}+module Pollock.Documentation.MetadataAndDoc+  ( MetaAndDoc (..)+  , withEmptyMetadata+  , metaAndDocConcat+  , metaAndDocAppend+  ) where++import Pollock.Documentation.Doc (Doc (DocEmpty), docAppend)+import Pollock.Documentation.Metadata+  ( Metadata+  , emptyMetadata+  , metaAppend+  )++data MetaAndDoc = MetaAndDoc+  { meta :: !Metadata+  , doc :: !Doc+  }++withEmptyMetadata :: Doc -> MetaAndDoc+withEmptyMetadata d =+  MetaAndDoc+    { meta = emptyMetadata+    , doc = d+    }++metaAndDocConcat :: [MetaAndDoc] -> MetaAndDoc+metaAndDocConcat = foldr metaAndDocAppend emptyMetaAndDoc++-- Append where for metadata prefence is on the right, but for doc it is on the left.+metaAndDocAppend :: MetaAndDoc -> MetaAndDoc -> MetaAndDoc+metaAndDocAppend md1 md2 =+  MetaAndDoc+    { meta = metaAppend (meta md2) (meta md1)+    , doc = docAppend (doc md1) (doc md2)+    }++emptyMetaAndDoc :: MetaAndDoc+emptyMetaAndDoc = MetaAndDoc{meta = emptyMetadata, doc = DocEmpty}
+ src/Pollock/Documentation/Parser.hs view
@@ -0,0 +1,157 @@+{- |+Module: Pollock.Documentation.Parser+Copyright: (c) Trevis Elser 2023+License: MIT+Maintainer: trevis@flipstone.com+Stability: experimental+Portability: non-portable+-}+module Pollock.Documentation.Parser+  ( processDocStringParas+  , processDocStrings+  , parseText+  )+where++import qualified Control.Applicative as App+import qualified Control.Monad as M+import qualified Data.Attoparsec.Text as AttoText+import qualified Data.Char as Char+import qualified Data.Text as T++import qualified Pollock.CompatGHC as CompatGHC+import Pollock.Documentation.Doc+  ( Doc+      ( DocCodeBlock+      , DocEmpty+      , DocParagraph+      , DocProperty+      , DocString+      )+  )+import Pollock.Documentation.Metadata (Metadata (Metadata, version))+import Pollock.Documentation.MetadataAndDoc+  ( MetaAndDoc (MetaAndDoc, doc, meta)+  , metaAndDocConcat+  , withEmptyMetadata+  )++parseText :: T.Text -> Doc+parseText =+  either error id+    . AttoText.parseOnly (fmap docStringFromText AttoText.takeText)+    . T.filter (/= '\r')++processDocStringParas ::+  CompatGHC.HsDocString -> MetaAndDoc+processDocStringParas =+  either error id+    . AttoText.parseOnly parseParas+    . T.pack+    . filter (/= '\r')+    . CompatGHC.renderHsDocString++processDocStrings ::+  [CompatGHC.HsDocString]+  -> Maybe MetaAndDoc+processDocStrings strs =+  case metaAndDocConcat $ fmap processDocStringParas strs of+    -- We check that we don't have any version info to render instead+    -- of just checking if there is no comment: there may not be a+    -- comment but we still want to pass through any meta data.+    MetaAndDoc{meta = Metadata Nothing, doc = DocEmpty} -> Nothing+    x -> Just x++since :: AttoText.Parser MetaAndDoc+since = do+  skipHorizontalSpace+  _ <- AttoText.string (T.pack "@since ")+  s <- AttoText.sepBy1 AttoText.decimal (AttoText.string $ T.pack ".")+  skipHorizontalSpace+  let+    metadata =+      Metadata+        { version = Just s+        }+  pure $ MetaAndDoc metadata DocEmpty++skipHorizontalSpace :: AttoText.Parser ()+skipHorizontalSpace =+  AttoText.skipWhile AttoText.isHorizontalSpace++takeLine :: AttoText.Parser T.Text+takeLine = takeToEndOfLine++takeNonEmptyLine :: AttoText.Parser T.Text+takeNonEmptyLine =+  M.mfilter (T.any (not . Char.isSpace)) takeLine++birdtracks :: AttoText.Parser MetaAndDoc+birdtracks =+  let line = do+        skipHorizontalSpace+        _ <- AttoText.string (T.pack ">")+        takeLine+   in fmap (withEmptyMetadata . DocCodeBlock . docStringFromText . T.intercalate (T.pack "\n")) $+        AttoText.many1 line++paragraph :: AttoText.Parser MetaAndDoc+paragraph =+  AttoText.choice+    [ since+    , birdtracks+    , fmap withEmptyMetadata codeblock+    , fmap withEmptyMetadata property+    , fmap (withEmptyMetadata . docStringFromText) takeLine+    , fmap (withEmptyMetadata . DocParagraph) textParagraph+    ]++docStringFromText :: T.Text -> Doc+docStringFromText = DocString . T.unpack++textParagraph :: AttoText.Parser Doc+textParagraph = do+  lines' <- AttoText.many1 takeNonEmptyLine+  App.pure $ (docStringFromText . T.intercalate (T.pack "\n")) lines'++parseParas :: AttoText.Parser MetaAndDoc+parseParas =+  fmap metaAndDocConcat . AttoText.many' $ do+    p <- paragraph+    consumeEmptyLines+    App.pure p++{- | Property parser.++>>> snd <$> parseOnly property "prop> hello world"+Right (DocProperty "hello world")+-}+property :: AttoText.Parser Doc+property =+  fmap (DocProperty . T.unpack . T.strip) $ do+    _ <- AttoText.string (T.pack "prop>")+    takeToEndOfLine++{- |+Paragraph level codeblock. Anything between the two delimiting \@ is parsed+for markup.+-}+codeblock :: AttoText.Parser Doc+codeblock = do+  let+    atText = T.pack "@"+  _ <- AttoText.string atText+  skipHorizontalSpace+  AttoText.endOfLine+  blockDoc <- textParagraph+  _ <- AttoText.string atText+  App.pure $ DocCodeBlock blockDoc++takeToEndOfLine :: AttoText.Parser T.Text+takeToEndOfLine = AttoText.takeWhile1 (not . AttoText.isEndOfLine)++consumeEmptyLines :: AttoText.Parser ()+consumeEmptyLines =+  M.void . AttoText.many' $ do+    skipHorizontalSpace+    AttoText.endOfLine
+ src/Pollock/DriverPlugin.hs view
@@ -0,0 +1,30 @@+{- |+Module: Pollock.DriverPlugin+Copyright: (c) Trevis Elser 2023+License: MIT+Maintainer: trevis@flipstone.com+Stability: experimental+-}+module Pollock.DriverPlugin+  ( ensureHaddockIsOn+  ) where++import qualified Pollock.CompatGHC as CompatGHC++{- | A helper suitable for use to set as 'driverPlugin' that ensures the Haddock option is set to+allow other funcationality provided here to work.+-}+ensureHaddockIsOn :: [a] -> CompatGHC.HscEnv -> IO CompatGHC.HscEnv+ensureHaddockIsOn _ env =+  let+    dflags = CompatGHC.hsc_dflags env+    newDflags =+      dflags+        { CompatGHC.generalFlags =+            CompatGHC.insertEnumSet CompatGHC.Opt_Haddock (CompatGHC.generalFlags dflags)+        }+   in+    pure $+      env+        { CompatGHC.hsc_dflags = newDflags+        }
+ src/Pollock/ModuleInfo.hs view
@@ -0,0 +1,16 @@+{-# OPTIONS_GHC -Wno-missing-import-lists #-}++{- |+Module      :  Pollock.ModuleInfo+Copyright   :  (c) Trevis Elser 2023+License     :  MIT++Maintainer  :  trevis@flipstone.com+Stability   :  experimental+-}+module Pollock.ModuleInfo+  ( module Export+  ) where++import Pollock.ModuleInfo.ModuleHeader as Export+import Pollock.ModuleInfo.ModuleInfo as Export
+ src/Pollock/ModuleInfo/ModuleHeader.hs view
@@ -0,0 +1,222 @@+{- |+Module:  Pollock.ModuleInfo.ModuleHeader+Copyright: (c) Trevis Elser 2023+License:  MIT+Maintainer: trevis@flipstone.com+Stability: experimental+Portability: not-portable+-}+module Pollock.ModuleInfo.ModuleHeader+  ( ModuleHeader (..)+  , processModuleHeader+  ) where++import qualified Control.Applicative as App+import qualified Data.Char as Char+import qualified Data.Maybe as Maybe++import qualified Pollock.CompatGHC as CompatGHC++-- FIXME Consider safety, language and extensions if they are manually present? Does anyone+-- actually do that? Unclear, but could be useful.+data ModuleHeader = ModuleHeader+  { description :: !(Maybe String)+  -- ^ The description field of the Haddock module header.+  , copyright :: !(Maybe String)+  -- ^ The copyright field of the Haddock module header.+  , license :: !(Maybe String)+  -- ^ The license field of the Haddock module header.+  , maintainer :: !(Maybe String)+  -- ^ The maintainer field of the Haddock module header.+  , stability :: !(Maybe String)+  -- ^ The stability field of the Haddock module header.+  , portability :: !(Maybe String)+  -- ^ The portability field of the Haddock module header.+  }++emptyHaddockModInfo :: ModuleHeader+emptyHaddockModInfo =+  ModuleHeader+    { description = Nothing+    , copyright = Nothing+    , license = Nothing+    , maintainer = Nothing+    , stability = Nothing+    , portability = Nothing+    }++processModuleHeader ::+  Maybe CompatGHC.HsDocString+  -> ModuleHeader+processModuleHeader mayStr =+  case mayStr of+    Nothing -> emptyHaddockModInfo+    Just hds ->+      parseModuleHeader $ CompatGHC.renderHsDocString hds++parseModuleHeader ::+  String -> ModuleHeader+parseModuleHeader str0 =+  let+    kvs :: [(String, String)]+    kvs = Maybe.fromMaybe mempty $ runP fields str0++    -- trim whitespaces+    trim :: String -> String+    trim = dropWhile Char.isSpace . reverse . dropWhile Char.isSpace . reverse++    getKey :: String -> Maybe String+    getKey key = fmap trim (lookup key kvs)++    descriptionOpt = getKey "Description"+    copyrightOpt = getKey "Copyright"+    licenseOpt = getKey "License"+    licenceOpt = getKey "Licence"+    spdxLicenceOpt = getKey "SPDX-License-Identifier"+    maintainerOpt = getKey "Maintainer"+    stabilityOpt = getKey "Stability"+    portabilityOpt = getKey "Portability"+   in+    ModuleHeader+      { description = descriptionOpt+      , copyright = copyrightOpt+      , license = spdxLicenceOpt App.<|> licenseOpt App.<|> licenceOpt+      , maintainer = maintainerOpt+      , stability = stabilityOpt+      , portability = portabilityOpt+      }++-------------------------------------------------------------------------------+-- Small parser to parse module header.+-------------------------------------------------------------------------------++{- | The below is a small parser framework how we read keys.++all fields in the header are optional and have the form++[spaces1][field name][spaces] ":"+   [text]"\n" ([spaces2][space][text]"\n" | [spaces]"\n")*+where each [spaces2] should have [spaces1] as a prefix.++Thus for the key "Description",++> Description : this is a+>    rather long+>+>    description+>+> The module comment starts here++the value will be "this is a .. description" and the rest will begin+at "The module comment".+-}++{- | 'C' is a 'Char' carrying its column.++This let us make an indentation-aware parser, as we know current indentation.+by looking at the next character in the stream ('curInd').++Thus we can munch all spaces but only not-spaces which are indented.+-}+data C = C {-# UNPACK #-} !Int Char++newtype P a = P {unP :: [C] -> Maybe ([C], a)}++instance Functor P where+  fmap f (P pn) =+    P ((fmap . fmap) f . pn)++instance Applicative P where+  pure x = P $ \s -> Just (s, x)+  (<*>) m1 m2 =+    P $ \t0 ->+      case unP m1 t0 of+        Nothing -> Nothing+        Just (t1, z) ->+          (fmap . fmap) z (unP m2 t1)++instance Monad P where+  m >>= k =+    P $ \s0 ->+      case unP m s0 of+        Nothing -> Nothing+        Just (s1, x) -> unP (k x) s1+  return = pure++instance App.Alternative P where+  empty = P $ const Nothing+  a <|> b = P $ \s -> unP a s App.<|> unP b s++runP :: P a -> String -> Maybe a+runP p input = fmap snd (unP p input')+ where+  input' =+    concat+      [ zipWith C [0 ..] l <> [C (length l) '\n']+      | l <- lines input+      ]++-------------------------------------------------------------------------------+--+-------------------------------------------------------------------------------++curInd :: P Int+curInd = P $ \s -> Just . (,) s $ case s of+  [] -> 0+  C i _ : _ -> i++munch :: (Int -> Char -> Bool) -> P String+munch p = P $ \cs ->+  let (xs, ys) = takeWhileMaybe p' cs in Just (ys, xs)+ where+  p' (C i c)+    | p i c = Just c+    | otherwise = Nothing++munch1 :: (Int -> Char -> Bool) -> P String+munch1 p = P $ \s -> case s of+  [] -> Nothing+  (c : cs)+    | Just c' <- p' c -> let (xs, ys) = takeWhileMaybe p' cs in Just (ys, c' : xs)+    | otherwise -> Nothing+ where+  p' (C i c)+    | p i c = Just c+    | otherwise = Nothing++char :: Char -> P Char+char c = P $ \s -> case s of+  [] -> Nothing+  (C _ c' : cs)+    | c == c' -> Just (cs, c)+    | otherwise -> Nothing++skipSpaces :: P ()+skipSpaces = P $ \cs -> Just (dropWhile (\(C _ c) -> Char.isSpace c) cs, ())++takeWhileMaybe :: (a -> Maybe b) -> [a] -> ([b], [a])+takeWhileMaybe f = go+ where+  go xs0@[] = ([], xs0)+  go xs0@(x : xs) = case f x of+    Just y -> let (ys, zs) = go xs in (y : ys, zs)+    Nothing -> ([], xs0)++-------------------------------------------------------------------------------+-- Fields+-------------------------------------------------------------------------------++field :: Int -> P (String, String)+field i = do+  fn <- munch1 $ \_ c -> Char.isAlpha c || c == '-'+  skipSpaces+  _ <- char ':'+  skipSpaces+  val <- munch $ \j c -> Char.isSpace c || j > i+  pure (fn, val)++fields :: P [(String, String)]+fields = do+  skipSpaces+  i <- curInd+  App.many (field i)
+ src/Pollock/ModuleInfo/ModuleInfo.hs view
@@ -0,0 +1,98 @@+{- |+Module:  Pollock.ModuleInfo.ModuleInfo+Copyright: (c) Trevis Elser 2023+License:  MIT+Maintainer: trevis@flipstone.com+Stability: experimental+Portability: portable+-}+module Pollock.ModuleInfo.ModuleInfo+  ( ModuleInfo (..)+  , buildModuleInfo+  ) where++import qualified Data.Maybe as Maybe++import qualified Pollock.CompatGHC as CompatGHC+import qualified Pollock.Documentation as Documentation+import qualified Pollock.ModuleInfo.ModuleHeader as ModuleHeader++data ModuleInfo = ModuleInfo+  { moduleHeader :: !ModuleHeader.ModuleHeader+  -- ^ The haddock module header+  , haddockableExports :: !Int+  -- ^ How many exported items that could have documentation attached.+  , haddockedExports :: !Int+  -- ^ How many exported items that do have haddock attached.+  , numWithSince :: !Int+  -- ^ How many exported items have a since annotation.+  , numWithCodeBlock :: !Int+  -- ^ How many exported items have a code block included in the documentation.+  , numWithExample :: !Int+  -- ^ How many exported items have an example included in the documentation.+  , numWithProperty :: !Int+  -- ^ How many exported items have a property included in the documentation.+  , numWithWarning :: !Int+  -- ^ How many exported items have a warning attached to them.+  }++buildModuleInfo :: Maybe CompatGHC.HsDocString -> [Documentation.ExportItem] -> ModuleInfo+buildModuleInfo str =+  let+    initialModuleInfo =+      ModuleInfo+        { moduleHeader = ModuleHeader.processModuleHeader str+        , haddockableExports = 0+        , haddockedExports = 0+        , numWithSince = 0+        , numWithCodeBlock = 0+        , numWithExample = 0+        , numWithProperty = 0+        , numWithWarning = 0+        }+   in+    foldr foldExportItemInfo initialModuleInfo++foldExportItemInfo :: Documentation.ExportItem -> ModuleInfo -> ModuleInfo+foldExportItemInfo exportItem moduleInfo =+  if hasDoc exportItem+    then+      moduleInfo+        { haddockableExports =+            haddockableExports moduleInfo + 1+        , haddockedExports =+            haddockedExports moduleInfo + 1+        , numWithSince =+            if Documentation.exportItemHasSinceVersion exportItem+              then numWithSince moduleInfo + 1+              else numWithSince moduleInfo+        , numWithCodeBlock =+            if Documentation.exportItemHasCodeBlock exportItem+              then numWithCodeBlock moduleInfo + 1+              else numWithCodeBlock moduleInfo+        , numWithExample =+            if Documentation.exportItemHasExample exportItem+              then numWithExample moduleInfo + 1+              else numWithExample moduleInfo+        , numWithProperty =+            if Documentation.exportItemHasProperty exportItem+              then numWithProperty moduleInfo + 1+              else numWithProperty moduleInfo+        , numWithWarning =+            if Documentation.exportItemHasWarning exportItem+              then numWithWarning moduleInfo + 1+              else numWithWarning moduleInfo+        }+    else -- With no docs we _only_ had an export, but nothing else.++      moduleInfo+        { haddockableExports =+            haddockableExports moduleInfo + 1+        }++hasDoc :: Documentation.ExportItem -> Bool+hasDoc+  ( Documentation.ExportItemDecl+      (Documentation.ExportDecl (Documentation.DocumentationForDecl d _ _))+    ) = Maybe.isJust d+hasDoc _ = True
+ src/Pollock/ProcessModule.hs view
@@ -0,0 +1,520 @@+{-# LANGUAGE ScopedTypeVariables #-}++{- |+Module: Pollock.ProcessModule+Copyright: (c) Trevis Elser 2023+License: MIT++Maintainer: trevis@flipstone.com+Stability: experimental+-}+module Pollock.ProcessModule+  ( processModule+  ) where++import qualified Control.Applicative as Applicative+import qualified Control.Monad.IO.Class as MIO+import qualified Data.Bifunctor as Bifunctor+import qualified Data.IntMap.Strict as IM+import qualified Data.Map.Strict as Map+import qualified Data.Maybe as Maybe+import qualified Data.Text as T++import qualified Pollock.CompatGHC as CompatGHC+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+  -> m ModuleInfo+processModule tcGblEnv = do+  let+    localInstances :: [CompatGHC.Name]+    localInstances =+      filter+        (CompatGHC.nameIsLocalOrFrom (CompatGHC.tcg_semantic_mod tcGblEnv))+        ( fmap CompatGHC.getName (CompatGHC.tcg_insts tcGblEnv)+            <> fmap CompatGHC.getName (CompatGHC.tcg_fam_insts tcGblEnv)+        )++    tcgExports = CompatGHC.tcg_exports tcGblEnv+    exportedNames = concatMap CompatGHC.availNames tcgExports+    -- Warnings on declarations in this module+    decl_warnings = mkWarningMap (CompatGHC.tcg_warns tcGblEnv) (CompatGHC.tcg_rdr_env tcGblEnv) exportedNames++  -- The docs added via Template Haskell's putDoc+  thDocs <-+    MIO.liftIO . fmap CompatGHC.extractTHDocs . CompatGHC.readIORef $ CompatGHC.tcg_th_docs tcGblEnv++  -- 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)++      decls = maybe mempty CompatGHC.topDecls $ CompatGHC.tcg_rn_decls tcGblEnv+      maps = mkMaps localInstances decls thDocs++      exportItems =+        mkExportItems+          (CompatGHC.tcg_semantic_mod tcGblEnv)+          decl_warnings+          (fmap fst decls)+          maps+          (importedModules tcGblEnv)+          (fullExplicitExportList tcGblEnv)+          tcgExports++  pure $ buildModuleInfo mbHeaderStr exportItems++-- Module imports of the form `import X`. Note that there is+-- a) no qualification and+-- b) no import list+importedModules :: CompatGHC.TcGblEnv -> Map.Map CompatGHC.ModuleName [CompatGHC.ModuleName]+importedModules tcGblEnv =+  -- If rn_exports aren't available then we know renamed source overall is not available and can+  -- short circuit here.+  case fullExplicitExportList tcGblEnv of+    Just _ -> unrestrictedModuleImports (fmap CompatGHC.unLoc (CompatGHC.tcg_rn_imports tcGblEnv))+    Nothing -> Map.empty++-- All elements of an explicit export list, if present+fullExplicitExportList ::+  CompatGHC.TcGblEnv -> Maybe [(CompatGHC.IE CompatGHC.GhcRn, CompatGHC.Avails)]+fullExplicitExportList =+  (fmap . fmap) unLocFirst . CompatGHC.tcg_rn_exports++-- We want to know which modules are imported without any qualification. This+-- way we can display module reexports more compactly. This mapping also looks+-- through aliases:+--+-- module M (module X) where+--   import M1 as X+--   import M2 as X+--+-- With our mapping we know that we can display exported modules M1 and M2.+--+unrestrictedModuleImports ::+  [CompatGHC.ImportDecl CompatGHC.GhcRn] -> Map.Map CompatGHC.ModuleName [CompatGHC.ModuleName]+unrestrictedModuleImports idecls =+  fmap (fmap (CompatGHC.unLoc . CompatGHC.ideclName)) $+    Map.filter (all isInteresting) impModMap+ where+  impModMap =+    Map.fromListWith (<>) (concatMap moduleMapping idecls)++  moduleMapping ::+    CompatGHC.ImportDecl CompatGHC.GhcRn+    -> [(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+         )++  isInteresting :: CompatGHC.ImportDecl CompatGHC.GhcRn -> Bool+  isInteresting idecl =+    case CompatGHC.ideclImportList idecl of+      -- i) no subset selected+      Nothing -> True+      -- ii) an import with a hiding clause+      -- without any names+      Just (CompatGHC.EverythingBut, CompatGHC.L _ []) -> True+      -- iii) any other case of qualification+      _ -> False++-------------------------------------------------------------------------------+-- Warnings+-------------------------------------------------------------------------------++mkWarningMap ::+  forall a.+  CompatGHC.Warnings a+  -> CompatGHC.GlobalRdrEnv+  -> [CompatGHC.Name]+  -> WarningMap+mkWarningMap warnings gre =+  Map.fromList . (fmap . fmap) parseWarning . CompatGHC.processWarnSome warnings gre++parseWarning :: CompatGHC.WarningTxt a -> Documentation.Doc+parseWarning w =+  let+    format :: String -> String -> Documentation.Doc+    format x =+      Documentation.DocWarning+        . Documentation.DocParagraph+        . Documentation.DocAppend (Documentation.DocString x)+        . 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))+      -> Documentation.Doc+    formatDeprecated =+      format "Deprecated: " . foldMsgs++    formatWarning ::+      (Foldable t) =>+      t (CompatGHC.Located (CompatGHC.WithHsDocIdentifiers CompatGHC.StringLiteral pass))+      -> Documentation.Doc+    formatWarning =+      format "Warning: " . foldMsgs+   in+    CompatGHC.mapWarningTxtMsg formatDeprecated formatWarning w++--------------------------------------------------------------------------------+-- Maps+--------------------------------------------------------------------------------++type Maps =+  ( DocMap+  , ArgMap+  , Map.Map+      CompatGHC.Name+      [CompatGHC.HsDecl CompatGHC.GhcRn]+  )++type DocMap = Map.Map CompatGHC.Name Documentation.MetaAndDoc+type ArgMap = Map.Map CompatGHC.Name Documentation.FnArgsDoc+type WarningMap = Map.Map CompatGHC.Name Documentation.Doc++{- | Create 'Maps' by looping through the declarations. For each declaration,+find its names, its subordinates, and its doc strings. Process doc strings+into 'Documentation.Doc's.+-}+mkMaps ::+  [CompatGHC.Name]+  -> [(CompatGHC.LHsDecl CompatGHC.GhcRn, [CompatGHC.HsDoc CompatGHC.GhcRn])]+  -> CompatGHC.ExtractedTHDocs+  -- ^ Template Haskell putDoc docs+  -> Maps+mkMaps+  instances+  hsdecls+  (CompatGHC.ExtractedTHDocs _ declDocs argDocs instDocs) =+    let+      thProcessedArgDocs = fmap (fmap mkMetaAndDoc) (CompatGHC.nonDetEltUniqMapToMap argDocs)+      thProcessedDeclDocs = fmap mkMetaAndDoc (CompatGHC.nonDetEltUniqMapToMap declDocs)+      thProcessedInstDocs = fmap mkMetaAndDoc (CompatGHC.nonDetEltUniqMapToMap instDocs)+      thDeclAndInstDocs = thProcessedDeclDocs <> thProcessedInstDocs+      (declDocLists, declArgLists, declLists) = unzip3 $ fmap (nonTHMappings instances) hsdecls+     in+      ( Map.union thDeclAndInstDocs $ buildDocMap declDocLists+      , unionArgMaps thProcessedArgDocs $ buildMapWithNotNullValues IM.null declArgLists+      , buildMapWithNotNullValues null declLists+      )++nonTHMappings ::+  [CompatGHC.Name]+  -> (CompatGHC.LHsDecl CompatGHC.GhcRn, [CompatGHC.HsDoc CompatGHC.GhcRn])+  -> ( [(CompatGHC.Name, Documentation.MetaAndDoc)]+     , [(CompatGHC.Name, IM.IntMap Documentation.MetaAndDoc)]+     , [(CompatGHC.Name, [CompatGHC.HsDecl CompatGHC.GhcRn])]+     )+nonTHMappings instances (CompatGHC.L (CompatGHC.SrcSpanAnn _ (CompatGHC.RealSrcSpan l _)) decl, hs_docStrs) =+  let args :: IM.IntMap Documentation.MetaAndDoc+      args =+        fmap mkMetaAndDoc (CompatGHC.declTypeDocs decl)++      instanceMap :: Map.Map CompatGHC.RealSrcSpan CompatGHC.Name+      instanceMap =+        Map.fromList $ foldr instanceFoldFn mempty instances++      (subNs, subDocs, subArgs) =+        unzip3 . fmap processSubordinates $+          CompatGHC.subordinates CompatGHC.emptyOccEnv instanceMap decl++      names = getAssociatedNames l decl instanceMap++      docMapping =+        Maybe.catMaybes subDocs+          <> case processDocStrings hs_docStrs of+            Just doc ->+              fmap (\x -> (x, doc)) names+            Nothing ->+              mempty+      argMapping = fmap (\x -> (x, args)) names <> subArgs++      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))+  -> (a, Maybe (a, Documentation.MetaAndDoc), (a, IM.IntMap Documentation.MetaAndDoc))+processSubordinates (name, docStrs', docStrMap) =+  (name, maybeSnd (name, processDocStrings docStrs'), (name, fmap mkMetaAndDoc docStrMap))++instanceFoldFn ::+  CompatGHC.Name+  -> [(CompatGHC.RealSrcSpan, CompatGHC.Name)]+  -> [(CompatGHC.RealSrcSpan, CompatGHC.Name)]+instanceFoldFn n accum =+  case CompatGHC.getSrcSpan n of+    CompatGHC.RealSrcSpan l _ ->+      (l, n) : accum+    _ -> accum++getAssociatedNames ::+  CompatGHC.RealSrcSpan+  -> CompatGHC.HsDecl CompatGHC.GhcRn+  -> Map.Map CompatGHC.RealSrcSpan CompatGHC.Name+  -> [CompatGHC.Name]+getAssociatedNames _ (CompatGHC.InstD _ d) instanceMap =+  let+    loc =+      case d of+        -- The CoAx's loc is the whole line, but only for TFs. The+        -- workaround is to dig into the family instance declaration and+        -- get the identifier with the right location.+        CompatGHC.TyFamInstD _ (CompatGHC.TyFamInstDecl _ d') -> CompatGHC.getLocA (CompatGHC.feqn_tycon d')+        _ -> 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 _ =+  CompatGHC.getMainDeclBinder CompatGHC.emptyOccEnv decl++{- | Unions together two 'ArgDocMaps' (or ArgMaps in haddock-api), such that two+maps with values for the same key merge the inner map as well.+Left biased so @unionArgMaps a b@ prefers @a@ over @b@.+-}+unionArgMaps ::+  forall b.+  Map.Map CompatGHC.Name (IM.IntMap b)+  -> Map.Map CompatGHC.Name (IM.IntMap b)+  -> Map.Map CompatGHC.Name (IM.IntMap b)+unionArgMaps a b = Map.foldrWithKey go b a+ where+  go ::+    CompatGHC.Name+    -> IM.IntMap b+    -> Map.Map CompatGHC.Name (IM.IntMap b)+    -> Map.Map CompatGHC.Name (IM.IntMap b)+  go n newArgMap acc =+    case Map.lookup n acc of+      Just oldArgMap ->+        Map.insert n (newArgMap `IM.union` oldArgMap) acc+      Nothing -> Map.insert n newArgMap acc++-- Note [2]:+------------+-- We relate ClsInsts to InstDecls and DerivDecls using the SrcSpans buried+-- inside them. That should work for normal user-written instances (from+-- looking at GHC sources). We can assume that commented instances are+-- user-written. This lets us relate Names (from ClsInsts) to comments+-- (associated with InstDecls and DerivDecls).++buildDocMap ::+  (Foldable t) =>+  t [(CompatGHC.Name, Documentation.MetaAndDoc)]+  -> Map.Map CompatGHC.Name Documentation.MetaAndDoc+buildDocMap =+  fromListWithAndFilter Documentation.metaAndDocAppend (CompatGHC.nubByName fst)++fromListWithAndFilter ::+  (Ord k, Foldable t) =>+  (a -> a -> a)+  -> (b -> [(k, a)])+  -> t b+  -> Map.Map k a+fromListWithAndFilter appendFn filterFn =+  Map.fromListWith appendFn . concatMap filterFn++buildMapWithNotNullValues ::+  (Semigroup b) =>+  (b -> Bool)+  -> [[(CompatGHC.Name, b)]]+  -> Map.Map CompatGHC.Name b+buildMapWithNotNullValues nullFn =+  fromListWithAndFilter (<>) (filter (not . nullFn . snd))++--------------------------------------------------------------------------------+-- Declarations+--------------------------------------------------------------------------------++{- | Build the list of items that will become the documentation, from the+export list.  At this point, the list of ExportItems is in terms of+original names.++We create the export items even if the module is hidden, since they+might be useful when creating the export items for other modules.+-}+mkExportItems ::+  CompatGHC.Module -- semantic module+  -> WarningMap+  -> [CompatGHC.LHsDecl CompatGHC.GhcRn] -- renamed source declarations+  -> Maps+  -> Map.Map CompatGHC.ModuleName [CompatGHC.ModuleName] -- imported modules+  -> Maybe [(CompatGHC.IE CompatGHC.GhcRn, CompatGHC.Avails)]+  -> CompatGHC.Avails -- exported stuff from this module+  -> [Documentation.ExportItem]+mkExportItems semMod warnings hsdecls maps unrestricted_imp_mods exportList allExports =+  case exportList of+    Nothing ->+      fullModuleContents+        semMod+        warnings+        hsdecls+        maps+        allExports+    Just exports -> concat $ traverse lookupExport exports+ where+  lookupExport ::+    (CompatGHC.IE CompatGHC.GhcRn, [CompatGHC.AvailInfo])+    -> [Documentation.ExportItem]+  lookupExport (CompatGHC.IEGroup{}, _) =+    mempty+  lookupExport (CompatGHC.IEDoc _ docStr, _) =+    pure . Documentation.mkExportDoc . mkMetaAndDoc $ CompatGHC.unLoc docStr+  lookupExport (CompatGHC.IEDocNamed _ _, _) =+    -- FIXME: If we have some named docs then that isn't really an export of some code to keep+    -- track of for coverage or other analysis. Make sure we don't need to restore this for+    -- something though.+    mempty+  -- liftErrMsg $+  --   findNamedDoc str (fmap CompatGHC.unLoc hsdecls) >>= \case+  --     Nothing -> pure []+  --     Just docStr ->+  --       pure [pollock_mkExportDoc $ processDocStringParas docStr]+  lookupExport (CompatGHC.IEModuleContents _ (CompatGHC.L _ mod_name), _)+    -- only consider exporting a module if we are sure we+    -- are really exporting the whole module and not some+    -- subset. We also look through module aliases here.+    | Just mods <- Map.lookup mod_name unrestricted_imp_mods+    , not (null mods) =+        mempty+  -- FIXME Can we get away with completely ignoring module exports like this?+  -- concat <$> traverse (moduleExport thisMod dflags modMap instIfaceMap) mods++  lookupExport (_, avails) =+    concatMap availExport (CompatGHC.nubAvails avails)++  availExport =+    availExportItem semMod warnings maps++availExportItem ::+  CompatGHC.Module -- semantic module+  -> WarningMap+  -> Maps+  -> CompatGHC.AvailInfo+  -> [Documentation.ExportItem]+availExportItem semMod warnings (docMap, argMap, declMap) avail =+  let+    n = CompatGHC.availName avail+   in+    if CompatGHC.nameModule n == semMod+      then case Map.lookup n declMap of+        Just [CompatGHC.ValD _ _] ->+          pure . Documentation.ExportItemDecl . Documentation.ExportDecl . fst $+            lookupDocs avail warnings docMap argMap+        Just ds ->+          case filter (not . CompatGHC.isValD) ds of+            [_] ->+              availExportDecl avail $ lookupDocs avail warnings docMap argMap+            _ ->+              mempty+        Nothing ->+          mempty+      else mempty++availExportDecl ::+  CompatGHC.AvailInfo+  -> (Documentation.DocumentationForDecl, [(CompatGHC.Name, Documentation.DocumentationForDecl)])+  -> [Documentation.ExportItem]+availExportDecl avail (doc, subs) =+  if CompatGHC.availExportsDecl avail+    then pure . Documentation.ExportItemDecl $ Documentation.ExportDecl doc+    else fmap (Documentation.ExportItemDecl . Documentation.ExportDecl . snd) subs++-- | Lookup docs for a declaration from maps.+lookupDocs ::+  CompatGHC.AvailInfo+  -> WarningMap+  -> DocMap+  -> ArgMap+  -> (Documentation.DocumentationForDecl, [(CompatGHC.Name, Documentation.DocumentationForDecl)])+lookupDocs avail' warnings docMap argMap =+  let n = CompatGHC.availName avail'+      lookupDoc name =+        Documentation.DocumentationForDecl+          (Map.lookup name docMap)+          (Map.lookup name warnings)+          (Map.findWithDefault IM.empty name argMap)+      subDocs =+        fmap (\x -> (x, lookupDoc x)) $ CompatGHC.availSubordinateNames avail'+   in (lookupDoc n, subDocs)++fullModuleContents ::+  CompatGHC.Module -- semantic module+  -> WarningMap+  -> [CompatGHC.LHsDecl CompatGHC.GhcRn] -- renamed source declarations+  -> Maps+  -> CompatGHC.Avails+  -> [Documentation.ExportItem]+fullModuleContents semMod warnings hsdecls maps@(_, _, declMap) avails =+  let availEnv = CompatGHC.availsToNameEnv (CompatGHC.nubAvails avails)+      fn :: CompatGHC.HsDecl CompatGHC.GhcRn -> [Documentation.ExportItem]+      fn decl =+        case decl of+          (CompatGHC.DocD _ (CompatGHC.DocGroup _ _)) ->+            mempty+          (CompatGHC.DocD _ (CompatGHC.DocCommentNamed _ docStr)) ->+            let+              doc' = mkMetaAndDoc $ CompatGHC.unLoc docStr+             in+              pure $ Documentation.mkExportDoc doc'+          (CompatGHC.ValD _ valDecl)+            | name : _ <- CompatGHC.collectHsBindBinders CompatGHC.CollNoDictBinders valDecl+            , Just (CompatGHC.SigD{} : _) <- filter isSigD <$> Map.lookup name declMap ->+                mempty+          _ ->+            let+              gn nm =+                case CompatGHC.lookupNameEnv availEnv nm of+                  Just avail' ->+                    availExportItem+                      semMod+                      warnings+                      maps+                      avail'+                  Nothing -> mempty+             in+              concatMap gn (CompatGHC.getMainDeclBinder CompatGHC.emptyOccEnv decl)+   in concatMap (fn . CompatGHC.unLoc) hsdecls++isSigD :: CompatGHC.HsDecl p -> Bool+isSigD (CompatGHC.SigD{}) = True+isSigD _ = False++mkMetaAndDoc :: CompatGHC.HsDoc CompatGHC.GhcRn -> Documentation.MetaAndDoc+mkMetaAndDoc = Documentation.processDocStringParas . CompatGHC.hsDocString++processDocStrings :: [CompatGHC.HsDoc CompatGHC.GhcRn] -> Maybe Documentation.MetaAndDoc+processDocStrings = Documentation.processDocStrings . fmap CompatGHC.hsDocString++unLocFirst :: (Bifunctor.Bifunctor bf) => bf (CompatGHC.GenLocated l b) c -> bf b c+unLocFirst =+  Bifunctor.first CompatGHC.unLoc++maybeSnd :: (a, Maybe b) -> Maybe (a, b)+maybeSnd (a, Just b) = Just (a, b)+maybeSnd (_, Nothing) = Nothing