Links to source location of class instance definitions

7 files changed, 62 insertions, 32 deletions

diff --git a/haddock-api/resources/html/Ocean.std-theme/ocean.css b/haddock-api/resources/html/Ocean.std-theme/ocean.css
index de436324..f762e832 100644
--- a/haddock-api/resources/html/Ocean.std-theme/ocean.css
+++ b/haddock-api/resources/html/Ocean.std-theme/ocean.css
@@ -378,6 +378,15 @@ div#style-menu-holder {
   margin: 0 -0.5em 0 0.5em;
 }
 
+#interface td.src .link {
+  float: right;
+  color: #919191;
+  border-left: 1px solid #919191;
+  background: #f0f0f0;
+  padding: 0 0.5em 0.2em;
+  margin: 0 -0.5em 0 0.5em;
+}
+
 #interface span.fixity {
   color: #919191;
   border-left: 1px solid #919191;
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index b717fc01..ee5bc861 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -544,14 +544,14 @@ ppDocInstances unicode (i : rest)
     (is, rest') = spanWith isUndocdInstance rest
 
 isUndocdInstance :: DocInstance a -> Maybe (InstHead a)
-isUndocdInstance (i,Nothing) = Just i
+isUndocdInstance (L _ i,Nothing) = Just i
 isUndocdInstance _ = Nothing
 
 -- | Print a possibly commented instance. The instance header is printed inside
 -- an 'argBox'. The comment is printed to the right of the box in normal comment
 -- style.
 ppDocInstance :: Bool -> DocInstance DocName -> LaTeX
-ppDocInstance unicode (instHead, doc) =
+ppDocInstance unicode (L _ instHead, doc) =
   declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX $ fmap _doc doc)
 
 
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 3bf4322d..d24a3f04 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -18,7 +18,6 @@ module Haddock.Backends.Xhtml.Decl (
   tyvarNames
 ) where
 
-
 import Haddock.Backends.Xhtml.DocMarkup
 import Haddock.Backends.Xhtml.Layout
 import Haddock.Backends.Xhtml.Names
@@ -270,7 +269,7 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode
       = subEquations qual $ map (ppTyFamEqn . unLoc) eqns
 
       | otherwise
-      = ppInstances instances docname unicode qual
+      = ppInstances links instances docname unicode qual
 
     -- Individual equation of a closed type family
     ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs
@@ -492,18 +491,19 @@ ppClassDecl summary links instances fixities loc d subdocs
     ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False) fs
       where wrap | p = parens | otherwise = id
 
-    instancesBit = ppInstances instances nm unicode qual
+    instancesBit = ppInstances links instances nm unicode qual
 
 ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
 
 
-ppInstances :: [DocInstance DocName] -> DocName -> Unicode -> Qualification -> Html
-ppInstances instances baseName unicode qual
-  = subInstances qual instName (map instDecl instances)
+ppInstances :: LinksInfo -> [DocInstance DocName] -> DocName -> Unicode -> Qualification -> Html
+ppInstances links instances baseName unicode qual
+  = subInstances qual instName links True baseName (map instDecl instances)
+  -- force Splice = True to use line URLs
   where
     instName = getOccString $ getName baseName
-    instDecl :: DocInstance DocName -> SubDecl
-    instDecl (inst, maybeDoc) = (instHead inst, maybeDoc, [])
+    instDecl :: DocInstance DocName -> (SubDecl,SrcSpan)
+    instDecl (L l inst, maybeDoc) = ((instHead inst, maybeDoc, []),l)
     instHead (n, ks, ts, ClassInst cs) = ppContextNoLocs cs unicode qual
         <+> ppAppNameTypes n ks ts unicode qual
     instHead (n, ks, ts, TypeInst rhs) = keyword "type"
@@ -582,7 +582,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl
                                      (map unLoc (con_names (unLoc c)))) fixities
       ]
 
-    instancesBit = ppInstances instances docname unicode qual
+    instancesBit = ppInstances links instances docname unicode qual
 
 
 
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index b2c60534..923958a7 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -148,6 +148,20 @@ subTable qual decls = Just $ table << aboves (concatMap subRow decls)
        docElement td << fmap (docToHtml Nothing qual) mdoc)
       : map (cell . (td <<)) subs
 
+-- | Sub table with source information (optional).
+subTableSrc :: Qualification -> LinksInfo -> Bool -> DocName -> [(SubDecl,SrcSpan)] -> Maybe Html
+subTableSrc _ _  _ _ [] = Nothing
+subTableSrc qual lnks splice dn decls = Just $ table << aboves (concatMap subRow decls)
+  where
+    subRow ((decl, mdoc, subs),loc) =
+      (td ! [theclass "src"] << decl
+      <+> linkHtml loc
+      <->
+      docElement td << fmap (docToHtml Nothing qual) mdoc
+      )
+      : map (cell . (td <<)) subs
+    linkHtml loc@(RealSrcSpan _) = links lnks loc splice dn
+    linkHtml _ = noHtml
 
 subBlock :: [Html] -> Maybe Html
 subBlock [] = Nothing
@@ -174,13 +188,15 @@ subEquations :: Qualification -> [SubDecl] -> Html
 subEquations qual = divSubDecls "equations" "Equations" . subTable qual
 
 
+-- | Generate sub table for instance declarations, with source
 subInstances :: Qualification
              -> String -- ^ Class name, used for anchor generation
-             -> [SubDecl] -> Html
-subInstances qual nm = maybe noHtml wrap . instTable
+             -> LinksInfo -> Bool -> DocName
+             -> [(SubDecl,SrcSpan)] -> Html
+subInstances qual nm lnks splice dn = maybe noHtml wrap . instTable
   where
     wrap = (subSection <<) . (subCaption +++)
-    instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTable qual
+    instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTableSrc qual lnks splice dn
     subSection = thediv ! [theclass "subs instances"]
     subCaption = paragraph ! collapseControl id_ True "caption" << "Instances"
     id_ = makeAnchorId $ "i:" ++ nm
@@ -200,12 +216,19 @@ declElem = paragraph ! [theclass "src"]
 -- a box for top level documented names
 -- it adds a source and wiki link at the right hand side of the box
 topDeclElem :: LinksInfo -> SrcSpan -> Bool -> [DocName] -> Html -> Html
-topDeclElem ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice names html =
-    declElem << (html <+> srcLink <+> wikiLink)
+topDeclElem lnks loc splice names html =
+    declElem << (html <+> (links lnks loc splice $ head names))
+        -- FIXME: is it ok to simply take the first name?
+
+-- | Adds a source and wiki link at the right hand side of the box.
+-- Name must be documented, otherwise we wouldn't get here.
+links :: LinksInfo -> SrcSpan -> Bool -> DocName -> Html
+links ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice (Documented n mdl) =
+   (srcLink <+> wikiLink)
   where srcLink = let nameUrl = Map.lookup origPkg sourceMap
                       lineUrl = Map.lookup origPkg lineMap
                       mUrl | splice    = lineUrl
-                                         -- Use the lineUrl as a backup
+                                        -- Use the lineUrl as a backup
                            | otherwise = maybe lineUrl Just nameUrl in
           case mUrl of
             Nothing  -> noHtml
@@ -227,10 +250,7 @@ topDeclElem ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice names htm
         origMod = nameModule n
         origPkg = modulePackageKey origMod
 
-        -- Name must be documented, otherwise we wouldn't get here
-        Documented n mdl = head names
-        -- FIXME: is it ok to simply take the first name?
-
         fname = case loc of
-                RealSrcSpan l -> unpackFS (srcSpanFile l)
-                UnhelpfulSpan _ -> error "topDeclElem UnhelpfulSpan"
+          RealSrcSpan l -> unpackFS (srcSpanFile l)
+          UnhelpfulSpan _ -> error "links: UnhelpfulSpan"
+links _ _ _ _ = noHtml
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index 1341e57f..37203d63 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -72,21 +72,22 @@ attachToExportItem expInfo iface ifaceMap instIfaceMap export =
       mb_info <- getAllInfo (tcdName d)
       insts <- case mb_info of
         Just (_, _, cls_instances, fam_instances) ->
-          let fam_insts = [ (synifyFamInst i opaque, n)
+          let fam_insts = [ (L (getSrcSpan n) $ synifyFamInst i opaque, doc)
                           | i <- sortBy (comparing instFam) fam_instances
-                          , let n = instLookup instDocMap (getName i) iface ifaceMap instIfaceMap
+                          , let n = getName i
+                          , let doc = instLookup instDocMap n iface ifaceMap instIfaceMap
                           , not $ isNameHidden expInfo (fi_fam i)
                           , not $ any (isTypeHidden expInfo) (fi_tys i)
                           , let opaque = isTypeHidden expInfo (fi_rhs i)
                           ]
-              cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap)
+              cls_insts = [ (L (getSrcSpan n) $ synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap)
                           | let is = [ (instanceHead' i, getName i) | i <- cls_instances ]
                           , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is
                           , not $ isInstanceHidden expInfo cls tys
                           ]
               -- fam_insts but with failing type fams filtered out
-              cleanFamInsts = [ (fi, n) | (Right fi, n) <- fam_insts ]
-              famInstErrs = [ errm | (Left errm, _) <- fam_insts ]
+              cleanFamInsts = [ (L l fi, n) | (L l (Right fi), n) <- fam_insts ]
+              famInstErrs = [ errm | (L _ (Left errm), _) <- fam_insts ]
           in do
             dfs <- getDynFlags
             let mkBug = (text "haddock-bug:" <+>) . text
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 1ea212f5..7b9481fe 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -499,10 +499,10 @@ renameExportItem item = case item of
     decl' <- renameLDecl decl
     doc'  <- renameDocForDecl doc
     subs' <- mapM renameSub subs
-    instances' <- forM instances $ \(inst, idoc) -> do
+    instances' <- forM instances $ \(L l inst, idoc) -> do
       inst' <- renameInstHead inst
       idoc' <- mapM renameDoc idoc
-      return (inst', idoc')
+      return (L l inst', idoc')
     fixities' <- forM fixities $ \(name, fixity) -> do
       name' <- lookupRn name
       return (name', fixity)
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index e93294a0..ae90ff07 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -300,8 +300,8 @@ instance OutputableBndr a => Outputable (InstType a) where
   ppr (TypeInst  a) = text "TypeInst"  <+> ppr a
   ppr (DataInst  a) = text "DataInst"  <+> ppr a
 
--- | An instance head that may have documentation.
-type DocInstance name = (InstHead name, Maybe (MDoc name))
+-- | An instance head that may have documentation and a source location.
+type DocInstance name = (Located (InstHead name), Maybe (MDoc name))
 
 -- | The head of an instance. Consists of a class name, a list of kind
 -- parameters, a list of type parameters and an instance type