diff options
| -rw-r--r-- | TODO | 13 | ||||
| -rw-r--r-- | src/HaddockDevHelp.hs | 13 | ||||
| -rw-r--r-- | src/HaddockHH.hs | 13 | ||||
| -rw-r--r-- | src/HaddockHH2.hs | 13 | ||||
| -rw-r--r-- | src/HaddockHtml.hs | 31 | ||||
| -rw-r--r-- | src/HaddockRename.hs | 36 | ||||
| -rw-r--r-- | src/HaddockTypes.hs | 15 | ||||
| -rw-r--r-- | src/HaddockUtil.hs | 6 | ||||
| -rw-r--r-- | src/Main.hs | 492 | ||||
| -rw-r--r-- | src/Map.hs | 4 |
10 files changed, 376 insertions, 260 deletions
@@ -1,16 +1,6 @@ ----------------------------------------------------------------------------- -- bugs -* I've been thinking of a solution along these lines: Haddock - processes the modules in two phases. The first phase resolves all the - names and determines the "definitive" documentation for each entity. - The second phase makes all the links point to the definitive - documentation, with certain exceptions: if the entity is also - documented in the local module, then point there instead. Perhaps - there are other exceptions. We might need a way to indicate - "definitive", or maybe just the module(s) furthest up the dependency - tree would do. - * The lexer should handle "...." in doc strings, only recognising it if the contents looks like a module name. @@ -39,9 +29,6 @@ * derived instance support isn't quite right (doing it properly is hard, though). -* Referring to something that has a defn but no type signature doesn't - elicit a useful message. - * The synopsis generated for a module with no docs should not attempt to link to the doc for each entity. We need a different kind of summary here: what we really want is just the documentation section but without diff --git a/src/HaddockDevHelp.hs b/src/HaddockDevHelp.hs index 51e96ea0..390fb6f3 100644 --- a/src/HaddockDevHelp.hs +++ b/src/HaddockDevHelp.hs @@ -10,11 +10,13 @@ import Data.Maybe ( fromMaybe ) import Text.PrettyPrint -ppDevHelpFile :: FilePath -> String -> Maybe String -> [(Module,Interface)] -> IO () +ppDevHelpFile :: FilePath -> String -> Maybe String -> [Interface] -> IO () ppDevHelpFile odir doctitle maybe_package ifaces = do let devHelpFile = package++".devhelp" - tree = mkModuleTree [ (mod, iface_package iface, toDescription iface) - | (mod, iface) <- ifaces ] + tree = mkModuleTree [ (iface_module iface, + iface_package iface, + toDescription iface) + | iface <- ifaces ] doc = text "<?xml version=\"1.0\" encoding=\"utf-8\" standalone=\"no\"?>" $$ (text "<book xmlns=\"http://www.devhelp.net/book\" title=\""<>text doctitle<> @@ -56,9 +58,10 @@ ppDevHelpFile odir doctitle maybe_package ifaces = do index :: [(HsName, [Module])] index = Map.toAscList (foldr getIfaceIndex Map.empty ifaces) - getIfaceIndex (mdl,iface) fm = + getIfaceIndex iface fm = Map.unionWith (++) (Map.fromListWith (flip (++)) [(name, [mdl]) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']) fm - + where mdl = iface_module iface + ppList [] = empty ppList ((name,refs):mdls) = ppReference name refs $$ diff --git a/src/HaddockHH.hs b/src/HaddockHH.hs index d5bf7109..59953575 100644 --- a/src/HaddockHH.hs +++ b/src/HaddockHH.hs @@ -71,7 +71,7 @@ ppHHContents odir doctitle maybe_package tree = do -- reconstruct the module name ------------------------------- -ppHHIndex :: FilePath -> Maybe String -> [(Module,Interface)] -> IO () +ppHHIndex :: FilePath -> Maybe String -> [Interface] -> IO () ppHHIndex odir maybe_package ifaces = do let indexHHFile = package++".hhk" @@ -93,8 +93,9 @@ ppHHIndex odir maybe_package ifaces = do index :: [(HsName, [Module])] index = Map.toAscList (foldr getIfaceIndex Map.empty ifaces) - getIfaceIndex (mdl,iface) fm = + getIfaceIndex iface fm = foldl (\m (k,e) -> Map.insertWith (++) k e m) fm [(name, [mdl]) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl'] + where mdl = iface_module iface ppList [] = empty ppList ((name,refs):mdls) = @@ -112,7 +113,7 @@ ppHHIndex odir maybe_package ifaces = do ppReference name refs -ppHHProject :: FilePath -> String -> Maybe String -> [(Module,Interface)] -> [FilePath] -> IO () +ppHHProject :: FilePath -> String -> Maybe String -> [Interface] -> [FilePath] -> IO () ppHHProject odir doctitle maybe_package ifaces pkg_paths = do let projectHHFile = package++".hhp" doc = @@ -136,7 +137,8 @@ ppHHProject odir doctitle maybe_package ifaces pkg_paths = do package = fromMaybe "pkg" maybe_package ppMods [] = empty - ppMods ((Module mdl,_):ifaces) = + ppMods (iface:ifaces) = + let Module mdl = iface_module iface in text (moduleHtmlFile mdl) $$ ppMods ifaces @@ -161,5 +163,6 @@ ppHHProject odir doctitle maybe_package ifaces pkg_paths = do chars :: [Char] chars = map fst (Map.toAscList (foldr getIfaceIndex Map.empty ifaces)) - getIfaceIndex (mdl,iface) fm = + getIfaceIndex iface fm = Map.union (Map.fromList [(toUpper (head (show name)),()) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']) fm + where mdl = iface_module iface diff --git a/src/HaddockHH2.hs b/src/HaddockHH2.hs index 9e023dda..6d4ce5c0 100644 --- a/src/HaddockHH2.hs +++ b/src/HaddockHH2.hs @@ -56,7 +56,7 @@ ppHH2Contents odir doctitle maybe_package tree = do ----------------------------------------------------------------------------------- -ppHH2Index :: FilePath -> Maybe String -> [(Module,Interface)] -> IO () +ppHH2Index :: FilePath -> Maybe String -> [Interface] -> IO () ppHH2Index odir maybe_package ifaces = do let indexKHH2File = package++"K.HxK" @@ -83,8 +83,9 @@ ppHH2Index odir maybe_package ifaces = do index :: [(HsName, [Module])] index = Map.toAscList (foldr getIfaceIndex Map.empty ifaces) - getIfaceIndex (mdl,iface) fm = + getIfaceIndex iface fm = Map.unionWith (++) (Map.fromListWith (flip (++)) [(name, [mdl]) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']) fm + where mdl = iface_module iface ppList [] = empty ppList ((name,mdls):vs) = @@ -98,7 +99,7 @@ ppHH2Index odir maybe_package ifaces = do ----------------------------------------------------------------------------------- -ppHH2Files :: FilePath -> Maybe String -> [(Module,Interface)] -> [FilePath] -> IO () +ppHH2Files :: FilePath -> Maybe String -> [Interface] -> [FilePath] -> IO () ppHH2Files odir maybe_package ifaces pkg_paths = do let filesHH2File = package++".HxF" doc = @@ -116,9 +117,10 @@ ppHH2Files odir maybe_package ifaces pkg_paths = do package = fromMaybe "pkg" maybe_package ppMods [] = empty - ppMods ((Module mdl,_):ifaces) = + ppMods (iface:ifaces) = text "<File Url=\"" <> text (moduleHtmlFile mdl) <> text "\"/>" $$ ppMods ifaces + where Module mdl = iface_module iface ppIndexFiles [] = empty ppIndexFiles (c:cs) = @@ -141,8 +143,9 @@ ppHH2Files odir maybe_package ifaces pkg_paths = do chars :: [Char] chars = map fst (Map.toAscList (foldr getIfaceIndex Map.empty ifaces)) - getIfaceIndex (mdl,iface) fm = + getIfaceIndex iface fm = Map.union (Map.fromList [(toUpper (head (show name)),()) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']) fm + where mdl = iface_module iface ----------------------------------------------------------------------------------- diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs index ced6e351..b02caf5b 100644 --- a/src/HaddockHtml.hs +++ b/src/HaddockHtml.hs @@ -40,7 +40,7 @@ import System.IO ( IOMode(..), hClose, hGetBuf, hPutBuf ) ppHtml :: String -> Maybe String -- package -> Maybe String - -> [(Module, Interface)] + -> [Interface] -> FilePath -- destination directory -> Maybe Doc -- prologue text, maybe -> Maybe String -- the Html Help format (--html-help) @@ -52,11 +52,11 @@ ppHtml doctitle maybe_package source_url ifaces odir prologue maybe_html_help_fo maybe_contents_url maybe_index_url = do let visible_ifaces = filter visible ifaces - visible (_, i) = OptHide `notElem` iface_options i + visible i = OptHide `notElem` iface_options i when (not (isJust maybe_contents_url)) $ ppHtmlContents odir doctitle maybe_package maybe_html_help_format maybe_index_url - [ (m,iface{iface_package=Nothing}) | (m,iface) <- visible_ifaces ] + [ iface{iface_package=Nothing} | iface <- visible_ifaces ] -- we don't want to display the packages in a single-package contents prologue @@ -72,7 +72,7 @@ ppHtml doctitle maybe_package source_url ifaces odir prologue maybe_html_help_fo ppHtmlHelpFiles :: String -- doctitle -> Maybe String -- package - -> [(Module, Interface)] + -> [Interface] -> FilePath -- destination directory -> Maybe String -- the Html Help format (--html-help) -> [FilePath] -- external packages paths @@ -80,7 +80,7 @@ ppHtmlHelpFiles ppHtmlHelpFiles doctitle maybe_package ifaces odir maybe_html_help_format pkg_paths = do let visible_ifaces = filter visible ifaces - visible (_, i) = OptHide `notElem` iface_options i + visible i = OptHide `notElem` iface_options i -- Generate index and contents page for Html Help if requested case maybe_html_help_format of @@ -217,12 +217,14 @@ ppHtmlContents -> Maybe String -> Maybe String -> Maybe String - -> [(Module,Interface)] -> Maybe Doc + -> [Interface] -> Maybe Doc -> IO () ppHtmlContents odir doctitle maybe_package maybe_html_help_format maybe_index_url mdls prologue = do let tree = mkModuleTree - [(mod,iface_package iface,toDescription iface) | (mod,iface) <- mdls] + [(iface_module iface, + iface_package iface, + toDescription iface) | iface <- mdls] html = header (documentCharacterEncoding +++ @@ -313,7 +315,7 @@ ppHtmlIndex :: FilePath -> Maybe String -> Maybe String -> Maybe String - -> [(Module,Interface)] + -> [Interface] -> IO () ppHtmlIndex odir doctitle maybe_package maybe_html_help_format maybe_contents_url ifaces = do let html = @@ -386,10 +388,11 @@ ppHtmlIndex odir doctitle maybe_package maybe_html_help_format maybe_contents_ur full_index = Map.fromListWith (flip (Map.unionWith (++))) (concat (map getIfaceIndex ifaces)) - getIfaceIndex (mdl,iface) = + getIfaceIndex iface = [ (hsNameStr nm, - Map.fromList [(orig, [(mdl, not (nm `Map.member` iface_reexported iface))])]) + Map.fromList [(orig, [(mdl, not (nm `elem` iface_reexported iface))])]) | (nm, orig) <- Map.toAscList (iface_env iface) ] + where mdl = iface_module iface indexElt :: (String, Map HsQName [(Module,Bool)]) -> HtmlTable indexElt (str, entities) = @@ -433,10 +436,12 @@ ppHtmlIndex odir doctitle maybe_package maybe_html_help_format maybe_contents_ur ppHtmlModule :: FilePath -> String -> Maybe String -> Maybe String -> Maybe String - -> (Module,Interface) -> IO () + -> Interface -> IO () ppHtmlModule odir doctitle source_url - maybe_contents_url maybe_index_url (Module mdl,iface) = do - let html = + maybe_contents_url maybe_index_url iface = do + let + Module mdl = iface_module iface + html = header (documentCharacterEncoding +++ thetitle (toHtml mdl) +++ styleSheet +++ diff --git a/src/HaddockRename.hs b/src/HaddockRename.hs index 6f8aafc5..5199c013 100644 --- a/src/HaddockRename.hs +++ b/src/HaddockRename.hs @@ -5,7 +5,7 @@ -- module HaddockRename ( - RnM, runRn, runRnFM, -- the monad (instance of Monad) + RnM, runRn, runRnFM, runRnUnqualFM, -- the monad (instance of Monad) renameExportList, renameDecl, @@ -14,6 +14,7 @@ module HaddockRename ( ) where import HaddockTypes +import HaddockUtil ( unQual ) import HsSyn import Map ( Map ) import qualified Map hiding ( Map ) @@ -27,7 +28,10 @@ import Monad -- renaming, and it returns a list of names which couldn't be found in -- the environment. -newtype GenRnM n a = RnM {unRn :: (n -> Maybe HsQName) -> (a,[n])} +newtype GenRnM n a = + RnM { unRn :: (n -> (Bool,HsQName)) -- name lookup function + -> (a,[n]) + } type RnM a = GenRnM HsQName a @@ -42,7 +46,7 @@ m `thenRn` k = RnM (\lkp -> case unRn m lkp of (a,out1) -> case unRn (k a) lkp of (b,out2) -> (b,out1++out2)) -getLookupRn :: RnM (HsQName -> Maybe HsQName) +getLookupRn :: RnM (HsQName -> (Bool,HsQName)) getLookupRn = RnM (\lkp -> (lkp,[])) outRn :: HsQName -> RnM () outRn name = RnM (\_ -> ((),[name])) @@ -51,13 +55,24 @@ lookupRn :: (HsQName -> a) -> HsQName -> RnM a lookupRn and_then name = do lkp <- getLookupRn case lkp name of - Nothing -> do outRn name; return (and_then name) - Just maps_to -> return (and_then maps_to) + (False,maps_to) -> do outRn name; return (and_then maps_to) + (True, maps_to) -> return (and_then maps_to) runRnFM :: Map HsQName HsQName -> RnM a -> (a,[HsQName]) -runRnFM env rn = unRn rn (flip Map.lookup env) - -runRn :: (n -> Maybe HsQName) -> GenRnM n a -> (a,[n]) +runRnFM env rn = unRn rn lkp + where lkp n = case Map.lookup n env of + Nothing -> (False, n) -- leave the qualified name + Just q -> (True, q) + +-- like runRnFM, but if it can't find a mapping for a name, +-- it leaves an unqualified name in place instead. +runRnUnqualFM :: Map HsQName HsQName -> RnM a -> (a,[HsQName]) +runRnUnqualFM env rn = unRn rn lkp + where lkp n = case Map.lookup n env of + Nothing -> (False, unQual n) -- remove the qualifier + Just q -> (True, q) + +runRn :: (n -> (Bool,HsQName)) -> GenRnM n a -> (a,[n]) runRn lkp rn = unRn rn lkp -- ----------------------------------------------------------------------------- @@ -230,7 +245,7 @@ renameMaybeDoc (Just doc) = Just `liftM` renameDoc doc lookupForDoc :: [HsQName] -> RnM Doc lookupForDoc qns = do lkp <- getLookupRn - case [ n | Just n <- map lkp qns ] of + case [ n | (True,n) <- map lkp qns ] of ns@(_:_) -> return (DocIdentifier ns) [] -> -- if we were given a qualified name, but there's nothing -- matching that name in scope, then just assume its existence @@ -239,7 +254,8 @@ lookupForDoc qns = do let quals = filter isQualified qns in if (not (null quals)) then return (DocIdentifier quals) - else + else do + outRn (head qns) -- no qualified names: just replace this name with its -- string representation. return (DocString (show (head qns))) diff --git a/src/HaddockTypes.hs b/src/HaddockTypes.hs index 82ce5a08..fafafe40 100644 --- a/src/HaddockTypes.hs +++ b/src/HaddockTypes.hs @@ -25,14 +25,14 @@ data Interface iface_filename :: FilePath, -- ^ the filename that contains the source code for this module + iface_module :: Module, + iface_package :: Maybe String, iface_env :: NameEnv, - -- ^ environment mapping names to *original* names - - iface_import_env :: Map HsQName HsQName, + -- ^ environment mapping exported names to *original* names - iface_reexported :: NameEnv, + iface_reexported :: [HsName], -- ^ For names exported by this module, but not -- actually documented in this module's documentation -- (perhaps because they are reexported via 'module M' @@ -69,7 +69,12 @@ data Interface -- ^ module-wide doc options } -data DocOption = OptHide | OptPrune | OptIgnoreExports +data DocOption + = OptHide -- this module should not appear in the docs + | OptPrune + | OptIgnoreExports -- pretend everything is exported + | OptNotDefinitive -- not the best place to get docs for things + -- exported by this module. deriving (Eq) data ExportItem diff --git a/src/HaddockUtil.hs b/src/HaddockUtil.hs index 434d935e..eacde1bb 100644 --- a/src/HaddockUtil.hs +++ b/src/HaddockUtil.hs @@ -10,7 +10,7 @@ module HaddockUtil ( -- * Misc utilities nameOfQName, collectNames, declBinders, declMainBinder, declSubBinders, splitTyConApp, restrictTo, declDoc, parseModuleHeader, freeTyCons, unbang, - addFieldDoc, addFieldDocs, addConDoc, addConDocs,toDescription, + addFieldDoc, addFieldDocs, addConDoc, addConDocs,toDescription, unQual, -- * Filename utilities basename, dirname, splitFilename3, @@ -51,6 +51,10 @@ nameOfQName :: HsQName -> HsName nameOfQName (Qual _ n) = n nameOfQName (UnQual n) = n +unQual :: HsQName -> HsQName +unQual (Qual _ n) = UnQual n +unQual n = n + collectNames :: [HsDecl] -> [HsName] collectNames ds = concat (map declBinders ds) diff --git a/src/Main.hs b/src/Main.hs index ad316cf2..bce33a5f 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -28,7 +28,7 @@ import Control.Monad ( when ) import Control.Monad.Writer ( Writer, runWriter, tell ) import Data.Char ( isSpace ) import Data.IORef ( writeIORef ) -import Data.List ( nub ) +import Data.List ( nub, (\\), foldl' ) import Data.Maybe ( isJust, maybeToList ) --import Debug.Trace import System.Console.GetOpt ( getOpt, usageInfo, ArgOrder(..), OptDescr(..), ArgDescr(..) ) @@ -188,15 +188,20 @@ run flags files = do prologue <- getPrologue flags - read_ifaces_s <- mapM readIface (map snd ifaces_to_read) + read_iface_stuff <- mapM readIface (map snd ifaces_to_read) - let read_ifaces = concat read_ifaces_s - visible_read_ifaces = filter ((OptHide `notElem`) . iface_options . snd) + let + (read_ifacess, doc_envs) = unzip read_iface_stuff + read_ifaces = concat read_ifacess + + ext_doc_env = Map.unions doc_envs + + visible_read_ifaces = filter ((OptHide `notElem`) . iface_options) read_ifaces - external_mods = map fst read_ifaces + external_mods = map iface_module read_ifaces pkg_paths = map fst ifaces_to_read - updateHTMLXRefs pkg_paths read_ifaces_s + updateHTMLXRefs pkg_paths read_ifacess when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags) && Flag_Html `elem` flags) $ @@ -221,34 +226,54 @@ run flags files = do -- process the modules in sorted order, building up a mapping from -- modules to interfaces. let - loop ifaces [] = return ifaces - loop ifaces ((hsmod,file):mdls) = do - let ((mdl,iface),msgs) = runWriter $ - mkInterface no_implicit_prelude verbose ifaces + loop mod_env ifaces [] = return (reverse ifaces) + loop mod_env ifaces ((hsmod,file):mdls) = do + let (iface,msgs) = runWriter $ + mkInterfacePhase1 no_implicit_prelude verbose mod_env file package hsmod - new_ifaces = Map.insert mdl iface ifaces - mapM (hPutStrLn stderr) msgs - loop new_ifaces mdls + new_mod_env = Map.insert (iface_module iface) iface mod_env + mapM_ (hPutStrLn stderr) msgs + loop new_mod_env (iface:ifaces) mdls + + let + mod_map = Map.fromList [ (iface_module iface,iface) + | iface <- read_ifaces ] + + ifaces <- loop mod_map read_ifaces sorted_mod_files + let + these_ifaces0 = [ iface | iface <- ifaces, + iface_module iface `notElem` external_mods ] - module_map <- loop (Map.fromList read_ifaces) sorted_mod_files - let mod_ifaces = Map.toAscList module_map + let these_ifaces1 = attachInstances these_ifaces0 + this_doc_env = buildGlobalDocEnv these_ifaces1 + global_doc_env = this_doc_env `Map.union` + ext_doc_env `Map.union` + builtinDocEnv - these_mod_ifaces0 = [ (mdl, iface) - | (mdl, iface) <- mod_ifaces, - mdl `notElem` external_mods ] + +-- Now do phase 2 + let + loop2 ifaces [] = return (reverse ifaces) + loop2 ifaces (iface:rest) = do + let (iface',msgs) = runWriter $ + mkInterfacePhase2 verbose iface global_doc_env + mapM_ (hPutStrLn stderr) msgs + loop2 (iface':ifaces) rest + + these_ifaces <- loop2 [] these_ifaces1 -- when (Flag_DocBook `elem` flags) $ -- putStr (ppDocBook odir mod_ifaces) - let these_mod_ifaces = attachInstances these_mod_ifaces0 when (Flag_Debug `elem` flags) $ do - mapM_ putStrLn (map show [ (mdl, Map.toAscList (iface_env i), + mapM_ putStrLn (map show [ (iface_module i, + Map.toAscList (iface_env i), Map.toAscList (iface_sub i)) - | (mdl, i) <- these_mod_ifaces ]) + | i <- these_ifaces ]) when (Flag_Html `elem` flags) $ do - ppHtml title package source_url these_mod_ifaces odir + ppHtml title package source_url these_ifaces odir prologue maybe_html_help_format maybe_contents_url maybe_index_url copyHtmlBits odir libdir css_file @@ -256,7 +281,7 @@ run flags files = do -- dump an interface if requested case dump_iface of Nothing -> return () - Just fn -> dumpInterfaces these_mod_ifaces fn + Just fn -> dumpInterfaces these_ifaces this_doc_env fn parseIfaceOption :: String -> (FilePath,FilePath) parseIfaceOption s = @@ -265,13 +290,13 @@ parseIfaceOption s = (file, _) -> ("", file) -updateHTMLXRefs :: [FilePath] -> [[(Module,Interface)]] -> IO () +updateHTMLXRefs :: [FilePath] -> [[Interface]] -> IO () updateHTMLXRefs paths ifaces_s = writeIORef html_xrefs_ref (Map.fromList mapping) where - mapping = [ (mdl, fpath) + mapping = [ (iface_module iface, fpath) | (fpath, ifaces) <- zip paths ifaces_s, - (mdl, _iface) <- ifaces + iface <- ifaces ] parse_file :: FilePath -> IO HsModule @@ -299,16 +324,21 @@ getPrologue flags ----------------------------------------------------------------------------- -- Figuring out the definitions that are exported from a module -mkInterface +-- We're going to make interfaces in two passes: +-- +-- 1. Rename the code. This basically involves resolving all +-- the names to "original names". +-- +-- 2. Convert all the entity references to "doc names". These are +-- the names we want to link to in the documentation. + +mkInterfacePhase1 :: Bool -- no implicit prelude -> Bool -- verbose -> ModuleMap -> FilePath -> Maybe String -> HsModule - -> ErrMsgM ( - Module, -- the module name - Interface -- its "interface" - ) + -> ErrMsgM Interface -- the "interface" of the module -mkInterface no_implicit_prelude verbose mod_map filename package +mkInterfacePhase1 no_implicit_prelude verbose mod_map filename package (HsModule mdl exps imps decls maybe_opts maybe_info maybe_doc) = do -- Process the options, if available @@ -358,96 +388,141 @@ mkInterface no_implicit_prelude verbose mod_map filename package (orig_decls, missing_names2) = runRnFM orig_env (mapM renameDecl annotated_decls) + (orig_module_doc, missing_names3) + = runRnFM orig_env (renameMaybeDoc maybe_doc) + + decl_map :: Map HsName HsDecl + decl_map = Map.fromList [ (n,d) | d <- orig_decls, n <- declBinders d ] + + instances = [ d | d@HsInstDecl{} <- orig_decls ] ++ + [ d | decl <- orig_decls, d <- derivedInstances mdl decl] + + -- trace (show (Map.toAscList orig_env)) $ do + -- gather up a list of entities that are exported (original names) (exported_names, exported_visible_names) <- exportedNames mdl mod_map locally_defined_names orig_env sub_map orig_exports opts - let - - -- build the import env, which maps original names to import names - local_import_env = Map.fromList (zip qual_local_names qual_local_names) - -- find the names exported by this module that other modules should *not* - -- link to (and point them to where they should). - reexports = getReExports mdl exported_names exported_visible_names - import_env - - import_env = buildImportEnv mod_map mdl exported_visible_names implicit_imps - `Map.union` local_import_env - --- trace (show (Map.toAscList orig_env)) $ do --- trace (show (Map.toAscList import_env)) $ do let - final_decls = orig_decls + -- maps exported HsNames to orig HsQNames + name_env = Map.fromList [ (nameOfQName n, n) | n <- exported_names ] - decl_map :: Map HsName HsDecl - decl_map = Map.fromList [ (n,d) | d <- final_decls, n <- declBinders d ] + -- find the names exported by this module that other modules should *not* + -- link to. + reexports = [ nm | n@(Qual _ nm) <- exported_names, + n `notElem` exported_visible_names ] - instances = [ d | d@HsInstDecl{} <- final_decls ] ++ - [ d | decl <- orig_decls, d <- derivedInstances mdl decl] + -- in -- make the "export items", which will be converted into docs later - orig_export_list <- mkExportItems mod_map mdl exported_names decl_map sub_map - final_decls opts orig_exports - + orig_export_items <- mkExportItems mod_map mdl exported_names decl_map sub_map + orig_decls opts orig_exports let -- prune the export list to just those declarations that have -- documentation, if the 'prune' option is on. pruned_export_list - | OptPrune `elem` opts = pruneExportItems orig_export_list - | otherwise = orig_export_list - - -- rename names in the exported declarations to point to things that - -- are closer, or maybe even exported by, the current module. - (renamed_export_list, _missing_names3) - = runRnFM import_env (renameExportItems pruned_export_list) - - name_env = Map.fromList [ (nameOfQName n, n) | n <- exported_names ] - - let - (orig_module_doc, missing_names4) - = runRnFM orig_env (renameMaybeDoc maybe_doc) - - (final_module_doc, _missing_names5) - = runRnFM import_env (renameMaybeDoc orig_module_doc) + | OptPrune `elem` opts = pruneExportItems orig_export_items + | otherwise = orig_export_items + -- in -- report any names we couldn't find/resolve - - let missing_names = missing_names1 ++ missing_names2 ++ missing_names4 + let + missing_names = missing_names1 ++ missing_names2 ++ missing_names3 --ignore missing_names3 & missing_names5 for now - filtered_missing_names = filter (`notElem` ignore) missing_names - - -- ignore certain builtin names ((),[], etc.), because these - -- cannot be exported anyway. - ignore = [unit_tycon_qname, fun_tycon_qname, list_tycon_qname, - unit_con_name, nil_con_name] + filtered_missing_names = filter (`notElem` builtinNames) missing_names name_strings = nub (map show filtered_missing_names) + -- in - when (not (null name_strings)) $ + when (OptHide `notElem` opts && + not (null name_strings)) $ tell ["Warning: " ++ show mdl ++ ": the following names could not be resolved:\n"++ " " ++ concat (map (' ':) name_strings) ] - return (mdl, Interface { + return (Interface { iface_filename = filename, + iface_module = mdl, iface_package = package, iface_env = name_env, - iface_import_env = import_env, iface_reexported = reexports, - iface_exports = renamed_export_list, iface_sub = sub_map, iface_orig_exports = pruned_export_list, - iface_insts = instances, iface_decls = decl_map, iface_info = maybe_info, - iface_doc = final_module_doc, - iface_options = opts + iface_doc = orig_module_doc, + iface_options = opts, + iface_exports = error "iface_exports", + iface_insts = instances } ) +-- ----------------------------------------------------------------------------- +-- Phase 2 + +mkInterfacePhase2 + :: Bool -- verbose + -> Interface + -> Map HsQName HsQName -- global doc-name mapping + -> ErrMsgM Interface + +mkInterfacePhase2 verbose iface gbl_doc_env = + case iface of { + Interface { + iface_module = this_mdl, + iface_env = env, + iface_reexported = reexports, + iface_orig_exports = orig_export_items, + iface_doc = orig_module_doc } -> + + let + exported_visible_names = + [orig | (nm,orig) <- Map.toAscList env, nm `notElem` reexports ] + + -- build the import_env. + import_env = foldl fn gbl_doc_env exported_visible_names + where fn env qnm@(Qual _ nm) = Map.insert qnm (Qual this_mdl nm) env + fn env (UnQual nm) = env + + -- rename names in the exported declarations to point to things that + -- are closer, or maybe even exported by, the current module. + (renamed_export_list, missing_names1) + = runRnUnqualFM import_env (renameExportItems orig_export_items) + + (final_module_doc, missing_names2) + = runRnUnqualFM import_env (renameMaybeDoc orig_module_doc) + + -- we're only interested in reporting missing *qualfied* + -- names, the unqualified ones are the ones that couldn't + -- be resolved in phase 1 and have already been reported. + filtered_missing_names = + filter isQual (missing_names1 ++ missing_names2) + where isQual (Qual _ _) = True + isQual _ = False + + missing_names = map show (nub filtered_missing_names) + in do + + -- report things that we couldn't link to. Only do this + -- for non-hidden modules. + when (OptHide `notElem` iface_options iface && + not (null missing_names)) $ + tell ["Warning: " ++ show this_mdl ++ + ": could not find link destinations for:\n"++ + " " ++ concat (map (' ':) missing_names) + ] + + -- trace (show (Map.toAscList import_env)) $ do + + return iface{ iface_exports = renamed_export_list, + iface_doc = final_module_doc } + } + +-- ----------------------------------------------------------------------------- + -- Try to generate instance declarations for derived instances. -- We can't do this properly without instance inference, but if a type -- variable occurs as a constructor argument, then we can just @@ -782,29 +857,6 @@ all_subs_of_qname _ n@(UnQual _) = error $ "Main.all_subs_of_qname: unexpected unqual'd name:" ++ show n -- ---------------------------------------------------------------------------- --- Get a list of names exported by this module that are not actually --- documented here, and build a mapping to point to where the --- documentation for those names can be found. This is used for --- constructing the iface_reexports field of the Interface. - -getReExports :: Module - -> [HsQName] -- all exported names - -> [HsQName] -- exported names which are documented here - -> Map HsQName HsQName - -> Map HsName HsQName -getReExports mdl exported exported_visible import_env - = Map.fromList (concat invisible_names) - where - invisible_names = [ get_name n | n <- exported, - n `notElem` exported_visible ] - - get_name (UnQual _) = [] - get_name n@(Qual m un) = - case Map.lookup n import_env of - Nothing -> [] - Just n' -> [(un,n')] - --- ---------------------------------------------------------------------------- -- Building name environments -- The orig env maps names in the current source file to @@ -841,46 +893,6 @@ buildOrigEnv this_mdl verbose mod_map imp_decls | otherwise = mdl --- The import env maps each "original" name referred to in the current --- module to the qualified name that we want to link to in the --- documentation. - -buildImportEnv :: ModuleMap -> Module - -> [HsQName] -- a list of names exported from here *with docs* - -> [HsImportDecl] -- the import decls - -> Map HsQName HsQName -buildImportEnv mod_map this_mod exported_names imp_decls - = foldr (flip (Map.unionWith (flip best_name))) Map.empty (map build imp_decls) - where - -- choose qualified results over unqualified ones. In the future - -- we might make more intelligent decisions about which name to - -- link to. - best_name n@(Qual _ _) _ = n - best_name _ n@(Qual _ _) = n - best_name n _ = n - - build imp_decl@(HsImportDecl _ mdl _ _ _) = - case Map.lookup mdl mod_map of - Nothing -> Map.empty - Just iface -> Map.fromList (map import_map imported_names) - where - imported_names = processImportDecl mod_map imp_decl - reexport_env = iface_reexported iface - - import_map (nm,qnm) = (qnm, maps_to) - where - maps_to - -- we re-export it, with docs - | qnm `elem` exported_names = Qual this_mod nm - -- re-exported from the other module, but not documented there: - -- find the right place using the iface_reexported environment. - | Just new_qnm <- Map.lookup nm reexport_env = new_qnm - -- if the destination is hidden, we have nowhere to link to - | OptHide `elem` iface_options iface = UnQual nm - -- otherwise, it's documented in the other module - | otherwise = Qual mdl nm - - processImportDecl :: ModuleMap -> HsImportDecl -> [(HsName,HsQName)] processImportDecl mod_map (HsImportDecl _ mdl is_qualified maybe_as imp_specs) = case Map.lookup mdl mod_map of @@ -920,6 +932,49 @@ processImportDecl mod_map (HsImportDecl _ mdl is_qualified maybe_as imp_specs) _ -> [] -- ----------------------------------------------------------------------------- + +-- | Build a mapping which for each original name, points to the "best" +-- place to link to in the documentation. For the definition of +-- "best", we use "the module nearest the bottom of the dependency +-- graph which exports this name", not including hidden modules. When +-- there are multiple choices, we pick a random one. +-- +-- The interfaces are passed in in topologically sorted order, but we start +-- by reversing the list so we can do a foldl. +-- +buildGlobalDocEnv :: [Interface] -> Map HsQName HsQName +buildGlobalDocEnv ifaces + = foldl upd Map.empty (reverse ifaces) + where + upd old_env iface + | OptHide `elem` iface_options iface + = old_env + | OptNotDefinitive `elem` iface_options iface + = foldl' keep_old old_env exported_names + | otherwise + = foldl' keep_new old_env exported_names + where + mdl = iface_module iface + exported_names = filter not_reexported (Map.elems (iface_env iface)) + + not_reexported (Qual _ n) = n `notElem` iface_reexported iface + not_reexported (UnQual n) = n `notElem` iface_reexported iface + -- UnQual probably shouldn't happen + + keep_old env qnm = Map.insertWith const qnm (Qual mdl nm) env + where nm = nameOfQName qnm + keep_new env qnm = Map.insert qnm (Qual mdl nm) env + where nm = nameOfQName qnm + +builtinDocEnv = Map.fromList (map (\a -> (a,a)) builtinNames) + +-- These names cannot be explicitly exported, so we need to treat +-- them specially. +builtinNames = + [unit_tycon_qname, fun_tycon_qname, list_tycon_qname, + unit_con_name, nil_con_name] + +-- ----------------------------------------------------------------------------- -- Expand multiple type signatures expandDecl :: HsDecl -> [HsDecl] @@ -1039,36 +1094,32 @@ sortModules mdls = mapM for_each_scc sccs -- ----------------------------------------------------------------------------- -- Collect instances and attach them to declarations -attachInstances :: [(Module,Interface)] -> [(Module,Interface)] +attachInstances :: [Interface] -> [Interface] attachInstances mod_ifaces = map attach mod_ifaces where inst_map = collectInstances mod_ifaces - attach (mod,iface) = (mod, iface{ iface_exports = new_exports }) + attach iface = iface{ iface_orig_exports = new_exports } where - new_exports = map attach_export (iface_exports iface) - - rename_insts :: [InstHead] -> [InstHead] - rename_insts insts = fst (runRnFM (iface_import_env iface) - (mapM renameInstHead insts)) + new_exports = map attach_export (iface_orig_exports iface) attach_export (ExportDecl nm decl _) = ExportDecl nm decl (case Map.lookup nm inst_map of Nothing -> [] - Just instheads -> rename_insts instheads) + Just instheads -> instheads) attach_export other_export = other_export -collectInstances - :: [(Module,Interface)] +collectInstances + :: [Interface] -> Map HsQName [InstHead] -- maps class/type names to instances -collectInstances mod_ifaces +collectInstances ifaces = Map.fromListWith (flip (++)) ty_inst_pairs `Map.union` Map.fromListWith (flip (++)) class_inst_pairs where - all_instances = concat (map (iface_insts.snd) mod_ifaces) + all_instances = concat (map iface_insts ifaces) class_inst_pairs = [ (cls, [(ctxt,(cls,args))]) | HsInstDecl _ ctxt (cls,args) _ <- all_instances ] @@ -1085,10 +1136,15 @@ collectInstances mod_ifaces -- FormatVersion hack to work out which one the interface file contains. thisFormatVersion :: FormatVersion -thisFormatVersion = mkFormatVersion 1 +thisFormatVersion = mkFormatVersion 2 -- | How we store interfaces. Not everything is stored. -type StoredInterface = +type StoredInterface2 = + (Module,Maybe Doc,Maybe String,Bool,[(HsName,Module)],[HsName], + [(HsName,[HsName])]) + +-- | How we store interfaces. Not everything is stored. +type StoredInterface1 = (Module,Maybe Doc,Maybe String,Bool,[(HsName,HsQName)],[(HsName,HsQName)], [(HsName,[HsName])]) @@ -1097,60 +1153,94 @@ type NullVersionStoredInterface = (Module,Maybe String,Bool,[(HsName,HsQName)],[(HsName,HsQName)], [(HsName,[HsName])]) -dumpInterfaces :: [(Module,Interface)] -> FilePath -> IO () -dumpInterfaces interfaces fileName = +dumpInterfaces :: [Interface] -> Map HsQName HsQName -> FilePath -> IO () +dumpInterfaces interfaces global_doc_env fileName = do let - preparedInterfaces :: [StoredInterface] + preparedInterfaces :: [StoredInterface2] preparedInterfaces = map from_interface interfaces bh <- openBinMem 100000 put_ bh thisFormatVersion put_ bh preparedInterfaces + putDocEnv bh global_doc_env writeBinMem bh fileName -readIface :: FilePath -> IO [(Module,Interface)] +readIface :: FilePath -> IO ([Interface], Map HsQName HsQName) readIface fileName = do bh <- readBinMem fileName formatVersion <- get bh - if formatVersion == thisFormatVersion - then - do - (stuff :: [StoredInterface]) <- get bh - return (map to_interface stuff) - else - if formatVersion == nullFormatVersion - then - do - (stuff :: [NullVersionStoredInterface]) <- get bh - return (map nullVersion_to_interface stuff) - else - do - noDieMsg ( - "Warning: The interface file " ++ show fileName - ++ " could not be read.\n" - ++ "Maybe it's from a later version of Haddock?\n") - return [] - -from_interface :: (Module,Interface) -> StoredInterface -from_interface (mdl,iface) = - (mdl, toDescription iface,iface_package iface, + case formatVersion of + v | v == thisFormatVersion -> do + (stuff :: [StoredInterface2]) <- get bh + doc_env <- getDocEnv bh + return (map to_interface2 stuff, doc_env) + v | v == mkFormatVersion 1 -> do + (stuff :: [StoredInterface1]) <- get bh + return (map to_interface1 stuff, Map.empty) + v | v == nullFormatVersion -> do + (stuff :: [NullVersionStoredInterface]) <- get bh + return (map nullVersion_to_interface stuff, Map.empty) + otherwise -> do + noDieMsg ( + "Warning: The interface file " ++ show fileName + ++ " could not be read.\n" + ++ "Maybe it's from a later version of Haddock?\n") + return ([], Map.empty) + +from_interface :: Interface -> StoredInterface2 +from_interface iface = + ( iface_module iface, + toDescription iface,iface_package iface, OptHide `elem` iface_options iface, - Map.toAscList (iface_env iface), - Map.toAscList (iface_reexported iface), + [(n,mdl) | (n,Qual mdl n') <- Map.toAscList (iface_env iface), + if n /= n' then error "help!" else True], + iface_reexported iface, Map.toAscList (iface_sub iface) ) -to_interface :: StoredInterface -> (Module,Interface) -to_interface (mdl,descriptionOpt,package, hide, env, reexported, sub) = - (mdl, Interface { +getDocEnv :: BinHandle -> IO (Map HsQName HsQName) +getDocEnv bh = do + doc_env_list <- get bh + return (Map.fromList [(Qual mdl1 nm,Qual mdl2 nm) | + (mdl1,nm,mdl2) <- doc_env_list]) + +putDocEnv :: BinHandle -> Map HsQName HsQName -> IO () +putDocEnv bh env = do + let doc_env_list = + [(mdl1,nm,mdl2) | (Qual mdl1 nm, Qual mdl2 _) <- Map.toAscList env] + put_ bh doc_env_list + + +to_interface1 :: StoredInterface1 -> Interface +to_interface1 (mdl,descriptionOpt,package, hide, env, reexported, sub) = + Interface { + iface_module = mdl, iface_filename = "", iface_package = package, iface_env = Map.fromList env, - iface_import_env = Map.empty, iface_sub = Map.fromList sub, - iface_reexported = Map.fromList reexported, + iface_reexported = map fst reexported, + iface_exports = [], + iface_orig_exports = [], + iface_insts = [], + iface_decls = Map.empty, + iface_info = toModuleInfo descriptionOpt, + iface_doc = Nothing, + iface_options = if hide then [OptHide] else [] + } + +to_interface2 :: StoredInterface2 -> Interface +to_interface2 (mdl,descriptionOpt,package, hide, env, reexported, sub) = + Interface { + iface_module = mdl, + iface_filename = "", + iface_package = package, + iface_env = + Map.fromList [(n,Qual mdl n) | (n,mdl) <- env], + iface_sub = Map.fromList sub, + iface_reexported = reexported, iface_exports = [], iface_orig_exports = [], iface_insts = [], @@ -1158,17 +1248,17 @@ to_interface (mdl,descriptionOpt,package, hide, env, reexported, sub) = iface_info = toModuleInfo descriptionOpt, iface_doc = Nothing, iface_options = if hide then [OptHide] else [] - }) + } -nullVersion_to_interface :: NullVersionStoredInterface -> (Module,Interface) +nullVersion_to_interface :: NullVersionStoredInterface -> Interface nullVersion_to_interface (mdl, package, hide, env, reexported, sub) = - (mdl, Interface { + Interface { + iface_module = mdl, iface_filename = "", iface_package = package, iface_env = Map.fromList env, - iface_import_env = Map.empty, iface_sub = Map.fromList sub, - iface_reexported = Map.fromList reexported, + iface_reexported = map fst reexported, iface_exports = [], iface_orig_exports = [], iface_insts = [], @@ -1176,7 +1266,7 @@ nullVersion_to_interface (mdl, package, hide, env, reexported, sub) = iface_info = emptyModuleInfo, iface_doc = Nothing, iface_options = if hide then [OptHide] else [] - }) + } toModuleInfo :: Maybe Doc -> ModuleInfo toModuleInfo descriptionOpt = @@ -34,13 +34,13 @@ insert :: Ord k => k -> a -> Map k a -> Map k a insert k a m = addToFM m k a insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a -insertWith c k a m = addToFM_C c m k a +insertWith c k a m = addToFM_C (flip c) m k a union :: Ord k => Map k a -> Map k a -> Map k a union = flip plusFM unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a -unionWith c l r = plusFM_C c r l +unionWith c l r = plusFM_C (flip c) r l unions :: Ord k => [Map k a] -> Map k a unions = foldl (flip plusFM) emptyFM |