Comments on instances

Implementing this was a little trickier than I thought, since we need to match
up instances from the renamed syntax with instances represented by
InstEnv.Instance. This is due to the current design of Haddock, which matches
comments with declarations from the renamed syntax, while getting the list of
instances of a class/family directly using the GHC API.

- Works for class instances only (Haddock has no support for type family
  instances yet)
- The comments are rendered to the right of the instance head in the HTML output
- No change to the .haddock file format
- Works for normal user-written instances only. No comments are added on
  derived or TH-generated instances

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