haddock 2.28.0 → 2.29.0
raw patch · 17 files changed
+1452/−863 lines, 17 filesdep ~haddock-api
Dependency ranges changed: haddock-api
Files
- CHANGES.md +6/−0
- haddock-api/src/Haddock.hs +47/−35
- haddock-api/src/Haddock/Backends/Hoogle.hs +55/−56
- haddock-api/src/Haddock/Backends/LaTeX.hs +29/−16
- haddock-api/src/Haddock/Backends/Xhtml.hs +70/−19
- haddock-api/src/Haddock/Convert.hs +17/−11
- haddock-api/src/Haddock/GhcUtils.hs +27/−7
- haddock-api/src/Haddock/Interface.hs +99/−72
- haddock-api/src/Haddock/Interface/AttachInstances.hs +61/−58
- haddock-api/src/Haddock/Interface/Create.hs +246/−212
- haddock-api/src/Haddock/Interface/LexParseRn.hs +127/−62
- haddock-api/src/Haddock/Interface/Rename.hs +235/−170
- haddock-api/src/Haddock/InterfaceFile.hs +1/−1
- haddock-api/src/Haddock/Options.hs +40/−2
- haddock-api/src/Haddock/Syb.hs +5/−45
- haddock-api/src/Haddock/Types.hs +385/−95
- haddock.cabal +2/−2
CHANGES.md view
@@ -1,3 +1,9 @@+## Changes in 2.29.0+ * Fixes for memory leaks and performance improvements++## Changes in 2.28.0+ * Support qualified and unqualified names in `--ignore-link-symbol`+ ## Changes in 2.24.0 * Reify oversaturated data family instances correctly (#1103)
haddock-api/src/Haddock.hs view
@@ -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 ]
haddock-api/src/Haddock/Backends/Hoogle.hs view
@@ -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]
haddock-api/src/Haddock/Backends/LaTeX.hs view
@@ -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
haddock-api/src/Haddock/Backends/Xhtml.hs view
@@ -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)
haddock-api/src/Haddock/Convert.hs view
@@ -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
haddock-api/src/Haddock/GhcUtils.hs view
@@ -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'
haddock-api/src/Haddock/Interface.hs view
@@ -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
haddock-api/src/Haddock/Interface/AttachInstances.hs view
@@ -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
haddock-api/src/Haddock/Interface/Create.hs view
@@ -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))
haddock-api/src/Haddock/Interface/LexParseRn.hs view
@@ -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
haddock-api/src/Haddock/Interface/Rename.hs view
@@ -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')
haddock-api/src/Haddock/InterfaceFile.hs view
@@ -75,7 +75,7 @@ mkPackageInterfaces piVisibility InterfaceFile { ifPackageInfo , ifInstalledIfaces- } = + } = PackageInterfaces { piPackageInfo = ifPackageInfo , piVisibility , piInstalledInterfaces = ifInstalledIfaces
haddock-api/src/Haddock/Options.hs view
@@ -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 ]
haddock-api/src/Haddock/Syb.hs view
@@ -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
haddock-api/src/Haddock/Types.hs view
@@ -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` ()+
haddock.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: haddock-version: 2.28.0+version: 2.29.0 synopsis: A documentation-generation tool for Haskell libraries description: This is Haddock, a tool for automatically generating documentation@@ -150,7 +150,7 @@ else -- in order for haddock's advertised version number to have proper meaning, -- we pin down to a single haddock-api version.- build-depends: haddock-api == 2.28.0+ build-depends: haddock-api == 2.29.0 test-suite html-test type: exitcode-stdio-1.0