More work, started working on the renaming phase -- this code will need a cleanup soon :)

2 files changed, 26 insertions, 54 deletions

diff --git a/src/HaddockTypes.hs b/src/HaddockTypes.hs
index 10d7f796..df059f7d 100644
--- a/src/HaddockTypes.hs
+++ b/src/HaddockTypes.hs
@@ -138,8 +138,10 @@ type ModuleMap = Map Module Interface
 type ModuleMap2 = Map GHC.Module HaddockModule
 
 data HaddockModule = HM {
-  hmod_options           :: [DocOption],
-  hmod_exported_decl_map :: Map GHC.Name (GHC.HsDecl GHC.Name),
-  hmod_orig_exports      :: [ExportItem2],
-  hmod_sub_map           :: Map GHC.Name [GHC.Name]
+  hmod_options            :: [DocOption],
+  hmod_exported_decl_map  :: Map GHC.Name (GHC.HsDecl GHC.Name),
+  hmod_doc_map            :: Map GHC.Name (GHC.HsDoc GHC.Name),  
+  hmod_orig_exports       :: [ExportItem2],
+  hmod_documented_exports :: [GHC.Name],
+  hmod_sub_map            :: Map GHC.Name [GHC.Name]
 }
diff --git a/src/Main.hs b/src/Main.hs
index 666bb6e6..7af7e25e 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -454,31 +454,17 @@ instance Outputable (GHC.DocEntity GHC.Name) where
   ppr (GHC.DocEntity d) = ppr d
   ppr (GHC.DeclEntity name) = ppr name
 
-
-{-  let loop ((mod, checkedMod):modules) module_map = do
-        exported_names <- get_exported_names
-        binding_group  <- get_binding_group 
-        let exported_decls_map = mk_exported_decls_map exported_names binding_group
-        let exported_decls = Map.elems exported_decls_map
-
-        mkExportItems module_map mod exported_names exported_decls_map
-        where 
-          get_binding_group = case GHC.renamedSource checkedMod of
-            Just (group, _, _) -> group
-            Nothing            -> die "Failed to get renamed source"
-          get_module_info = case GHC.checkedModuleInfo checkedMod of 
-            Just mi -> return mi
-            Nothing -> die "Failed to get checkedModuleInfo"
-          get_exported_names = do
-            module_info <- get_module_info  
-            return (GHC.modInfoExports module_info)     
--}          
-
 type FullyCheckedModule = (GHC.ParsedSource, 
                            GHC.RenamedSource, 
                            GHC.TypecheckedSource, 
                            GHC.ModuleInfo)
 
+getDocumentedExports :: [ExportItem2] -> [GHC.Name]
+getDocumentedExports exports = concatMap getName exports
+  where
+  getName (ExportDecl2 name _ _ _) = [name]
+  getName _ = [] 
+
 pass1 :: [(GHC.Module, FullyCheckedModule)] -> [Flag] -> ErrMsgM ModuleMap2
 pass1 modules flags = worker modules (Map.empty) flags
   where
@@ -507,10 +493,12 @@ pass1 modules flags = worker modules (Map.empty) flags
                                     exports ignore_all_exports docMap
 
       let haddock_module = HM {
-            hmod_options           = opts,
-            hmod_exported_decl_map = exportedDeclMap,
-            hmod_orig_exports      = export_items,
-            hmod_sub_map           = sub_map
+            hmod_options            = opts,
+            hmod_exported_decl_map  = exportedDeclMap,
+            hmod_doc_map            = docMap,
+            hmod_orig_exports       = export_items,
+            hmod_sub_map            = sub_map,
+            hmod_documented_exports = getDocumentedExports export_items
           }
 
       let module_map' = Map.insert mod haddock_module module_map
@@ -579,24 +567,6 @@ mk_sub_map_from_group group =
   Map.fromList [ (name, subs) | L _ tycld <- GHC.hs_tyclds group,
                  let name:subs = map unLoc (GHC.tyClDeclNames tycld) ]
 
-recover_decls_from_group :: GHC.HsGroup GHC.Name -> [GHC.HsDecl GHC.Name]
-recover_decls_from_group group = 
-  map (withDoc    GHC.SigD    . unLoc) (sigs_from_valds (GHC.hs_valds group)) ++
-  map (withDoc    GHC.TyClD   . unLoc) (GHC.hs_tyclds group) ++
-  map (withoutDoc GHC.InstD   . unLoc) (GHC.hs_instds group) ++
-  map (withoutDoc GHC.DefD    . unLoc) (GHC.hs_defds  group) ++ 
-  map (withDoc    GHC.ForD    . unLoc) (GHC.hs_fords  group) ++
-  map (withoutDoc GHC.DeprecD . unLoc) (GHC.hs_depds  group) ++
-  map (withoutDoc GHC.RuleD   . unLoc) (GHC.hs_ruleds group) 
-  where 
-    sigs_from_valds (GHC.ValBindsOut _ lsigs) = lsigs  
-    sigs_from_valds _ = error "recover_decls_from_group: illegal input"
-    withDoc c d = c d Nothing
---    withDoc c d = case GHC.getMainDeclBinder (c d Nothing) of
---                    Just name -> c d (find_doc name group)
---                    Nothing -> c d Nothing
-    withoutDoc c d = c d
-
 mkDeclMap :: [GHC.Name] -> GHC.HsGroup GHC.Name -> Map GHC.Name (GHC.HsDecl GHC.Name) 
 mkDeclMap names group = Map.fromList [ (n,d)  | (n,Just d) <- maybeDecls ]
   where 
@@ -1082,9 +1052,8 @@ mkExportItems mod_map this_mod exported_names exportedDeclMap localDeclMap sub_m
     declWith :: GHC.Name -> ErrMsgM [ ExportItem2 ]
     declWith t | not (isExternalName t) = return []
     declWith t
-	| Just decl <- findDecl t
-	= let maybeDoc = Map.lookup t docMap in
-          return [ ExportDecl2 t (restrictTo subs (extractDecl t mdl decl)) maybeDoc [] ]
+	| (Just decl, maybeDoc) <- findDecl t
+        = return [ ExportDecl2 t (restrictTo subs (extractDecl t mdl decl)) maybeDoc [] ]
 	| otherwise
 	= return [ ExportNoDecl2 t t subs ]
 	-- can't find the decl (it might be from another package), but let's
@@ -1107,14 +1076,15 @@ mkExportItems mod_map this_mod exported_names exportedDeclMap localDeclMap sub_m
 		| otherwise -> return [ ExportModule2 m ]
 	     Nothing -> return [] -- already emitted a warning in exportedNames
 
-    findDecl :: GHC.Name -> Maybe (GHC.HsDecl GHC.Name)
-    findDecl n | not (isExternalName n) = Nothing
+    findDecl :: GHC.Name -> (Maybe (GHC.HsDecl GHC.Name), Maybe (GHC.HsDoc GHC.Name))
+    findDecl n | not (isExternalName n) = error "This shouldn't happen"
     findDecl n 
-	| m == this_mod = Map.lookup n exportedDeclMap
+	| m == this_mod = (Map.lookup n exportedDeclMap, Map.lookup n docMap)
 	| otherwise = 
 	   case Map.lookup m mod_map of
-		Just hmod -> Map.lookup n (hmod_exported_decl_map hmod)
-		Nothing -> Nothing
+		Just hmod -> (Map.lookup n (hmod_exported_decl_map hmod), 
+                              Map.lookup n (hmod_doc_map hmod))
+		Nothing -> (Nothing, Nothing)
       where
         m = nameModule n