aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Backends
diff options
context:
space:
mode:
authorƁukasz Hanuszczak <lukasz.hanuszczak@gmail.com>2015-07-31 16:24:36 +0200
committerMateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>2015-08-21 18:22:33 +0100
commita49a3f0840f2880814c35f58d89805b3cd3039d3 (patch)
tree0b05a507ab0bb74d307b2624939f3906ccfa4797 /haddock-api/src/Haddock/Backends
parentca667e192d0867c9c2a3025918414147f50b7c19 (diff)
Fix issue with incorrect instance details sections being expanded.
Diffstat (limited to 'haddock-api/src/Haddock/Backends')
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs39
1 files 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 af946f9f..35e5c5f6 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
-------------------------------------------------------------------------------