Add instances, build renaming environment, start on the renamer

examples/hide-bug/B.hs

-module B(f, T) where import A
+module B(Test) where 
+
+data Test = Test

examples/hide-bug/C.hs

-module C(module B) where import B
+module C(C.bla) where 
+
+import D
+
+bla :: Test
+bla = undefined

examples/hide-bug/D.hs

 -- The link to the type T in the doc for this module should point to 
 -- B.T, not A.T.  Bug fixed in rev 1.59 of Main.hs.
-module D(f) where import C
+module D(Test) where 
+
+import B

src/HaddockRename.hs

@@ -5,21 +5,26 @@
 --
 
 module HaddockRename (
-	RnM, runRn, runRnFM, runRnUnqualFM, -- the monad (instance of Monad)
+	RnM, runRn, runRnFM, -- the monad (instance of Monad)
 
-	renameExportList, 
-	renameDecl,
-	renameExportItems, renameInstHead,
-	renameDoc, renameMaybeDoc,
+	--renameExportList, 
+	--renameDecl,
+	--renameExportItems, renameInstHead,
+	--renameDoc, renameMaybeDoc,
+  renameMaybeDoc, renameExportItems,
   ) where
 
 import HaddockTypes
 import HaddockUtil	( unQual )
-import HsSyn2
+--import HsSyn2
 import Map ( Map )
 import qualified Map hiding ( Map )
 
-import Monad
+import Prelude hiding ( mapM )
+import Control.Monad hiding ( mapM )
+import Data.Traversable
+
+import GHC
 
 -- -----------------------------------------------------------------------------
 -- Monad for renaming
@@ -29,11 +34,11 @@ import Monad
 -- the environment.
 
 newtype GenRnM n a = 
-  RnM { unRn :: (n -> (Bool,HsQName))	-- name lookup function
+  RnM { unRn :: (n -> (Bool, DocName))	-- name lookup function
              -> (a,[n])
       }
 
-type RnM a = GenRnM HsQName a
+type RnM a = GenRnM Name a
 
 instance Monad (GenRnM n) where
   (>>=) = thenRn
@@ -46,56 +51,76 @@ m `thenRn` k = RnM (\lkp -> case unRn m lkp of
 				(a,out1) -> case unRn (k a) lkp of
 						(b,out2) -> (b,out1++out2))
 
-getLookupRn :: RnM (HsQName -> (Bool,HsQName))
+getLookupRn :: RnM (Name -> (Bool, DocName))
 getLookupRn = RnM (\lkp -> (lkp,[]))
-outRn :: HsQName -> RnM ()
+outRn :: Name -> RnM ()
 outRn name = RnM (\_ -> ((),[name]))
 
-lookupRn :: (HsQName -> a) -> HsQName -> RnM a
+lookupRn :: (DocName -> a) -> Name -> RnM a
 lookupRn and_then name = do
   lkp <- getLookupRn
   case lkp name of
 	(False,maps_to) -> do outRn name; return (and_then maps_to)
 	(True, maps_to) -> return (and_then maps_to)
 
-runRnFM :: Map HsQName HsQName -> RnM a -> (a,[HsQName])
+runRnFM :: Map Name Name -> RnM a -> (a,[Name])
 runRnFM env rn = unRn rn lkp 
   where lkp n = case Map.lookup n env of
-		  Nothing -> (False, n) -- leave the qualified name
-		  Just q  -> (True,  q)
-
--- like runRnFM, but if it can't find a mapping for a name,
--- it leaves an unqualified name in place instead.
-runRnUnqualFM :: Map HsQName HsQName -> RnM a -> (a,[HsQName])
-runRnUnqualFM env rn = unRn rn lkp 
-  where lkp n = case Map.lookup n env of
-		  Nothing -> (False, unQual n) -- remove the qualifier
-		  Just q  -> (True, q)
+		  Nothing -> (False, NoLink n) 
+		  Just q  -> (True,  Link q)
 
-runRn :: (n -> (Bool,HsQName)) -> GenRnM n a -> (a,[n])
+runRn :: (n -> (Bool,DocName)) -> GenRnM n a -> (a,[n])
 runRn lkp rn = unRn rn lkp
 
--- -----------------------------------------------------------------------------
--- Renaming source code & documentation
+renameExportItems :: [ExportItem2 Name] -> RnM [ExportItem2 DocName]
+renameExportItems items = mapM renameExportItem items
 
-renameExportList :: [HsExportSpec] -> RnM [HsExportSpec]
-renameExportList spec = mapM renameExport spec
-  where
-    renameExport (HsEVar x) = lookupRn HsEVar x
-    renameExport (HsEAbs x) = lookupRn HsEAbs x
-    renameExport (HsEThingAll x) = lookupRn HsEThingAll x
-    renameExport (HsEThingWith x cs) = do
-	cs' <- mapM (lookupRn id) cs
-	lookupRn (\x' -> HsEThingWith x' cs') x
-    renameExport (HsEModuleContents m) = return (HsEModuleContents m)
-    renameExport (HsEGroup lev doc0) = do
-	doc <- renameDoc doc0
-	return (HsEGroup lev doc)
-    renameExport (HsEDoc doc0) = do
-	doc <- renameDoc doc0
-	return (HsEDoc doc)
-    renameExport (HsEDocNamed str) = return (HsEDocNamed str)
+renameMaybeDoc :: Maybe (HsDoc Name) -> RnM (Maybe (HsDoc DocName))
+renameMaybeDoc mbDoc = mapM renameDoc mbDoc
+
+renameDoc :: HsDoc Name -> RnM (HsDoc DocName)
+renameDoc doc = case doc of
+
+  DocEmpty -> return DocEmpty
+
+  DocAppend a b -> do
+    a' <- renameDoc a
+    b' <- renameDoc b
+    return (DocAppend a' b')
+
+  DocString str -> return (DocString str)
+
+  DocParagraph doc -> do
+    doc' <- renameDoc doc
+    return (DocParagraph doc')
 
+  DocIdentifier ids -> do
+    lkp <- getLookupRn
+    case [ n | (True, n) <- map lkp ids ] of
+      ids'@(_:_) -> return (DocIdentifier ids')
+      [] -> return (DocIdentifier (map Link ids))
+
+  DocModule str -> return (DocModule str)
+
+  DocEmphasis doc -> do
+    doc' <- renameDoc doc
+    return (DocEmphasis doc')
+
+  DocMonospaced doc -> do
+    doc' <- renameDoc doc
+    return (DocMonospaced doc')
+
+  DocUnorderedList docs -> do
+    docs' <- mapM renameDoc docs
+    return (DocUnorderedList docs')
+
+  DocOrderedList docs -> do
+    docs' <- mapM renameDoc docs
+    return (DocOrderedList docs')
+
+-- -----------------------------------------------------------------------------
+-- Renaming source code & documentation
+{-
 
 renameDecl :: HsDecl -> RnM HsDecl
 renameDecl decl
@@ -207,62 +232,6 @@ renameInstHead (ctx,asst) = do
   asst <- renamePred asst
   return (ctx,asst)
 
--- -----------------------------------------------------------------------------
--- Renaming documentation
-
--- Renaming documentation is done by "marking it up" from ordinary Doc
--- into (Rn Doc), which can then be renamed with runRn.
-markupRename :: DocMarkup [HsQName] (RnM Doc)
-markupRename = Markup {
-  markupEmpty         = return DocEmpty,
-  markupString        = return . DocString,
-  markupParagraph     = liftM DocParagraph,
-  markupAppend        = liftM2 DocAppend,
-  markupIdentifier    = lookupForDoc,
-  markupModule        = return . DocModule,
-  markupEmphasis      = liftM DocEmphasis,
-  markupMonospaced    = liftM DocMonospaced,
-  markupUnorderedList = liftM DocUnorderedList . sequence,
-  markupOrderedList   = liftM DocOrderedList . sequence,
-  markupDefList       = liftM DocDefList . mapM markupDef,
-  markupCodeBlock     = liftM DocCodeBlock,
-  markupURL	      = return . DocURL,
-  markupAName	      = return . DocAName
-  }
-
-markupDef (ma,mb) = do a <- ma; b <- mb; return (a,b)
-
-renameDoc :: Doc -> RnM Doc
-renameDoc = markup markupRename
-
-renameMaybeDoc :: Maybe Doc -> RnM (Maybe Doc)
-renameMaybeDoc Nothing = return Nothing
-renameMaybeDoc (Just doc) = Just `liftM` renameDoc doc
-
--- ---------------------------------------------------------------------------
--- Looking up names in documentation
-
-lookupForDoc :: [HsQName] -> RnM Doc
-lookupForDoc qns = do
-  lkp <- getLookupRn
-  case [ n | (True,n) <- map lkp qns ] of
-	ns@(_:_) -> return (DocIdentifier ns)
-	[] -> -- if we were given a qualified name, but there's nothing
-	      -- matching that name in scope, then just assume its existence
-	      -- (this means you can use qualified names in doc strings wihout
-	      -- worrying about whether the entity is in scope).
-	      let quals = filter isQualified qns in
-	      if (not (null quals)) then
-		return (DocIdentifier quals)
-	      else do
-		outRn (head qns)
-		-- no qualified names: just replace this name with its
-		-- string representation.
-		return (DocString (show (head qns)))
- where
-   isQualified (Qual _ _) = True
-   isQualified _ = False
-   
 -- -----------------------------------------------------------------------------
 
 renameExportItems :: [ExportItem] -> RnM [ExportItem]
@@ -284,3 +253,28 @@ renameExportItems items = mapM rn items
 	rn (ExportDoc doc0)
 	   = do doc <- renameDoc doc0
 		return (ExportDoc doc)
+-}
+
+renameInstHead = undefined
+
+
+renameDecl = undefined
+
+renameExportItem :: ExportItem2 Name -> RnM (ExportItem2 DocName)
+renameExportItem item = case item of 
+  ExportModule2 mod -> return (ExportModule2 mod)
+  ExportGroup2 lev id doc -> do
+    doc' <- renameDoc doc
+    return (ExportGroup2 lev id doc')
+  ExportDecl2 x decl doc instances -> do
+    decl' <- renameDecl decl
+    doc' <- mapM renameDoc doc
+    instances' <- mapM renameInstHead instances
+    return (ExportDecl2 x decl' doc' instances')
+  ExportNoDecl2 x y subs -> do
+    y' <- lookupRn id y
+    subs' <- mapM (lookupRn id) subs
+    return (ExportNoDecl2 x y' subs')
+  ExportDoc2 doc -> do
+    doc' <- renameDoc doc
+    return (ExportDoc2 doc')

src/HaddockTypes.hs

@@ -9,7 +9,8 @@ module HaddockTypes (
   NameEnv, Interface(..), ExportItem(..), ExportItem2(..), ModuleMap, ModuleMap2,
   HaddockModule(..), 
   -- * Misc types
-  DocOption(..), InstHead,
+  DocOption(..), InstHead, InstHead2,
+  DocName(..),
  ) where
 
 import HsSyn2
@@ -108,40 +109,71 @@ data ExportItem
   | ExportModule	-- a cross-reference to another module
 	Module
 
-data ExportItem2 
+data ExportItem2 name
   = ExportDecl2
-	GHC.Name	      -- the original name
-	(GHC.HsDecl GHC.Name) -- a declaration
-        (Maybe (GHC.HsDoc GHC.Name))       -- maybe a doc comment
-	[InstHead]	      -- instances relevant to this declaration
+        GHC.Name	      -- the original name
+	(GHC.LHsDecl name) -- a declaration
+        (Maybe (GHC.HsDoc name))       -- maybe a doc comment
+	[InstHead2]	      -- instances relevant to this declaration
 
   | ExportNoDecl2	-- an exported entity for which we have no documentation
 			-- (perhaps becuase it resides in another package)
-	GHC.Name		-- the original name
-	GHC.Name		-- where to link to
-	[GHC.Name]	-- subordinate names
+	GHC.Name	-- the original name
+	name		-- where to link to
+	[name]	-- subordinate names
 
   | ExportGroup2		-- a section heading
 	Int		-- section level (1, 2, 3, ... )
 	String		-- section "id" (for hyperlinks)
-	(GHC.HsDoc GHC.Name)		-- section heading text
+	(GHC.HsDoc name)		-- section heading text
 
   | ExportDoc2		-- some documentation
-	(GHC.HsDoc GHC.Name)
+	(GHC.HsDoc name)
 
   | ExportModule2	-- a cross-reference to another module
 	GHC.Module
 
 type InstHead = (HsContext,HsAsst)
 
+type InstHead2 = ([GHC.TyVar], [GHC.PredType], GHC.Class, [GHC.Type])
+
 type ModuleMap = Map Module Interface
 type ModuleMap2 = Map GHC.Module HaddockModule
 
+data DocName = Link GHC.Name | NoLink GHC.Name
+
 data HaddockModule = HM {
+
+-- | A value to identify the module
+  hmod_mod                :: GHC.Module,
+
+-- | The documentation header for this module
+  hmod_doc                :: Maybe (GHC.HsDoc GHC.Name),
+
+-- | The Haddock options for this module (prune, ignore-exports, etc)
   hmod_options            :: [DocOption],
-  hmod_exported_decl_map  :: Map GHC.Name (GHC.HsDecl GHC.Name),
+
+  hmod_exported_decl_map  :: Map GHC.Name (GHC.LHsDecl 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]
+  hmod_export_items       :: [ExportItem2 GHC.Name],
+
+-- | All the names that are defined in this module
+  hmod_locals             :: [GHC.Name],
+
+-- | All the names that are exported by this module
+  hmod_exports            :: [GHC.Name],
+
+-- | All the visible names exported by this module
+-- For a name to be visible, it has to:
+-- - be exported normally, and not via a full module re-exportation.
+-- - have a declaration in this module or any of it's imports, with the exception
+--   that it can't be from another package.
+-- Basically, a visible name is a name that will show up in the documentation.
+-- for this module.
+  hmod_visible_exports    :: [GHC.Name],
+
+  hmod_sub_map            :: Map GHC.Name [GHC.Name],
+
+-- | The instances exported by this module
+  hmod_instances          :: [GHC.Instance]
 }

src/HaddockUtil.hs

@@ -143,8 +143,8 @@ addConDocs (x:xs) doc = addConDoc x doc : xs
 -- ---------------------------------------------------------------------------
 -- Making abstract declarations
 
-restrictTo :: [GHC.Name] -> (GHC.HsDecl GHC.Name) -> (GHC.HsDecl GHC.Name)
-restrictTo names decl = case decl of
+restrictTo :: [GHC.Name] -> (GHC.LHsDecl GHC.Name) -> (GHC.LHsDecl GHC.Name)
+restrictTo names (L loc decl) = L loc $ case decl of
   GHC.TyClD d doc | GHC.isDataDecl d && GHC.tcdND d == GHC.DataType -> 
     GHC.TyClD (d { GHC.tcdCons = restrictCons names (GHC.tcdCons d) }) doc
   GHC.TyClD d doc | GHC.isDataDecl d && GHC.tcdND d == GHC.NewType ->