Mon Nov 20 20:52:14 UTC 2017

Repository : ssh://git@git.haskell.org/haddock

On branches: 2.17.3.1-spanfix,alexbiehl-patch-1,ghc-8.0,ghc-8.0-facebook,ghc-head,ghc-head1,haddock-quick,headdock-library-1.4.5,ie_avails,issue-303,issue-475,master,pr-filter-maps,pr/cabal-desc,travis,v2.16,v2.17,v2.17.3,v2.18,wip-located-module-as,wip/D2418,wip/T11080-open-data-kinds,wip/T11258,wip/T11430,wip/T12105,wip/T12105-2,wip/T12942,wip/T13163,wip/T3384,wip/embelleshed-rdr,wip/new-tree-one-param,wip/rae,wip/remove-frames,wip/remove-frames1,wip/revert-ttg-2017-11-20,wip/ttg-2017-10-13,wip/ttg-2017-10-31,wip/ttg-2017-11-06,wip/ttg2-2017-11-10,wip/ttg3-2017-11-12,wip/ttg4-constraints-2017-11-13
Link       : http://git.haskell.org/haddock.git/commitdiff/a49a3f0840f2880814c35f58d89805b3cd3039d3

>---------------------------------------------------------------

commit a49a3f0840f2880814c35f58d89805b3cd3039d3
Author: Łukasz Hanuszczak <lukasz.hanuszczak at gmail.com>
Date:   Fri Jul 31 16:24:36 2015 +0200

    Fix issue with incorrect instance details sections being expanded.


>---------------------------------------------------------------

a49a3f0840f2880814c35f58d89805b3cd3039d3
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 39 ++++++++++++++++++++++----
 1 file changed, 34 insertions(+), 5 deletions(-)

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index af946f9..35e5c5f 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE TransformListComp #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE Rank2Types #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Haddock.Backends.Html.Decl
@@ -26,8 +27,11 @@ import Haddock.Backends.Xhtml.Types
 import Haddock.Backends.Xhtml.Utils
 import Haddock.GhcUtils
 import Haddock.Types
+import Haddock.Syb
 import Haddock.Doc (combineDocumentation)
 
+import           Data.Bits
+import           Data.Data (Data, cast)
 import           Data.List             ( intersperse, sort )
 import qualified Data.Map as Map
 import           Data.Maybe
@@ -35,6 +39,7 @@ import           Text.XHtml hiding     ( name, title, p, quote )
 
 import GHC
 import GHC.Exts
+import Unique
 import Name
 import BooleanFormula
 
@@ -553,7 +558,7 @@ ppInstances links origin instances baseName splice unicode qual
 ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification
            -> Maybe (MDoc DocName) -> InstOrigin -> Int -> InstHead DocName
            -> SubDecl
-ppInstHead links splice unicode qual mdoc origin no (InstHead {..}) =
+ppInstHead links splice unicode qual mdoc origin no ihd@(InstHead {..}) =
     case ihdInstType of
         ClassInst { .. } ->
             ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual <+> typ
@@ -561,7 +566,7 @@ ppInstHead links splice unicode qual mdoc origin no (InstHead {..}) =
             , [subInstDetails iid ats sigs]
             )
           where
-            iid = instanceId origin no ihdClsName
+            iid = instanceId origin no ihd
             sigs = ppInstanceSigs links splice unicode qual clsiSigs
             ats = ppInstanceAssocTys links splice unicode qual clsiAssocTys
         TypeInst rhs ->
@@ -600,15 +605,39 @@ lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
 lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n
 
 
-instanceId :: InstOrigin -> Int -> DocName -> String
-instanceId orgin no name =
-    qual orgin ++ ":" ++ (occNameString . getOccName) name ++ "-" ++ show no
+instanceId :: InstOrigin -> Int -> InstHead DocName -> String
+instanceId orgin no ihd = concat
+    [ qual orgin
+    , ":" ++ (occNameString . getOccName . ihdClsName) ihd
+    , "-" ++ show (instHeadId ihd)
+    , "-" ++ show no
+    ]
   where
     qual OriginClass = "ic"
     qual OriginData = "id"
     qual OriginFamily = "if"
 
 
+-- | Compute unique identifier for given instance.
+--
+-- This is rather poor way of doing it. Ideally, we would like to have
+-- everything wrapped in a stateful monad that allows us to generate unique
+-- identifiers as needed. Since introducing such monad would require major
+-- refactoring, for now we just generate naive hash for given instance.
+--
+-- Hashing is very, very trivial and turns a list of 'DocName' to 'Int'. Idea
+-- for such simple hash function is stolen from
+-- <http://stackoverflow.com/questions/9262879/create-a-unique-integer-for-each-string here>.
+instHeadId :: InstHead DocName -> Int
+instHeadId (InstHead { .. }) =
+    djb2 . map key $ [ihdClsName] ++ names ihdTypes ++ names ihdKinds
+  where
+    names = everything (++) $
+        maybeToList . (cast :: forall a. Data a => a -> Maybe DocName)
+    djb2 = foldl (\h c -> h * 33 `xor` c) 5381
+    key = getKey . nameUnique . getName
+
+
 -------------------------------------------------------------------------------
 -- * Data & newtype declarations
 -------------------------------------------------------------------------------

