From 1283a3c195ed226fc6d1c84a25de1d42d556cfad Mon Sep 17 00:00:00 2001 From: simonmar Date: Wed, 8 May 2002 11:21:56 +0000 Subject: [haddock @ 2002-05-08 11:21:56 by simonmar] Add a facility for specifying options that affect Haddock's treatment of the module. Options are given at the top of the module in a comma-separated list, beginning with '-- #'. eg. -- # prune, hide, ignore-exports Options currently available, with their meanings: prune: ignore declarations which have no documentation annotations ignore-exports: act as if the export list were not specified (i.e. export everything local to the module). hide: do not include this module in the generated documentation, but propagate any exported definitions to modules which re-export them. There's a slight change in the semantics for re-exporting a full module by giving 'module M' in the export list: if module M does not have the 'hide' option, then the documentation will now just contain a reference to module M rather than the full inlined contents of that module. These features, and some other changes in the pipeline, are the result of discussions between myself and Manuel Chakravarty (author of IDoc) yesterday. Also: some cleanups, use a Writer monad to collect error messages in some places instead of just printing them with trace. --- src/HaddockHtml.hs | 14 +- src/HaddockRename.hs | 2 + src/HaddockTypes.hs | 12 +- src/HsLexer.lhs | 5 +- src/HsParser.ly | 20 ++- src/HsSyn.lhs | 6 +- src/Main.hs | 363 +++++++++++++++++++++++++++++++-------------------- 7 files changed, 268 insertions(+), 154 deletions(-) (limited to 'src') diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs index 5059070e..7d7700a4 100644 --- a/src/HaddockHtml.hs +++ b/src/HaddockHtml.hs @@ -48,14 +48,17 @@ ppHtml title source_url ifaces odir maybe_css libdir = do icon_file = libdir ++ pathSeparator:iconFile icon_destination = odir ++ pathSeparator:iconFile + visible_ifaces = filter visible ifaces + visible (m,i) = OptHide `notElem` iface_options i + css_contents <- readFile css_file writeFile css_destination css_contents icon_contents <- readFile icon_file writeFile icon_destination icon_contents - ppHtmlContents odir title source_url (map fst ifaces) - ppHtmlIndex odir title ifaces - mapM_ (ppHtmlModule odir title source_url) ifaces + ppHtmlContents odir title source_url (map fst visible_ifaces) + ppHtmlIndex odir title visible_ifaces + mapM_ (ppHtmlModule odir title source_url) visible_ifaces moduleHtmlFile :: String -> FilePath moduleHtmlFile mod = mod ++ ".html" -- ToDo: Z-encode filename? @@ -359,8 +362,6 @@ ppModuleContents exports process :: Int -> [ExportItem] -> ([Html],[ExportItem]) process n [] = ([], []) - process n (ExportDecl _ : rest) = process n rest - process n (ExportDoc _ : rest) = process n rest process n items@(ExportGroup lev id doc : rest) | lev <= n = ( [], items ) | otherwise = ( html:sections, rest2 ) @@ -369,6 +370,7 @@ ppModuleContents exports +++ mk_subsections subsections (subsections, rest1) = process lev rest (sections, rest2) = process n rest1 + process n (_ : rest) = process n rest mk_subsections [] = noHtml mk_subsections ss = ddef << dlist << concatHtml ss @@ -392,6 +394,8 @@ processExport doc_map summary (ExportDecl decl) processExport doc_map summary (ExportDoc doc) | summary = Html.emptyTable | otherwise = docBox (markup htmlMarkup doc) +processExport doc_map summary (ExportModule (Module mod)) + = declBox (toHtml "module" <+> ppHsModule mod) ppDocGroup lev doc | lev == 1 = tda [ theclass "section1" ] << doc diff --git a/src/HaddockRename.hs b/src/HaddockRename.hs index ce954a52..f897c600 100644 --- a/src/HaddockRename.hs +++ b/src/HaddockRename.hs @@ -194,6 +194,8 @@ lookupIdString str = do renameExportItems items = mapM rn items where + rn (ExportModule mod) + = return (ExportModule mod) rn (ExportGroup lev id doc) = do doc <- renameDoc doc return (ExportGroup lev id doc) diff --git a/src/HaddockTypes.hs b/src/HaddockTypes.hs index f99d2893..5af102d4 100644 --- a/src/HaddockTypes.hs +++ b/src/HaddockTypes.hs @@ -7,6 +7,7 @@ module HaddockTypes ( -- * Module interfaces NameEnv, Interface(..), ModuleInfo(..), ExportItem(..), ModuleMap, + DocOption(..), -- * User documentation strings DocString, GenDoc(..), Doc, ParsedDoc, DocMarkup(..), @@ -52,8 +53,11 @@ data Interface iface_info :: Maybe ModuleInfo, -- ^ information from the module header - iface_doc :: Maybe Doc + iface_doc :: Maybe Doc, -- ^ documentation from the module header + + iface_options :: [DocOption] + -- ^ module-wide doc options } data ModuleInfo = ModuleInfo @@ -61,6 +65,9 @@ data ModuleInfo = ModuleInfo stability :: String, maintainer :: String } +data DocOption = OptHide | OptPrune | OptIgnoreExports + deriving (Eq) + type DocString = String data ExportItem @@ -75,6 +82,9 @@ data ExportItem | ExportDoc -- some documentation Doc + | ExportModule -- a cross-reference to another module + Module + type ModuleMap = FiniteMap Module Interface -- ----------------------------------------------------------------------------- diff --git a/src/HsLexer.lhs b/src/HsLexer.lhs index 8f5c0174..1899dda5 100644 --- a/src/HsLexer.lhs +++ b/src/HsLexer.lhs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: HsLexer.lhs,v 1.4 2002/04/25 14:40:05 simonmar Exp $ +-- $Id: HsLexer.lhs,v 1.5 2002/05/08 11:21:56 simonmar Exp $ -- -- (c) The GHC Team, 1997-2000 -- @@ -68,6 +68,7 @@ data Token | DocCommentPrev String -- something beginning '-- ^' | DocCommentNamed String -- something beginning '-- $' | DocSection Int String -- a section heading + | DocOptions String -- Reserved operators @@ -223,6 +224,7 @@ lexer cont input (SrcLoc _ x) y col = doc (' ':'^':_) = True doc (' ':'*':_) = True doc (' ':'$':_) = True + doc (' ':'#':_) = True doc _ = False nextTab x = x + (tAB_LENGTH - (x-1) `mod` tAB_LENGTH) @@ -283,6 +285,7 @@ lexToken cont s loc y x = '-':'-':' ':'^':s -> docComment DocCommentPrev cont s loc y x '-':'-':' ':'$':s -> docComment DocCommentNamed cont s loc y x '-':'-':' ':'*':s -> docSection cont ('*':s) loc y x + '-':'-':' ':'#':s -> docComment DocOptions cont s loc y x '\'':s -> lexChar cont s loc y (x+1) '\"':s{-"-} -> lexString cont s loc y (x+1) diff --git a/src/HsParser.ly b/src/HsParser.ly index 5a254ec1..2ca9c88f 100644 --- a/src/HsParser.ly +++ b/src/HsParser.ly @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- -$Id: HsParser.ly,v 1.7 2002/05/06 12:32:32 simonmar Exp $ +$Id: HsParser.ly,v 1.8 2002/05/08 11:21:56 simonmar Exp $ (c) Simon Marlow, Sven Panne 1997-2000 @@ -72,6 +72,7 @@ Docs > DOCPREV { DocCommentPrev $$ } > DOCNAMED { DocCommentNamed $$ } > DOCGROUP { DocSection _ _ } +> DOCOPTIONS { DocOptions $$ } Symbols @@ -152,13 +153,18 @@ Module Header > module :: { HsModule } > : optdoc 'module' modid maybeexports 'where' body -> { HsModule $3 $4 (reverse (fst $6)) (reverse (snd $6)) $1 } +> { HsModule $3 $4 (reverse (fst $6)) (reverse (snd $6)) +> (fst $1) (snd $1) } > | body -> { HsModule main_mod Nothing (reverse (fst $1)) (reverse (snd $1)) Nothing } - -> optdoc :: { Maybe String } -> : DOCNEXT { Just $1 } -> | {- empty -} { Nothing } +> { HsModule main_mod Nothing (reverse (fst $1)) (reverse (snd $1)) +> Nothing Nothing } + +> optdoc :: { (Maybe String, Maybe String) } +> : DOCNEXT { (Nothing, Just $1) } +> | DOCOPTIONS { (Just $1, Nothing) } +> | DOCOPTIONS DOCNEXT { (Just $1, Just $2) } +> | DOCNEXT DOCOPTIONS { (Just $2, Just $1) } +> | {- empty -} { (Nothing, Nothing) } > body :: { ([HsImportDecl],[HsDecl]) } > : '{' bodyaux '}' { $2 } diff --git a/src/HsSyn.lhs b/src/HsSyn.lhs index e732f2f8..5054a8df 100644 --- a/src/HsSyn.lhs +++ b/src/HsSyn.lhs @@ -1,5 +1,5 @@ % ----------------------------------------------------------------------------- -% $Id: HsSyn.lhs,v 1.5 2002/04/26 11:18:57 simonmar Exp $ +% $Id: HsSyn.lhs,v 1.6 2002/05/08 11:21:56 simonmar Exp $ % % (c) The GHC Team, 1997-2002 % @@ -68,7 +68,9 @@ instance Show HsIdentifier where showsPrec _ (HsSpecial s) = showString s data HsModule = HsModule Module (Maybe [HsExportSpec]) - [HsImportDecl] [HsDecl] (Maybe String) + [HsImportDecl] [HsDecl] + (Maybe String) -- the doc options + (Maybe String) -- the module doc deriving Show -- Export/Import Specifications diff --git a/src/Main.hs b/src/Main.hs index 08a70bde..c5d39844 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -25,12 +25,15 @@ import FiniteMap --import Pretty import RegexString +import Maybe ( maybeToList ) import List ( nub ) import Monad ( when ) import Char ( isSpace ) import IO import IOExts +import MonadWriter + #if __GLASGOW_HASKELL__ < 500 import Regex import PackedString @@ -106,14 +109,15 @@ run flags files = do writeIORef saved_flags flags parsed_mods <- sequence (map parse_file files) - let ifaces = [ mkInterface module_map file parsed + let ifaces = [ runWriter (mkInterface module_map file parsed) | (file,parsed) <- zip files parsed_mods ] - mod_ifaces = [ (m,i) | (m,i,_,_) <- ifaces ] + mod_ifaces = [ (m,i) | ((m,i),msgs) <- ifaces ] + all_msgs = concat (map snd ifaces) + module_map = listToFM mod_ifaces - sequence [ reportMissingNames m ns_docs ns_decls - | (m, _, ns_docs, ns_decls) <- ifaces ] + mapM (hPutStrLn stderr) all_msgs when (Flag_DocBook `elem` flags) $ putStr (ppDocBook odir mod_ifaces) @@ -133,116 +137,142 @@ parse_file file = do exitWith (ExitFailure 1) ) -reportMissingNames m [] [] = return () -reportMissingNames (Module m) ns_docs ns_decls = do - hPutStrLn stderr ("Warning: in module " ++ m ++ - ", the following names could not be resolved:") - let name_strings = nub (map show ns_decls ++ ns_docs) - hPutStrLn stderr (" " ++ concat (map (' ':) name_strings)) - ----------------------------------------------------------------------------- -- Figuring out the definitions that are exported from a module -mkInterface :: ModuleMap -> FilePath -> HsModule - -> (Module, -- the module name - Interface, -- its "interface" - [String], -- a list of names we couldn't resolve in the docs - [HsQName] -- a list of names we couldn't resolve in the decls - ) +mkInterface + :: ModuleMap -> FilePath -> HsModule + -> ErrMsgM ( + Module, -- the module name + Interface -- its "interface" + ) -mkInterface mod_map filename (HsModule mod exps imps decls maybe_doc) - = (mod, Interface { - iface_filename = filename, - iface_env = name_env, - iface_exports = renamed_export_list, - iface_orig_exports = orig_export_list, - iface_decls = decl_map, - iface_info = maybe_info, - iface_name_docs = doc_map, - iface_doc = module_doc - }, - missing_names_doc1 ++ missing_names_doc2, - missing_names1 ++ missing_names2 --ignore missing_names3 for now, - ) - where - (module_doc, maybe_info, missing_names_doc1) = - case maybe_doc of - Nothing -> (Nothing, Nothing, []) - Just doc -> (Just doc2, maybe_info, ns) - where - (doc1, maybe_info) = parseModuleHeader doc - (doc2,ns) = formatDocString (lookupForDoc import_env) doc1 +mkInterface mod_map filename + (HsModule mod exps imps decls maybe_opts maybe_doc) = do - locally_defined_names = collectNames decls + -- Process the options, if available + options <- case maybe_opts of + Just opt_str -> processOptions opt_str + Nothing -> return [] - qual_local_names = map (Qual mod) locally_defined_names - unqual_local_names = map UnQual locally_defined_names + let + locally_defined_names = collectNames decls - local_env = listToFM (zip unqual_local_names qual_local_names ++ - zip qual_local_names qual_local_names) + qual_local_names = map (Qual mod) locally_defined_names + unqual_local_names = map UnQual locally_defined_names + + local_env = listToFM (zip unqual_local_names qual_local_names ++ + zip qual_local_names qual_local_names) -- both qualified and unqualifed names are in scope for local things - -- build the orig_env, which maps names to *original* names (so we can - -- find the original declarations & docs for things). - (ext_orig_envs, ext_import_envs) + -- build the orig_env, which maps names to *original* names (so we can + -- find the original declarations & docs for things). + (ext_orig_envs, ext_import_envs) = unzip (map (buildEnv mod_map mod exported_names) imps) - orig_env = foldr plusFM local_env ext_orig_envs - import_env = foldr plusFM local_env ext_import_envs + orig_env = foldr plusFM local_env ext_orig_envs + import_env = foldr plusFM local_env ext_import_envs - -- convert names in source code to original, fully qualified, names - (orig_exports, missing_names1) + -- convert names in source code to original, fully qualified, names + (orig_exports, missing_names1) = runRnFM orig_env (mapMaybeM renameExportList exps) - (orig_decls, missing_names2) + (orig_decls, missing_names2) = runRnFM orig_env (mapM renameDecl decls) - orig_decl_map :: FiniteMap HsName HsDecl - orig_decl_map = listToFM [ (n,d) | d <- orig_decls, n <- declBinders d ] + orig_decl_map :: FiniteMap HsName HsDecl + orig_decl_map = listToFM [ (n,d) | d <- orig_decls, n <- declBinders d ] - -- gather up a list of entities that are exported (original names) - exported_names = exportedNames mod mod_map orig_decls + -- gather up a list of entities that are exported (original names) + exported_names = exportedNames mod mod_map orig_decls locally_defined_names orig_exports - orig_decl_map - - final_decls = concat (map expandDecl orig_decls) - - -- match documentation to names, and resolve identifiers in the documentation - local_docstrings :: [(HsName,DocString)] - local_docstrings = collectDoc final_decls - - local_docs_formatted :: [(HsName,(Doc,[String]))] - local_docs_formatted = - [ (n, formatDocString (lookupForDoc orig_env) doc) - | (n, doc) <- local_docstrings ] - - local_docs :: [(HsName,Doc)] -- with *original* names - local_docs = [ (n,doc) | (n,(doc,_)) <- local_docs_formatted ] - - -- collect the list of names which we couldn't resolve in the documentation - missing_names_doc2 = concat [ ns | (n,(doc,ns)) <- local_docs_formatted ] - - -- get the documentation associated with entities exported from this module - -- ToDo: we should really store the documentation in both orig and imported - -- forms, like the export items. - doc_map :: FiniteMap HsName Doc -- with *imported* names - doc_map = listToFM - [ (nameOfQName n, doc) - | n <- exported_names, - Just doc <- [lookupDoc mod_map mod local_docs import_env n] ] - - decl_map :: FiniteMap HsName HsDecl - decl_map = listToFM [ (n,d) | d <- final_decls, n <- declBinders d ] + orig_decl_map options + + -- Parse the module header + (module_doc, maybe_info, missing_names_doc1) <- + case maybe_doc of + Nothing -> return (Nothing, Nothing, []) + Just doc -> do + let (doc1, maybe_info) = parseModuleHeader doc + (doc2,ns) <- formatDocString (lookupForDoc import_env) doc1 + return (Just doc2, maybe_info, ns) + + let + final_decls = concat (map expandDecl orig_decls) + + -- match documentation to names, and resolve identifiers in the + -- documentation + local_docstrings :: [(HsName,DocString)] + local_docstrings = collectDoc final_decls + + formatLocalDoc (n,doc) = do + doc' <- formatDocString (lookupForDoc orig_env) doc + return (n,doc') + + local_docs_formatted <- mapM formatLocalDoc local_docstrings + + let + local_docs :: [(HsName,Doc)] -- with *original* names + local_docs = [ (n,doc) | (n,(doc,_)) <- local_docs_formatted ] + + -- collect the list of names which we couldn't resolve in the documentation + missing_names_doc2 = concat [ ns | (n,(doc,ns)) <- local_docs_formatted ] + + -- get the documentation associated with entities exported from this module + -- ToDo: we should really store the documentation in both orig and imported + -- forms, like the export items. + doc_map :: FiniteMap HsName Doc -- with *imported* names + doc_map = listToFM + [ (nameOfQName n, doc) + | n <- exported_names, + Just doc <- [lookupDoc mod_map mod local_docs import_env n] ] + + decl_map :: FiniteMap HsName HsDecl + decl_map = listToFM [ (n,d) | d <- final_decls, n <- declBinders d ] -- make the "export items", which will be converted into docs later - orig_export_list = mkExportItems mod_map mod orig_env - decl_map final_decls orig_exports - - -- 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 orig_export_list) - - name_env = listToFM [ (nameOfQName n, n) | n <- exported_names ] + orig_export_list <- mkExportItems mod_map mod orig_env + decl_map final_decls options 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` options = pruneExportItems doc_map 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 = listToFM [ (nameOfQName n, n) | n <- exported_names ] + + -- report any names we couldn't find/resolve + + let missing_names_doc = missing_names_doc1 ++ missing_names_doc2 + missing_names = missing_names1 ++ missing_names2 + --ignore missing_names3 for now, + + name_strings = nub (map show missing_names ++ missing_names_doc) + + when (not (null name_strings)) $ + tell ["Warning: in module " ++ (case mod of Module m -> m) ++ + ", the following names could not be resolved:\n\ + \ " ++ concat (map (' ':) name_strings) + ] + + return (mod, Interface { + iface_filename = filename, + iface_env = name_env, + iface_exports = renamed_export_list, + iface_orig_exports = pruned_export_list, + iface_decls = decl_map, + iface_info = maybe_info, + iface_name_docs = doc_map, + iface_doc = module_doc, + iface_options = options + } + ) -- ----------------------------------------------------------------------------- -- Find the documentation for a particular name, and rename the @@ -274,13 +304,20 @@ mkExportItems :: ModuleMap -> Module -> FiniteMap HsQName HsQName -- maps orig to imported names -> FiniteMap HsName HsDecl -- maps local names to declarations -> [HsDecl] -- decls in the current module + -> [DocOption] -> Maybe [HsExportSpec] - -> [ExportItem] -mkExportItems mod_map mod env decl_map decls Nothing - = fullContentsOfThisModule decls env -- everything exported -mkExportItems mod_map mod env decl_map decls (Just specs) - = concat (map lookupExport specs) + -> ErrMsgM [ExportItem] +mkExportItems mod_map mod env decl_map decls options maybe_exps + | Nothing <- maybe_exps = everything_local_exported + | OptIgnoreExports `elem` options = everything_local_exported + | Just specs <- maybe_exps = do + exps <- mapM lookupExport specs + return (concat exps) where + + everything_local_exported = + fullContentsOfThisModule decls env -- everything exported + lookupExport (HsEVar x) | Just decl <- findDecl x = let decl' | HsTypeSig loc ns ty <- decl @@ -288,39 +325,46 @@ mkExportItems mod_map mod env decl_map decls (Just specs) | otherwise = decl in - [ ExportDecl decl' ] + return [ ExportDecl decl' ] -- ToDo: cope with record selectors here lookupExport (HsEAbs t) | Just decl <- findDecl t - = [ ExportDecl (restrictTo [] decl) ] + = return [ ExportDecl (restrictTo [] decl) ] lookupExport (HsEThingAll t) | Just decl <- findDecl t - = [ ExportDecl decl ] + = return [ ExportDecl decl ] lookupExport (HsEThingWith t cs) | Just decl <- findDecl t - = [ ExportDecl (restrictTo (map nameOfQName cs) decl) ] + = return [ ExportDecl (restrictTo (map nameOfQName cs) decl) ] lookupExport (HsEModuleContents m) = fullContentsOf m lookupExport (HsEGroup lev str) - = [ ExportGroup lev "" doc ] - where (doc, _names) = formatDocHeading (lookupForDoc env) str - -- ToDo: report the unresolved names + = do (doc, _names) <- formatDocHeading (lookupForDoc env) str + return [ ExportGroup lev "" doc ] + -- ToDo: report the unresolved names lookupExport (HsEDoc str) - = [ ExportDoc doc ] - where (doc, _names) = formatDocString (lookupForDoc env) str + = do (doc, _names) <- formatDocString (lookupForDoc env) str + return [ ExportDoc doc ] -- ToDo: report the unresolved names lookupExport (HsEDocNamed str) - | Just found <- findNamedDoc str decls - = let (doc, _names) = formatDocString (lookupForDoc env) found in - [ ExportDoc doc ] + = do r <- findNamedDoc str decls + case r of + Nothing -> return [] + Just found -> do + (doc, _nms) <- formatDocString (lookupForDoc env) found + return [ ExportDoc doc ] - lookupExport _ = [] -- didn't find it? + lookupExport _ = return [] -- didn't find it? fullContentsOf m | m == mod = fullContentsOfThisModule decls env | otherwise = case lookupFM mod_map m of - Just iface -> iface_orig_exports iface - Nothing -> trace ("Warning: module not found: " ++ show m) [] + Just iface + | OptHide `elem` iface_options iface + -> return (iface_orig_exports iface) + | otherwise -> return [ ExportModule m ] + Nothing -> do tell ["Warning: module not found: " ++ show m] + return [] findDecl :: HsQName -> Maybe HsDecl findDecl (UnQual n) @@ -330,17 +374,15 @@ mkExportItems mod_map mod env decl_map decls (Just specs) | otherwise = case lookupFM mod_map m of Just iface -> lookupFM (iface_decls iface) n - Nothing -> - trace ("Warning: module not found: " ++ show m) Nothing + Nothing -> Nothing fullContentsOfThisModule decls env = - [ mkExportItem decl | decl <- decls, keepDecl decl ] - where mkExportItem (HsDocGroup lev str) = - ExportGroup lev "" doc - where - (doc, _names) = formatDocHeading (lookupForDoc env) str + mapM mkExportItem (filter keepDecl decls) + where mkExportItem (HsDocGroup lev str) = do + (doc, _names) <- formatDocHeading (lookupForDoc env) str + return (ExportGroup lev "" doc) -- ToDo: report the unresolved names - mkExportItem decl = ExportDecl decl + mkExportItem decl = return (ExportDecl decl) keepDecl HsTypeSig{} = True @@ -351,18 +393,30 @@ keepDecl HsClassDecl{} = True keepDecl HsDocGroup{} = True keepDecl _ = False +-- ----------------------------------------------------------------------------- +-- Pruning + +pruneExportItems :: FiniteMap HsName Doc -> [ExportItem] -> [ExportItem] +pruneExportItems doc_map items = filter has_doc items + where has_doc (ExportDecl d) | Just n <- declMainBinder d = n `elemFM` doc_map + has_doc _ = True + -- ----------------------------------------------------------------------------- -- Gather a list of original names exported from this module exportedNames :: Module -> ModuleMap -> [HsDecl] -> [HsName] -> Maybe [HsExportSpec] -> FiniteMap HsName HsDecl + -> [DocOption] -> [HsQName] -exportedNames mod mod_scope decls local_names Nothing decl_map - = map (Qual mod) local_names -exportedNames mod mod_scope decls local_names (Just expspecs) decl_map - = concat (map extract expspecs) + +exportedNames mod mod_scope decls local_names maybe_exps decl_map options + | Nothing <- maybe_exps = all_local_names + | OptIgnoreExports `elem` options = all_local_names + | Just expspecs <- maybe_exps = concat (map extract expspecs) where + all_local_names = map (Qual mod) local_names + extract e = case e of HsEVar x -> [x] @@ -493,24 +547,26 @@ docsFromField (HsFieldDecl nms ty Nothing) rest -- this one formats a heading formatDocHeading :: (String -> Maybe HsQName) -> DocString - -> (Doc,[String]) + -> ErrMsgM (Doc,[String]) formatDocHeading lookup string = format parseString lookup string -- this one formats a sequence of paragraphs formatDocString :: (String -> Maybe HsQName) -> DocString - -> (Doc,[String]) + -> ErrMsgM (Doc,[String]) formatDocString lookup string = format parseParas lookup string format :: ([Token] -> Either String ParsedDoc) -> (String -> Maybe HsQName) -> DocString - -> (Doc, [String]) + -> ErrMsgM (Doc, [String]) format parse lookup string = case parse (tokenise string) of - Left error -> trace ("Warning: parse error in doc string beginning:\n\ - \ " ++ take 40 string) (DocEmpty, []) - Right doc -> runRn lookup (resolveDoc doc) - + Left error -> do + tell ["Warning: parse error in doc string beginning:\n\ + \ " ++ take 40 string] + return (DocEmpty, []) + Right doc -> + return (runRn lookup (resolveDoc doc)) -- --------------------------------------------------------------------------- -- Looking up names in documentation @@ -584,17 +640,48 @@ mkRegexWithOpts s single_line case_sensitive -- ----------------------------------------------------------------------------- -- Named documentation -findNamedDoc :: String -> [HsDecl] -> Maybe String +findNamedDoc :: String -> [HsDecl] -> ErrMsgM (Maybe String) findNamedDoc str decls = case matchRegex docNameRE str of Just (name:_) -> search decls - where search [] = Nothing + where search [] = do + tell ["Cannot find documentation for: $" ++ name] + return Nothing search (HsDocCommentNamed str : rest) = case matchRegexAll docNameRE str of Just (_, _, after, _, name':_) - | name == name' -> Just after + | name == name' -> return (Just after) _otherwise -> search rest search (_other_decl : rest) = search rest - _other -> Nothing + _other -> do + tell ["Invalid documentation name: $" ++ str] + return Nothing docNameRE = mkRegex "[ \t]*([A-Za-z0-9_]*)" + +-- ----------------------------------------------------------------------------- +-- Haddock options embedded in the source file + +processOptions :: String -> ErrMsgM [DocOption] +processOptions str = do + case break (== ',') str of + (this, ',':rest) -> do + opt <- parseOption this + opts <- processOptions rest + return (maybeToList opt ++ opts) + (this, _) + | all isSpace this -> return [] + | otherwise -> do opt <- parseOption this; return (maybeToList opt) + +parseOption :: String -> ErrMsgM (Maybe DocOption) +parseOption "hide" = return (Just OptHide) +parseOption "prune" = return (Just OptPrune) +parseOption "ignore-exports" = return (Just OptIgnoreExports) +parseOption other = do tell ["Unrecognised option: " ++ other]; return Nothing + +-- ----------------------------------------------------------------------------- +-- A monad which collects error messages + +type ErrMsg = String +type ErrMsgM a = Writer [ErrMsg] a + -- cgit v1.2.3