[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
<chak@cse.unsw.edu.au> (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.

1 files changed, 225 insertions, 138 deletions

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
+