3 files changed, 71 insertions, 21 deletions

diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs
index b996f278..a10cb36a 100644
--- a/src/Haddock/Interface/AttachInstances.hs
+++ b/src/Haddock/Interface/AttachInstances.hs
@@ -18,7 +18,9 @@ module Haddock.Interface.AttachInstances (attachInstances) where
 import Haddock.Types
 import Haddock.Convert
 
+import Control.Arrow
 import Data.List
+import qualified Data.Map as Map
 
 import GHC
 import Name
@@ -40,22 +42,38 @@ import FastString
 #define FSLIT(x) (mkFastString# (x#))
 
 
-attachInstances :: [Interface] -> Ghc [Interface]
-attachInstances = mapM attach
+attachInstances :: [Interface] -> InstIfaceMap -> Ghc [Interface]
+attachInstances ifaces instIfaceMap = mapM attach ifaces
   where
     attach iface = do
       newItems <- mapM attachExport $ ifaceExportItems iface
       return $ iface { ifaceExportItems = newItems }
-
-    attachExport export@ExportDecl{expItemDecl = L _ (TyClD d)} = do
-       mb_info <- getAllInfo (unLoc (tcdLName d))
-       return $ export { expItemInstances = case mb_info of
-         Just (_, _, instances) ->
-           map synifyInstHead . sortImage instHead . map instanceHead $ instances
-         Nothing ->
-           []
-        }
-    attachExport export = return export
+      where
+        attachExport export@ExportDecl{expItemDecl = L _ (TyClD d)} = do
+           mb_info <- getAllInfo (unLoc (tcdLName d))
+           return $ export { expItemInstances = case mb_info of
+             Just (_, _, instances) ->
+               let insts = map (first synifyInstHead) $ sortImage (first instHead)
+                             [ (instanceHead i, getName i) | i <- instances ]
+               in [ (name, inst, lookupInstDoc name iface instIfaceMap)
+                  | (inst, name) <- insts ]
+             Nothing -> []
+            }
+        attachExport export = return export
+
+
+lookupInstDoc :: Name -> Interface -> InstIfaceMap -> Maybe (HsDoc Name)
+-- TODO: capture this pattern in a function (when we have streamlined the
+-- handling of instances)
+lookupInstDoc name iface ifaceMap =
+  case Map.lookup name (ifaceInstanceDocMap iface) of
+    Just doc -> Just doc
+    Nothing -> do -- in Maybe
+      instIface <- Map.lookup modName ifaceMap
+      (Just doc, _) <- Map.lookup name (instDocMap instIface)
+      return doc
+  where
+    modName = nameModule name
 
 
 -- | Like GHC's getInfo but doesn't cut things out depending on the
@@ -63,6 +81,7 @@ attachInstances = mapM attach
 getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance]))
 getAllInfo name = withSession $ \hsc_env -> ioMsg $ tcRnGetInfo hsc_env name
 
+
 --------------------------------------------------------------------------------
 -- Collecting and sorting instances
 --------------------------------------------------------------------------------
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index f1023825..874037d7 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -56,13 +56,18 @@ createInterface ghcMod flags modMap instIfaceMap = do
   (info, mbDoc)    <- liftErrMsg $ lexParseRnHaddockModHeader
                                        gre (ghcMbDocHdr ghcMod)
   decls0           <- liftErrMsg $ declInfos gre (topDecls (ghcGroup ghcMod))
-  let decls         = filterOutInstances decls0
+
+  let instances      = ghcInstances ghcMod
+      localInsts     = filter (nameIsLocalOrFrom mdl . getName) instances
+      declDocs       = [ (decl, doc) | (L _ decl, (Just doc, _), _) <- decls0 ]
+      instanceDocMap = mkInstanceDocMap localInsts declDocs
+
+      decls         = filterOutInstances decls0
       declMap       = mkDeclMap decls
       exports       = fmap (reverse . map unLoc) (ghcMbExports ghcMod)
       localNames    = ghcDefinedNames ghcMod
       ignoreExps    = Flag_IgnoreAllExports `elem` flags
       exportedNames = ghcExportedNames ghcMod
-      instances     = ghcInstances ghcMod
 
   liftErrMsg $ warnAboutFilteredDecls mdl decls0
 
@@ -93,7 +98,8 @@ createInterface ghcMod flags modMap instIfaceMap = do
     ifaceVisibleExports  = visibleNames, 
     ifaceDeclMap         = declMap,
     ifaceSubMap          = mkSubMap declMap exportedNames,
-    ifaceInstances       = ghcInstances ghcMod
+    ifaceInstances       = instances,
+    ifaceInstanceDocMap  = instanceDocMap
   }
 
 
@@ -128,6 +134,22 @@ parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing
 -- Declarations
 --------------------------------------------------------------------------------
 
+
+mkInstanceDocMap :: [Instance] -> [(HsDecl name, doc)] -> Map Name doc
+mkInstanceDocMap instances decls =
+  -- We relate Instances to InstDecls using the SrcSpans buried inside them.
+  -- That should work for normal user-written instances (from looking at GHC
+  -- sources). We can assume that commented instances are user-written.
+  -- This lets us relate Names (from Instances) to comments (associated
+  -- with InstDecls).
+  let docMap = Map.fromList [ (loc, doc)
+                            | (InstD (InstDecl (L loc _) _ _ _), doc) <- decls ]
+
+  in Map.fromList [ (name, doc) | inst <- instances
+                  , let name = getName inst
+                  , Just doc <- [ Map.lookup (getSrcSpan name) docMap ] ]
+
+
 -- | Make a sub map from a declaration map. Make sure we only include exported
 -- names.
 mkSubMap :: Map Name DeclInfo -> [Name] -> Map Name [Name]
@@ -137,13 +159,13 @@ mkSubMap declMap exports =
     filterSubs (_, _, subs) = [ sub  | (sub, _) <- subs, sub `elem` exports ]
 
 
--- Make a map from names to 'DeclInfo's. Exclude declarations that don't
--- have names (instances and stand-alone documentation comments). Include
+-- Make a map from names to 'DeclInfo's. Exclude declarations that don't have
+-- names (e.g. instances and stand-alone documentation comments). Include
 -- subordinate names, but map them to their parent declarations. 
 mkDeclMap :: [DeclInfo] -> Map Name DeclInfo
 mkDeclMap decls = Map.fromList . concat $
   [ (declName d, (parent, doc, subs)) : subDecls
-  | (parent@(L _ d), doc, subs) <- decls 
+  | (parent@(L _ d), doc, subs) <- decls
   , let subDecls = [ (n, (parent, doc', [])) | (n, doc') <- subs ]
   , not (isDocD d), not (isInstD d) ]
 
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index 5eac9e67..308c86c5 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -37,8 +37,13 @@ renameInterface renamingEnv warnings iface =
   let localEnv = foldl fn renamingEnv (ifaceVisibleExports iface)
         where fn env name = Map.insert name (ifaceMod iface) env
 
-      docMap = Map.map (\(_,x,_) -> x) (ifaceDeclMap iface)
-      docs   = Map.toList docMap
+      docMap   = Map.map (\(_,x,_) -> x) (ifaceDeclMap iface)
+
+      -- make instance docs into 'docForDecls'
+      instDocs = [ (name, (Just doc, Map.empty))
+                 | (name, doc) <- Map.toList (ifaceInstanceDocMap iface) ]
+
+      docs     = Map.toList docMap ++ instDocs
       renameMapElem (k,d) = do d' <- renameDocForDecl d; return (k, d')
 
       -- rename names in the exported declarations to point to things that
@@ -448,7 +453,11 @@ renameExportItem item = case item of
     decl' <- renameLDecl decl
     doc'  <- renameDocForDecl doc
     subs' <- mapM renameSub subs
-    instances' <- mapM renameInstHead instances
+    instances' <- forM instances $ \(name, inst, idoc) -> do
+      name' <- rename name
+      inst' <- renameInstHead inst
+      idoc' <- mapM renameDoc idoc
+      return (name', inst', idoc')
     return (ExportDecl decl' doc' subs' instances')
   ExportNoDecl x subs -> do
     x'    <- lookupRn id x