aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/HaddockHtml.hs14
-rw-r--r--src/HaddockRename.hs2
-rw-r--r--src/HaddockTypes.hs12
-rw-r--r--src/HsLexer.lhs5
-rw-r--r--src/HsParser.ly20
-rw-r--r--src/HsSyn.lhs6
-rw-r--r--src/Main.hs363
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
+
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-15 18:31:07 +0000