aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--haddock-api/src/Haddock.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs34
-rw-r--r--hypsrc-test/ref/src/Types.html56
3 files changed, 61 insertions, 31 deletions
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 85ccde3d..8ef8f5ca 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -65,7 +65,7 @@ import System.Directory (doesDirectoryExist, getTemporaryDirectory)
import Text.ParserCombinators.ReadP (readP_to_S)
import GHC hiding (verbosity)
-import Config
+import GHC.Settings.Config
import GHC.Driver.Session hiding (projectVersion, verbosity)
import GHC.Utils.Error
import GHC.Unit
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index e01d7114..12f37ced 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -13,6 +13,7 @@ import Haddock.Backends.Hyperlinker.Utils
import qualified Data.ByteString as BS
import GHC.Iface.Ext.Types
+import GHC.Iface.Ext.Utils ( isEvidenceContext , emptyNodeInfo )
import GHC.Unit.Module ( ModuleName, moduleNameString )
import GHC.Types.Name ( getOccString, isInternalName, Name, nameModule, nameUnique )
import GHC.Types.SrcLoc
@@ -105,6 +106,7 @@ renderWithAst srcs Node{..} toks = anchored $ case toks of
_ -> go nodeChildren toks
where
+ nodeInfo = maybe emptyNodeInfo id (Map.lookup SourceInfo $ getSourcedNodeInfo sourcedNodeInfo)
go _ [] = mempty
go [] xs = foldMap renderToken xs
go (cur:rest) xs =
@@ -139,8 +141,9 @@ richToken srcs details Token{..}
contexts = concatMap (Set.elems . identInfo) . Map.elems . nodeIdentifiers $ details
- -- pick an arbitary identifier to hyperlink with
- identDet = Map.lookupMin . nodeIdentifiers $ details
+ -- pick an arbitary non-evidence identifier to hyperlink with
+ identDet = Map.lookupMin $ Map.filter notEvidence $ nodeIdentifiers $ details
+ notEvidence = not . any isEvidenceContext . identInfo
-- If we have name information, we can make links
linked = case identDet of
@@ -163,7 +166,8 @@ annotate ni content =
| otherwise = mempty
annotation = typ ++ identTyps
typ = unlines (nodeType ni)
- typedIdents = [ (n,t) | (n, identType -> Just t) <- Map.toList $ nodeIdentifiers ni ]
+ typedIdents = [ (n,t) | (n, c@(identType -> Just t)) <- Map.toList $ nodeIdentifiers ni
+ , not (any isEvidenceContext $ identInfo c) ]
identTyps
| length typedIdents > 1 || null (nodeType ni)
= concatMap (\(n,t) -> printName n ++ " :: " ++ t ++ "\n") typedIdents
@@ -176,17 +180,19 @@ richTokenStyle
:: Bool -- ^ are we lacking a type annotation?
-> ContextInfo -- ^ in what context did this token show up?
-> [StyleClass]
-richTokenStyle True Use = ["hs-type"]
-richTokenStyle False Use = ["hs-var"]
-richTokenStyle _ RecField{} = ["hs-var"]
-richTokenStyle _ PatternBind{} = ["hs-var"]
-richTokenStyle _ MatchBind{} = ["hs-var"]
-richTokenStyle _ TyVarBind{} = ["hs-type"]
-richTokenStyle _ ValBind{} = ["hs-var"]
-richTokenStyle _ TyDecl = ["hs-type"]
-richTokenStyle _ ClassTyDecl{} = ["hs-type"]
-richTokenStyle _ Decl{} = ["hs-var"]
-richTokenStyle _ IEThing{} = [] -- could be either a value or type
+richTokenStyle True Use = ["hs-type"]
+richTokenStyle False Use = ["hs-var"]
+richTokenStyle _ RecField{} = ["hs-var"]
+richTokenStyle _ PatternBind{} = ["hs-var"]
+richTokenStyle _ MatchBind{} = ["hs-var"]
+richTokenStyle _ TyVarBind{} = ["hs-type"]
+richTokenStyle _ ValBind{} = ["hs-var"]
+richTokenStyle _ TyDecl = ["hs-type"]
+richTokenStyle _ ClassTyDecl{} = ["hs-type"]
+richTokenStyle _ Decl{} = ["hs-var"]
+richTokenStyle _ IEThing{} = [] -- could be either a value or type
+richTokenStyle _ EvidenceVarBind{} = []
+richTokenStyle _ EvidenceVarUse{} = []
tokenStyle :: TokenType -> [StyleClass]
tokenStyle TkIdentifier = ["hs-identifier"]
diff --git a/hypsrc-test/ref/src/Types.html b/hypsrc-test/ref/src/Types.html
index e08382dd..835fafb0 100644
--- a/hypsrc-test/ref/src/Types.html
+++ b/hypsrc-test/ref/src/Types.html
@@ -699,8 +699,11 @@
><span
> </span
><span class="annot"
- ><a href="Types.html#Bar"
- ><span class="hs-identifier hs-type"
+ ><span class="annottext"
+ >Quux
+</span
+ ><a href="Types.html#Bar"
+ ><span class="hs-identifier hs-var"
>Bar</span
></a
></span
@@ -761,8 +764,11 @@
><span
> </span
><span class="annot"
- ><a href="Types.html#Baz"
- ><span class="hs-identifier hs-type"
+ ><span class="annottext"
+ >Quux
+</span
+ ><a href="Types.html#Baz"
+ ><span class="hs-identifier hs-var"
>Baz</span
></a
></span
@@ -864,8 +870,11 @@
><span
> </span
><span class="annot"
- ><a href="Types.html#Bar"
- ><span class="hs-identifier hs-type"
+ ><span class="annottext"
+ >Quux
+</span
+ ><a href="Types.html#Bar"
+ ><span class="hs-identifier hs-var"
>Bar</span
></a
></span
@@ -926,8 +935,11 @@
><span
> </span
><span class="annot"
- ><a href="Types.html#Baz"
- ><span class="hs-identifier hs-type"
+ ><span class="annottext"
+ >Quux
+</span
+ ><a href="Types.html#Baz"
+ ><span class="hs-identifier hs-var"
>Baz</span
></a
></span
@@ -1060,8 +1072,11 @@
><span
> </span
><span class="annot"
- ><a href="Types.html#Bar"
- ><span class="hs-identifier hs-type"
+ ><span class="annottext"
+ >Quux
+</span
+ ><a href="Types.html#Bar"
+ ><span class="hs-identifier hs-var"
>Bar</span
></a
></span
@@ -1112,8 +1127,11 @@
><span
> </span
><span class="annot"
- ><a href="Types.html#Baz"
- ><span class="hs-identifier hs-type"
+ ><span class="annottext"
+ >Quux
+</span
+ ><a href="Types.html#Baz"
+ ><span class="hs-identifier hs-var"
>Baz</span
></a
></span
@@ -1207,8 +1225,11 @@
><span class="hs-special"
>(</span
><span class="annot"
- ><a href="Types.html#Bar"
- ><span class="hs-identifier hs-type"
+ ><span class="annottext"
+ >Quux
+</span
+ ><a href="Types.html#Bar"
+ ><span class="hs-identifier hs-var"
>Bar</span
></a
></span
@@ -1259,8 +1280,11 @@
><span class="hs-special"
>(</span
><span class="annot"
- ><a href="Types.html#Baz"
- ><span class="hs-identifier hs-type"
+ ><span class="annottext"
+ >Quux
+</span
+ ><a href="Types.html#Baz"
+ ><span class="hs-identifier hs-var"
>Baz</span
></a
></span
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 10:48:23 +0000