aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src
diff options
context:
space:
mode:
authorXia Li-yao <Lysxia@users.noreply.github.com>2020-12-08 10:43:05 -0500
committerGitHub <noreply@github.com>2020-12-08 16:43:05 +0100
commit7240b69e3444e40546c7a17855eed2e5ab8a0816 (patch)
tree18ea535168a8418a3556c6efb9789d068d99a546 /haddock-api/src
parent1bedd20b94359728c25f64f7643a0ca0fb0f9fa2 (diff)
Add dangling changes from branches ghc-8.6 and ghc-8.8 (#1243)
* Fix multiple typos and inconsistencies in doc/markup.rst Note: I noticed some overlap with #1112 from @wygulmage and #1081 from @parsonsmatt after creating these proposed changes - mea culpa for not looking at the open PRs sooner. * Fix #1113 If no Signatures, no section of index.html * Change the formatting of missing link destinations The current formatting of the missing link destination does not really help user to understand the reasons of the missing link. To address this, I've changed the formatting in two ways: - the missing link symbol name is now fully qualified. This way you immediately know which haskell module cannot be linked. It is then easier to understand why this module does not have documentation (hidden module or broken documentation). - one line per missing link, that's more readable now that symbol name can be longer due to qualification. For example, before haddock was listing missing symbol such as: ``` could not find link destinations for: Word8 Word16 mapMaybe ``` Now it is listed as: ``` could not find link destinations for: - Data.Word.Word8 - Data.Word.Word16 - Data.Maybe.mapMaybe ``` * Add `--ignore-link-symbol` command line argument This argument can be used multiples time. A missing link to a symbol listed by `--ignore-link-symbol` won't trigger "missing link" warning. * Forbid spaces in anchors (#1148) * Improve error messages with context information (#1060) Co-authored-by: Matt Audesse <matt@mattaudesse.com> Co-authored-by: Mike Pilgrem <mpilgrem@users.noreply.github.com> Co-authored-by: Guillaume Bouchard <guillaume.bouchard@tweag.io> Co-authored-by: Pepe Iborra <pepeiborra@gmail.com>
Diffstat (limited to 'haddock-api/src')
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml.hs1
-rw-r--r--haddock-api/src/Haddock/Interface.hs2
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs27
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs16
-rw-r--r--haddock-api/src/Haddock/Options.hs10
-rw-r--r--haddock-api/src/Haddock/Types.hs22
6 files changed, 60 insertions, 18 deletions
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 4e87d0be..f80a9c05 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -307,6 +307,7 @@ ppPrologue pkg qual title (Just doc) =
ppSignatureTree :: Maybe Package -> Qualification -> [ModuleTree] -> Html
+ppSignatureTree _ _ [] = mempty
ppSignatureTree pkg qual ts =
divModuleList << (sectionName << "Signatures" +++ mkNodeList pkg qual [] "n" ts)
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index 66e0bedc..d1e1dae1 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -111,7 +111,7 @@ processModules verbosity modules flags extIfaces = do
let warnings = Flag_NoWarnings `notElem` flags
dflags <- getDynFlags
let (interfaces'', msgs) =
- runWriter $ mapM (renameInterface dflags links warnings) interfaces'
+ runWriter $ mapM (renameInterface dflags (ignoredSymbols flags) links warnings) interfaces'
liftIO $ mapM_ putStrLn msgs
return (interfaces'', homeLinks)
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 5a58e1ac..d554eeb3 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -39,6 +39,7 @@ import Data.Ord
import Control.Applicative
import Control.Monad
import Data.Traversable
+import GHC.Stack (HasCallStack)
import Avail hiding (avail)
import qualified Avail
@@ -58,16 +59,21 @@ import FastString ( unpackFS, bytesFS )
import BasicTypes ( StringLiteral(..), SourceText(..), PromotionFlag(..) )
import qualified Outputable as O
+mkExceptionContext :: TypecheckedModule -> String
+mkExceptionContext =
+ ("creating Haddock interface for " ++) . moduleNameString . ms_mod_name . pm_mod_summary . tm_parsed_module
-- | Use a 'TypecheckedModule' to produce an 'Interface'.
-- To do this, we need access to already processed modules in the topological
-- sort. That's what's in the 'IfaceMap'.
-createInterface :: TypecheckedModule
+createInterface :: HasCallStack
+ => TypecheckedModule
-> [Flag] -- Boolean flags
-> IfaceMap -- Locally processed modules
-> InstIfaceMap -- External, already installed interfaces
-> ErrMsgGhc Interface
-createInterface tm flags modMap instIfaceMap = do
+createInterface tm flags modMap instIfaceMap =
+ withExceptionContext (mkExceptionContext tm) $ do
let ms = pm_mod_summary . tm_parsed_module $ tm
mi = moduleInfo tm
@@ -207,7 +213,6 @@ createInterface tm flags modMap instIfaceMap = do
, ifaceDynFlags = dflags
}
-
-- | Given all of the @import M as N@ declarations in a package,
-- create a mapping from the module identity of M, to an alias N
-- (if there are multiple aliases, we pick the last one.) This
@@ -652,7 +657,8 @@ collectDocs = go Nothing []
-- 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
- :: Bool -- is it a signature
+ :: HasCallStack
+ => Bool -- is it a signature
-> IfaceMap
-> Maybe Package -- this package
-> Module -- this module
@@ -711,7 +717,8 @@ mkExportItems
availExportItem is_sig modMap thisMod semMod warnings exportedNames
maps fixMap splices instIfaceMap dflags avail
-availExportItem :: Bool -- is it a signature
+availExportItem :: HasCallStack
+ => Bool -- is it a signature
-> IfaceMap
-> Module -- this module
-> Module -- semantic module
@@ -804,7 +811,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
Just synifiedDecl -> pure synifiedDecl
Nothing -> O.pprPanic "availExportItem" (O.text err)
- availExportDecl :: AvailInfo -> LHsDecl GhcRn
+ availExportDecl :: HasCallStack => AvailInfo -> LHsDecl GhcRn
-> (DocForDecl Name, [(Name, DocForDecl Name)])
-> ErrMsgGhc [ ExportItem GhcRn ]
availExportDecl avail decl (doc, subs)
@@ -1075,7 +1082,8 @@ fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNam
-- This function looks through the declarations in this module to try to find
-- the one with the right name.
extractDecl
- :: DeclMap -- ^ all declarations in the file
+ :: HasCallStack
+ => DeclMap -- ^ all declarations in the file
-> Name -- ^ name of the declaration to extract
-> LHsDecl GhcRn -- ^ parent declaration
-> Either ErrMsg (LHsDecl GhcRn)
@@ -1159,10 +1167,11 @@ extractDecl declMap name decl
_ -> Left "internal: extractDecl (ClsInstD)"
_ -> Left ("extractDecl: Unhandled decl for " ++ getOccString name)
-extractPatternSyn :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> Either ErrMsg (LSig GhcRn)
+extractPatternSyn :: HasCallStack => Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> Either ErrMsg (LSig GhcRn)
extractPatternSyn nm t tvs cons =
case filter matches cons of
- [] -> Left "extractPatternSyn: constructor pattern not found"
+ [] -> Left . O.showSDocUnsafe $
+ O.text "constructor pattern " O.<+> O.ppr nm O.<+> O.text "not found in type" O.<+> O.ppr t
con:_ -> pure (extract <$> con)
where
matches :: LConDecl GhcRn -> Bool
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 97f128d7..b4ff31e5 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -29,6 +29,7 @@ import Control.Applicative
import Control.Arrow ( first )
import Control.Monad hiding (mapM)
import qualified Data.Map as Map hiding ( Map )
+import qualified Data.Set as Set
import Prelude hiding (mapM)
-- | Traverse docstrings and ASTs in the Haddock interface, renaming 'Name' to
@@ -39,8 +40,8 @@ import Prelude hiding (mapM)
--
-- The renamed output gets written into fields in the Haddock interface record
-- that were previously left empty.
-renameInterface :: DynFlags -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface
-renameInterface dflags renamingEnv warnings iface =
+renameInterface :: DynFlags -> [String] -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface
+renameInterface _dflags ignoredSymbols renamingEnv warnings iface =
-- first create the local env, where every name exported by this module
-- is mapped to itself, and everything else comes from the global renaming
@@ -75,8 +76,15 @@ renameInterface dflags renamingEnv warnings iface =
-- Note that since the renamed AST represents equality constraints as
-- @HasOpTy t1 eqTyCon_RDR t2@ (and _not_ as @HsEqTy t1 t2@), we need to
-- manually filter out 'eqTyCon_RDR' (aka @~@).
- strings = [ pretty dflags n
+
+ qualifiedName n = (moduleNameString $ moduleName $ nameModule n) <> "." <> getOccString n
+
+ ignoreSet = Set.fromList ignoredSymbols
+
+ strings = [ qualifiedName n
+
| n <- missingNames
+ , not (qualifiedName n `Set.member` ignoreSet)
, not (isSystemName n)
, not (isBuiltInSyntax n)
, Exact n /= eqTyCon_RDR
@@ -88,7 +96,7 @@ renameInterface dflags renamingEnv warnings iface =
unless (OptHide `elem` ifaceOptions iface || null strings || not warnings) $
tell ["Warning: " ++ moduleString (ifaceMod iface) ++
": could not find link destinations for:\n"++
- unwords (" " : strings) ]
+ intercalate "\n\t- " ("" : strings) ]
return $ iface { ifaceRnDoc = finalModuleDoc,
ifaceRnDocMap = rnDocMap,
diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs
index 510810b0..8a18a60d 100644
--- a/haddock-api/src/Haddock/Options.hs
+++ b/haddock-api/src/Haddock/Options.hs
@@ -36,7 +36,8 @@ module Haddock.Options (
readIfaceArgs,
optPackageName,
optPackageVersion,
- modulePackageInfo
+ modulePackageInfo,
+ ignoredSymbols
) where
@@ -108,6 +109,7 @@ data Flag
| Flag_PackageVersion String
| Flag_Reexport String
| Flag_SinceQualification String
+ | Flag_IgnoreLinkSymbol String
deriving (Eq, Show)
@@ -219,7 +221,9 @@ options backwardsCompat =
Option [] ["package-version"] (ReqArg Flag_PackageVersion "VERSION")
"version of the package being documented in usual x.y.z.w format",
Option [] ["since-qual"] (ReqArg Flag_SinceQualification "QUAL")
- "package qualification of @since, one of\n'always' (default) or 'only-external'"
+ "package qualification of @since, one of\n'always' (default) or 'only-external'",
+ Option [] ["ignore-link-symbol"] (ReqArg Flag_IgnoreLinkSymbol "SYMBOL")
+ "name of a symbol which does not trigger a warning in case of link issue"
]
@@ -336,6 +340,8 @@ verbosity flags =
Left e -> throwE e
Right v -> v
+ignoredSymbols :: [Flag] -> [String]
+ignoredSymbols flags = [ symbol | Flag_IgnoreLinkSymbol symbol <- flags ]
ghcFlags :: [Flag] -> [String]
ghcFlags flags = [ option | Flag_OptGhc option <- flags ]
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index ec76fb72..c2cf08bb 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -39,6 +39,7 @@ import Data.Void (Void)
import Documentation.Haddock.Types
import BasicTypes (Fixity(..), PromotionFlag(..))
+import Exception (ExceptionMonad(..), ghandle)
import GHC
import DynFlags (Language)
import qualified GHC.LanguageExtensions as LangExt
@@ -649,17 +650,28 @@ tell w = Writer ((), w)
-- | Haddock's own exception type.
-data HaddockException = HaddockException String deriving Typeable
+data HaddockException
+ = HaddockException String
+ | WithContext [String] SomeException
+ deriving Typeable
instance Show HaddockException where
show (HaddockException str) = str
-
+ show (WithContext ctxts se) = unlines $ ["While " ++ ctxt ++ ":\n" | ctxt <- reverse ctxts] ++ [show se]
throwE :: String -> a
instance Exception HaddockException
throwE str = throw (HaddockException str)
+withExceptionContext :: ExceptionMonad m => String -> m a -> m a
+withExceptionContext ctxt =
+ ghandle (\ex ->
+ case ex of
+ HaddockException e -> throw $ WithContext [ctxt] (toException ex)
+ WithContext ctxts se -> throw $ WithContext (ctxt:ctxts) se
+ ) .
+ ghandle (throw . WithContext [ctxt])
-- In "Haddock.Interface.Create", we need to gather
-- @Haddock.Types.ErrMsg@s a lot, like @ErrMsgM@ does,
@@ -694,6 +706,12 @@ instance Monad ErrMsgGhc where
instance MonadIO ErrMsgGhc where
liftIO m = WriterGhc (fmap (\x -> (x, [])) (liftIO m))
+instance ExceptionMonad ErrMsgGhc where
+ gcatch act hand = WriterGhc $
+ runWriterGhc act `gcatch` (runWriterGhc . hand)
+ gmask act = WriterGhc $ gmask $ \mask ->
+ runWriterGhc $ act (WriterGhc . mask . runWriterGhc)
+
-----------------------------------------------------------------------------
-- * Pass sensitive types
-----------------------------------------------------------------------------