diff --git a/haddock-api.cabal b/haddock-api.cabal --- a/haddock-api.cabal +++ b/haddock-api.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: haddock-api -version: 2.28.0 +version: 2.29.0 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries diff --git a/src/Haddock.hs b/src/Haddock.hs --- a/src/Haddock.hs +++ b/src/Haddock.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} @@ -46,6 +47,7 @@ import Haddock.Utils import Haddock.GhcUtils (modifySessionDynFlags, setOutputDir) +import Control.DeepSeq (force) import Control.Monad hiding (forM_) import Control.Monad.IO.Class (MonadIO(..)) import Data.Bifunctor (second) @@ -55,9 +57,9 @@ import Control.Exception import Data.Maybe import Data.IORef -import Data.Map (Map) +import Data.Map.Strict (Map) import Data.Version (makeVersion) -import qualified Data.Map as Map +import qualified Data.Map.Strict as Map import System.IO import System.Exit import System.FilePath @@ -73,9 +75,9 @@ import Text.ParserCombinators.ReadP (readP_to_S) import GHC hiding (verbosity) import GHC.Settings.Config -import GHC.Driver.Session hiding (projectVersion, verbosity) import GHC.Driver.Config.Logger (initLogFlags) import GHC.Driver.Env +import GHC.Driver.Session hiding (projectVersion, verbosity) import GHC.Utils.Error import GHC.Utils.Logger import GHC.Types.Name.Cache @@ -159,19 +161,21 @@ qual <- rightOrThrowE (qualification flags) sinceQual <- rightOrThrowE (sinceQualification flags) - -- inject dynamic-too into flags before we proceed + -- Inject dynamic-too into ghc options if the ghc we are using was built with + -- dynamic linking flags'' <- ghc flags $ do df <- getDynFlags case lookup "GHC Dynamic" (compilerInfo df) of Just "YES" -> return $ Flag_OptGhc "-dynamic-too" : flags _ -> return flags + -- Inject `-j` into ghc options, if given to Haddock flags' <- pure $ case optParCount flags'' of Nothing -> flags'' Just Nothing -> Flag_OptGhc "-j" : flags'' Just (Just n) -> Flag_OptGhc ("-j" ++ show n) : flags'' - -- bypass the interface version check + -- Whether or not to bypass the interface version check let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags -- Create a temporary directory and redirect GHC output there (unless user @@ -183,24 +187,26 @@ let withDir | Flag_NoTmpCompDir `elem` flags = id | otherwise = withTempOutputDir + -- Output warnings about potential misuse of some flags unless (Flag_NoWarnings `elem` flags) $ do hypSrcWarnings flags - forM_ (warnings args) $ \warning -> do - hPutStrLn stderr warning + mapM_ (hPutStrLn stderr) (optGhcWarnings args) when noChecks $ hPutStrLn stderr noCheckWarning ghc flags' $ withDir $ do dflags <- getDynFlags logger <- getLogger - unit_state <- hsc_units <$> getSession + !unit_state <- hsc_units <$> getSession + -- If any --show-interface was used, show the given interfaces forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do name_cache <- freshNameCache mIfaceFile <- readInterfaceFiles name_cache [(("", Nothing), Visible, path)] noChecks forM_ mIfaceFile $ \(_,_,_, ifaceFile) -> do putMsg logger $ renderJson (jsonInterfaceFile ifaceFile) + -- If we were given source files to generate documentation from, do it if not (null files) then do (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files let packageInfo = PackageInfo { piPackageName = @@ -220,6 +226,8 @@ -- Render the interfaces. liftIO $ renderStep logger dflags unit_state flags sinceQual qual packages ifaces + -- If we were not given any input files, error if documentation was + -- requested else do when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $ throwE "No input file(s)." @@ -241,8 +249,8 @@ withTempDir dir action -- | Create warnings about potential misuse of -optghc -warnings :: [String] -> [String] -warnings = map format . filter (isPrefixOf "-optghc") +optGhcWarnings :: [String] -> [String] +optGhcWarnings = map format . filter (isPrefixOf "-optghc") where format arg = concat ["Warning: `", arg, "' means `-o ", drop 2 arg, "', did you mean `-", arg, "'?"] @@ -267,12 +275,14 @@ readPackagesAndProcessModules :: [Flag] -> [String] -> Ghc ([(DocPaths, Visibility, FilePath, InterfaceFile)], [Interface], LinkEnv) readPackagesAndProcessModules flags files = do - -- Get packages supplied with --read-interface. + -- Whether or not we bypass the interface file version check let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags + + -- Read package dependency interface files supplied with --read-interface name_cache <- hsc_NC <$> getSession packages <- liftIO $ readInterfaceFiles name_cache (readIfaceArgs flags) noChecks - -- Create the interfaces -- this is the core part of Haddock. + -- Create the interfaces for the given modules -- this is the core part of Haddock let ifaceFiles = map (\(_, _, _, ifaceFile) -> ifaceFile) packages (ifaces, homeLinks) <- processModules (verbosity flags) files flags ifaceFiles @@ -414,17 +424,17 @@ unwire m = m { moduleUnit = unwireUnit unit_state (moduleUnit m) } reexportedIfaces <- concat `fmap` (for (reexportFlags flags) $ \mod_str -> do - let warn = hPutStrLn stderr . ("Warning: " ++) + let warn' = hPutStrLn stderr . ("Warning: " ++) case readP_to_S parseHoleyModule mod_str of [(m, "")] | Just iface <- Map.lookup m installedMap -> return [iface] | otherwise - -> warn ("Cannot find reexported module '" ++ mod_str ++ "'") >> return [] - _ -> warn ("Cannot parse reexported module flag '" ++ mod_str ++ "'") >> return []) + -> warn' ("Cannot find reexported module '" ++ mod_str ++ "'") >> return [] + _ -> warn' ("Cannot parse reexported module flag '" ++ mod_str ++ "'") >> return []) libDir <- getHaddockLibDir flags - prologue <- getPrologue dflags' flags + !prologue <- force <$> getPrologue dflags' flags themes <- getThemes libDir flags >>= either bye return let withQuickjump = Flag_QuickJumpIndex `elem` flags @@ -492,7 +502,7 @@ pkgVer = fromMaybe (makeVersion []) mpkgVer - in ppHoogle dflags' unit_state pkgNameStr pkgVer title (fmap _doc prologue) + in ppHoogle dflags' pkgNameStr pkgVer title (fmap _doc prologue) visibleIfaces odir _ -> putStrLn . unlines $ [ "haddock: Unable to find a package providing module " @@ -550,20 +560,19 @@ -- compilation and linking. Then run the given 'Ghc' action. withGhc' :: String -> Bool -> [String] -> (DynFlags -> Ghc a) -> IO a withGhc' libDir needHieFiles flags ghcActs = runGhc (Just libDir) $ do - logger <- getLogger - dynflags' <- parseGhcFlags logger =<< getSessionDynFlags + logger <- getLogger + dynflags' <- parseGhcFlags logger =<< getSessionDynFlags - -- We disable pattern match warnings because than can be very - -- expensive to check - let dynflags'' = unsetPatternMatchWarnings $ - updOptLevel 0 dynflags' - -- ignore the following return-value, which is a list of packages - -- that may need to be re-linked: Haddock doesn't do any - -- dynamic or static linking at all! - _ <- setSessionDynFlags dynflags'' - ghcActs dynflags'' - where + -- We disable pattern match warnings because than can be very + -- expensive to check + let dynflags'' = unsetPatternMatchWarnings $ updOptLevel 0 dynflags' + -- ignore the following return-value, which is a list of packages + -- that may need to be re-linked: Haddock doesn't do any + -- dynamic or static linking at all! + _ <- setSessionDynFlags dynflags'' + ghcActs dynflags'' + where -- ignore sublists of flags that start with "+RTS" and end in "-RTS" -- -- See https://github.com/haskell/haddock/issues/666 @@ -574,7 +583,6 @@ go _ func False = func False go arg func True = arg : func True - parseGhcFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags parseGhcFlags logger dynflags = do -- TODO: handle warnings? @@ -733,36 +741,40 @@ -- | Generate some warnings about potential misuse of @--hyperlinked-source@. hypSrcWarnings :: [Flag] -> IO () hypSrcWarnings flags = do - when (hypSrc && any isSourceUrlFlag flags) $ hPutStrLn stderr $ concat [ "Warning: " , "--source-* options are ignored when " , "--hyperlinked-source is enabled." ] - when (not hypSrc && any isSourceCssFlag flags) $ hPutStrLn stderr $ concat [ "Warning: " , "source CSS file is specified but " , "--hyperlinked-source is disabled." ] - where + hypSrc :: Bool hypSrc = Flag_HyperlinkedSource `elem` flags + + isSourceUrlFlag :: Flag -> Bool isSourceUrlFlag (Flag_SourceBaseURL _) = True isSourceUrlFlag (Flag_SourceModuleURL _) = True isSourceUrlFlag (Flag_SourceEntityURL _) = True isSourceUrlFlag (Flag_SourceLEntityURL _) = True isSourceUrlFlag _ = False + + isSourceCssFlag :: Flag -> Bool isSourceCssFlag (Flag_SourceCss _) = True isSourceCssFlag _ = False updateHTMLXRefs :: [(FilePath, InterfaceFile)] -> IO () updateHTMLXRefs packages = do - writeIORef html_xrefs_ref (Map.fromList mapping) - writeIORef html_xrefs_ref' (Map.fromList mapping') + let !modMap = force $ Map.fromList mapping + !modNameMap = force $ Map.fromList mapping' + writeIORef html_xrefs_ref modMap + writeIORef html_xrefs_ref' modNameMap where mapping = [ (instMod iface, html) | (html, ifaces) <- packages , iface <- ifInstalledIfaces ifaces ] diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + ----------------------------------------------------------------------------- -- | -- Module : Haddock.Backends.Hoogle @@ -15,12 +15,14 @@ -- http://www.haskell.org/hoogle/ ----------------------------------------------------------------------------- module Haddock.Backends.Hoogle ( + -- * Main entry point to Hoogle output generation ppHoogle + + -- * Utilities for generating Hoogle output during interface creation + , ppExportD + , outWith ) where -import GHC.Types.Basic ( OverlapFlag(..), OverlapMode(..), TopLevelFlag(..) ) -import GHC.Types.SourceText -import GHC.Core.InstEnv (ClsInst(..)) import Documentation.Haddock.Markup import Haddock.GhcUtils import Haddock.Types hiding (Version) @@ -28,27 +30,28 @@ import GHC import GHC.Driver.Ppr +import GHC.Plugins (TopLevelFlag(..)) import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Unit.State -import GHC.Hs.Decls (ppDataDefnHeader, pp_vanilla_decl_head) import Data.Char import Data.Foldable (toList) -import Data.List (dropWhileEnd, intercalate, isPrefixOf) +import Data.List (intercalate, isPrefixOf) import Data.Maybe import Data.Version import System.Directory import System.FilePath + prefix :: [String] prefix = ["-- Hoogle documentation, generated by Haddock" ,"-- See Hoogle, http://www.haskell.org/hoogle/" ,""] -ppHoogle :: DynFlags -> UnitState -> String -> Version -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO () -ppHoogle dflags unit_state package version synopsis prologue ifaces odir = do +ppHoogle :: DynFlags -> String -> Version -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO () +ppHoogle dflags package version synopsis prologue ifaces odir = do let -- Since Hoogle is line based, we want to avoid breaking long lines. dflags' = dflags{ pprCols = maxBound } filename = package ++ ".txt" @@ -56,18 +59,24 @@ docWith dflags' (drop 2 $ dropWhile (/= ':') synopsis) prologue ++ ["@package " ++ package] ++ ["@version " ++ showVersion version - | not (null (versionBranch version)) ] ++ - concat [ppModule dflags' unit_state i | i <- ifaces, OptHide `notElem` ifaceOptions i] + | not (null (versionBranch version)) + ] ++ + concat [ppModule dflags' i | i <- ifaces, OptHide `notElem` ifaceOptions i] createDirectoryIfMissing True odir writeUtf8File (odir filename) (unlines contents) -ppModule :: DynFlags -> UnitState -> Interface -> [String] -ppModule dflags unit_state iface = +ppModule :: DynFlags -> Interface -> [String] +ppModule dflags iface = "" : ppDocumentation dflags (ifaceDoc iface) ++ ["module " ++ moduleString (ifaceMod iface)] ++ - concatMap (ppExport dflags) (ifaceExportItems iface) ++ - concatMap (ppInstance dflags unit_state) (ifaceInstances iface) + concatMap ppExportItem (ifaceRnExportItems $ iface) ++ + map (fromMaybe "" . haddockClsInstPprHoogle) (ifaceInstances iface) +-- | If the export item is an 'ExportDecl', get the attached Hoogle textual +-- database entries for that export declaration. +ppExportItem :: ExportItem DocNameI -> [String] +ppExportItem (ExportDecl RnExportD { rnExpDHoogle = o }) = o +ppExportItem _ = [] --------------------------------------------------------------------- -- Utility functions @@ -97,13 +106,6 @@ outHsSigType :: DynFlags -> HsSigType GhcRn -> String outHsSigType dflags = out dflags . reparenSigType . dropHsDocTy - -dropComment :: String -> String -dropComment (' ':'-':'-':' ':_) = [] -dropComment (x:xs) = x : dropComment xs -dropComment [] = [] - - outWith :: Outputable a => (SDoc -> String) -> a -> [Char] outWith p = f . unwords . map (dropWhile isSpace) . lines . p . ppr where @@ -124,29 +126,38 @@ --------------------------------------------------------------------- -- How to print each export -ppExport :: DynFlags -> ExportItem GhcRn -> [String] -ppExport dflags ExportDecl { expItemDecl = L _ decl - , expItemPats = bundledPats - , expItemMbDoc = mbDoc - , expItemSubDocs = subdocs - , expItemFixities = fixities - } = concat [ ppDocumentation dflags dc ++ f d - | (d, (dc, _)) <- (decl, mbDoc) : bundledPats - ] ++ - ppFixities - where - f (TyClD _ d@DataDecl{}) = ppData dflags d subdocs - f (TyClD _ d@SynDecl{}) = ppSynonym dflags d - f (TyClD _ d@ClassDecl{}) = ppClass dflags d subdocs - f (TyClD _ (FamDecl _ d)) = ppFam dflags d - f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags [name] typ] - f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags [name] typ] - f (SigD _ sig) = ppSig dflags sig - f _ = [] +ppExportD :: DynFlags -> ExportD GhcRn -> [String] +ppExportD dflags + ExportD + { expDDecl = L _ decl + , expDPats = bundledPats + , expDMbDoc = mbDoc + , expDSubDocs = subdocs + , expDFixities = fixities + } + = let + -- Since Hoogle is line based, we want to avoid breaking long lines. + dflags' = dflags{ pprCols = maxBound } + in + concat + [ ppDocumentation dflags' dc ++ f d + | (d, (dc, _)) <- (decl, mbDoc) : bundledPats + ] ++ ppFixities + where + f :: HsDecl GhcRn -> [String] + f (TyClD _ d@DataDecl{}) = ppData dflags d subdocs + f (TyClD _ d@SynDecl{}) = ppSynonym dflags d + f (TyClD _ d@ClassDecl{}) = ppClass dflags d subdocs + f (TyClD _ (FamDecl _ d)) = ppFam dflags d + f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags [name] typ] + f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags [name] typ] + f (SigD _ sig) = ppSig dflags sig + f _ = [] - ppFixities = concatMap (ppFixity dflags) fixities -ppExport _ _ = [] + ppFixities :: [String] + ppFixities = concatMap (ppFixity dflags) fixities + ppSigWithDoc :: DynFlags -> Sig GhcRn -> [(Name, DocForDecl Name)] -> [String] ppSigWithDoc dflags sig subdocs = case sig of TypeSig _ names t -> concatMap (mkDocSig "" (dropWildCards t)) names @@ -167,7 +178,7 @@ -- note: does not yet output documentation for class methods ppClass :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> [String] -ppClass dflags decl subdocs = +ppClass dflags decl@(ClassDecl {}) subdocs = (out dflags decl{tcdSigs=[], tcdATs=[], tcdATDefs=[], tcdMeths=emptyLHsBinds} ++ ppTyFams) : ppMethods where @@ -193,7 +204,7 @@ , nest 4 . vcat . map (Outputable.<> semi) $ elems , rbrace ] - +ppClass _ _non_cls_decl _ = [] ppFam :: DynFlags -> FamilyDecl GhcRn -> [String] ppFam dflags decl@(FamilyDecl { fdInfo = info }) = [out dflags decl'] @@ -203,18 +214,6 @@ -- for Hoogle, so pretend it doesn't have any. ClosedTypeFamily{} -> decl { fdInfo = OpenTypeFamily } _ -> decl - -ppInstance :: DynFlags -> UnitState -> ClsInst -> [String] -ppInstance dflags unit_state x = - [dropComment $ outWith (showSDocForUser dflags unit_state alwaysQualify) cls] - where - -- As per #168, we don't want safety information about the class - -- in Hoogle output. The easiest way to achieve this is to set the - -- safety information to a state where the Outputable instance - -- produces no output which means no overlap and unsafe (or [safe] - -- is generated). - cls = x { is_flag = OverlapFlag { overlapMode = NoOverlap NoSourceText - , isSafeOverlap = False } } ppSynonym :: DynFlags -> TyClDecl GhcRn -> [String] ppSynonym dflags x = [out dflags x] diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -18,6 +18,7 @@ ) where import Documentation.Haddock.Markup +import Haddock.Doc (combineDocumentation) import Haddock.Types import Haddock.Utils import Haddock.GhcUtils @@ -42,10 +43,6 @@ import Data.Foldable ( toList ) import Prelude hiding ((<>)) -import Haddock.Doc (combineDocumentation) - --- import Debug.Trace - {- SAMPLE OUTPUT \haddockmoduleheading{\texttt{Data.List}} @@ -180,7 +177,18 @@ -- | Prints out an entry in a module export list. exportListItem :: ExportItem DocNameI -> LaTeX -exportListItem ExportDecl { expItemDecl = decl, expItemSubDocs = subdocs } +exportListItem + ( ExportDecl + ( RnExportD + { rnExpDExpD = + ( ExportD + { expDDecl = decl + , expDSubDocs = subdocs + } + ) + } + ) + ) = let (leader, names) = declNames decl in sep (punctuate comma [ leader <+> ppDocBinder name | name <- names ]) <> case subdocs of @@ -215,9 +223,18 @@ isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsSigType DocNameI) -isSimpleSig ExportDecl { expItemDecl = L _ (SigD _ (TypeSig _ lnames t)) - , expItemMbDoc = (Documentation Nothing Nothing, argDocs) } - | Map.null argDocs = Just (map unLoc lnames, unLoc (dropWildCards t)) +isSimpleSig + ( ExportDecl + ( RnExportD + { rnExpDExpD = + ExportD + { expDDecl = L _ (SigD _ (TypeSig _ lnames t)) + , expDMbDoc = (Documentation Nothing Nothing, argDocs) + } + } + ) + ) + | Map.null argDocs = Just (map unLoc lnames, unLoc (dropWildCards t)) isSimpleSig _ = Nothing @@ -229,7 +246,7 @@ processExport :: ExportItem DocNameI -> LaTeX processExport (ExportGroup lev _id0 doc) = ppDocGroup lev (docToLaTeX doc) -processExport (ExportDecl decl pats doc subdocs insts fixities _splice) +processExport (ExportDecl (RnExportD (ExportD decl pats doc subdocs insts fixities _splice) _)) = ppDecl decl pats doc insts subdocs fixities processExport (ExportNoDecl y []) = ppDocName y @@ -292,13 +309,9 @@ -> LaTeX ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of - TyClD _ d@FamDecl {} -> ppFamDecl False doc instances d unicode - TyClD _ d@DataDecl {} -> ppDataDecl pats instances subdocs (Just doc) d unicode - TyClD _ d@SynDecl {} -> ppTySyn (doc, fnArgsDoc) d unicode --- Family instances happen via FamInst now --- TyClD _ d@TySynonym{} --- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode --- Family instances happen via FamInst now + TyClD _ d@FamDecl {} -> ppFamDecl False doc instances d unicode + TyClD _ d@DataDecl {} -> ppDataDecl pats instances subdocs (Just doc) d unicode + TyClD _ d@SynDecl {} -> ppTySyn (doc, fnArgsDoc) d unicode TyClD _ d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode SigD _ (TypeSig _ lnames ty) -> ppFunSig Nothing (doc, fnArgsDoc) (map unLoc lnames) (dropWildCards ty) unicode SigD _ (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -11,7 +11,12 @@ -- Stability : experimental -- Portability : portable ----------------------------------------------------------------------------- -{-# LANGUAGE CPP, NamedFieldPuns, TupleSections, TypeApplications #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE BangPatterns #-} + module Haddock.Backends.Xhtml ( ppHtml, copyHtmlBits, ppHtmlIndex, ppHtmlContents, @@ -41,18 +46,19 @@ import Control.Monad ( when, unless ) import qualified Data.ByteString.Builder as Builder +import Control.DeepSeq (force) import Data.Bifunctor ( bimap ) import Data.Char ( toUpper, isSpace ) import Data.Either ( partitionEithers ) -import Data.Foldable ( traverse_) +import Data.Foldable ( traverse_, foldl') import Data.List ( sortBy, isPrefixOf, intersperse ) import Data.Maybe import System.Directory import System.FilePath hiding ( () ) import qualified System.IO as IO import qualified System.FilePath as FilePath -import Data.Map ( Map ) -import qualified Data.Map as Map hiding ( Map ) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map import qualified Data.Set as Set hiding ( Set ) import Data.Ord ( comparing ) @@ -356,7 +362,7 @@ ppSignatureTrees :: Maybe Package -> Qualification -> [(PackageInfo, [ModuleTree])] -> Html ppSignatureTrees _ _ tss | all (null . snd) tss = mempty -ppSignatureTrees pkg qual [(info, ts)] = +ppSignatureTrees pkg qual [(info, ts)] = divPackageList << (sectionName << "Signatures" +++ ppSignatureTree pkg qual "n" info ts) ppSignatureTrees pkg qual tss = divModuleList << @@ -427,8 +433,6 @@ mkNodeList pkg qual (s:ss) p ts ) - - -------------------------------------------------------------------------------- -- * Generate the index -------------------------------------------------------------------------------- @@ -522,11 +526,11 @@ names = exportName item ++ exportSubs item exportSubs :: ExportItem DocNameI -> [IdP DocNameI] - exportSubs ExportDecl { expItemSubDocs } = map fst expItemSubDocs + exportSubs (ExportDecl (RnExportD { rnExpDExpD = ExportD { expDSubDocs } })) = map fst expDSubDocs exportSubs _ = [] exportName :: ExportItem DocNameI -> [IdP DocNameI] - exportName ExportDecl { expItemDecl } = getMainDeclBinderI (unLoc expItemDecl) + exportName (ExportDecl (RnExportD { rnExpDExpD = ExportD { expDDecl } })) = getMainDeclBinderI (unLoc expDDecl) exportName ExportNoDecl { expItemName } = [expItemName] exportName _ = [] @@ -538,7 +542,7 @@ -- update link using relative path to output directory fixLink :: FilePath -> JsonIndexEntry -> JsonIndexEntry - fixLink ifaceFile jie = + fixLink ifaceFile jie = jie { jieLink = makeRelative odir (takeDirectory ifaceFile) FilePath. jieLink jie } @@ -623,14 +627,34 @@ -- that export that entity. Each of the modules exports the entity -- in a visible or invisible way (hence the Bool). full_index :: Map String (Map GHC.Name [(Module,Bool)]) - full_index = Map.fromListWith (flip (Map.unionWith (++))) - (concatMap getIfaceIndex ifaces) + full_index = foldl' f Map.empty ifaces + where + f :: Map String (Map Name [(Module, Bool)]) + -> InstalledInterface + -> Map String (Map Name [(Module, Bool)]) + f !idx iface = + Map.unionWith + (Map.unionWith (\a b -> let !x = force $ a ++ b in x)) + idx + (getIfaceIndex iface) + + getIfaceIndex :: InstalledInterface -> Map String (Map Name [(Module, Bool)]) getIfaceIndex iface = - [ (getOccString name - , Map.fromList [(name, [(mdl, name `Set.member` visible)])]) - | name <- instExports iface ] + foldl' f Map.empty (instExports iface) where + f :: Map String (Map Name [(Module, Bool)]) + -> Name + -> Map String (Map Name [(Module, Bool)]) + f !idx name = + let !vis = name `Set.member` visible + in + Map.insertWith + (Map.unionWith (++)) + (getOccString name) + (Map.singleton name [(mdl, vis)]) + idx + mdl = instMod iface visible = Set.fromList (instVisibleExports iface) @@ -722,7 +746,17 @@ -- todo: if something has only sub-docs, or fn-args-docs, should -- it be measured here and thus prevent omitting the synopsis? - has_doc ExportDecl { expItemMbDoc = (Documentation mDoc mWarning, _) } = isJust mDoc || isJust mWarning + has_doc + ( ExportDecl + ( RnExportD + { rnExpDExpD = + ExportD + { expDMbDoc = + ( Documentation mDoc mWarn, _ ) + } + } + ) + ) = isJust mDoc || isJust mWarn has_doc (ExportNoDecl _ _) = False has_doc (ExportModule _) = False has_doc _ = True @@ -816,11 +850,28 @@ processExport :: Bool -> LinksInfo -> Bool -> Maybe Package -> Qualification -> ExportItem DocNameI -> Maybe Html -processExport _ _ _ _ _ ExportDecl { expItemDecl = L _ (InstD {}) } = Nothing -- Hide empty instances +processExport _ _ _ _ _ + ( ExportDecl + ( RnExportD + { rnExpDExpD = + ExportD + { expDDecl = L _ (InstD {}) + } + } + ) + ) + = Nothing -- Hide empty instances +processExport summary links unicode pkg qual + ( ExportDecl + ( RnExportD + { rnExpDExpD = + ExportD decl pats doc subdocs insts fixities splice + } + ) + ) + = processDecl summary $ ppDecl summary links decl pats doc insts fixities subdocs splice unicode pkg qual processExport summary _ _ pkg qual (ExportGroup lev id0 doc) = nothingIf summary $ groupHeading lev id0 << docToHtmlNoAnchors (Just id0) pkg qual (mkMeta doc) -processExport summary links unicode pkg qual (ExportDecl decl pats doc subdocs insts fixities splice) - = processDecl summary $ ppDecl summary links decl pats doc insts fixities subdocs splice unicode pkg qual processExport summary _ _ _ qual (ExportNoDecl y []) = processDeclOneLiner summary $ ppDocName qual Prefix True y processExport summary _ _ _ qual (ExportNoDecl y subs) diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs --- a/src/Haddock/Convert.hs +++ b/src/Haddock/Convert.hs @@ -1,4 +1,8 @@ -{-# LANGUAGE CPP, PatternGuards, TypeFamilies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BangPatterns #-} + ----------------------------------------------------------------------------- -- | -- Module : Haddock.Convert @@ -19,6 +23,7 @@ PrintRuntimeReps(..), ) where +import Control.DeepSeq (force) import GHC.Data.Bag ( emptyBag ) import GHC.Types.Basic ( TupleSort(..), DefMethSpec(..), TopLevelFlag(..) ) import GHC.Types.SourceText (SourceText(..)) @@ -72,7 +77,7 @@ tyThingToLHsDecl :: PrintRuntimeReps -> TyThing - -> Either ErrMsg ([ErrMsg], (HsDecl GhcRn)) + -> Either String ([String], (HsDecl GhcRn)) tyThingToLHsDecl prr t = case t of -- ids (functions and zero-argument a.k.a. CAFs) get a type signature. -- Including built-in functions like seq. @@ -88,7 +93,7 @@ -- later in the file (also it's used for class associated-types too.) ATyCon tc | Just cl <- tyConClass_maybe tc -- classes are just a little tedious - -> let extractFamilyDecl :: TyClDecl a -> Either ErrMsg (FamilyDecl a) + -> let extractFamilyDecl :: TyClDecl a -> Either String (FamilyDecl a) extractFamilyDecl (FamDecl _ d) = return d extractFamilyDecl _ = Left "tyThingToLHsDecl: impossible associated tycon" @@ -116,7 +121,7 @@ extractAtItem :: ClassATItem - -> Either ErrMsg (LFamilyDecl GhcRn, Maybe (LTyFamDefltDecl GhcRn)) + -> Either String (LFamilyDecl GhcRn, Maybe (LTyFamDefltDecl GhcRn)) extractAtItem (ATI at_tc def) = do tyDecl <- synifyTyCon prr Nothing at_tc famDecl <- extractFamilyDecl tyDecl @@ -181,7 +186,7 @@ where args_poly = tyConArgsPolyKinded tc -synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl GhcRn) +synifyAxiom :: CoAxiom br -> Either String (HsDecl GhcRn) synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) | isOpenTypeFamilyTyCon tc , Just branch <- coAxiomSingleBranch_maybe ax @@ -201,7 +206,7 @@ :: PrintRuntimeReps -> Maybe (CoAxiom br) -- ^ RHS of type synonym -> TyCon -- ^ type constructor to convert - -> Either ErrMsg (TyClDecl GhcRn) + -> Either String (TyClDecl GhcRn) synifyTyCon prr _coax tc | isPrimTyCon tc = return $ @@ -359,7 +364,7 @@ -- result-type. -- But you might want pass False in simple enough cases, -- if you think it looks better. -synifyDataCon :: Bool -> DataCon -> Either ErrMsg (LConDecl GhcRn) +synifyDataCon :: Bool -> DataCon -> Either String (LConDecl GhcRn) synifyDataCon use_gadt_syntax dc = let -- dataConIsInfix allegedly tells us whether it was declared with @@ -394,7 +399,7 @@ ConDeclField noAnn [noLocA $ FieldOcc (flSelector fl) (noLocA $ mkVarUnqual $ field_label $ flLabel fl)] synTy Nothing - mk_h98_arg_tys :: Either ErrMsg (HsConDeclH98Details GhcRn) + mk_h98_arg_tys :: Either String (HsConDeclH98Details GhcRn) mk_h98_arg_tys = case (use_named_field_syntax, use_infix_syntax) of (True,True) -> Left "synifyDataCon: contradiction!" (True,False) -> return $ RecCon (noLocA field_tys) @@ -451,8 +456,9 @@ -> [TyVar] -- ^ free variables in the type to convert -> Id -- ^ the 'Id' from which to get the type signature -> Sig GhcRn -synifyIdSig prr s vs i = TypeSig noAnn [synifyNameN i] (synifySigWcType s vs t) +synifyIdSig prr s vs i = TypeSig noAnn [n] (synifySigWcType s vs t) where + !n = force $ synifyNameN i t = defaultType prr (varType i) -- | Turn a 'ClassOpItem' into a list of signatures. The list returned is going @@ -639,7 +645,7 @@ = mk_app_tys (HsTyVar noAnn prom $ noLocA (getName tc)) vis_tys where - prom = if isPromotedDataCon tc then IsPromoted else NotPromoted + !prom = if isPromotedDataCon tc then IsPromoted else NotPromoted mk_app_tys ty_app ty_args = foldl (\t1 t2 -> noLocA $ HsAppTy noExtField t1 t2) (noLocA ty_app) @@ -865,7 +871,7 @@ synifyClsIdSig = synifyIdSig ShowRuntimeRep DeleteTopLevelQuantification vs -- Convert a family instance, this could be a type family or data family -synifyFamInst :: FamInst -> Bool -> Either ErrMsg (InstHead GhcRn) +synifyFamInst :: FamInst -> Bool -> Either String (InstHead GhcRn) synifyFamInst fi opaque = do ityp' <- ityp fam_flavor return InstHead diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs --- a/src/Haddock/GhcUtils.hs +++ b/src/Haddock/GhcUtils.hs @@ -27,9 +27,10 @@ import Control.Arrow import Data.Char ( isSpace ) -import Data.Foldable ( toList ) +import Data.Foldable ( toList, foldl' ) import Data.List.NonEmpty ( NonEmpty ) import Data.Maybe ( mapMaybe, fromMaybe ) +import qualified Data.Set as Set import Haddock.Types( DocName, DocNameI, XRecCond ) @@ -47,7 +48,7 @@ import GHC.Types.Var.Set ( VarSet, emptyVarSet ) import GHC.Types.Var.Env ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv ) import GHC.Core.TyCo.Rep ( Type(..) ) -import GHC.Core.Type ( isRuntimeRepVar ) +import GHC.Core.Type ( isRuntimeRepVar, binderVar ) import GHC.Builtin.Types( liftedRepTy ) import GHC.Data.StringBuffer ( StringBuffer ) @@ -339,7 +340,7 @@ where -- Shorter name for 'reparenType' - go :: XParTy a ~ EpAnn AnnParen => Precedence -> HsType a -> HsType a + go :: Precedence -> HsType a -> HsType a go _ (HsBangTy x b ty) = HsBangTy x b (reparenLType ty) go _ (HsTupleTy x con tys) = HsTupleTy x con (map reparenLType tys) go _ (HsSumTy x tys) = HsSumTy x (map reparenLType tys) @@ -359,7 +360,6 @@ p' _ = PREC_TOP -- parens will get added anyways later... ctxt' = mapXRec @a (\xs -> map (goL (p' xs)) xs) ctxt in paren p PREC_CTX $ HsQualTy x ctxt' (goL PREC_TOP ty) - -- = paren p PREC_FUN $ HsQualTy x (fmap (mapXRec @a (map reparenLType)) ctxt) (reparenLType ty) go p (HsFunTy x w ty1 ty2) = paren p PREC_FUN $ HsFunTy x w (goL PREC_FUN ty1) (goL PREC_TOP ty2) go p (HsAppTy x fun_ty arg_ty) @@ -377,12 +377,11 @@ go _ t@XHsType{} = t -- Located variant of 'go' - goL :: XParTy a ~ EpAnn AnnParen => Precedence -> LHsType a -> LHsType a + goL :: Precedence -> LHsType a -> LHsType a goL ctxt_prec = mapXRec @a (go ctxt_prec) -- Optionally wrap a type in parens - paren :: XParTy a ~ EpAnn AnnParen - => Precedence -- Precedence of context + paren :: Precedence -- Precedence of context -> Precedence -- Precedence of top-level operator -> HsType a -> HsType a -- Wrap in parens if (ctxt >= op) paren ctxt_prec op_prec | ctxt_prec >= op_prec = HsParTy noAnn . wrapXRec @a @@ -649,6 +648,27 @@ ('\n', b') -> (splitStringBuffer buf b', advanceSrcLoc l '\n', b') (c , b') -> spanCppLine (advanceSrcLoc l c) b' + +------------------------------------------------------------------------------- +-- * Names in a 'Type' +------------------------------------------------------------------------------- + +-- | Given a 'Type', return a set of 'Name's coming from the 'TyCon's within +-- the type. +typeNames :: Type -> Set.Set Name +typeNames ty = go ty Set.empty + where + go :: Type -> Set.Set Name -> Set.Set Name + go t acc = + case t of + TyVarTy {} -> acc + AppTy t1 t2 -> go t2 $ go t1 acc + FunTy _ _ t1 t2 -> go t2 $ go t1 acc + TyConApp tcon args -> foldl' (\s t' -> go t' s) (Set.insert (getName tcon) acc) args + ForAllTy bndr t' -> go t' $ go (tyVarKind (binderVar bndr)) acc + LitTy _ -> acc + CastTy t' _ -> go t' acc + CoercionTy {} -> acc ------------------------------------------------------------------------------- -- * Free variables of a 'Type' diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs --- a/src/Haddock/Interface.hs +++ b/src/Haddock/Interface.hs @@ -1,4 +1,8 @@ -{-# LANGUAGE CPP, OverloadedStrings, BangPatterns, NamedFieldPuns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TupleSections #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface @@ -36,21 +40,20 @@ import Haddock.GhcUtils (moduleString, pretty) import Haddock.Interface.AttachInstances (attachInstances) -import Haddock.Interface.Create (createInterface1, runIfM) +import Haddock.Interface.Create (createInterface1) import Haddock.Interface.Rename (renameInterface) import Haddock.InterfaceFile (InterfaceFile, ifInstalledIfaces, ifLinkEnv) import Haddock.Options hiding (verbosity) -import Haddock.Types (DocOption (..), Documentation (..), ExportItem (..), IfaceMap, InstIfaceMap, Interface, LinkEnv, - expItemDecl, expItemMbDoc, ifaceDoc, ifaceExportItems, ifaceExports, ifaceHaddockCoverage, - ifaceInstances, ifaceMod, ifaceOptions, ifaceVisibleExports, instMod, runWriter, throwE) +import Haddock.Types import Haddock.Utils (Verbosity (..), normal, out, verbose) import Control.Monad (unless, when) -import Control.Monad.IO.Class (MonadIO) -import Data.IORef (atomicModifyIORef', newIORef, readIORef) -import Data.List (foldl', isPrefixOf, nub) +import Data.IORef (atomicModifyIORef', newIORef, readIORef, IORef) +import Data.List (foldl', isPrefixOf) +import Data.Maybe (mapMaybe) +import Data.Traversable (for) import Text.Printf (printf) -import qualified Data.Map as Map +import qualified Data.Map.Strict as Map import qualified Data.Set as Set import GHC hiding (verbosity) @@ -62,7 +65,7 @@ import GHC.Plugins import GHC.Tc.Types (TcGblEnv (..), TcM) import GHC.Tc.Utils.Env (tcLookupGlobal) -import GHC.Tc.Utils.Monad (getTopEnv, setGblEnv) +import GHC.Tc.Utils.Monad (getTopEnv) import GHC.Unit.Module.Graph import GHC.Utils.Error (withTiming) @@ -89,21 +92,26 @@ liftIO $ hSetEncoding stderr $ mkLocaleEncoding TransliterateCodingFailure #endif + dflags <- getDynFlags + out verbosity verbose "Creating interfaces..." - let - instIfaceMap :: InstIfaceMap - instIfaceMap = Map.fromList - [ (instMod iface, iface) - | ext <- extIfaces - , iface <- ifInstalledIfaces ext - ] + + -- Map from a module to a corresponding installed interface + let instIfaceMap :: InstIfaceMap + instIfaceMap = Map.fromList + [ (instMod iface, iface) + | ext <- extIfaces + , iface <- ifInstalledIfaces ext + ] + (interfaces, ms) <- createIfaces verbosity modules flags instIfaceMap let exportedNames = Set.unions $ map (Set.fromList . ifaceExports) $ filter (\i -> not $ OptHide `elem` ifaceOptions i) interfaces mods = Set.fromList $ map ifaceMod interfaces + out verbosity verbose "Attaching instances..." interfaces' <- {-# SCC attachInstances #-} withTimingM "attachInstances" (const ()) $ do @@ -117,26 +125,44 @@ links = homeLinks `Map.union` extLinks out verbosity verbose "Renaming interfaces..." + let warnings = Flag_NoWarnings `notElem` flags - dflags <- getDynFlags - let (interfaces'', msgs) = - runWriter $ mapM (renameInterface dflags (ignoredSymbols flags) links warnings) interfaces' - liftIO $ mapM_ putStrLn msgs + ignoredSymbolSet = ignoredSymbols flags - return (interfaces'', homeLinks) + interfaces'' <- + withTimingM "renameAllInterfaces" (const ()) $ + for interfaces' $ \i -> do + withTimingM ("renameInterface: " <+> pprModuleName (moduleName (ifaceMod i))) (const ()) $ + renameInterface dflags ignoredSymbolSet links warnings (Flag_Hoogle `elem` flags) i + return (interfaces'', homeLinks) -------------------------------------------------------------------------------- -- * Module typechecking and Interface creation -------------------------------------------------------------------------------- - -createIfaces :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc ([Interface], ModuleSet) +createIfaces + :: Verbosity + -- ^ Verbosity requested by the caller + -> [String] + -- ^ List of modules provided as arguments to Haddock (still in FilePath + -- format) + -> [Flag] + -- ^ Command line flags which Hadddock was invoked with + -> InstIfaceMap + -- ^ Map from module to corresponding installed interface file + -> Ghc ([Interface], ModuleSet) + -- ^ Resulting interfaces createIfaces verbosity modules flags instIfaceMap = do - (haddockPlugin, getIfaces, getModules) <- liftIO $ plugin - verbosity flags instIfaceMap + -- Initialize the IORefs for the interface map and the module set + (ifaceMapRef, moduleSetRef) <- liftIO $ do + m <- newIORef Map.empty + s <- newIORef emptyModuleSet + return (m, s) let + haddockPlugin = plugin verbosity flags instIfaceMap ifaceMapRef moduleSetRef + installHaddockPlugin :: HscEnv -> HscEnv installHaddockPlugin hsc_env = let @@ -161,9 +187,12 @@ throwE "Cannot typecheck modules" Succeeded -> do modGraph <- GHC.getModuleGraph - ifaceMap <- liftIO getIfaces - moduleSet <- liftIO getModules + (ifaceMap, moduleSet) <- liftIO $ do + m <- atomicModifyIORef' ifaceMapRef (Map.empty,) + s <- atomicModifyIORef' moduleSetRef (Set.empty,) + return (m, s) + let -- We topologically sort the module graph including boot files, -- so it should be acylic (hopefully we failed much earlier if this is not the case) @@ -205,19 +234,20 @@ -- i.e. if module A imports B, then B is preferred over A, -- but if module A {-# SOURCE #-} imports B, then we can't say the same. -- + go :: SCC ModuleGraphNode -> Maybe Module go (AcyclicSCC (ModuleNode _ ms)) - | NotBoot <- isBootSummary ms = [ms] - | otherwise = [] - go (AcyclicSCC _) = [] + | NotBoot <- isBootSummary ms = Just $ ms_mod ms + | otherwise = Nothing + go (AcyclicSCC _) = Nothing go (CyclicSCC _) = error "haddock: module graph cyclic even with boot files" ifaces :: [Interface] ifaces = [ Map.findWithDefault (error "haddock:iface") - (ms_mod ms) + m ifaceMap - | ms <- concatMap go $ topSortModuleGraph False modGraph Nothing + | m <- mapMaybe go $ topSortModuleGraph False modGraph Nothing ] return (ifaces, moduleSet) @@ -227,20 +257,18 @@ -- interfaces. Due to the plugin nature we benefit from GHC's capabilities to -- parallelize the compilation process. plugin - :: MonadIO m - => Verbosity + :: Verbosity + -- ^ Verbosity requested by the Haddock caller -> [Flag] + -- ^ Command line flags which Hadddock was invoked with -> InstIfaceMap - -> m - ( - StaticPlugin -- the plugin to install with GHC - , m IfaceMap -- get the processed interfaces - , m ModuleSet -- get the loaded modules - ) -plugin verbosity flags instIfaceMap = liftIO $ do - ifaceMapRef <- newIORef Map.empty - moduleSetRef <- newIORef emptyModuleSet - + -- ^ Map from module to corresponding installed interface file + -> IORef IfaceMap + -- ^ The 'IORef' to write the interface map to + -> IORef ModuleSet + -- ^ The 'IORef' to write the module set to + -> StaticPlugin -- the plugin to install with GHC +plugin verbosity flags instIfaceMap ifaceMapRef moduleSetRef = let processTypeCheckedResult :: ModSummary -> TcGblEnv -> TcM () processTypeCheckedResult mod_summary tc_gbl_env @@ -250,46 +278,43 @@ | otherwise = do hsc_env <- getTopEnv ifaces <- liftIO $ readIORef ifaceMapRef - (iface, modules) <- withTiming (hsc_logger hsc_env) - "processModule" (const ()) $ - processModule1 verbosity flags ifaces instIfaceMap hsc_env mod_summary tc_gbl_env + (iface, modules) <- + withTiming (hsc_logger hsc_env) "processModule1" (const ()) $ + processModule1 verbosity flags ifaces instIfaceMap hsc_env mod_summary tc_gbl_env + liftIO $ do atomicModifyIORef' ifaceMapRef $ \xs -> (Map.insert (ms_mod mod_summary) iface xs, ()) atomicModifyIORef' moduleSetRef $ \xs -> (modules `unionModuleSet` xs, ()) - - staticPlugin :: StaticPlugin - staticPlugin = StaticPlugin + in + StaticPlugin { spPlugin = PluginWithArgs { paPlugin = defaultPlugin { renamedResultAction = keepRenamedSource - , typeCheckResultAction = \_ mod_summary tc_gbl_env -> setGblEnv tc_gbl_env $ do + , typeCheckResultAction = \_ mod_summary tc_gbl_env -> do processTypeCheckedResult mod_summary tc_gbl_env pure tc_gbl_env - } , paArguments = [] } } - pure - ( staticPlugin - , liftIO (readIORef ifaceMapRef) - , liftIO (readIORef moduleSetRef) - ) - - processModule1 :: Verbosity + -- ^ Verbosity requested by the Haddock caller -> [Flag] + -- ^ Command line flags which Hadddock was invoked with -> IfaceMap + -- ^ Map from module to corresponding interface, for the modules we have + -- already processed -> InstIfaceMap + -- ^ Map from module to corresponding installed interface file -> HscEnv -> ModSummary -> TcGblEnv @@ -302,12 +327,12 @@ unit_state = hsc_units hsc_env - (!interface, messages) <- do + !interface <- do logger <- getLogger {-# SCC createInterface #-} - withTiming logger "createInterface" (const ()) $ runIfM (fmap Just . tcLookupGlobal) $ - createInterface1 flags unit_state mod_summary tc_gbl_env - ifaces inst_ifaces + withTiming logger "createInterface" (const ()) $ + runIfM (fmap Just . tcLookupGlobal) $ + createInterface1 flags unit_state mod_summary tc_gbl_env ifaces inst_ifaces -- We need to keep track of which modules were somehow in scope so that when -- Haddock later looks for instances, it also looks in these modules too. @@ -324,7 +349,6 @@ , unQualOK gre -- In scope unqualified ] - liftIO $ mapM_ putStrLn (nub messages) dflags <- getDynFlags let @@ -349,9 +373,10 @@ undocumentedExports :: [String] undocumentedExports = [ formatName (locA s) n - | ExportDecl { expItemDecl = L s n - , expItemMbDoc = (Documentation Nothing _, _) - } <- ifaceExportItems interface + | ExportDecl ExportD + { expDDecl = L s n + , expDMbDoc = (Documentation Nothing _, _) + } <- ifaceExportItems interface ] where formatName :: SrcSpan -> HsDecl GhcRn -> String @@ -396,12 +421,14 @@ buildHomeLinks ifaces = foldl' upd Map.empty (reverse ifaces) where upd old_env iface - | OptHide `elem` ifaceOptions iface = old_env + | OptHide `elem` ifaceOptions iface = + old_env | OptNotHome `elem` ifaceOptions iface = - foldl' keep_old old_env exported_names - | otherwise = foldl' keep_new old_env exported_names + foldl' keep_old old_env exported_names + | otherwise = + foldl' keep_new old_env exported_names where - exported_names = ifaceVisibleExports iface ++ map getName (ifaceInstances iface) + exported_names = ifaceVisibleExports iface ++ map haddockClsInstName (ifaceInstances iface) mdl = ifaceMod iface keep_old env n = Map.insertWith (\_ old -> old) n mdl env keep_new env n = Map.insert n mdl env diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs --- a/src/Haddock/Interface/AttachInstances.hs +++ b/src/Haddock/Interface/AttachInstances.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BangPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} ----------------------------------------------------------------------------- @@ -13,23 +14,25 @@ -- Stability : experimental -- Portability : portable ----------------------------------------------------------------------------- -module Haddock.Interface.AttachInstances (attachInstances) where +module Haddock.Interface.AttachInstances (attachInstances, instHead) where -import Haddock.Types import Haddock.Convert +import Haddock.GhcUtils (typeNames) +import Haddock.Types import Control.Applicative ((<|>)) import Control.Arrow hiding ((<+>)) +import Control.DeepSeq (force) +import Data.Foldable (foldl') import Data.List (sortBy) import Data.Ord (comparing) import Data.Maybe ( maybeToList, mapMaybe, fromMaybe ) -import qualified Data.Map as Map +import qualified Data.Map.Strict as Map import qualified Data.Set as Set import GHC.Data.FastString (unpackFS) import GHC.Core.Class -import GHC.Core (isOrphan) import GHC.Core.FamInstEnv import GHC import GHC.Core.InstEnv @@ -74,13 +77,21 @@ attachOrphanInstances :: ExportInfo -> (Name -> Maybe (MDoc Name)) -- ^ how to lookup the doc of an instance - -> [ClsInst] -- ^ a list of orphan instances + -> [HaddockClsInst] -- ^ a list of instances -> [DocInstance GhcRn] attachOrphanInstances expInfo getInstDoc cls_instances = - [ (synifyInstHead i, getInstDoc n, (L (getSrcSpan n) n), Nothing) - | let is = [ (instanceSig i, getName i) | i <- cls_instances, isOrphan (is_orphan i) ] - , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is - , not $ isInstanceHidden expInfo cls tys + [ (synified, getInstDoc instName, (L (getSrcSpan instName) instName), Nothing) + | let is = + [ ( haddockClsInstHead i + , haddockClsInstSynified i + , haddockClsInstName i + , haddockClsInstClsName i + , haddockClsInstTyNames i + ) + | i <- cls_instances, haddockClsInstIsOrphan i + ] + , (_, synified, instName, cls, tyNames) <- sortBy (comparing $ (\(ih,_,_,_,_) -> ih)) is + , not $ isInstanceHidden expInfo cls tyNames ] @@ -93,7 +104,7 @@ -> Ghc (ExportItem GhcRn) attachToExportItem index expInfo getInstDoc getFixity export = case attachFixities export of - e@ExportDecl { expItemDecl = L eSpan (TyClD _ d) } -> do + ExportDecl e@(ExportD { expDDecl = L eSpan (TyClD _ d) }) -> do insts <- let mb_instances = lookupNameEnv index (tcdName d) cls_instances = maybeToList mb_instances >>= fst @@ -101,7 +112,7 @@ fam_insts = [ ( synFamInst , getInstDoc n , spanNameE n synFamInst (L (locA eSpan) (tcdName d)) - , nameModule_maybe n + , mb_mdl ) | i <- sortBy (comparing instFam) fam_instances , let n = getName i @@ -109,16 +120,21 @@ , not $ any (isTypeHidden expInfo) (fi_tys i) , let opaque = isTypeHidden expInfo (fi_rhs i) , let synFamInst = synifyFamInst i opaque + , let !mb_mdl = force $ nameModule_maybe n ] cls_insts = [ ( synClsInst , getInstDoc n , spanName n synClsInst (L (locA eSpan) (tcdName d)) - , nameModule_maybe n + , mb_mdl ) | let is = [ (instanceSig i, getName i) | i <- cls_instances ] , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is - , not $ isInstanceHidden expInfo cls tys + , not $ isInstanceHidden + expInfo + (getName cls) + (foldl' (\acc t -> acc `Set.union` typeNames t) Set.empty tys) , let synClsInst = synifyInstHead i + , let !mb_mdl = force $ nameModule_maybe n ] -- fam_insts but with failing type fams filtered out cleanFamInsts = [ (fi, n, L l r, m) | (Right fi, n, L l (Right r), m) <- fam_insts ] @@ -127,22 +143,39 @@ let mkBug = (text "haddock-bug:" <+>) . text putMsgM (sep $ map mkBug famInstErrs) return $ cls_insts ++ cleanFamInsts - return $ e { expItemInstances = insts } + return $ ExportDecl e { expDInstances = insts } e -> return e where - attachFixities e@ExportDecl{ expItemDecl = L _ d - , expItemPats = patsyns - , expItemSubDocs = subDocs - } = e { expItemFixities = - nubByName fst $ expItemFixities e ++ - [ (n',f) | n <- getMainDeclBinder emptyOccEnv d - , n' <- n : (map fst subDocs ++ patsyn_names) - , f <- maybeToList (getFixity n') - ] } + attachFixities + ( ExportDecl + ( e@ExportD + { expDDecl = L _ d + , expDPats = patsyns + , expDSubDocs = subDocs + } + ) + ) + = ExportDecl e + { expDFixities = fixities + } where + fixities :: [(Name, Fixity)] + !fixities = force . Map.toList $ foldl' f Map.empty all_names + + f :: Map.Map Name Fixity -> Name -> Map.Map Name Fixity + f !fs n = Map.alter (<|> getFixity n) n fs + + patsyn_names :: [Name] patsyn_names = concatMap (getMainDeclBinder emptyOccEnv . fst) patsyns + all_names :: [Name] + all_names = + getMainDeclBinder emptyOccEnv d + ++ map fst subDocs + ++ patsyn_names + attachFixities e = e + -- spanName: attach the location to the name that is the same file as the instance location spanName s (InstHead { ihdClsName = clsn }) (L instL instn) = let s1 = getSrcSpan s @@ -175,27 +208,6 @@ -- Collecting and sorting instances -------------------------------------------------------------------------------- --- | Stable name for stable comparisons. GHC's `Name` uses unstable --- ordering based on their `Unique`'s. -newtype SName = SName Name - -instance Eq SName where - SName n1 == SName n2 = n1 `stableNameCmp` n2 == EQ - -instance Ord SName where - SName n1 `compare` SName n2 = n1 `stableNameCmp` n2 - --- | Simplified type for sorting types, ignoring qualification (not visible --- in Haddock output) and unifying special tycons with normal ones. --- For the benefit of the user (looks nice and predictable) and the --- tests (which prefer output to be deterministic). -data SimpleType = SimpleType SName [SimpleType] - | SimpleIntTyLit Integer - | SimpleStringTyLit String - | SimpleCharTyLit Char - deriving (Eq,Ord) - - instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], SName, [SimpleType]) instHead (_, _, cls, args) = (map argCount args, SName (className cls), map simplify args) @@ -248,30 +260,21 @@ -- | We say that an instance is «hidden» iff its class or any (part) -- of its type(s) is hidden. -isInstanceHidden :: ExportInfo -> Class -> [Type] -> Bool -isInstanceHidden expInfo cls tys = +isInstanceHidden :: ExportInfo -> Name -> Set.Set Name -> Bool +isInstanceHidden expInfo cls tyNames = instClassHidden || instTypeHidden where instClassHidden :: Bool - instClassHidden = isNameHidden expInfo $ getName cls + instClassHidden = isNameHidden expInfo cls instTypeHidden :: Bool - instTypeHidden = any (isTypeHidden expInfo) tys + instTypeHidden = any (isNameHidden expInfo) tyNames isTypeHidden :: ExportInfo -> Type -> Bool isTypeHidden expInfo = typeHidden where typeHidden :: Type -> Bool - typeHidden t = - case t of - TyVarTy {} -> False - AppTy t1 t2 -> typeHidden t1 || typeHidden t2 - FunTy _ _ t1 t2 -> typeHidden t1 || typeHidden t2 - TyConApp tcon args -> nameHidden (getName tcon) || any typeHidden args - ForAllTy bndr ty -> typeHidden (tyVarKind (binderVar bndr)) || typeHidden ty - LitTy _ -> False - CastTy ty _ -> typeHidden ty - CoercionTy {} -> False + typeHidden t = any nameHidden $ typeNames t nameHidden :: Name -> Bool nameHidden = isNameHidden expInfo diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -31,32 +31,37 @@ module Haddock.Interface.Create (IfM, runIfM, createInterface1) where import Documentation.Haddock.Doc (metaDocAppend) -import Haddock.Convert (PrintRuntimeReps (..), tyThingToLHsDecl) +import Haddock.Backends.Hoogle (outWith) +import Haddock.Convert (PrintRuntimeReps (..), tyThingToLHsDecl, synifyInstHead) import Haddock.GhcUtils (addClassContext, filterSigNames, lHsQTyVarsToTypes, mkEmptySigType, moduleString, parents, - pretty, restrictTo, sigName, unL) + pretty, restrictTo, sigName, unL, typeNames) +import Haddock.Interface.AttachInstances (instHead) import Haddock.Interface.LexParseRn import Haddock.Options (Flag (..), modulePackageInfo) -import Haddock.Types hiding (liftErrMsg) +import Haddock.Types import Haddock.Utils (replace) import Control.Applicative ((<|>)) -import Control.Monad.Reader (MonadReader (..), ReaderT, asks, runReaderT) -import Control.Monad.Writer.Strict hiding (tell) +import Control.DeepSeq +import Control.Monad.State.Strict import Data.Bitraversable (bitraverse) import Data.Foldable (toList) import Data.List (find, foldl') import qualified Data.IntMap as IM import Data.IntMap (IntMap) -import Data.Map (Map) -import qualified Data.Map as M +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M import Data.Maybe (catMaybes, fromJust, isJust, mapMaybe, maybeToList) +import qualified Data.Set as Set import Data.Traversable (for) import GHC hiding (lookupName) +import GHC.Core (isOrphan) import GHC.Core.Class (ClassMinimalDef, classMinimalDef) import GHC.Core.ConLike (ConLike (..)) +import GHC.Core.InstEnv import GHC.Data.FastString (unpackFS) -import GHC.Driver.Ppr (showSDoc) +import GHC.Driver.Ppr (showSDoc, showSDocForUser) import GHC.HsToCore.Docs hiding (mkMaps, unionArgMaps) import GHC.IORef (readIORef) import GHC.Stack (HasCallStack) @@ -80,59 +85,6 @@ import GHC.Unit.Module.Warnings import GHC.Types.Unique.Map -newtype IfEnv m = IfEnv - { - -- | Lookup names in the environment. - ife_lookup_name :: Name -> m (Maybe TyThing) - } - - --- | A monad in which we create Haddock interfaces. Not to be confused with --- `GHC.Tc.Types.IfM` which is used to write GHC interfaces. --- --- In the past `createInterface` was running in the `Ghc` monad but proved hard --- to sustain as soon as we moved over for Haddock to be a plugin. Also abstracting --- over the Ghc specific clarifies where side effects happen. -newtype IfM m a = IfM { unIfM :: ReaderT (IfEnv m) (WriterT [ErrMsg] m) a } - - -deriving newtype instance Functor m => Functor (IfM m) -deriving newtype instance Applicative m => Applicative (IfM m) -deriving newtype instance Monad m => Monad (IfM m) -deriving newtype instance MonadIO m => MonadIO (IfM m) -deriving newtype instance Monad m => MonadReader (IfEnv m) (IfM m) -deriving newtype instance Monad m => MonadWriter [ErrMsg] (IfM m) - - --- | Run an `IfM` action. -runIfM - -- | Lookup a global name in the current session. Used in cases - -- where declarations don't - :: (Name -> m (Maybe TyThing)) - -- | The action to run. - -> IfM m a - -- | Result and accumulated error/warning messages. - -> m (a, [ErrMsg]) -runIfM lookup_name action = do - let - if_env = IfEnv - { - ife_lookup_name = lookup_name - } - runWriterT (runReaderT (unIfM action) if_env) - - -liftErrMsg :: Monad m => ErrMsgM a -> IfM m a -liftErrMsg action = do - writer (runWriter action) - - -lookupName :: Monad m => Name -> IfM m (Maybe TyThing) -lookupName name = IfM $ do - lookup_name <- asks ife_lookup_name - lift $ lift (lookup_name name) - - createInterface1 :: MonadIO m => [Flag] @@ -157,6 +109,8 @@ } } = mod_sum + !ml_hie_file' = force ml_hie_file + TcGblEnv { tcg_mod @@ -204,13 +158,12 @@ decls <- case tcg_rn_decls of Nothing -> do - tell [ "Warning: Renamed source is not available" ] + warn "Warning: Renamed source is not available" pure [] - Just dx -> - pure (topDecls dx) + Just dx -> pure (topDecls dx) -- Derive final options to use for haddocking this module - doc_opts <- liftErrMsg $ mkDocOpts (haddockOptions ms_hspp_opts) flags tcg_mod + doc_opts <- mkDocOpts (haddockOptions ms_hspp_opts) flags tcg_mod let -- All elements of an explicit export list, if present @@ -225,7 +178,7 @@ -- All the exported Names of this module. exported_names :: [Name] - exported_names = + !exported_names = force $ concatMap availNamesWithSelectors tcg_exports -- Module imports of the form `import X`. Note that there is @@ -254,14 +207,14 @@ liftIO $ extractTHDocs <$> readIORef tcg_th_docs -- Process the top-level module header documentation. - (!info, header_doc) <- liftErrMsg $ processModuleHeader dflags pkg_name + (!info, !header_doc) <- force <$> processModuleHeader dflags pkg_name tcg_rdr_env safety (fmap hsDocString thMbDocStr <|> (hsDocString . unLoc <$> tcg_doc_hdr)) -- Warnings on declarations in this module - decl_warnings <- liftErrMsg (mkWarningMap dflags tcg_warns tcg_rdr_env exported_names) + decl_warnings <- mkWarningMap dflags tcg_warns tcg_rdr_env exported_names -- Warning on the module header - mod_warning <- liftErrMsg (moduleWarning dflags tcg_rdr_env tcg_warns) + mod_warning <- moduleWarning dflags tcg_rdr_env tcg_warns let -- Warnings in this module and transitive warnings from dependent modules @@ -269,7 +222,7 @@ warnings = M.unions (decl_warnings : map ifaceWarningMap (M.elems ifaces)) maps@(!docs, !arg_docs, !decl_map, _) <- - liftErrMsg (mkMaps dflags pkg_name tcg_rdr_env local_instances decls thDocs) + mkMaps dflags pkg_name tcg_rdr_env local_instances decls thDocs export_items <- mkExportItems is_sig ifaces pkg_name tcg_mod tcg_semantic_mod warnings tcg_rdr_env exported_names (map fst decls) maps fixities @@ -277,7 +230,7 @@ let visible_names :: [Name] - visible_names = mkVisibleNames maps export_items doc_opts + !visible_names = force $ mkVisibleNames maps export_items doc_opts -- Measure haddock documentation coverage. pruned_export_items :: [ExportItem GhcRn] @@ -292,32 +245,32 @@ aliases :: Map Module ModuleName aliases = mkAliasMap unit_state tcg_rn_imports + insts :: [HaddockClsInst] + !insts = force $ map (fromClsInst (Flag_Hoogle `elem` flags) dflags unit_state) tcg_insts + return $! Interface { ifaceMod = tcg_mod , ifaceIsSig = is_sig , ifaceOrigFilename = msHsFilePath mod_sum - , ifaceHieFile = Just ml_hie_file + , ifaceHieFile = Just ml_hie_file' , ifaceInfo = info , ifaceDoc = Documentation header_doc mod_warning , ifaceRnDoc = Documentation Nothing Nothing , ifaceOptions = doc_opts , ifaceDocMap = docs , ifaceArgMap = arg_docs - , ifaceRnDocMap = M.empty - , ifaceRnArgMap = M.empty , ifaceExportItems = if OptPrune `elem` doc_opts then pruned_export_items else export_items - , ifaceRnExportItems = [] + , ifaceRnExportItems = [] -- Filled in renameInterfaceRn , ifaceExports = exported_names , ifaceVisibleExports = visible_names , ifaceDeclMap = decl_map , ifaceFixMap = fixities , ifaceModuleAliases = aliases - , ifaceInstances = tcg_insts - , ifaceFamInstances = tcg_fam_insts + , ifaceInstances = insts , ifaceOrphanInstances = [] -- Filled in attachInstances - , ifaceRnOrphanInstances = [] -- Filled in attachInstances + , ifaceRnOrphanInstances = [] -- Filled in renameInterfaceRn , ifaceHaddockCoverage = coverage , ifaceWarningMap = warnings , ifaceDynFlags = dflags @@ -329,12 +282,12 @@ -- (if there are multiple aliases, we pick the last one.) This -- will go in 'ifaceModuleAliases'. mkAliasMap :: UnitState -> [LImportDecl GhcRn] -> M.Map Module ModuleName -mkAliasMap state impDecls = +mkAliasMap st impDecls = M.fromList $ mapMaybe (\(SrcLoc.L _ impDecl) -> do SrcLoc.L _ alias <- ideclAs impDecl return - (lookupModuleDyn state + (lookupModuleDyn st -- TODO: This is supremely dodgy, because in general the -- UnitId isn't going to look anything like the package -- qualifier (even with old versions of GHC, the @@ -393,19 +346,72 @@ -- ezyang: Not really... lookupModuleDyn :: UnitState -> PkgQual -> ModuleName -> Module -lookupModuleDyn state pkg_qual mdlName = case pkg_qual of +lookupModuleDyn st pkg_qual mdlName = case pkg_qual of OtherPkg uid -> Module.mkModule (RealUnit (Definite uid)) mdlName ThisPkg uid -> Module.mkModule (RealUnit (Definite uid)) mdlName - NoPkgQual -> case lookupModuleInAllUnits state mdlName of + NoPkgQual -> case lookupModuleInAllUnits st mdlName of (m,_):_ -> m [] -> Module.mkModule Module.mainUnit mdlName +-- | Prune a 'ClsInst' down to a 'HaddockClsInst'. The goal is to remove as much +-- unnecessary information from the 'ClsInst' as possible by precomputing the +-- information we eventually want from it. +fromClsInst + :: Bool + -- ^ Was Hoogle output requested? + -> DynFlags + -- ^ GHC session dynflags + -> UnitState + -- ^ GHC session dynflags + -> ClsInst + -- ^ Class instance to convert + -> HaddockClsInst + -- ^ Resulting Haddock class instance +fromClsInst doHoogle dflags unitState inst = + HaddockClsInst + { haddockClsInstPprHoogle = + if doHoogle then Just (ppInstance inst) else Nothing + , haddockClsInstName = getName inst + , haddockClsInstClsName = getName cls + , haddockClsInstIsOrphan = isOrphan $ is_orphan inst + , haddockClsInstSynified = synifyInstHead instSig + , haddockClsInstHead = instHead instSig + , haddockClsInstTyNames = + foldl' (\ns t -> ns `Set.union` typeNames t) Set.empty tys + } + where + instSig :: ([TyVar], [Type], Class, [Type]) + instSig@(_,_,cls,tys) = instanceSig inst + ppInstance :: ClsInst -> String + ppInstance i = + dropComment $ outWith (showSDocForUser dflags unitState alwaysQualify) i' + where + -- As per #168, we don't want safety information about the class + -- in Hoogle output. The easiest way to achieve this is to set the + -- safety information to a state where the Outputable instance + -- produces no output which means no overlap and unsafe (or [safe] + -- is generated). + i' = i { is_flag = OverlapFlag { overlapMode = NoOverlap NoSourceText + , isSafeOverlap = False } } + + dropComment :: String -> String + dropComment (' ':'-':'-':' ':_) = [] + dropComment (x:xs) = x : dropComment xs + dropComment [] = [] + + ------------------------------------------------------------------------------- -- Warnings ------------------------------------------------------------------------------- -mkWarningMap :: DynFlags -> Warnings a -> GlobalRdrEnv -> [Name] -> ErrMsgM WarningMap +mkWarningMap + :: MonadIO m + => DynFlags + -> Warnings a + -> GlobalRdrEnv + -> [Name] + -> IfM m WarningMap mkWarningMap dflags warnings gre exps = case warnings of NoWarnings -> pure M.empty WarnAll _ -> pure M.empty @@ -416,12 +422,22 @@ , let n = greMangledName elt, n `elem` exps ] in M.fromList <$> traverse (bitraverse pure (parseWarning dflags gre)) ws' -moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings a -> ErrMsgM (Maybe (Doc Name)) +moduleWarning + :: MonadIO m + => DynFlags + -> GlobalRdrEnv + -> Warnings a + -> IfM m (Maybe (Doc Name)) moduleWarning _ _ NoWarnings = pure Nothing moduleWarning _ _ (WarnSome _) = pure Nothing moduleWarning dflags gre (WarnAll w) = Just <$> parseWarning dflags gre w -parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt a -> ErrMsgM (Doc Name) +parseWarning + :: MonadIO m + => DynFlags + -> GlobalRdrEnv + -> WarningTxt a + -> IfM m (Doc Name) parseWarning dflags gre w = case w of DeprecatedTxt _ msg -> format "Deprecated: " (foldMap (unpackFS . sl_fs . hsDocString . unLoc) msg) WarningTxt _ msg -> format "Warning: " (foldMap (unpackFS . sl_fs . hsDocString . unLoc) msg) @@ -436,12 +452,11 @@ -- Haddock options that are embedded in the source file ------------------------------------------------------------------------------- - -mkDocOpts :: Maybe String -> [Flag] -> Module -> ErrMsgM [DocOption] +mkDocOpts :: MonadIO m => Maybe String -> [Flag] -> Module -> IfM m [DocOption] mkDocOpts mbOpts flags mdl = do opts <- case mbOpts of Just opts -> case words $ replace ',' ' ' opts of - [] -> tell ["No option supplied to DOC_OPTION/doc_option"] >> return [] + [] -> warn "No option supplied to DOC_OPTION/doc_option" >> return [] xs -> fmap catMaybes (mapM parseOption xs) Nothing -> return [] pure (foldl go opts flags) @@ -456,14 +471,13 @@ | m == Flag_ShowExtensions mdlStr = OptIgnoreExports : os | otherwise = os -parseOption :: String -> ErrMsgM (Maybe DocOption) +parseOption :: MonadIO m => String -> IfM m (Maybe DocOption) parseOption "hide" = return (Just OptHide) parseOption "prune" = return (Just OptPrune) parseOption "ignore-exports" = return (Just OptIgnoreExports) parseOption "not-home" = return (Just OptNotHome) parseOption "show-extensions" = return (Just OptShowExtensions) -parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing - +parseOption other = warn ("Unrecognised option: " ++ other) >> return Nothing -------------------------------------------------------------------------------- -- Maps @@ -475,24 +489,28 @@ -- | Create 'Maps' by looping through the declarations. For each declaration, -- find its names, its subordinates, and its doc strings. Process doc strings -- into 'Doc's. -mkMaps :: DynFlags - -> Maybe Package -- this package - -> GlobalRdrEnv - -> [Name] - -> [(LHsDecl GhcRn, [HsDoc GhcRn])] - -> ExtractedTHDocs -- ^ Template Haskell putDoc docs - -> ErrMsgM Maps +mkMaps + :: MonadIO m + => DynFlags + -> Maybe Package -- this package + -> GlobalRdrEnv + -> [Name] + -> [(LHsDecl GhcRn, [HsDoc GhcRn])] + -> ExtractedTHDocs -- ^ Template Haskell putDoc docs + -> IfM m Maps mkMaps dflags pkgName gre instances decls thDocs = do (a, b, c) <- unzip3 <$> traverse mappings decls (th_a, th_b) <- thMappings - pure ( th_a `M.union` f' (map (nubByName fst) a) - , fmap intmap2mapint $ - th_b `unionArgMaps` (f (filterMapping (not . IM.null) b)) - , f (filterMapping (not . null) c) + pure ( force $ + th_a `M.union` f' (map (nubByName fst) a) + , force $ + fmap intmap2mapint $ + th_b `unionArgMaps` (f (filterMapping (not . IM.null) b)) + , f c , instanceMap ) where - f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b + f :: (Ord a, Semigroup b) => [[(a, b)]] -> Map a b f = M.fromListWith (<>) . concat f' :: [[(Name, MDoc Name)]] -> Map Name (MDoc Name) @@ -508,14 +526,16 @@ -- | Extract the mappings from template haskell. -- No DeclMap/InstMap is needed since we already have access to the -- doc strings - thMappings :: ErrMsgM (Map Name (MDoc Name), Map Name (IntMap (MDoc Name))) + thMappings + :: MonadIO m + => IfM m (Map Name (MDoc Name), Map Name (IntMap (MDoc Name))) thMappings = do let ExtractedTHDocs _ declDocs argDocs instDocs = thDocs - ds2mdoc :: (HsDoc GhcRn) -> ErrMsgM (MDoc Name) + ds2mdoc :: MonadIO m => (HsDoc GhcRn) -> IfM m (MDoc Name) ds2mdoc = processDocStringParas dflags pkgName gre . hsDocString let cvt = M.fromList . nonDetEltsUniqMap @@ -526,21 +546,27 @@ return (declDocs' <> instDocs', argDocs') - mappings :: (LHsDecl GhcRn, [HsDoc GhcRn]) - -> ErrMsgM ( [(Name, MDoc Name)] - , [(Name, IntMap (MDoc Name))] - , [(Name, [LHsDecl GhcRn])] - ) + mappings + :: MonadIO m + => (LHsDecl GhcRn, [HsDoc GhcRn]) + -> IfM m + ( [(Name, MDoc Name)] + , [(Name, IntMap (MDoc Name))] + , [(Name, DeclMapEntry)] + ) mappings (ldecl@(L (SrcSpanAnn _ (RealSrcSpan l _)) decl), hs_docStrs) = do let docStrs = map hsDocString hs_docStrs - declDoc :: [HsDocString] -> IntMap HsDocString - -> ErrMsgM (Maybe (MDoc Name), IntMap (MDoc Name)) + declDoc + :: MonadIO m + => [HsDocString] + -> IntMap HsDocString + -> IfM m (Maybe (MDoc Name), IntMap (MDoc Name)) declDoc strs m = do doc' <- processDocStrings dflags pkgName gre strs m' <- traverse (processDocStringParas dflags pkgName gre) m pure (doc', m') - (doc, args) <- declDoc docStrs (fmap hsDocString (declTypeDocs decl)) + (!doc, !args) <- force <$> declDoc docStrs (fmap hsDocString (declTypeDocs decl)) let subs :: [(Name, [HsDocString], IntMap HsDocString)] @@ -554,7 +580,7 @@ subNs = [ n | (n, _, _) <- subs ] dm = [ (n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs ] am = [ (n, args) | n <- ns ] ++ zip subNs subArgs - cm = [ (n, [ldecl]) | n <- ns ++ subNs ] + cm = [ (n, toDeclMapEntry ldecl) | n <- ns ++ subNs ] seqList ns `seq` seqList subNs `seq` @@ -606,8 +632,6 @@ -- Declarations -------------------------------------------------------------------------------- - - -- | Extract a map of fixity declarations only mkFixMap :: HsGroup GhcRn -> FixMap mkFixMap group_ = @@ -623,7 +647,7 @@ -- 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 - :: Monad m + :: MonadIO m => Bool -- is it a signature -> IfaceMap -> Maybe Package -- this package @@ -647,25 +671,25 @@ maps fixMap unrestricted_imp_mods splices exportList allExports instIfaceMap dflags = case exportList of - Nothing -> + Nothing -> do fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNames decls maps fixMap splices instIfaceMap dflags allExports Just exports -> fmap concat $ mapM lookupExport exports where - lookupExport (IEGroup _ lev docStr, _) = liftErrMsg $ do - doc <- processDocString dflags gre (hsDocString . unLoc $ docStr) + lookupExport (IEGroup _ lev docStr, _) = do + !doc <- force <$> processDocString dflags gre (hsDocString . unLoc $ docStr) return [ExportGroup lev "" doc] - lookupExport (IEDoc _ docStr, _) = liftErrMsg $ do - doc <- processDocStringParas dflags pkgName gre (hsDocString . unLoc $ docStr) + lookupExport (IEDoc _ docStr, _) = do + !doc <- force <$> processDocStringParas dflags pkgName gre (hsDocString . unLoc $ docStr) return [ExportDoc doc] - lookupExport (IEDocNamed _ str, _) = liftErrMsg $ + lookupExport (IEDocNamed _ str, _) = findNamedDoc str [ unL d | d <- decls ] >>= \case Nothing -> return [] Just docStr -> do - doc <- processDocStringParas dflags pkgName gre docStr + !doc <- force <$> processDocStringParas dflags pkgName gre docStr return [ExportDoc doc] lookupExport (IEModuleContents _ (L _ mod_name), _) @@ -676,8 +700,7 @@ , not (null mods) = concat <$> traverse (moduleExport thisMod dflags modMap instIfaceMap) mods - lookupExport (_, avails) = - concat <$> traverse availExport (nubAvails avails) + lookupExport (_, avails) = concat <$> traverse availExport (nubAvails avails) availExport avail = availExportItem is_sig modMap thisMod semMod warnings exportedNames @@ -697,7 +720,7 @@ availExportItem :: forall m - . Monad m + . MonadIO m => Bool -- is it a signature -> IfaceMap -> Module -- this module @@ -720,29 +743,34 @@ let t = availName avail r <- findDecl avail case r of - ([L l' (ValD _ _)], (doc, _)) -> do - let l = locA l' - -- Top-level binding without type signature - export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap + (Just (EValD srcSpan), (doc, _)) -> do + -- Since the DeclMapEntry is an 'EValD', we know the declaration is a + -- top-level binding without a type signature. We get type information + -- for the binding from the GHC interface file using the + -- 'hiValExportItem' function + export <- hiValExportItem dflags t srcSpan doc (srcSpan `elem` splices) $ M.lookup t fixMap return [export] - (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds -> - let declNames = getMainDeclBinder emptyOccEnv (unL decl) + + (Just (EOther d), docs_) -> + let declNames = getMainDeclBinder emptyOccEnv (unL d) in case () of _ - -- We should not show a subordinate by itself if any of its - -- parents is also exported. See note [1]. + -- If 't' is not the main declaration binder, then it is a + -- subordinate name in the declaration. If any of its parents are + -- also exported, we do not want to show its documentation by + -- itself. See note [1]. | t `notElem` declNames, - Just p <- find isExported (parents t $ unL decl) -> - do liftErrMsg $ tell [ + Just p <- find isExported (parents t $ unL d) -> do + warn $ "Warning: " ++ moduleString thisMod ++ ": " ++ pretty dflags (nameOccName t) ++ " is exported separately but " ++ "will be documented under " ++ pretty dflags (nameOccName p) ++ ". Consider exporting it together with its parent(s)" ++ - " for code clarity." ] - return [] + " for code clarity." + return [] -- normal case - | otherwise -> case decl of + | otherwise -> case d of -- A single signature might refer to many names, but we -- create an export item for a single name only. So we -- modify the signature to contain only that single name. @@ -758,10 +786,10 @@ availExportDecl avail (L loc $ TyClD noExtField ClassDecl { tcdSigs = sig ++ tcdSigs, .. }) docs_ - _ -> availExportDecl avail decl docs_ + _ -> availExportDecl avail d docs_ -- Declaration from another package - ([], _) -> do + (Nothing, _) -> do mayDecl <- hiDecl dflags t case mayDecl of Nothing -> return [ ExportNoDecl t [] ] @@ -772,15 +800,12 @@ -- with signature inheritance case M.lookup (nameModule t) instIfaceMap of Nothing -> do - liftErrMsg $ tell - ["Warning: Couldn't find .haddock for export " ++ pretty dflags t] - let subs_ = availNoDocs avail - availExportDecl avail decl (noDocForDecl, subs_) + warn $ "Warning: Couldn't find .haddock for export " ++ pretty dflags t + let subs_ = availNoDocs avail + availExportDecl avail decl (noDocForDecl, subs_) Just iface -> availExportDecl avail decl (lookupDocs avail warnings (instDocMap iface) (instArgMap iface)) - _ -> return [] - -- Tries 'extractDecl' first then falls back to 'hiDecl' if that fails availDecl :: Name -> LHsDecl GhcRn -> IfM m (LHsDecl GhcRn) availDecl declName parentDecl = @@ -804,47 +829,58 @@ bundledPatSyns <- findBundledPatterns avail let - patSynNames = + !patSynNames = force $ concatMap (getMainDeclBinder emptyOccEnv . fst) bundledPatSyns - fixities = + !doc' = force doc + !subs' = force subs + + !restrictToNames = force $ fmap fst subs' + + !fixities = force [ (n, f) - | n <- availName avail : fmap fst subs ++ patSynNames + | n <- availName avail : fmap fst subs' ++ patSynNames , Just f <- [M.lookup n fixMap] ] - return [ ExportDecl { - expItemDecl = restrictTo (fmap fst subs) extractedDecl - , expItemPats = bundledPatSyns - , expItemMbDoc = doc - , expItemSubDocs = subs - , expItemInstances = [] - , expItemFixities = fixities - , expItemSpliced = False - } - ] + return + [ ExportDecl ExportD + { expDDecl = restrictTo restrictToNames extractedDecl + , expDPats = bundledPatSyns + , expDMbDoc = doc' + , expDSubDocs = subs' + , expDInstances = [] + , expDFixities = fixities + , expDSpliced = False + } + ] | otherwise = for subs $ \(sub, sub_doc) -> do extractedDecl <- availDecl sub decl - return ( ExportDecl { - expItemDecl = extractedDecl - , expItemPats = [] - , expItemMbDoc = sub_doc - , expItemSubDocs = [] - , expItemInstances = [] - , expItemFixities = [ (sub, f) | Just f <- [M.lookup sub fixMap] ] - , expItemSpliced = False - } ) + let + !fixities = force [ (sub, f) | Just f <- [M.lookup sub fixMap] ] + !subDoc = force sub_doc + return $ + ExportDecl ExportD + { expDDecl = extractedDecl + , expDPats = [] + , expDMbDoc = subDoc + , expDSubDocs = [] + , expDInstances = [] + , expDFixities = fixities + , expDSpliced = False + } + exportedNameSet = mkNameSet exportedNames isExported n = elemNameSet n exportedNameSet - findDecl :: AvailInfo -> IfM m ([LHsDecl GhcRn], (DocForDecl Name, [(Name, DocForDecl Name)])) + findDecl :: AvailInfo -> IfM m (Maybe DeclMapEntry, (DocForDecl Name, [(Name, DocForDecl Name)])) findDecl avail | m == semMod = case M.lookup n declMap of - Just ds -> return (ds, lookupDocs avail warnings docMap argMap) + Just d -> return (Just d, lookupDocs avail warnings docMap argMap) Nothing | is_sig -> do -- OK, so it wasn't in the local declaration map. It could @@ -852,19 +888,19 @@ -- from the type. mb_r <- hiDecl dflags n case mb_r of - Nothing -> return ([], (noDocForDecl, availNoDocs avail)) + Nothing -> return (Nothing, (noDocForDecl, availNoDocs avail)) -- TODO: If we try harder, we might be able to find -- a Haddock! Look in the Haddocks for each thing in -- requirementContext (unitState) - Just decl -> return ([decl], (noDocForDecl, availNoDocs avail)) + Just decl -> return (Just $ toDeclMapEntry decl, (noDocForDecl, availNoDocs avail)) | otherwise -> - return ([], (noDocForDecl, availNoDocs avail)) + return (Nothing, (noDocForDecl, availNoDocs avail)) | Just iface <- M.lookup (semToIdMod (moduleUnit thisMod) m) modMap - , Just ds <- M.lookup n (ifaceDeclMap iface) = - return (ds, lookupDocs avail warnings + , Just d <- M.lookup n (ifaceDeclMap iface) = + return (Just d, lookupDocs avail warnings (ifaceDocMap iface) (ifaceArgMap iface)) - | otherwise = return ([], (noDocForDecl, availNoDocs avail)) + | otherwise = return (Nothing, (noDocForDecl, availNoDocs avail)) where n = availName avail m = nameModule n @@ -877,9 +913,9 @@ Just (AConLike PatSynCon{}) -> do export_items <- declWith (Avail.avail name) pure [ (unLoc patsyn_decl, patsyn_doc) - | ExportDecl { - expItemDecl = patsyn_decl - , expItemMbDoc = patsyn_doc + | ExportDecl ExportD + { expDDecl = patsyn_decl + , expDMbDoc = patsyn_doc } <- export_items ] _ -> pure [] @@ -902,17 +938,16 @@ | Module.isHoleModule m = mkModule this_uid (moduleName m) | otherwise = m -hiDecl :: Monad m => DynFlags -> Name -> IfM m (Maybe (LHsDecl GhcRn)) +hiDecl :: MonadIO m => DynFlags -> Name -> IfM m (Maybe (LHsDecl GhcRn)) hiDecl dflags t = do mayTyThing <- lookupName t case mayTyThing of Nothing -> do - liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty dflags t] + warn $ "Warning: Not found in environment: " ++ pretty dflags t return Nothing Just x -> case tyThingToLHsDecl ShowRuntimeRep x of - Left m -> liftErrMsg (tell [bugWarn m]) >> return Nothing - Right (m, t') -> liftErrMsg (tell $ map bugWarn m) - >> return (Just $ noLocA t') + Left m -> (warn $ bugWarn m) >> return Nothing + Right (m, t') -> mapM (warn . bugWarn) m >> return (Just $ noLocA t') where warnLine x = O.text "haddock-bug:" O.<+> O.text x O.<> O.comma O.<+> O.quotes (O.ppr t) O.<+> @@ -924,13 +959,13 @@ -- have a meaningful 'SrcSpan'. So we pass down 'SrcSpan' for the -- declaration and use it instead - 'nLoc' here. hiValExportItem - :: Monad m => DynFlags -> Name -> SrcSpan -> DocForDecl Name -> Bool + :: MonadIO m => DynFlags -> Name -> SrcSpan -> DocForDecl Name -> Bool -> Maybe Fixity -> IfM m (ExportItem GhcRn) hiValExportItem dflags name nLoc doc splice fixity = do mayDecl <- hiDecl dflags name case mayDecl of Nothing -> return (ExportNoDecl name []) - Just decl -> return (ExportDecl (fixSpan decl) [] doc [] [] fixities splice) + Just decl -> return (ExportDecl $ ExportD (fixSpan decl) [] doc [] [] fixities splice) where fixSpan (L (SrcSpanAnn a l) t) = L (SrcSpanAnn a (SrcLoc.combineSrcSpans l nLoc)) t fixities = case fixity of @@ -941,7 +976,7 @@ -- | Lookup docs for a declaration from maps. lookupDocs :: AvailInfo -> WarningMap -> DocMap Name -> ArgMap Name -> (DocForDecl Name, [(Name, DocForDecl Name)]) -lookupDocs avail warnings docMap argMap = +lookupDocs avail warningMap docMap argMap = let n = availName avail in let lookupArgDoc x = M.findWithDefault M.empty x argMap in let doc = (lookupDoc n, lookupArgDoc n) in @@ -950,13 +985,13 @@ ] in (doc, subDocs) where - lookupDoc name = Documentation (M.lookup name docMap) (M.lookup name warnings) + lookupDoc name = Documentation (M.lookup name docMap) (M.lookup name warningMap) -- | Export the given module as `ExportModule`. We are not concerned with the -- single export items of the given module. moduleExport - :: Monad m + :: MonadIO m => Module -- ^ Module A (identity, NOT semantic) -> DynFlags -- ^ The flags used when typechecking A -> IfaceMap -- ^ Already created interfaces @@ -976,8 +1011,9 @@ case M.lookup expMod (M.mapKeys moduleName instIfaceMap) of Just iface -> return [ ExportModule (instMod iface) ] Nothing -> do - liftErrMsg $ tell ["Warning: " ++ pretty dflags thisMod ++ ": Could not find " ++ - "documentation for exported module: " ++ pretty dflags expMod] + warn $ + "Warning: " ++ pretty dflags thisMod ++ ": Could not find " ++ + "documentation for exported module: " ++ pretty dflags expMod return [] where m = mkModule (moduleUnit thisMod) expMod -- Identity module! @@ -1004,7 +1040,7 @@ -- zip through the renamed declarations. fullModuleContents - :: Monad m + :: MonadIO m => Bool -- is it a signature -> IfaceMap -> Maybe Package -- this package @@ -1027,14 +1063,14 @@ (concat . concat) `fmap` (for decls $ \decl -> do case decl of (L _ (DocD _ (DocGroup lev docStr))) -> do - doc <- liftErrMsg (processDocString dflags gre (hsDocString . unLoc $ docStr)) + !doc <- force <$> processDocString dflags gre (hsDocString . unLoc $ docStr) return [[ExportGroup lev "" doc]] (L _ (DocD _ (DocCommentNamed _ docStr))) -> do - doc <- liftErrMsg (processDocStringParas dflags pkgName gre (hsDocString . unLoc $ docStr)) + !doc <- force <$> processDocStringParas dflags pkgName gre (hsDocString . unLoc $ docStr) return [[ExportDoc doc]] (L _ (ValD _ valDecl)) | name:_ <- collectHsBindBinders CollNoDictBinders valDecl - , Just (L _ SigD{}:_) <- filter isSigD <$> M.lookup name declMap + , Just (EOther (L _ SigD{})) <- M.lookup name declMap -> return [] _ -> for (getMainDeclBinder emptyOccEnv (unLoc decl)) $ \nm -> do @@ -1044,9 +1080,6 @@ semMod warnings exportedNames maps fixMap splices instIfaceMap dflags avail Nothing -> pure []) - where - isSigD (L _ SigD{}) = True - isSigD _ = False -- | Sometimes the declaration we want to export is not the "main" declaration: -- it might be an individual record selector or a class method. In these @@ -1060,7 +1093,7 @@ => DeclMap -- ^ all declarations in the file -> Name -- ^ name of the declaration to extract -> LHsDecl GhcRn -- ^ parent declaration - -> Either ErrMsg (LHsDecl GhcRn) + -> Either String (LHsDecl GhcRn) extractDecl declMap name decl | name `elem` getMainDeclBinder emptyOccEnv (unLoc decl) = pure decl | otherwise = @@ -1091,7 +1124,7 @@ (_, [L pos fam_decl]) -> pure (L pos (TyClD noExtField (FamDecl noExtField fam_decl))) ([], []) - | Just (famInstDecl:_) <- M.lookup name declMap + | Just (EOther famInstDecl) <- M.lookup name declMap -> extractDecl declMap name famInstDecl _ -> Left (concat [ "Ambiguous decl for ", getOccString name , " in class ", getOccString clsNm ]) @@ -1106,7 +1139,7 @@ TyClD _ FamDecl {} | isValName name - , Just (famInst:_) <- M.lookup name declMap + , Just (EOther famInst) <- M.lookup name declMap -> extractDecl declMap name famInst InstD _ (DataFamInstD _ (DataFamInstDecl (FamEqn { feqn_tycon = L _ n @@ -1139,7 +1172,7 @@ extractPatternSyn :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] - -> Either ErrMsg (LSig GhcRn) + -> Either String (LSig GhcRn) extractPatternSyn nm t tvs cons = case filter matches cons of [] -> Left . O.showSDocOneLine O.defaultSDocContext $ @@ -1179,7 +1212,7 @@ mkAppTyArg f (HsArgPar _) = HsParTy noAnn f extractRecSel :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] - -> Either ErrMsg (LSig GhcRn) + -> Either String (LSig GhcRn) extractRecSel _ _ _ [] = Left "extractRecSel: selector not found" extractRecSel nm t tvs (L _ con : rest) = @@ -1204,7 +1237,7 @@ pruneExportItems :: [ExportItem GhcRn] -> [ExportItem GhcRn] pruneExportItems = filter hasDoc where - hasDoc (ExportDecl{expItemMbDoc = (Documentation d _, _)}) = isJust d + hasDoc (ExportDecl ExportD {expDMbDoc = (Documentation d _, _)}) = isJust d hasDoc _ = True @@ -1214,10 +1247,10 @@ | otherwise = let ns = concatMap exportName exports in seqList ns `seq` ns where - exportName e@ExportDecl {} = name ++ subs ++ patsyns - where subs = map fst (expItemSubDocs e) - patsyns = concatMap (getMainDeclBinder emptyOccEnv . fst) (expItemPats e) - name = case unLoc $ expItemDecl e of + exportName (ExportDecl e@ExportD{}) = name ++ subs ++ patsyns + where subs = map fst (expDSubDocs e) + patsyns = concatMap (getMainDeclBinder emptyOccEnv . fst) (expDPats e) + name = case unLoc $ expDDecl e of InstD _ d -> maybeToList $ SrcLoc.lookupSrcSpan (getInstLoc d) instMap decl -> getMainDeclBinder emptyOccEnv decl exportName ExportNoDecl {} = [] -- we don't count these as visible, since @@ -1229,11 +1262,12 @@ seqList (x : xs) = x `seq` seqList xs -- | Find a stand-alone documentation comment by its name. -findNamedDoc :: String -> [HsDecl GhcRn] -> ErrMsgM (Maybe HsDocString) +findNamedDoc :: MonadIO m => String -> [HsDecl GhcRn] -> IfM m (Maybe HsDocString) findNamedDoc name = search where search [] = do - tell ["Cannot find documentation for: $" ++ name] + -- TODO: Make sure this isn't duplicating messages + warn $ "Cannot find documentation for: $" ++ name return Nothing search (DocD _ (DocCommentNamed name' doc) : rest) | name == name' = return (Just (hsDocString . unLoc $ doc)) diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs --- a/src/Haddock/Interface/LexParseRn.hs +++ b/src/Haddock/Interface/LexParseRn.hs @@ -1,7 +1,7 @@ -{-# OPTIONS_GHC -Wwarn #-} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wwarn #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.LexParseRn @@ -23,9 +23,11 @@ import Control.Arrow import Control.Monad +import Control.Monad.State.Strict import Data.Functor import Data.List ((\\), maximumBy) import Data.Ord +import qualified Data.Set as Set import Documentation.Haddock.Doc (metaDocConcat) import GHC.Driver.Session (languageExtensions) import qualified GHC.LanguageExtensions as LangExt @@ -33,15 +35,21 @@ import Haddock.Interface.ParseModuleHeader import Haddock.Parser import Haddock.Types +import GHC.Data.EnumSet as EnumSet +import GHC.Driver.Ppr ( showPpr, showSDoc ) +import GHC.Parser.PostProcess import GHC.Types.Name import GHC.Types.Avail ( availName ) -import GHC.Parser.PostProcess -import GHC.Driver.Ppr ( showPpr, showSDoc ) import GHC.Types.Name.Reader -import GHC.Data.EnumSet as EnumSet +import GHC.Utils.Outputable (Outputable) -processDocStrings :: DynFlags -> Maybe Package -> GlobalRdrEnv -> [HsDocString] - -> ErrMsgM (Maybe (MDoc Name)) +processDocStrings + :: MonadIO m + => DynFlags + -> Maybe Package + -> GlobalRdrEnv + -> [HsDocString] + -> IfM m (Maybe (MDoc Name)) processDocStrings dflags pkg gre strs = do mdoc <- metaDocConcat <$> traverse (processDocStringParas dflags pkg gre) strs case mdoc of @@ -51,20 +59,42 @@ MetaDoc { _meta = Meta Nothing Nothing, _doc = DocEmpty } -> pure Nothing x -> pure (Just x) -processDocStringParas :: DynFlags -> Maybe Package -> GlobalRdrEnv -> HsDocString -> ErrMsgM (MDoc Name) +processDocStringParas + :: MonadIO m + => DynFlags + -> Maybe Package + -> GlobalRdrEnv + -> HsDocString + -> IfM m (MDoc Name) processDocStringParas dflags pkg gre hds = - overDocF (rename dflags gre) $ parseParas dflags pkg (renderHsDocString hds) + overDocF (rename dflags gre) (parseParas dflags pkg (renderHsDocString hds)) -processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Doc Name) +processDocString + :: MonadIO m + => DynFlags + -> GlobalRdrEnv + -> HsDocString + -> IfM m (Doc Name) processDocString dflags gre hds = - processDocStringFromString dflags gre (renderHsDocString hds) + processDocStringFromString dflags gre (renderHsDocString hds) -processDocStringFromString :: DynFlags -> GlobalRdrEnv -> String -> ErrMsgM (Doc Name) +processDocStringFromString + :: MonadIO m + => DynFlags + -> GlobalRdrEnv + -> String + -> IfM m (Doc Name) processDocStringFromString dflags gre hds = - rename dflags gre $ parseString dflags hds + rename dflags gre (parseString dflags hds) -processModuleHeader :: DynFlags -> Maybe Package -> GlobalRdrEnv -> SafeHaskellMode -> Maybe HsDocString - -> ErrMsgM (HaddockModInfo Name, Maybe (MDoc Name)) +processModuleHeader + :: MonadIO m + => DynFlags + -> Maybe Package + -> GlobalRdrEnv + -> SafeHaskellMode + -> Maybe HsDocString + -> IfM m (HaddockModInfo Name, Maybe (MDoc Name)) processModuleHeader dflags pkgName gre safety mayStr = do (hmi, doc) <- case mayStr of @@ -82,10 +112,13 @@ let flags :: [LangExt.Extension] -- We remove the flags implied by the language setting and we display the language instead flags = EnumSet.toList (extensionFlags dflags) \\ languageExtensions (language dflags) - return (hmi { hmi_safety = Just $ showPpr dflags safety - , hmi_language = language dflags - , hmi_extensions = flags - } , doc) + return + (hmi { hmi_safety = Just $ showPpr dflags safety + , hmi_language = language dflags + , hmi_extensions = flags + } + , doc + ) where failure = (emptyHaddockModInfo, Nothing) @@ -100,12 +133,18 @@ -- fallbacks in case we can't locate the identifiers. -- -- See the comments in the source for implementation commentary. -rename :: DynFlags -> GlobalRdrEnv -> Doc NsRdrName -> ErrMsgM (Doc Name) +rename + :: MonadIO m + => DynFlags + -> GlobalRdrEnv + -> Doc NsRdrName + -> IfM m (Doc Name) rename dflags gre = rn where + rn :: MonadIO m => Doc NsRdrName -> IfM m (Doc Name) rn d = case d of DocAppend a b -> DocAppend <$> rn a <*> rn b - DocParagraph doc -> DocParagraph <$> rn doc + DocParagraph p -> DocParagraph <$> rn p DocIdentifier i -> do let NsRdrName ns x = unwrap i occ = rdrNameOcc x @@ -150,14 +189,14 @@ -- There are multiple names available. gres -> ambiguous dflags i gres - DocWarning doc -> DocWarning <$> rn doc - DocEmphasis doc -> DocEmphasis <$> rn doc - DocBold doc -> DocBold <$> rn doc - DocMonospaced doc -> DocMonospaced <$> rn doc + DocWarning dw -> DocWarning <$> rn dw + DocEmphasis de -> DocEmphasis <$> rn de + DocBold db -> DocBold <$> rn db + DocMonospaced dm -> DocMonospaced <$> rn dm DocUnorderedList docs -> DocUnorderedList <$> traverse rn docs DocOrderedList docs -> DocOrderedList <$> traverseSnd rn docs DocDefList list -> DocDefList <$> traverse (\(a, b) -> (,) <$> rn a <*> rn b) list - DocCodeBlock doc -> DocCodeBlock <$> rn doc + DocCodeBlock dcb -> DocCodeBlock <$> rn dcb DocIdentifierUnchecked x -> pure (DocIdentifierUnchecked x) DocModule (ModLink m l) -> DocModule . ModLink m <$> traverse rn l DocHyperlink (Hyperlink u l) -> DocHyperlink . Hyperlink u <$> traverse rn l @@ -180,23 +219,32 @@ -- users shouldn't rely on this doing the right thing. See tickets -- #253 and #375 on the confusion this causes depending on which -- default we pick in 'rename'. -outOfScope :: DynFlags -> Namespace -> Wrap RdrName -> ErrMsgM (Doc a) +outOfScope :: MonadIO m => DynFlags -> Namespace -> Wrap RdrName -> IfM m (Doc a) outOfScope dflags ns x = - case unwrap x of - Unqual occ -> warnAndMonospace (x $> occ) - Qual mdl occ -> pure (DocIdentifierUnchecked (x $> (mdl, occ))) - Orig _ occ -> warnAndMonospace (x $> occ) - Exact name -> warnAndMonospace (x $> name) -- Shouldn't happen since x is out of scope + case unwrap x of + Unqual occ -> warnAndMonospace (x $> occ) + Qual mdl occ -> pure (DocIdentifierUnchecked (x $> (mdl, occ))) + Orig _ occ -> warnAndMonospace (x $> occ) + Exact name -> warnAndMonospace (x $> name) -- Shouldn't happen since x is out of scope where - prefix = case ns of - Value -> "the value " - Type -> "the type " - None -> "" + prefix = + case ns of + Value -> "the value " + Type -> "the type " + None -> "" + warnAndMonospace :: (MonadIO m, Outputable a) => Wrap a -> IfM m (DocH mod id) warnAndMonospace a = do let a' = showWrapped (showPpr dflags) a - tell ["Warning: " ++ prefix ++ "'" ++ a' ++ "' is out of scope.\n" ++ - " If you qualify the identifier, haddock can try to link it anyway."] + + -- If we have already warned for this identifier, don't warn again + firstWarn <- Set.notMember a' <$> gets ifeOutOfScopeNames + when firstWarn $ do + warn $ + "Warning: " ++ prefix ++ "'" ++ a' ++ "' is out of scope.\n" ++ + " If you qualify the identifier, haddock can try to link it anyway." + modify' (\env -> env { ifeOutOfScopeNames = Set.insert a' (ifeOutOfScopeNames env) }) + pure (monospaced a') monospaced = DocMonospaced . DocString @@ -205,25 +253,35 @@ -- Prefers local names primarily and type constructors or class names secondarily. -- -- Emits a warning if the 'GlobalRdrElts's don't belong to the same type or class. -ambiguous :: DynFlags - -> Wrap NsRdrName - -> [GlobalRdrElt] -- ^ More than one @gre@s sharing the same `RdrName` above. - -> ErrMsgM (Doc Name) +ambiguous + :: MonadIO m + => DynFlags + -> Wrap NsRdrName + -> [GlobalRdrElt] -- ^ More than one @gre@s sharing the same `RdrName` above. + -> IfM m (Doc Name) ambiguous dflags x gres = do - let noChildren = map availName (gresToAvailInfo gres) - dflt = maximumBy (comparing (isLocalName &&& isTyConName)) noChildren - msg = "Warning: " ++ showNsRdrName dflags x ++ " is ambiguous. It is defined\n" ++ - concatMap (\n -> " * " ++ defnLoc n ++ "\n") (map greMangledName gres) ++ - " You may be able to disambiguate the identifier by qualifying it or\n" ++ - " by specifying the type/value namespace explicitly.\n" ++ - " Defaulting to the one defined " ++ defnLoc dflt - -- TODO: Once we have a syntax for namespace qualification (#667) we may also - -- want to emit a warning when an identifier is a data constructor for a type - -- of the same name, but not the only constructor. - -- For example, for @data D = C | D@, someone may want to reference the @D@ - -- constructor. - when (length noChildren > 1) $ tell [msg] - pure (DocIdentifier (x $> dflt)) + let noChildren = map availName (gresToAvailInfo gres) + dflt = maximumBy (comparing (isLocalName &&& isTyConName)) noChildren + nameStr = showNsRdrName dflags x + msg = "Warning: " ++ nameStr ++ " is ambiguous. It is defined\n" ++ + concatMap (\n -> " * " ++ defnLoc n ++ "\n") (map greMangledName gres) ++ + " You may be able to disambiguate the identifier by qualifying it or\n" ++ + " by specifying the type/value namespace explicitly.\n" ++ + " Defaulting to the one defined " ++ defnLoc dflt + + -- TODO: Once we have a syntax for namespace qualification (#667) we may also + -- want to emit a warning when an identifier is a data constructor for a type + -- of the same name, but not the only constructor. + -- For example, for @data D = C | D@, someone may want to reference the @D@ + -- constructor. + + -- If we have already warned for this name, do not warn again + firstWarn <- Set.notMember nameStr <$> gets ifeAmbiguousNames + when (length noChildren > 1 && firstWarn) $ do + warn msg + modify' (\env -> env { ifeAmbiguousNames = Set.insert nameStr (ifeAmbiguousNames env) }) + + pure (DocIdentifier (x $> dflt)) where isLocalName (nameSrcLoc -> RealSrcLoc {}) = True isLocalName _ = False @@ -232,12 +290,19 @@ -- | Handle value-namespaced names that cannot be for values. -- -- Emits a warning that the value-namespace is invalid on a non-value identifier. -invalidValue :: DynFlags -> Wrap NsRdrName -> ErrMsgM (Doc a) +invalidValue :: MonadIO m => DynFlags -> Wrap NsRdrName -> IfM m (Doc a) invalidValue dflags x = do - tell ["Warning: " ++ showNsRdrName dflags x ++ " cannot be value, yet it is\n" ++ - " namespaced as such. Did you mean to specify a type namespace\n" ++ - " instead?"] - pure (DocMonospaced (DocString (showNsRdrName dflags x))) + let nameStr = showNsRdrName dflags x + + -- If we have already warned for this name, do not warn again + firstWarn <- Set.notMember nameStr <$> gets ifeInvalidValues + when firstWarn $ do + warn $ + "Warning: " ++ nameStr ++ " cannot be value, yet it is\n" ++ + " namespaced as such. Did you mean to specify a type namespace\n" ++ + " instead?" + modify' (\env -> env { ifeInvalidValues = Set.insert nameStr (ifeInvalidValues env) }) + pure (DocMonospaced (DocString (showNsRdrName dflags x))) -- | Printable representation of a wrapped and namespaced name showNsRdrName :: DynFlags -> Wrap NsRdrName -> String diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -1,6 +1,9 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + ---------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.Rename @@ -17,6 +20,7 @@ import Data.Traversable (mapM) +import Haddock.Backends.Hoogle (ppExportD) import Haddock.GhcUtils import Haddock.Types @@ -27,13 +31,14 @@ import GHC.Builtin.Types (eqTyCon_RDR) import Control.Applicative -import Control.Arrow ( first ) +import Control.DeepSeq (force) import Control.Monad hiding (mapM) -import Data.List (intercalate) -import qualified Data.Map as Map hiding ( Map ) +import Control.Monad.Reader +import Control.Monad.Writer.CPS +import Data.Foldable (traverse_) +import qualified Data.Map.Strict as Map import qualified Data.Set as Set import Prelude hiding (mapM) -import GHC.HsToCore.Docs import GHC.Types.Basic ( TopLevelFlag(..) ) -- | Traverse docstrings and ASTs in the Haddock interface, renaming 'Name' to @@ -44,164 +49,249 @@ -- -- The renamed output gets written into fields in the Haddock interface record -- that were previously left empty. -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 - -- env - let localEnv = foldl fn renamingEnv (ifaceVisibleExports iface) - where fn env name = Map.insert name (ifaceMod iface) env - - -- rename names in the exported declarations to point to things that - -- are closer to, or maybe even exported by, the current module. - (renamedExportItems, missingNames1) - = runRnFM localEnv (renameExportItems (ifaceExportItems iface)) - - (rnDocMap, missingNames2) = runRnFM localEnv (mapM renameDoc (ifaceDocMap iface)) - - (rnArgMap, missingNames3) = runRnFM localEnv (mapM (mapM renameDoc) (ifaceArgMap iface)) - - (renamedOrphanInstances, missingNames4) - = runRnFM localEnv (mapM renameDocInstance (ifaceOrphanInstances iface)) - - (finalModuleDoc, missingNames5) - = runRnFM localEnv (renameDocumentation (ifaceDoc iface)) - - -- combine the missing names and filter out the built-ins, which would - -- otherwise always be missing. - missingNames = nubByName id $ filter isExternalName -- XXX: isExternalName filters out too much - (missingNames1 ++ missingNames2 ++ missingNames3 - ++ missingNames4 ++ missingNames5) - - -- Filter out certain built in type constructors using their string - -- representation. - -- - -- 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 @~@). +renameInterface + :: DynFlags + -- ^ GHC session dyn flags + -> Map.Map (Maybe String) (Set.Set String) + -- ^ Ignored symbols. A map from module names to unqualified names. Module + -- 'Just M' mapping to name 'f' means that link warnings should not be + -- generated for occurances of specifically 'M.f'. Module 'Nothing' mapping to + -- name 'f' means that link warnings should not be generated for any 'f'. + -> LinkEnv + -- ^ Link environment. A map from 'Name' to 'Module', where name 'n' maps to + -- module 'M' if 'M' is the preferred link destination for name 'n'. + -> Bool + -- ^ Are warnings enabled? + -> Bool + -- ^ Is Hoogle output enabled? + -> Interface + -- ^ The interface we are renaming. + -> Ghc Interface + -- ^ The renamed interface. Note that there is nothing really special about + -- this being in the 'Ghc' monad. This could very easily be any 'MonadIO' or + -- even pure, depending on the link warnings are reported. +renameInterface dflags ignoreSet renamingEnv warnings hoogle iface = do + let (iface', warnedNames) = + runRnM + dflags + mdl + localLinkEnv + warnName + (hoogle && not (OptHide `elem` ifaceOptions iface)) + (renameInterfaceRn iface) + reportMissingLinks mdl warnedNames + return iface' + where + -- The current module + mdl :: Module + mdl = ifaceMod iface - qualifiedName n = (moduleNameString $ moduleName $ nameModule n) <> "." <> getOccString n + -- The local link environment, where every name exported by this module is + -- mapped to the module itself, and everything else comes from the global + -- renaming env + localLinkEnv :: LinkEnv + localLinkEnv = foldr f renamingEnv (ifaceVisibleExports iface) + where f name !env = Map.insert name mdl env - ignoreSet = Set.fromList ignoredSymbols + -- The function used to determine whether we should warn about a name + -- which we do not find in the renaming environment + warnName name = + -- Warnings must be enabled + warnings - strings = [ qualifiedName n + -- Current module must not be hidden from Haddock + && not (OptHide `elem` ifaceOptions iface) - | n <- missingNames - , not (qualifiedName n `Set.member` ignoreSet) - , not (isSystemName n) - , not (isBuiltInSyntax n) - , Exact n /= eqTyCon_RDR - ] + -- Must be an external name that is not built-in syntax, not a type + -- variable, and not '~' + && isExternalName name + && not (isBuiltInSyntax name) + && not (isTyVarName name) + && Exact name /= eqTyCon_RDR - in do - -- report things that we couldn't link to. Only do this for non-hidden - -- modules. - unless (OptHide `elem` ifaceOptions iface || null strings || not warnings) $ - tell ["Warning: " ++ moduleString (ifaceMod iface) ++ - ": could not find link destinations for:\n"++ - intercalate "\n\t- " ("" : strings) ] + -- Must not be in the set of ignored symbols for the module or the + -- unqualified ignored symbols + && not (getOccString name `Set.member` ignoreSet') + where + -- The set of ignored symbols within the module this name is located + -- in unioned with the set of globally ignored symbols + ignoreSet' :: Set.Set String + ignoreSet' = + Set.union + (Map.findWithDefault Set.empty (Just $ modString name) ignoreSet) + (Map.findWithDefault Set.empty Nothing ignoreSet) - return $ iface { ifaceRnDoc = finalModuleDoc, - ifaceRnDocMap = rnDocMap, - ifaceRnArgMap = rnArgMap, - ifaceRnExportItems = renamedExportItems, - ifaceRnOrphanInstances = renamedOrphanInstances} + modString :: Name -> String + modString = moduleString . nameModule +-- | Output warning messages indicating that the renamer could not find link +-- destinations for the names in the given set as they occur in the given +-- module. +reportMissingLinks :: Module -> Set.Set Name -> Ghc () +reportMissingLinks mdl names + | Set.null names = return () + | otherwise = + liftIO $ do + putStrLn $ "Warning: " ++ moduleString mdl ++ ": could not find link destinations for: " + traverse_ (putStrLn . ("\t- " ++) . qualifiedName) names + where + qualifiedName :: Name -> String + qualifiedName name = moduleString (nameModule name) ++ "." ++ getOccString name -------------------------------------------------------------------------------- -- Monad for renaming -------------------------------------------------------------------------------- - --- | The monad does two things for us: it passes around the environment for --- renaming, and it returns a list of names which couldn't be found in --- the environment. -newtype RnM a = - RnM { unRn :: (Name -> (Bool, DocName)) - -- Name lookup function. The 'Bool' indicates that if the name - -- was \"found\" in the environment. - - -> (a, [Name] -> [Name]) - -- Value returned, as well as a difference list of the names not - -- found - } +-- | A renaming monad which provides 'MonadReader' access to a renaming +-- environment, and 'MonadWriter' access to a 'Set' of names for which link +-- warnings should be generated, based on the renaming environment. +newtype RnM a = RnM { unRnM :: ReaderT RnMEnv (Writer (Set.Set Name)) a } + deriving newtype (Functor, Applicative, Monad, MonadReader RnMEnv, MonadWriter (Set.Set Name)) -instance Monad RnM where - m >>= k = RnM $ \lkp -> let (a, out1) = unRn m lkp - (b, out2) = unRn (k a) lkp - in (b, out1 . out2) +-- | The renaming monad environment. Stores the linking environment (mapping +-- names to modules), the link warning predicate, and the current module. +data RnMEnv = RnMEnv + { -- | The linking environment (map from names to modules) + rnLinkEnv :: LinkEnv -instance Functor RnM where - fmap f (RnM lkp) = RnM (first f . lkp) + -- | Link warning predicate (whether failing to find a link destination + -- for a given name should result in a warning) + , rnWarnName :: (Name -> Bool) -instance Applicative RnM where - pure a = RnM (const (a, id)) - mf <*> mx = RnM $ \lkp -> let (f, out1) = unRn mf lkp - (x, out2) = unRn mx lkp - in (f x, out1 . out2) + -- | The current module + , rnModuleString :: String --- | Look up a 'Name' in the renaming environment. -lookupRn :: Name -> RnM DocName -lookupRn name = RnM $ \lkp -> - case lkp name of - (False,maps_to) -> (maps_to, (name :)) - (True, maps_to) -> (maps_to, id) + -- | Should Hoogle output be generated for this module? + , rnHoogleOutput :: Bool --- | Look up a 'Name' in the renaming environment, but don't warn if you don't --- find the name. Prefer to use 'lookupRn' whenever possible. -lookupRnNoWarn :: Name -> RnM DocName -lookupRnNoWarn name = RnM $ \lkp -> (snd (lkp name), id) + -- | GHC Session DynFlags, necessary for Hoogle output generation + , rnDynFlags :: DynFlags + } --- | Run the renamer action using lookup in a 'LinkEnv' as the lookup function. --- Returns the renamed value along with a list of `Name`'s that could not be --- renamed because they weren't in the environment. -runRnFM :: LinkEnv -> RnM a -> (a, [Name]) -runRnFM env rn = let (x, dlist) = unRn rn lkp in (x, dlist []) +-- | Run the renamer action in a renaming environment built using the given +-- module, link env, and link warning predicate. Returns the renamed value along +-- with a set of 'Name's that were not renamed and should be warned for (i.e. +-- they satisfied the link warning predicate). +runRnM :: DynFlags -> Module -> LinkEnv -> (Name -> Bool) -> Bool -> RnM a -> (a, Set.Set Name) +runRnM dflags mdl linkEnv warnName hoogleOutput rn = + runWriter $ runReaderT (unRnM rn) rnEnv where - lkp n | isTyVarName n = (True, Undocumented n) - | otherwise = case Map.lookup n env of - Nothing -> (False, Undocumented n) - Just mdl -> (True, Documented n mdl) - + rnEnv :: RnMEnv + rnEnv = RnMEnv + { rnLinkEnv = linkEnv + , rnWarnName = warnName + , rnModuleString = moduleString mdl + , rnHoogleOutput = hoogleOutput + , rnDynFlags = dflags + } -------------------------------------------------------------------------------- -- Renaming -------------------------------------------------------------------------------- +-- | Rename an `Interface` in the renaming environment. +renameInterfaceRn :: Interface -> RnM Interface +renameInterfaceRn iface = do + exportItems <- renameExportItems (ifaceExportItems iface) + orphans <- mapM renameDocInstance (ifaceOrphanInstances iface) + finalModDoc <- renameDocumentation (ifaceDoc iface) + pure $! iface + { ifaceRnDoc = finalModDoc -rename :: Name -> RnM DocName -rename = lookupRn + -- The un-renamed export items are not used after renaming + , ifaceRnExportItems = exportItems + , ifaceExportItems = [] + -- The un-renamed orphan instances are not used after renaming + , ifaceRnOrphanInstances = orphans + , ifaceOrphanInstances = [] + } -renameL :: GenLocated l Name -> RnM (GenLocated l DocName) -renameL = mapM rename +-- | Lookup a 'Name' in the renaming environment. +lookupRn :: Name -> RnM DocName +lookupRn name = RnM $ do + linkEnv <- asks rnLinkEnv + case Map.lookup name linkEnv of + Nothing -> return $ Undocumented name + Just mdl -> return $ Documented name mdl +-- | Rename a 'Name' in the renaming environment. This is very similar to +-- 'lookupRn', but tracks any names not found in the renaming environment if the +-- `rnWarnName` predicate is true. +renameName :: Name -> RnM DocName +renameName name = do + warnName <- asks rnWarnName + docName <- lookupRn name + case docName of + Undocumented _ -> do + when (warnName name) $ + tell $ Set.singleton name + return docName + _ -> return docName + +-- | Rename a located 'Name' in the current renaming environment. +renameNameL :: GenLocated l Name -> RnM (GenLocated l DocName) +renameNameL = mapM renameName + +-- | Rename a list of export items in the current renaming environment. renameExportItems :: [ExportItem GhcRn] -> RnM [ExportItem DocNameI] renameExportItems = mapM renameExportItem +-- | Rename an 'ExportItem' in the current renaming environment. +renameExportItem :: ExportItem GhcRn -> RnM (ExportItem DocNameI) +renameExportItem item = case item of + ExportModule mdl -> return (ExportModule mdl) + ExportGroup lev id_ doc -> do + doc' <- renameDoc doc + return (ExportGroup lev id_ doc') + ExportDecl ed@(ExportD decl pats doc subs instances fixities splice) -> do + -- If Hoogle output should be generated, generate it + RnMEnv{..} <- ask + let !hoogleOut = force $ + if rnHoogleOutput then + ppExportD rnDynFlags ed + else + [] + decl' <- renameLDecl decl + pats' <- renamePats pats + doc' <- renameDocForDecl doc + subs' <- mapM renameSub subs + instances' <- forM instances renameDocInstance + fixities' <- forM fixities $ \(name, fixity) -> do + name' <- lookupRn name + return (name', fixity) + + return $ + ExportDecl RnExportD + { rnExpDExpD = ExportD decl' pats' doc' subs' instances' fixities' splice + , rnExpDHoogle = hoogleOut + } + ExportNoDecl x subs -> do + x' <- lookupRn x + subs' <- mapM lookupRn subs + return (ExportNoDecl x' subs') + ExportDoc doc -> do + doc' <- renameDoc doc + return (ExportDoc doc') + renameDocForDecl :: DocForDecl Name -> RnM (DocForDecl DocName) renameDocForDecl (doc, fnArgsDoc) = (,) <$> renameDocumentation doc <*> renameFnArgsDoc fnArgsDoc - renameDocumentation :: Documentation Name -> RnM (Documentation DocName) renameDocumentation (Documentation mDoc mWarning) = Documentation <$> mapM renameDoc mDoc <*> mapM renameDoc mWarning - renameLDocHsSyn :: Located (WithHsDocIdentifiers HsDocString a) -> RnM (Located (WithHsDocIdentifiers HsDocString b)) renameLDocHsSyn (L l doc) = return (L l (WithHsDocIdentifiers (hsDocString doc) [])) - renameDoc :: Traversable t => t (Wrap Name) -> RnM (t (Wrap DocName)) -renameDoc = traverse (traverse rename) +renameDoc = traverse (traverse renameName) renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName) renameFnArgsDoc = mapM renameDoc - renameLType :: LHsType GhcRn -> RnM (LHsType DocNameI) renameLType = mapM renameType @@ -236,8 +326,8 @@ renameInjectivityAnn :: LInjectivityAnn GhcRn -> RnM (LInjectivityAnn DocNameI) renameInjectivityAnn (L loc (InjectivityAnn _ lhs rhs)) - = do { lhs' <- renameL lhs - ; rhs' <- mapM renameL rhs + = do { lhs' <- renameNameL lhs + ; rhs' <- mapM renameNameL rhs ; return (L loc (InjectivityAnn noExtField lhs' rhs')) } renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn GhcRn) @@ -263,7 +353,7 @@ ltype' <- renameLType ltype return (HsQualTy { hst_xqual = noAnn, hst_ctxt = lcontext', hst_body = ltype' }) - HsTyVar _ ip (L l n) -> return . HsTyVar noAnn ip . L l =<< rename n + HsTyVar _ ip (L l n) -> return . HsTyVar noAnn ip . L l =<< renameName n HsBangTy _ b ltype -> return . HsBangTy noAnn b =<< renameLType ltype HsStarTy _ isUni -> return (HsStarTy noAnn isUni) @@ -291,7 +381,7 @@ HsSumTy _ ts -> HsSumTy noAnn <$> mapM renameLType ts HsOpTy _ prom a (L loc op) b -> do - op' <- rename op + op' <- renameName op a' <- renameLType a b' <- renameLType b return (HsOpTy noAnn prom a' (L loc op') b') @@ -346,10 +436,10 @@ renameLTyVarBndr :: LHsTyVarBndr flag GhcRn -> RnM (LHsTyVarBndr flag DocNameI) renameLTyVarBndr (L loc (UserTyVar _ fl (L l n))) - = do { n' <- rename n + = do { n' <- renameName n ; return (L loc (UserTyVar noExtField fl (L l n'))) } renameLTyVarBndr (L loc (KindedTyVar _ fl (L lv n) kind)) - = do { n' <- rename n + = do { n' <- renameName n ; kind' <- renameLKind kind ; return (L loc (KindedTyVar noExtField fl (L lv n') kind')) } @@ -360,7 +450,7 @@ renameInstHead :: InstHead GhcRn -> RnM (InstHead DocNameI) renameInstHead InstHead {..} = do - cname <- rename ihdClsName + cname <- renameName ihdClsName types <- mapM renameType ihdTypes itype <- case ihdInstType of ClassInst { .. } -> ClassInst @@ -415,14 +505,14 @@ return (FamDecl { tcdFExt = noExtField, tcdFam = decl' }) SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdRhs = rhs } -> do - lname' <- renameL lname + lname' <- renameNameL lname tyvars' <- renameLHsQTyVars tyvars rhs' <- renameLType rhs return (SynDecl { tcdSExt = noExtField, tcdLName = lname', tcdTyVars = tyvars' , tcdFixity = fixity, tcdRhs = rhs' }) DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn } -> do - lname' <- renameL lname + lname' <- renameNameL lname tyvars' <- renameLHsQTyVars tyvars defn' <- renameDataDefn defn return (DataDecl { tcdDExt = noExtField, tcdLName = lname', tcdTyVars = tyvars' @@ -432,7 +522,7 @@ , tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars, tcdFixity = fixity , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do lcontext' <- traverse renameLContext lcontext - lname' <- renameL lname + lname' <- renameNameL lname ltyvars' <- renameLHsQTyVars ltyvars lfundeps' <- mapM renameLFunDep lfundeps lsigs' <- mapM renameLSig lsigs @@ -449,8 +539,8 @@ where renameLFunDep :: LHsFunDep GhcRn -> RnM (LHsFunDep DocNameI) renameLFunDep (L loc (FunDep _ xs ys)) = do - xs' <- mapM rename (map unLoc xs) - ys' <- mapM rename (map unLoc ys) + xs' <- mapM renameName (map unLoc xs) + ys' <- mapM renameName (map unLoc ys) return (L (locA loc) (FunDep noExtField (map noLocA xs') (map noLocA ys'))) renameLSig (L loc sig) = return . L (locA loc) =<< renameSig sig @@ -467,7 +557,7 @@ , fdResultSig = result , fdInjectivityAnn = injectivity }) = do info' <- renameFamilyInfo info - lname' <- renameL lname + lname' <- renameNameL lname ltyvars' <- renameLHsQTyVars ltyvars result' <- renameFamilyResultSig result injectivity' <- renameMaybeInjectivityAnn injectivity @@ -483,7 +573,7 @@ -> RnM (PseudoFamilyDecl DocNameI) renamePseudoFamilyDecl (PseudoFamilyDecl { .. }) = PseudoFamilyDecl <$> renameFamilyInfo pfdInfo - <*> renameL pfdLName + <*> renameNameL pfdLName <*> mapM renameLType pfdTyVars <*> renameFamilyResultSig pfdKindSig @@ -512,7 +602,7 @@ , con_mb_cxt = lcontext, con_args = details , con_doc = mbldoc , con_forall = forall_ }) = do - lname' <- renameL lname + lname' <- renameNameL lname ltyvars' <- mapM renameLTyVarBndr ltyvars lcontext' <- traverse renameLContext lcontext details' <- renameH98Details details @@ -527,7 +617,7 @@ , con_mb_cxt = lcontext, con_g_args = details , con_res_ty = res_ty , con_doc = mbldoc } = do - lnames' <- mapM renameL lnames + lnames' <- mapM renameNameL lnames bndrs' <- mapM renameOuterTyVarBndrs bndrs lcontext' <- traverse renameLContext lcontext details' <- renameGADTDetails details @@ -570,28 +660,28 @@ renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI) renameLFieldOcc (L l (FieldOcc sel lbl)) = do - sel' <- rename sel + sel' <- renameName sel return $ L l (FieldOcc sel' lbl) renameSig :: Sig GhcRn -> RnM (Sig DocNameI) renameSig sig = case sig of TypeSig _ lnames ltype -> do - lnames' <- mapM renameL lnames + lnames' <- mapM renameNameL lnames ltype' <- renameLSigWcType ltype return (TypeSig noExtField lnames' ltype') ClassOpSig _ is_default lnames sig_ty -> do - lnames' <- mapM renameL lnames + lnames' <- mapM renameNameL lnames ltype' <- renameLSigType sig_ty return (ClassOpSig noExtField is_default lnames' ltype') PatSynSig _ lnames sig_ty -> do - lnames' <- mapM renameL lnames + lnames' <- mapM renameNameL lnames sig_ty' <- renameLSigType sig_ty return $ PatSynSig noExtField lnames' sig_ty' FixSig _ (FixitySig _ lnames fixity) -> do - lnames' <- mapM renameL lnames + lnames' <- mapM renameNameL lnames return $ FixSig noExtField (FixitySig noExtField lnames' fixity) MinimalSig _ (L l s) -> do - s' <- traverse (traverse lookupRnNoWarn) s + s' <- traverse (traverse lookupRn) s return $ MinimalSig noExtField (L l s') -- we have filtered out all other kinds of signatures in Interface.Create _ -> error "expected TypeSig" @@ -599,11 +689,11 @@ renameForD :: ForeignDecl GhcRn -> RnM (ForeignDecl DocNameI) renameForD (ForeignImport _ lname ltype x) = do - lname' <- renameL lname + lname' <- renameNameL lname ltype' <- renameLSigType ltype return (ForeignImport noExtField lname' ltype' (renameForI x)) renameForD (ForeignExport _ lname ltype x) = do - lname' <- renameL lname + lname' <- renameNameL lname ltype' <- renameLSigType ltype return (ForeignExport noExtField lname' ltype' (renameForE x)) @@ -664,7 +754,7 @@ renameTyFamInstEqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs , feqn_pats = pats, feqn_fixity = fixity , feqn_rhs = rhs }) - = do { tc' <- renameL tc + = do { tc' <- renameNameL tc ; bndrs' <- renameOuterTyVarBndrs bndrs ; pats' <- mapM renameLTypeArg pats ; rhs' <- renameLType rhs @@ -689,7 +779,7 @@ rename_data_fam_eqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs , feqn_pats = pats, feqn_fixity = fixity , feqn_rhs = defn }) - = do { tc' <- renameL tc + = do { tc' <- renameNameL tc ; bndrs' <- renameOuterTyVarBndrs bndrs ; pats' <- mapM renameLTypeArg pats ; defn' <- renameDataDefn defn @@ -718,37 +808,12 @@ renameDocInstance :: DocInstance GhcRn -> RnM (DocInstance DocNameI) renameDocInstance (inst, idoc, L l n, m) = do inst' <- renameInstHead inst - n' <- rename n + n' <- renameName n idoc' <- mapM renameDoc idoc return (inst', idoc', L l n', m) -renameExportItem :: ExportItem GhcRn -> RnM (ExportItem DocNameI) -renameExportItem item = case item of - ExportModule mdl -> return (ExportModule mdl) - ExportGroup lev id_ doc -> do - doc' <- renameDoc doc - return (ExportGroup lev id_ doc') - ExportDecl decl pats doc subs instances fixities splice -> do - decl' <- renameLDecl decl - pats' <- renamePats pats - doc' <- renameDocForDecl doc - subs' <- mapM renameSub subs - instances' <- forM instances renameDocInstance - fixities' <- forM fixities $ \(name, fixity) -> do - name' <- lookupRn name - return (name', fixity) - return (ExportDecl decl' pats' doc' subs' instances' fixities' splice) - ExportNoDecl x subs -> do - x' <- lookupRn x - subs' <- mapM lookupRn subs - return (ExportNoDecl x' subs') - ExportDoc doc -> do - doc' <- renameDoc doc - return (ExportDoc doc') - - renameSub :: (Name, DocForDecl Name) -> RnM (DocName, DocForDecl DocName) renameSub (n,doc) = do - n' <- rename n + n' <- renameName n doc' <- renameDocForDecl doc return (n', doc') diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -75,7 +75,7 @@ mkPackageInterfaces piVisibility InterfaceFile { ifPackageInfo , ifInstalledIfaces - } = + } = PackageInterfaces { piPackageInfo = ifPackageInfo , piVisibility , piInstalledInterfaces = ifInstalledIfaces diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs --- a/src/Haddock/Options.hs +++ b/src/Haddock/Options.hs @@ -45,6 +45,11 @@ import qualified Data.Char as Char +import Data.List (dropWhileEnd) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set import Data.Version import Control.Applicative import GHC.Data.FastString @@ -353,8 +358,41 @@ Left e -> throwE e Right v -> v -ignoredSymbols :: [Flag] -> [String] -ignoredSymbols flags = [ symbol | Flag_IgnoreLinkSymbol symbol <- flags ] +-- | Get the ignored symbols from the given flags. These are the symbols for +-- which no link warnings will be generated if their link destinations cannot be +-- determined. +-- +-- Symbols may be provided as qualified or unqualified names (e.g. +-- 'Data.Map.dropWhileEnd' or 'dropWhileEnd', resp). If qualified, no link +-- warnings will be produced for occurances of that name when it is imported +-- from that module. If unqualified, no link warnings will be produced for any +-- occurances of that name from any module. +ignoredSymbols :: [Flag] -> Map (Maybe String) (Set String) +ignoredSymbols flags = + foldr addToMap Map.empty [ splitSymbol symbol | Flag_IgnoreLinkSymbol symbol <- flags ] + where + -- Split a symbol into its module name and unqualified name, producing + -- 'Nothing' for the module name if the given symbol is already unqualified + splitSymbol :: String -> (Maybe String, String) + splitSymbol s = + -- Drop the longest suffix not containing a '.' character + case dropWhileEnd (/= '.') s of + + -- If the longest suffix is empty, there was no '.'. + -- Assume it is an unqualified name (no module string). + "" -> (Nothing, s) + + -- If the longest suffix is not empty, there was a '.'. + -- Assume it is a qualified name. `s'` will be the module string followed + -- by the last '.', e.g. "Data.List.", so take `init s'` as the module + -- string. Drop the length of `s'` from the original string `s` to + -- obtain to the unqualified name. + s' -> (Just $ init s', drop (length s') s) + + -- Add a (module name, name) pair to the map from modules to their ignored + -- symbols + addToMap :: (Maybe String, String) -> Map (Maybe String) (Set String) -> Map (Maybe String) (Set String) + addToMap (m, name) symbs = Map.insertWith (Set.union) m (Set.singleton name) symbs ghcFlags :: [Flag] -> [String] ghcFlags flags = [ option | Flag_OptGhc option <- flags ] diff --git a/src/Haddock/Syb.hs b/src/Haddock/Syb.hs --- a/src/Haddock/Syb.hs +++ b/src/Haddock/Syb.hs @@ -4,15 +4,15 @@ {-# LANGUAGE ScopedTypeVariables #-} module Haddock.Syb - ( everything, everythingButType, everythingWithState - , everywhere, everywhereButType - , mkT, mkQ, extQ - , combine + ( everythingWithState + , everywhereButType + , mkT + , mkQ + , extQ ) where import Data.Data -import Control.Applicative import Data.Maybe import Data.Foldable @@ -21,34 +21,6 @@ isType :: forall a b. (Typeable a, Typeable b) => b -> Bool isType _ = isJust $ eqT @a @b --- | Perform a query on each level of a tree. --- --- This is stolen directly from SYB package and copied here to not introduce --- additional dependencies. -everything :: (r -> r -> r) - -> (forall a. Data a => a -> r) - -> (forall a. Data a => a -> r) -everything k f x = foldl' k (f x) (gmapQ (everything k f) x) - --- | Variation of "everything" with an added stop condition --- Just like 'everything', this is stolen from SYB package. -everythingBut :: (r -> r -> r) - -> (forall a. Data a => a -> (r, Bool)) - -> (forall a. Data a => a -> r) -everythingBut k f x = let (v, stop) = f x - in if stop - then v - else foldl' k v (gmapQ (everythingBut k f) x) - --- | Variation of "everything" that does not recurse into children of type t --- requires AllowAmbiguousTypes -everythingButType :: - forall t r. (Typeable t) - => (r -> r -> r) - -> (forall a. Data a => a -> r) - -> (forall a. Data a => a -> r) -everythingButType k f = everythingBut k $ (,) <$> f <*> isType @t - -- | Perform a query with state on each level of a tree. -- -- This is the same as 'everything' but allows for stateful computations. In @@ -61,12 +33,6 @@ let (r, s') = f x s in foldl' k r (gmapQ (everythingWithState s' k f) x) --- | Apply transformation on each level of a tree. --- --- Just like 'everything', this is stolen from SYB package. -everywhere :: (forall a. Data a => a -> a) -> (forall a. Data a => a -> a) -everywhere f = f . gmapT (everywhere f) - -- | Variation on everywhere with an extra stop condition -- Just like 'everything', this is stolen from SYB package. everywhereBut :: (forall a. Data a => a -> Bool) @@ -105,9 +71,3 @@ -- Another function stolen from SYB package. extQ :: (Typeable a, Typeable b) => (a -> q) -> (b -> q) -> a -> q extQ f g a = maybe (f a) g (cast a) - --- | Combine two queries into one using alternative combinator. -combine :: Alternative f => (forall a. Data a => a -> f r) - -> (forall a. Data a => a -> f r) - -> (forall a. Data a => a -> f r) -combine f g x = f x <|> g x diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -1,4 +1,10 @@ -{-# LANGUAGE CPP, DeriveDataTypeable, DeriveTraversable, StandaloneDeriving, TypeFamilies, RecordWildCards #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -30,22 +36,23 @@ , HsDocString, LHsDocString , Fixity(..) , module Documentation.Haddock.Types - - -- $ Reexports - , runWriter - , tell ) where import Control.DeepSeq import Control.Exception (throw) import Control.Monad.Catch -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Writer.Strict (Writer, WriterT, MonadWriter(..), lift, runWriter, runWriterT) +import Control.Monad.State.Strict import Data.Typeable (Typeable) import Data.Map (Map) import Data.Data (Data) +import qualified Data.Set as Set import Documentation.Haddock.Types +import qualified GHC.Data.Strict as Strict import GHC.Types.Fixity (Fixity(..)) +import GHC.Types.Name (stableNameCmp) +import GHC.Types.Name.Reader (RdrName(..)) +import GHC.Types.SourceText (SourceText(..)) +import GHC.Types.SrcLoc (BufSpan(..), BufPos(..)) import GHC.Types.Var (Specificity) import GHC @@ -64,17 +71,17 @@ type DocMap a = Map Name (MDoc a) type ArgMap a = Map Name (Map Int (MDoc a)) type SubMap = Map Name [Name] -type DeclMap = Map Name [LHsDecl GhcRn] +type DeclMap = Map Name DeclMapEntry type InstMap = Map RealSrcSpan Name type FixMap = Map Name Fixity type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources +type WarningMap = Map Name (Doc Name) ----------------------------------------------------------------------------- --- * Interface +-- * Interfaces and Interface creation ----------------------------------------------------------------------------- - -- | 'Interface' holds all information used to render a single Haddock page. -- It represents the /interface/ of a module. The core business of Haddock -- lies in creating this structure. Note that the record contains some fields @@ -101,63 +108,55 @@ , ifaceRnDoc :: !(Documentation DocName) -- | Haddock options for this module (prune, ignore-exports, etc). - , ifaceOptions :: ![DocOption] + , ifaceOptions :: [DocOption] -- | Declarations originating from the module. Excludes declarations without -- names (instances and stand-alone documentation comments). Includes -- names of subordinate declarations mapped to their parent declarations. - , ifaceDeclMap :: !(Map Name [LHsDecl GhcRn]) + , ifaceDeclMap :: !DeclMap -- | Documentation of declarations originating from the module (including -- subordinates). , ifaceDocMap :: !(DocMap Name) , ifaceArgMap :: !(ArgMap Name) - -- | Documentation of declarations originating from the module (including - -- subordinates). - , ifaceRnDocMap :: !(DocMap DocName) - , ifaceRnArgMap :: !(ArgMap DocName) - , ifaceFixMap :: !(Map Name Fixity) - , ifaceExportItems :: ![ExportItem GhcRn] - , ifaceRnExportItems :: ![ExportItem DocNameI] + , ifaceExportItems :: [ExportItem GhcRn] + , ifaceRnExportItems :: [ExportItem DocNameI] -- | All names exported by the module. - , ifaceExports :: ![Name] + , ifaceExports :: [Name] -- | All \"visible\" names exported by the module. -- A visible name is a name that will show up in the documentation of the -- module. - , ifaceVisibleExports :: ![Name] + , ifaceVisibleExports :: [Name] -- | Aliases of module imports as in @import A.B.C as C@. , ifaceModuleAliases :: !AliasMap -- | Instances exported by the module. - , ifaceInstances :: ![ClsInst] - , ifaceFamInstances :: ![FamInst] + , ifaceInstances :: [HaddockClsInst] -- | Orphan instances - , ifaceOrphanInstances :: ![DocInstance GhcRn] - , ifaceRnOrphanInstances :: ![DocInstance DocNameI] + , ifaceOrphanInstances :: [DocInstance GhcRn] + , ifaceRnOrphanInstances :: [DocInstance DocNameI] -- | The number of haddockable and haddocked items in the module, as a -- tuple. Haddockable items are the exports and the module itself. - , ifaceHaddockCoverage :: !(Int, Int) + , ifaceHaddockCoverage :: (Int, Int) -- | Warnings for things defined in this module. - , ifaceWarningMap :: !WarningMap + , ifaceWarningMap :: WarningMap -- | Tokenized source code of module (available if Haddock is invoked with -- source generation flag). , ifaceHieFile :: !(Maybe FilePath) + , ifaceDynFlags :: !DynFlags } -type WarningMap = Map Name (Doc Name) - - -- | A subset of the fields of 'Interface' that we store in the interface -- files. data InstalledInterface = InstalledInterface @@ -191,7 +190,6 @@ , instFixMap :: Map Name Fixity } - -- | Convert an 'Interface' to an 'InstalledInterface' toInstalledIface :: Interface -> InstalledInterface toInstalledIface interface = InstalledInterface @@ -207,40 +205,81 @@ } ------------------------------------------------------------------------------ --- * Export items & declarations ------------------------------------------------------------------------------ +-- | A monad in which we create Haddock interfaces. Not to be confused with +-- `GHC.Tc.Types.IfM` which is used to write GHC interfaces. +-- +-- In the past `createInterface` was running in the `Ghc` monad but proved hard +-- to sustain as soon as we moved over for Haddock to be a plugin. Also abstracting +-- over the Ghc specific clarifies where side effects happen. +newtype IfM m a = IfM { unIfM :: StateT (IfEnv m) m a } +deriving newtype instance Functor m => Functor (IfM m) +deriving newtype instance (Monad m, Applicative m) => Applicative (IfM m) +deriving newtype instance Monad m => Monad (IfM m) +deriving newtype instance MonadIO m => MonadIO (IfM m) +deriving newtype instance Monad m => MonadState (IfEnv m) (IfM m) -data ExportItem name +-- | Interface creation environment. The name sets are used primarily during +-- processing of doc strings to avoid emitting the same type of warning for the +-- same name twice. This was previously done using a Writer monad and then +-- nubbing the list of warning messages after accumulation. This new approach +-- was implemented to avoid the nubbing of potentially large lists of strings. +data IfEnv m = IfEnv + { + -- | Lookup names in the environment. + ifeLookupName :: Name -> m (Maybe TyThing) - -- | An exported declaration. - = ExportDecl + -- | Names which we have warned about for being out of scope + , ifeOutOfScopeNames :: !(Set.Set String) + + -- | Names which we have warned about for being ambiguous + , ifeAmbiguousNames :: !(Set.Set String) + + -- | Named which we have warned about for being inappropriately namespaced + -- as values + , ifeInvalidValues :: !(Set.Set String) + } + +-- | Run an `IfM` action. +runIfM + :: (Monad m) + -- | Lookup a global name in the current session. Used in cases + -- where declarations don't + => (Name -> m (Maybe TyThing)) + -- | The action to run. + -> IfM m a + -- | Result and accumulated error/warning messages. + -> m a +runIfM lookup_name action = do + let + if_env = IfEnv { - -- | A declaration. - expItemDecl :: !(LHsDecl name) + ifeLookupName = lookup_name + , ifeOutOfScopeNames = Set.empty + , ifeAmbiguousNames = Set.empty + , ifeInvalidValues = Set.empty + } + evalStateT (unIfM action) if_env - -- | Bundled patterns for a data type declaration - , expItemPats :: ![(HsDecl name, DocForDecl (IdP name))] +-- | Look up a name in the current environment +lookupName :: Monad m => Name -> IfM m (Maybe TyThing) +lookupName name = IfM $ do + lookup_name <- gets ifeLookupName + lift (lookup_name name) - -- | Maybe a doc comment, and possibly docs for arguments (if this - -- decl is a function or type-synonym). - , expItemMbDoc :: !(DocForDecl (IdP name)) +-- | Very basic logging function that simply prints to stdout +warn :: MonadIO m => String -> IfM m () +warn msg = liftIO $ putStrLn msg - -- | Subordinate names, possibly with documentation. - , expItemSubDocs :: ![(IdP name, DocForDecl (IdP name))] +----------------------------------------------------------------------------- +-- * Export items & declarations +----------------------------------------------------------------------------- - -- | Instances relevant to this declaration, possibly with - -- documentation. - , expItemInstances :: ![DocInstance name] - -- | Fixity decls relevant to this declaration (including subordinates). - , expItemFixities :: ![(IdP name, Fixity)] +data ExportItem name - -- | Whether the ExportItem is from a TH splice or not, for generating - -- the appropriate type of Source link. - , expItemSpliced :: !Bool - } + -- | An exported declaration. + = ExportDecl (XExportDecl name) -- | An exported entity for which we have no documentation (perhaps because it -- resides in another package). @@ -248,7 +287,7 @@ { expItemName :: !(IdP name) -- | Subordinate names. - , expItemSubs :: ![IdP name] + , expItemSubs :: [IdP name] } -- | A section heading. @@ -270,22 +309,106 @@ -- | A cross-reference to another module. | ExportModule !Module +-- | A type family mapping a name type index to types of export declarations. +-- The pre-renaming type index ('GhcRn') is mapped to the type of export +-- declarations which do not include Hoogle output ('ExportD'), since Hoogle output is +-- generated during the Haddock renaming step. The post-renaming type index +-- ('DocNameI') is mapped to the type of export declarations which do include +-- Hoogle output ('RnExportD'). +type family XExportDecl x where + XExportDecl GhcRn = ExportD GhcRn + XExportDecl DocNameI = RnExportD + +-- | Represents an export declaration that Haddock has discovered to be exported +-- from a module. The @name@ index indicated whether the declaration has been +-- renamed such that each 'Name' points to it's optimal link destination. +data ExportD name = ExportD + { + -- | A declaration. + expDDecl :: !(LHsDecl name) + + -- | Bundled patterns for a data type declaration + , expDPats :: [(HsDecl name, DocForDecl (IdP name))] + + -- | Maybe a doc comment, and possibly docs for arguments (if this + -- decl is a function or type-synonym). + , expDMbDoc :: !(DocForDecl (IdP name)) + + -- | Subordinate names, possibly with documentation. + , expDSubDocs :: [(IdP name, DocForDecl (IdP name))] + + -- | Instances relevant to this declaration, possibly with + -- documentation. + , expDInstances :: [DocInstance name] + + -- | Fixity decls relevant to this declaration (including subordinates). + , expDFixities :: [(IdP name, Fixity)] + + -- | Whether the ExportD is from a TH splice or not, for generating + -- the appropriate type of Source link. + , expDSpliced :: !Bool + } + +-- | Represents export declarations that have undergone renaming such that every +-- 'Name' in the declaration points to an optimal link destination. Since Hoogle +-- output is also generated during the renaming step, each declaration is also +-- attached to its Hoogle textual database entries, /if/ Hoogle output is +-- enabled and the module is not hidden in the generated documentation using the +-- @{-# OPTIONS_HADDOCK hide #-}@ pragma. +data RnExportD = RnExportD + { + -- | The renamed export declaration + rnExpDExpD :: !(ExportD DocNameI) + + -- | If Hoogle textbase (textual database) output is enabled, the text + -- output lines for this declaration. If Hoogle output is not enabled, the + -- list will be empty. + , rnExpDHoogle :: [String] + } + data Documentation name = Documentation - { documentationDoc :: Maybe (MDoc name) - , documentationWarning :: !(Maybe (Doc name)) + { documentationDoc :: Maybe (MDoc name) + , documentationWarning :: Maybe (Doc name) } deriving Functor +instance NFData name => NFData (Documentation name) where + rnf (Documentation d w) = d `deepseq` w `deepseq` () -- | Arguments and result are indexed by Int, zero-based from the left, -- because that's the easiest to use when recursing over types. type FnArgsDoc name = Map Int (MDoc name) type DocForDecl name = (Documentation name, FnArgsDoc name) - noDocForDecl :: DocForDecl name noDocForDecl = (Documentation Nothing Nothing, mempty) +-- | As we build the declaration map, we really only care to track whether we +-- have only seen a value declaration for a 'Name', or anything else. This type +-- is used to represent those cases. If the only declaration attached to a +-- 'Name' is a 'ValD', we will consult the GHC interface file to determine the +-- type of the value, and attach the 'SrcSpan' from the 'EValD' constructor to +-- it. If we see any other type of declaration for the 'Name', we can just use +-- it. +-- +-- This type saves us from storing /every/ declaration we see for a given 'Name' +-- in the map, which is unnecessary and very problematic for overall memory +-- usage. +data DeclMapEntry + = EValD !SrcSpan + | EOther (LHsDecl GhcRn) +instance Semigroup DeclMapEntry where + (EValD _) <> e = e + e <> _ = e + +-- | Transform a declaration into a 'DeclMapEntry'. If it is a 'ValD' +-- declaration, only the source location will be noted (since that is all we +-- care to store in the 'DeclMap' due to the way top-level bindings with no type +-- signatures are handled). Otherwise, the entire declaration will be kept. +toDeclMapEntry :: LHsDecl GhcRn -> DeclMapEntry +toDeclMapEntry (L l (ValD _ _)) = EValD (locA l) +toDeclMapEntry d = EOther d + ----------------------------------------------------------------------------- -- * Cross-referencing ----------------------------------------------------------------------------- @@ -300,6 +423,9 @@ , rdrName :: !RdrName } +instance NFData NsRdrName where + rnf (NsRdrName ns rdrN) = ns `seq` rdrN `deepseq` () + -- | Extends 'Name' with cross-reference information. data DocName = Documented Name Module @@ -360,6 +486,12 @@ | Backticked { unwrap :: n } -- ^ add backticks around the name deriving (Show, Functor, Foldable, Traversable) +instance NFData n => NFData (Wrap n) where + rnf w = case w of + Unadorned n -> rnf n + Parenthesized n -> rnf n + Backticked n -> rnf n + -- | Useful for debugging instance Outputable n => Outputable (Wrap n) where ppr (Unadorned n) = ppr n @@ -379,6 +511,58 @@ -- * Instances ----------------------------------------------------------------------------- +data HaddockClsInst = HaddockClsInst + { haddockClsInstPprHoogle :: Maybe String + , haddockClsInstName :: Name + , haddockClsInstClsName :: Name + , haddockClsInstIsOrphan :: Bool + , haddockClsInstHead :: ([Int], SName, [SimpleType]) + , haddockClsInstSynified :: InstHead GhcRn + , haddockClsInstTyNames :: Set.Set Name + } + +-- | TODO: This instance is not lawful. We leave the 'InstHead' segment of the +-- class instance evaluated only to WHNF. This should probably be fixed. +instance NFData HaddockClsInst where + rnf (HaddockClsInst h n cn o hd s ns) = + h + `deepseq` n + `deepseq` cn + `deepseq` o + `deepseq` hd + `deepseq` s + `seq` ns + `deepseq` () + +-- | Stable name for stable comparisons. GHC's `Name` uses unstable +-- ordering based on their `Unique`'s. +newtype SName = SName Name + deriving newtype NFData + +instance Eq SName where + SName n1 == SName n2 = n1 `stableNameCmp` n2 == EQ + +instance Ord SName where + SName n1 `compare` SName n2 = n1 `stableNameCmp` n2 + +-- | Simplified type for sorting types, ignoring qualification (not visible +-- in Haddock output) and unifying special tycons with normal ones. +-- For the benefit of the user (looks nice and predictable) and the +-- tests (which prefer output to be deterministic). +data SimpleType = SimpleType SName [SimpleType] + | SimpleIntTyLit Integer + | SimpleStringTyLit String + | SimpleCharTyLit Char + deriving (Eq,Ord) + +instance NFData SimpleType where + rnf st = + case st of + SimpleType sn sts -> sn `deepseq` sts `deepseq` () + SimpleIntTyLit i -> rnf i + SimpleStringTyLit s -> rnf s + SimpleCharTyLit c -> rnf c + -- | The three types of instances data InstType name = ClassInst @@ -472,6 +656,12 @@ type DocMarkup id a = DocMarkupH (Wrap (ModuleName, OccName)) id a +instance NFData Meta where + rnf (Meta v p) = v `deepseq` p `deepseq` () + +instance NFData id => NFData (MDoc id) where + rnf (MetaDoc m d) = m `deepseq` d `deepseq` () + instance (NFData a, NFData mod) => NFData (DocH mod a) where rnf doc = case doc of @@ -535,6 +725,21 @@ exampleToString (Example expression result) = ">>> " ++ expression ++ "\n" ++ unlines result +instance NFData name => NFData (HaddockModInfo name) where + rnf (HaddockModInfo{..}) = + hmi_description + `deepseq` hmi_copyright + `deepseq` hmi_license + `deepseq` hmi_maintainer + `deepseq` hmi_stability + `deepseq` hmi_portability + `deepseq` hmi_safety + `deepseq` hmi_language + `deepseq` hmi_extensions + `deepseq` () + +instance NFData LangExt.Extension + data HaddockModInfo name = HaddockModInfo { hmi_description :: Maybe (Doc name) , hmi_copyright :: Maybe String @@ -547,7 +752,6 @@ , hmi_extensions :: [LangExt.Extension] } - emptyHaddockModInfo :: HaddockModInfo a emptyHaddockModInfo = HaddockModInfo { hmi_description = Nothing @@ -635,24 +839,12 @@ -- * Error handling ----------------------------------------------------------------------------- - --- A monad which collects error messages, locally defined to avoid a dep on mtl - - -type ErrMsg = String -type ErrMsgM = Writer [ErrMsg] - - --- Exceptions - - -- | Haddock's own exception type. 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] @@ -670,29 +862,6 @@ ) . handle (throwM . WithContext [ctxt]) --- In "Haddock.Interface.Create", we need to gather --- @Haddock.Types.ErrMsg@s a lot, like @ErrMsgM@ does, --- but we can't just use @GhcT ErrMsgM@ because GhcT requires the --- transformed monad to be MonadIO. -newtype ErrMsgGhc a = ErrMsgGhc { unErrMsgGhc :: WriterT [ErrMsg] Ghc a } - - -deriving newtype instance Functor ErrMsgGhc -deriving newtype instance Applicative ErrMsgGhc -deriving newtype instance Monad ErrMsgGhc -deriving newtype instance (MonadWriter [ErrMsg]) ErrMsgGhc -deriving newtype instance MonadIO ErrMsgGhc - - -runWriterGhc :: ErrMsgGhc a -> Ghc (a, [ErrMsg]) -runWriterGhc = runWriterT . unErrMsgGhc - -liftGhcToErrMsgGhc :: Ghc a -> ErrMsgGhc a -liftGhcToErrMsgGhc = ErrMsgGhc . lift - -liftErrMsg :: ErrMsgM a -> ErrMsgGhc a -liftErrMsg = writer . runWriter - ----------------------------------------------------------------------------- -- * Pass sensitive types ----------------------------------------------------------------------------- @@ -850,3 +1019,124 @@ type instance XCFunDep DocNameI = NoExtField type instance XCTyFamInstDecl DocNameI = NoExtField + +----------------------------------------------------------------------------- +-- * NFData instances for GHC types +----------------------------------------------------------------------------- + +instance NFData RdrName where + rnf (Unqual on) = rnf on + rnf (Qual mn on) = mn `deepseq` on `deepseq` () + rnf (Orig m on) = m `deepseq` on `deepseq` () + rnf (Exact n) = rnf n + +instance NFData SourceText where + rnf NoSourceText = () + rnf (SourceText s) = rnf s + +instance NFData FixityDirection where + rnf InfixL = () + rnf InfixR = () + rnf InfixN = () + +instance NFData Fixity where + rnf (Fixity sourceText n dir) = + sourceText `deepseq` n `deepseq` dir `deepseq` () + +instance NFData ann => NFData (SrcSpanAnn' ann) where + rnf (SrcSpanAnn a ss) = a `deepseq` ss `deepseq` () + +instance NFData (EpAnn NameAnn) where + rnf EpAnnNotUsed = () + rnf (EpAnn en ann cs) = en `deepseq` ann `deepseq` cs `deepseq` () + +instance NFData NameAnn where + rnf (NameAnn a b c d e) = + a + `deepseq` b + `deepseq` c + `deepseq` d + `deepseq` e + `deepseq` () + rnf (NameAnnCommas a b c d e) = + a + `deepseq` b + `deepseq` c + `deepseq` d + `deepseq` e + `deepseq` () + rnf (NameAnnBars a b c d e) = + a + `deepseq` b + `deepseq` c + `deepseq` d + `deepseq` e + `deepseq` () + rnf (NameAnnOnly a b c d) = + a + `deepseq` b + `deepseq` c + `deepseq` d + `deepseq` () + rnf (NameAnnRArrow a b) = + a + `deepseq` b + `deepseq` () + rnf (NameAnnQuote a b c) = + a + `deepseq` b + `deepseq` c + `deepseq` () + rnf (NameAnnTrailing a) = rnf a + +instance NFData TrailingAnn where + rnf (AddSemiAnn epaL) = rnf epaL + rnf (AddCommaAnn epaL) = rnf epaL + rnf (AddVbarAnn epaL) = rnf epaL + +instance NFData NameAdornment where + rnf NameParens = () + rnf NameParensHash = () + rnf NameBackquotes = () + rnf NameSquare = () + +instance NFData EpaLocation where + rnf (EpaSpan ss bs) = ss `seq` bs `deepseq` () + rnf (EpaDelta dp lc) = dp `seq` lc `deepseq` () + +instance NFData EpAnnComments where + rnf (EpaComments cs) = rnf cs + rnf (EpaCommentsBalanced cs1 cs2) = cs1 `deepseq` cs2 `deepseq` () + +instance NFData EpaComment where + rnf (EpaComment t rss) = t `deepseq` rss `seq` () + +instance NFData EpaCommentTok where + rnf (EpaDocComment ds) = rnf ds + rnf (EpaDocOptions s) = rnf s + rnf (EpaLineComment s) = rnf s + rnf (EpaBlockComment s) = rnf s + rnf EpaEofComment = () + + +instance NFData a => NFData (Strict.Maybe a) where + rnf Strict.Nothing = () + rnf (Strict.Just x) = rnf x + +instance NFData BufSpan where + rnf (BufSpan p1 p2) = p1 `deepseq` p2 `deepseq` () + +instance NFData BufPos where + rnf (BufPos n) = rnf n + +instance NFData Anchor where + rnf (Anchor ss op) = ss `seq` op `deepseq` () + +instance NFData AnchorOperation where + rnf UnchangedAnchor = () + rnf (MovedAnchor dp) = rnf dp + +instance NFData DeltaPos where + rnf (SameLine n) = rnf n + rnf (DifferentLine n m) = n `deepseq` m `deepseq` () +