From d0284590978f4fefd3c6845e628f8efa2100ac34 Mon Sep 17 00:00:00 2001
From: Gil Mizrahi <gilmi@posteo.net>
Date: Tue, 5 Jan 2021 13:14:44 +0200
Subject: [PATCH] Fix #1206 by passing instance name as anchor
(cherry picked from commit 88106cbe72b6a444a9b335ee53089d8eac503bd7)
---
.../src/Haddock/Backends/Xhtml/Decl.hs | 15 +-
.../src/Haddock/Backends/Xhtml/Layout.hs | 10 +-
html-test/ref/Bug1206.html | 483 ++++++++++++++++++
html-test/src/Bug1206.hs | 43 ++
4 files changed, 541 insertions(+), 10 deletions(-)
create mode 100644 html-test/ref/Bug1206.html
create mode 100644 html-test/src/Bug1206.hs
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 0b0050df5f..19fe5abde7 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -634,10 +634,12 @@ ppInstances links origin instances splice unicode pkg qual
-- force Splice = True to use line URLs
where
instName = getOccString origin
- instDecl :: Int -> DocInstance DocNameI -> (SubDecl, Maybe Module, Located DocName)
+ instDecl :: Int -> DocInstance DocNameI -> (String, SubDecl, Maybe Module, Located DocName)
instDecl no (inst, mdoc, loc, mdl) =
- ((ppInstHead links splice unicode qual mdoc origin False no inst mdl), mdl, loc)
-
+ (instanceAnchor, mModule, mdl, loc)
+ where
+ instanceAnchor = getOccString (ihdClsName inst) <> "_" <> show no <> ":"
+ mModule = ppInstHead links splice unicode qual mdoc origin False no inst mdl
ppOrphanInstances :: LinksInfo
-> [DocInstance DocNameI]
@@ -649,9 +651,12 @@ ppOrphanInstances links instances splice unicode pkg qual
instOrigin :: InstHead name -> InstOrigin (IdP name)
instOrigin inst = OriginClass (ihdClsName inst)
- instDecl :: Int -> DocInstance DocNameI -> (SubDecl, Maybe Module, Located DocName)
+ instDecl :: Int -> DocInstance DocNameI -> (String, SubDecl, Maybe Module, Located DocName)
instDecl no (inst, mdoc, loc, mdl) =
- ((ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst Nothing), mdl, loc)
+ (instanceAnchor, mModule, mdl, loc)
+ where
+ instanceAnchor = getOccString (ihdClsName inst) <> "_" <> show no <> ":"
+ mModule = ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst Nothing
ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index d61d6d9bb8..e646fdc4bc 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -153,16 +153,16 @@ subTable pkg qual decls = Just $ table << aboves (concatMap subRow decls)
-- | Sub table with source information (optional).
subTableSrc :: Maybe Package -> Qualification -> LinksInfo -> Bool
- -> [(SubDecl, Maybe Module, Located DocName)] -> Maybe Html
+ -> [(String, SubDecl, Maybe Module, Located DocName)] -> Maybe Html
subTableSrc _ _ _ _ [] = Nothing
subTableSrc pkg qual lnks splice decls = Just $ table << aboves (concatMap subRow decls)
where
- subRow ((decl, mdoc, subs), mdl, L loc dn) =
+ subRow (instanchor, (decl, mdoc, subs), mdl, L loc dn) =
(td ! [theclass "src clearfix"] <<
(thespan ! [theclass "inst-left"] << decl)
<+> linkHtml loc mdl dn
<->
- docElement td << fmap (docToHtml Nothing pkg qual) mdoc
+ docElement td << fmap (docToHtml (Just instanchor) pkg qual) mdoc
)
: map (cell . (td <<)) subs
@@ -201,7 +201,7 @@ subEquations pkg qual = divSubDecls "equations" "Equations" . subTable pkg qual
subInstances :: Maybe Package -> Qualification
-> String -- ^ Class name, used for anchor generation
-> LinksInfo -> Bool
- -> [(SubDecl, Maybe Module, Located DocName)] -> Html
+ -> [(String, SubDecl, Maybe Module, Located DocName)] -> Html
subInstances pkg qual nm lnks splice = maybe noHtml wrap . instTable
where
wrap contents = subSection (hdr +++ collapseDetails id_ DetailsOpen (summary +++ contents))
@@ -214,7 +214,7 @@ subInstances pkg qual nm lnks splice = maybe noHtml wrap . instTable
subOrphanInstances :: Maybe Package -> Qualification
-> LinksInfo -> Bool
- -> [(SubDecl, Maybe Module, Located DocName)] -> Html
+ -> [(String, SubDecl, Maybe Module, Located DocName)] -> Html
subOrphanInstances pkg qual lnks splice = maybe noHtml wrap . instTable
where
wrap = ((h1 << "Orphan instances") +++)
diff --git a/html-test/ref/Bug1206.html b/html-test/ref/Bug1206.html
new file mode 100644
index 0000000000..4b0a28e9ef
--- /dev/null
+++ b/html-test/ref/Bug1206.html
@@ -0,0 +1,483 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml"
+><head
+ ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
+ /><meta name="viewport" content="width=device-width, initial-scale=1"
+ /><title
+ >Bug1206</title
+ ><link href="#" rel="stylesheet" type="text/css" title="Linuwial"
+ /><link rel="stylesheet" type="text/css" href="#"
+ /><link rel="stylesheet" type="text/css" href="#"
+ /><script src="haddock-bundle.min.js" async="async" type="text/javascript"
+ ></script
+ ><script type="text/x-mathjax-config"
+ >MathJax.Hub.Config({ tex2jax: { processClass: "mathjax", ignoreClass: ".*" } });</script
+ ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript"
+ ></script
+ ></head
+ ><body
+ ><div id="package-header"
+ ><span class="caption empty"
+ > </span
+ ><ul class="links" id="page-menu"
+ ><li
+ ><a href="#"
+ >Contents</a
+ ></li
+ ><li
+ ><a href="#"
+ >Index</a
+ ></li
+ ></ul
+ ></div
+ ><div id="content"
+ ><div id="module-header"
+ ><table class="info"
+ ><tr
+ ><th
+ >Safe Haskell</th
+ ><td
+ >Safe-Inferred</td
+ ></tr
+ ></table
+ ><p class="caption"
+ >Bug1206</p
+ ></div
+ ><div id="description"
+ ><p class="caption"
+ >Description</p
+ ><div class="doc"
+ ><p
+ >Bug 1206</p
+ ></div
+ ></div
+ ><div id="synopsis"
+ ><details id="syn"
+ ><summary
+ >Synopsis</summary
+ ><ul class="details-toggle" data-details-id="syn"
+ ><li class="src short"
+ ><span class="keyword"
+ >data</span
+ > <a href="#"
+ >T</a
+ > a = <a href="#"
+ >T</a
+ > a</li
+ ></ul
+ ></details
+ ></div
+ ><div id="interface"
+ ><h1
+ >Documentation</h1
+ ><div class="top"
+ ><p class="src"
+ ><span class="keyword"
+ >data</span
+ > <a id="t:T" class="def"
+ >T</a
+ > a <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><div class="doc"
+ ><p
+ >A simple identity type</p
+ ></div
+ ><div class="subs constructors"
+ ><p class="caption"
+ >Constructors</p
+ ><table
+ ><tr
+ ><td class="src"
+ ><a id="v:T" class="def"
+ >T</a
+ > a</td
+ ><td class="doc empty"
+ > </td
+ ></tr
+ ></table
+ ></div
+ ><div class="subs instances"
+ ><h4 class="instances details-toggle-control details-toggle" data-details-id="i:T"
+ >Instances</h4
+ ><details id="i:T" open="open"
+ ><summary class="hide-when-js-enabled"
+ >Instances details</summary
+ ><table
+ ><tr
+ ><td class="src clearfix"
+ ><span class="inst-left"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:T:Show:1"
+ ></span
+ > <a href="#" title="Text.Show"
+ >Show</a
+ > a => <a href="#" title="Text.Show"
+ >Show</a
+ > (<a href="#" title="Bug1206"
+ >T</a
+ > a)</span
+ > <a href="#" class="selflink"
+ >#</a
+ ></td
+ ><td class="doc empty"
+ > </td
+ ></tr
+ ><tr
+ ><td colspan="2"
+ ><details id="i:id:T:Show:1"
+ ><summary class="hide-when-js-enabled"
+ >Instance details</summary
+ ><p
+ >Defined in <a href="#"
+ >Bug1206</a
+ ></p
+ > <div class="subs methods"
+ ><p class="caption"
+ >Methods</p
+ ><p class="src"
+ ><a href="#"
+ >showsPrec</a
+ > :: <a href="#" title="Data.Int"
+ >Int</a
+ > -> <a href="#" title="Bug1206"
+ >T</a
+ > a -> <a href="#" title="Text.Show"
+ >ShowS</a
+ > <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><p class="src"
+ ><a href="#"
+ >show</a
+ > :: <a href="#" title="Bug1206"
+ >T</a
+ > a -> <a href="#" title="Data.String"
+ >String</a
+ > <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><p class="src"
+ ><a href="#"
+ >showList</a
+ > :: [<a href="#" title="Bug1206"
+ >T</a
+ > a] -> <a href="#" title="Text.Show"
+ >ShowS</a
+ > <a href="#" class="selflink"
+ >#</a
+ ></p
+ ></div
+ ></details
+ ></td
+ ></tr
+ ><tr
+ ><td class="src clearfix"
+ ><span class="inst-left"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:T:Semigroup:2"
+ ></span
+ > <a href="#" title="Prelude"
+ >Semigroup</a
+ > (<a href="#" title="Bug1206"
+ >T</a
+ > <a href="#" title="Data.Int"
+ >Int</a
+ >)</span
+ > <a href="#" class="selflink"
+ >#</a
+ ></td
+ ><td class="doc"
+ ><p
+ ><code
+ ><a href="#" title="Data.Monoid"
+ ><></a
+ ></code
+ > = 'T (a + b)'</p
+ ><p
+ >Docs for the <code
+ >Semigroup</code
+ > instance of <code
+ >(T Int)</code
+ ></p
+ ><h4 class="subheading details-toggle-control details-toggle" data-details-id="ch:Semigroup_2:0"
+ >Examples</h4
+ ><details id="ch:Semigroup_2:0"
+ ><summary class="hide-when-js-enabled"
+ >Expand</summary
+ ><pre class="screen"
+ ><code class="prompt"
+ >>>> </code
+ ><strong class="userinput"
+ ><code
+ >T 2 <> T (3 :: Int)
+</code
+ ></strong
+ >T 5
+</pre
+ ></details
+ ></td
+ ></tr
+ ><tr
+ ><td colspan="2"
+ ><details id="i:id:T:Semigroup:2"
+ ><summary class="hide-when-js-enabled"
+ >Instance details</summary
+ ><p
+ >Defined in <a href="#"
+ >Bug1206</a
+ ></p
+ > <div class="subs methods"
+ ><p class="caption"
+ >Methods</p
+ ><p class="src"
+ ><a href="#"
+ >(<>)</a
+ > :: <a href="#" title="Bug1206"
+ >T</a
+ > <a href="#" title="Data.Int"
+ >Int</a
+ > -> <a href="#" title="Bug1206"
+ >T</a
+ > <a href="#" title="Data.Int"
+ >Int</a
+ > -> <a href="#" title="Bug1206"
+ >T</a
+ > <a href="#" title="Data.Int"
+ >Int</a
+ > <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><p class="src"
+ ><a href="#"
+ >sconcat</a
+ > :: <a href="#" title="Data.List.NonEmpty"
+ >NonEmpty</a
+ > (<a href="#" title="Bug1206"
+ >T</a
+ > <a href="#" title="Data.Int"
+ >Int</a
+ >) -> <a href="#" title="Bug1206"
+ >T</a
+ > <a href="#" title="Data.Int"
+ >Int</a
+ > <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><p class="src"
+ ><a href="#"
+ >stimes</a
+ > :: <a href="#" title="Prelude"
+ >Integral</a
+ > b => b -> <a href="#" title="Bug1206"
+ >T</a
+ > <a href="#" title="Data.Int"
+ >Int</a
+ > -> <a href="#" title="Bug1206"
+ >T</a
+ > <a href="#" title="Data.Int"
+ >Int</a
+ > <a href="#" class="selflink"
+ >#</a
+ ></p
+ ></div
+ ></details
+ ></td
+ ></tr
+ ><tr
+ ><td class="src clearfix"
+ ><span class="inst-left"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:T:Semigroup:3"
+ ></span
+ > <a href="#" title="Prelude"
+ >Semigroup</a
+ > a => <a href="#" title="Prelude"
+ >Semigroup</a
+ > (<a href="#" title="Bug1206"
+ >T</a
+ > a)</span
+ > <a href="#" class="selflink"
+ >#</a
+ ></td
+ ><td class="doc"
+ ><p
+ ><code
+ ><a href="#" title="Data.Monoid"
+ ><></a
+ ></code
+ > = 'T (a <> b)'</p
+ ><p
+ >Docs for the <code
+ >Semigroup</code
+ > instance of <code
+ >Semigroup a => T a</code
+ ></p
+ ><h4 class="subheading details-toggle-control details-toggle" data-details-id="ch:Semigroup_3:0"
+ >Examples</h4
+ ><details id="ch:Semigroup_3:0"
+ ><summary class="hide-when-js-enabled"
+ >Expand</summary
+ ><pre class="screen"
+ ><code class="prompt"
+ >>>> </code
+ ><strong class="userinput"
+ ><code
+ >T (Product 1) <> T (Product 2)
+</code
+ ></strong
+ >T (Product {getProduct = 2})
+</pre
+ ></details
+ ></td
+ ></tr
+ ><tr
+ ><td colspan="2"
+ ><details id="i:id:T:Semigroup:3"
+ ><summary class="hide-when-js-enabled"
+ >Instance details</summary
+ ><p
+ >Defined in <a href="#"
+ >Bug1206</a
+ ></p
+ > <div class="subs methods"
+ ><p class="caption"
+ >Methods</p
+ ><p class="src"
+ ><a href="#"
+ >(<>)</a
+ > :: <a href="#" title="Bug1206"
+ >T</a
+ > a -> <a href="#" title="Bug1206"
+ >T</a
+ > a -> <a href="#" title="Bug1206"
+ >T</a
+ > a <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><p class="src"
+ ><a href="#"
+ >sconcat</a
+ > :: <a href="#" title="Data.List.NonEmpty"
+ >NonEmpty</a
+ > (<a href="#" title="Bug1206"
+ >T</a
+ > a) -> <a href="#" title="Bug1206"
+ >T</a
+ > a <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><p class="src"
+ ><a href="#"
+ >stimes</a
+ > :: <a href="#" title="Prelude"
+ >Integral</a
+ > b => b -> <a href="#" title="Bug1206"
+ >T</a
+ > a -> <a href="#" title="Bug1206"
+ >T</a
+ > a <a href="#" class="selflink"
+ >#</a
+ ></p
+ ></div
+ ></details
+ ></td
+ ></tr
+ ><tr
+ ><td class="src clearfix"
+ ><span class="inst-left"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:T:Monoid:4"
+ ></span
+ > <a href="#" title="Data.Monoid"
+ >Monoid</a
+ > a => <a href="#" title="Data.Monoid"
+ >Monoid</a
+ > (<a href="#" title="Bug1206"
+ >T</a
+ > a)</span
+ > <a href="#" class="selflink"
+ >#</a
+ ></td
+ ><td class="doc"
+ ><p
+ ><code
+ ><a href="#" title="Data.Monoid"
+ >mempty</a
+ ></code
+ > = 'T mempty'</p
+ ><p
+ >Docs for the <code
+ >Monoid</code
+ > instance of <code
+ >Monoid a => T a</code
+ ></p
+ ><h4 class="subheading details-toggle-control details-toggle" data-details-id="ch:Monoid_4:0"
+ >Examples</h4
+ ><details id="ch:Monoid_4:0"
+ ><summary class="hide-when-js-enabled"
+ >Expand</summary
+ ><pre class="screen"
+ ><code class="prompt"
+ >>>> </code
+ ><strong class="userinput"
+ ><code
+ >mempty :: T String
+</code
+ ></strong
+ >T ""
+</pre
+ ></details
+ ></td
+ ></tr
+ ><tr
+ ><td colspan="2"
+ ><details id="i:id:T:Monoid:4"
+ ><summary class="hide-when-js-enabled"
+ >Instance details</summary
+ ><p
+ >Defined in <a href="#"
+ >Bug1206</a
+ ></p
+ > <div class="subs methods"
+ ><p class="caption"
+ >Methods</p
+ ><p class="src"
+ ><a href="#"
+ >mempty</a
+ > :: <a href="#" title="Bug1206"
+ >T</a
+ > a <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><p class="src"
+ ><a href="#"
+ >mappend</a
+ > :: <a href="#" title="Bug1206"
+ >T</a
+ > a -> <a href="#" title="Bug1206"
+ >T</a
+ > a -> <a href="#" title="Bug1206"
+ >T</a
+ > a <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><p class="src"
+ ><a href="#"
+ >mconcat</a
+ > :: [<a href="#" title="Bug1206"
+ >T</a
+ > a] -> <a href="#" title="Bug1206"
+ >T</a
+ > a <a href="#" class="selflink"
+ >#</a
+ ></p
+ ></div
+ ></details
+ ></td
+ ></tr
+ ></table
+ ></details
+ ></div
+ ></div
+ ></div
+ ></div
+ ></body
+ ></html
+>
diff --git a/html-test/src/Bug1206.hs b/html-test/src/Bug1206.hs
new file mode 100644
index 0000000000..600af0e825
--- /dev/null
+++ b/html-test/src/Bug1206.hs
@@ -0,0 +1,43 @@
+{- | Bug 1206
+-}
+
+{-# language FlexibleInstances #-}
+
+module Bug1206 where
+
+-- | A simple identity type
+data T a = T a
+ deriving Show
+
+-- | '<>' = 'T (a + b)'
+--
+-- Docs for the @Semigroup@ instance of @(T Int)@
+--
+-- ==== __Examples__
+--
+-- >>> T 2 <> T (3 :: Int)
+-- T 5
+instance {-# overlapping #-} Semigroup (T Int) where
+ (<>) (T a) (T b) = T (a + b)
+
+-- | '<>' = 'T (a <> b)'
+--
+-- Docs for the @Semigroup@ instance of @Semigroup a => T a@
+--
+-- ==== __Examples__
+--
+-- >>> T (Product 1) <> T (Product 2)
+-- T (Product {getProduct = 2})
+instance {-# overlapping #-} Semigroup a => Semigroup (T a) where
+ (<>) (T a) (T b) = T (a <> b)
+
+-- | 'mempty' = 'T mempty'
+--
+-- Docs for the @Monoid@ instance of @Monoid a => T a@
+--
+-- ==== __Examples__
+--
+-- >>> mempty :: T String
+-- T ""
+instance Monoid a => Monoid (T a) where
+ mempty = T mempty
--
GitLab