From 1b6bcd62e7f5534be45a0d5737b76d181c2d934b Mon Sep 17 00:00:00 2001
From: Phil Ruffwind <rf@rufflewind.com>
Date: Wed, 30 Sep 2015 02:22:43 -0400
Subject: Move the permalinks to "#" on the right side

Since pull request #407, the identifiers have been permalinked to
themselves, but this makes it difficult to copy the identifier by
double-clicking.  To work around this usability problem, the permalinks
are now placed on the far right adjacent to "Source", indicated by "#".

Also, 'namedAnchor' now uses 'id' instead of 'name' (which is obsolete).
---
 haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 11 +++++++----
 haddock-api/src/Haddock/Backends/Xhtml/Names.hs  |  6 +++---
 haddock-api/src/Haddock/Backends/Xhtml/Utils.hs  |  2 +-
 3 files changed, 11 insertions(+), 8 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index 98df09fe..26aeaff8 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -43,12 +43,13 @@ import Haddock.Backends.Xhtml.DocMarkup
 import Haddock.Backends.Xhtml.Types
 import Haddock.Backends.Xhtml.Utils
 import Haddock.Types
-import Haddock.Utils (makeAnchorId)
+import Haddock.Utils (makeAnchorId, nameAnchorId)
 import qualified Data.Map as Map
 import Text.XHtml hiding ( name, title, p, quote )
 
 import FastString            ( unpackFS )
 import GHC
+import Name (nameOccName)
 
 --------------------------------------------------------------------------------
 -- * Sections of the document
@@ -256,9 +257,11 @@ topDeclElem lnks loc splice names html =
 -- | 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
+links ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice docName@(Documented n mdl) =
+  srcLink <+> wikiLink <+> (selfLink ! [theclass "selflink"] << "#")
+  where selfLink = linkedAnchor (nameAnchorId (nameOccName (getName docName)))
+
+        srcLink = let nameUrl = Map.lookup origPkg sourceMap
                       lineUrl = Map.lookup origPkg lineMap
                       mUrl | splice    = lineUrl
                                         -- Use the lineUrl as a backup
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
index c69710d1..5492178b 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
@@ -120,11 +120,11 @@ ppBinderWith :: Notation -> Bool -> OccName -> Html
 -- the documentation or is the actual definition; in the latter case, we also
 -- set the 'id' and 'class' attributes.
 ppBinderWith notation isRef n =
-  linkedAnchor name ! attributes << ppBinder' notation n
+  makeAnchor << ppBinder' notation n
   where
     name = nameAnchorId n
-    attributes | isRef     = []
-               | otherwise = [identifier name, theclass "def"]
+    makeAnchor | isRef     = linkedAnchor name
+               | otherwise = namedAnchor name ! [theclass "def"]
 
 ppBinder' :: Notation -> OccName -> Html
 ppBinder' notation n = wrapInfix notation n $ ppOccName n
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
index 98ff4007..1d49807d 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
@@ -195,7 +195,7 @@ dot = toHtml "."
 
 -- | Generate a named anchor
 namedAnchor :: String -> Html -> Html
-namedAnchor n = anchor ! [XHtml.name n]
+namedAnchor n = anchor ! [XHtml.identifier n]
 
 
 linkedAnchor :: String -> Html -> Html
-- 
cgit v1.2.3