diff options
| -rw-r--r-- | src/HaddockHtml.hs | 14 | ||||
| -rw-r--r-- | src/HaddockRename.hs | 2 | ||||
| -rw-r--r-- | src/HaddockTypes.hs | 12 | ||||
| -rw-r--r-- | src/HsLexer.lhs | 5 | ||||
| -rw-r--r-- | src/HsParser.ly | 20 | ||||
| -rw-r--r-- | src/HsSyn.lhs | 6 | ||||
| -rw-r--r-- | src/Main.hs | 363 |
7 files changed, 268 insertions, 154 deletions
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 @@ -352,17 +394,29 @@ 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 + |