aboutsummaryrefslogtreecommitdiff
path: root/haddock-api
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api')
-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
-----------------------------------------------------------------------------
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-13 05:16:21 +0000