diff options
Diffstat (limited to 'haddock-api/src/Haddock')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml.hs | 1 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface.hs | 2 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Create.hs | 27 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Rename.hs | 16 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Options.hs | 10 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Types.hs | 22 |
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 ----------------------------------------------------------------------------- |