aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Backends
diff options
context:
space:
mode:
authorYuchen Pei <hi@ypei.me>2022-07-18 12:29:27 +1000
committerYuchen Pei <hi@ypei.me>2022-07-18 18:09:23 +1000
commitdd392e27526983833359d3ea5bf2b0b60236e991 (patch)
tree8859a3b5cdee8f9414da9e72b0844bdb2f71aa5e /haddock-api/src/Haddock/Backends
parent1713efee8a913784e93746c4a339b2641a24df51 (diff)
Adding hackage url to top level decl properties
Diffstat (limited to 'haddock-api/src/Haddock/Backends')
-rw-r--r--haddock-api/src/Haddock/Backends/Org.hs55
-rw-r--r--haddock-api/src/Haddock/Backends/Org/Types.hs3
2 files changed, 38 insertions, 20 deletions
diff --git a/haddock-api/src/Haddock/Backends/Org.hs b/haddock-api/src/Haddock/Backends/Org.hs
index cdd95d42..f0b91b50 100644
--- a/haddock-api/src/Haddock/Backends/Org.hs
+++ b/haddock-api/src/Haddock/Backends/Org.hs
@@ -172,17 +172,22 @@ toOrgDocument title mbPrologue pkgId ifaces =
processPackage
:: String -> Maybe (Doc RdrName) -> String -> [Interface] -> [OrgBlock]
processPackage title mbPrologue pkgId ifaces =
- headingPlainTextCId title pkgId packageLevel
+ Heading packageLevel
+ [plaintext title]
+ (cIdProp pkgId ++ hackageProp (hackagePackageUrl pkgId))
: Paragraph [plaintext $ maybe [] removeMarkup' mbPrologue]
: concatMap processModule (sortOn ifaceMod ifaces)
processModule :: Interface -> [OrgBlock]
processModule iface =
let
- mdl = moduleString $ ifaceMod iface
- pkg = cleanPkgStr $ unitString $ moduleUnit $ ifaceMod iface
- path = (pkg, mdl)
- heading = headingPlainTextCId mdl (pkg ++ "." ++ mdl) modLevel
+ mdl = moduleString $ ifaceMod iface
+ pkg = cleanPkgStr $ unitString $ moduleUnit $ ifaceMod iface
+ path = (pkg, mdl)
+ heading = Heading
+ modLevel
+ [plaintext mdl]
+ (cIdProp (pkg ++ "." ++ mdl) ++ hackageProp (hackageModuleUrl pkg mdl))
description = ppDocumentation (ifaceRnDoc iface) (Just modLevel)
exported =
evalState (mapM (processExport path) (ifaceRnExportItems iface)) modLevel
@@ -466,7 +471,7 @@ ppTyClDecl (DataDecl _ (L _ name) tcdTyVars _ defn@(HsDataDefn { dd_ND = nd, dd_
)
: if gadt then [plaintext " where"] else []
)
- (cIdPaths path name)
+ (cIdPaths path name ++ hackageUrlProp path name)
]
++ ppDocForDecl docs (Just level)
++ ppDataDefn defn subdocs path (level + 1)
@@ -489,7 +494,7 @@ ppTyClDecl (SynDecl _ (L _ name) tcdTyVars _fixity (L _ rhs)) docs _ path level
)
++ ppHsType rhs
)
- (cIdPaths path name)
+ (cIdPaths path name ++ hackageUrlProp path name)
]
++ ppDocForDecl docs (Just level)
-- class
@@ -504,7 +509,7 @@ ppTyClDecl (ClassDecl {..}) docs subdocs path level =
, intersperse Whitespace (map (Plain . ppName) (tyvarNames tcdTyVars))
]
)
- (cIdPaths path (unLoc tcdLName))
+ (cIdPaths path (unLoc tcdLName) ++ hackageUrlProp path (unLoc tcdLName))
]
++ ppDocForDecl docs (Just level)
-- TODO: do we need an aDoc here instead of M.empty?
@@ -523,7 +528,7 @@ ppTyClDecl (FamDecl _ (FamilyDecl _ (ClosedTypeFamily mbEqns) TopLevel (L _ name
++ maybe [] ppLInjectivityAnn mbInj
++ [plaintext " where"]
)
- (cIdPaths path name)
+ (cIdPaths path name ++ hackageUrlProp path name)
: ppDocForDecl docs (Just level)
++ concatMap (\x -> ppLTyFamInstEqn x subdocs path (level + 1))
(fromMaybe [] mbEqns)
@@ -538,7 +543,7 @@ ppTyClDecl (FamDecl _ (FamilyDecl _ info TopLevel (L _ name) tyvars _fixity (L _
++ ppFamilyResultSig resSig op
++ maybe [] ppLInjectivityAnn mbInj
)
- (cIdPaths path name)
+ (cIdPaths path name ++ hackageUrlProp path name)
: ppDocForDecl docs (Just level)
where
pre = case info of
@@ -722,7 +727,9 @@ ppSig (TypeSig _ lhs rhs) (doc, aDoc) _ path level =
]
++ (ppHsSigType hsSig)
)
- (concatMap (cIdPaths path . unLoc) lhs)
+ ( concatMap (cIdPaths path . unLoc) lhs
+ ++ concatMap (hackageUrlProp path . unLoc) lhs
+ )
: (if M.null aDoc then [] else ppHsSigTypeDoc hsSig aDoc)
++ ppDocumentation doc (Just level)
where hsSig = unLoc (dropWildCards rhs)
@@ -755,7 +762,9 @@ ppSig (PatSynSig _ names (L _ hsSig)) (doc, aDoc) _ path level =
]
++ (ppHsSigType hsSig)
)
- (concatMap (cIdPaths path . unLoc) names)
+ ( concatMap (cIdPaths path . unLoc) names
+ ++ concatMap (hackageUrlProp path . unLoc) names
+ )
: (if M.null aDoc then [] else ppHsSigTypeDoc hsSig aDoc)
++ ppDocumentation doc (Just level)
@@ -997,15 +1006,21 @@ removeHash :: String -> String
removeHash s | length s > 65 = take (length s - 65) s
removeHash s = s
-hackageUrl :: String -> String -> String -> Bool -> String
+hackagePackageUrl :: String -> String
+hackagePackageUrl pkg = "https://hackage.haskell.org/package/" ++ pkg
+
+hackageModuleUrl :: String -> String -> String
+hackageModuleUrl pkg mdl =
+ hackagePackageUrl pkg ++ "/docs/" ++ dotsToDashes mdl ++ ".html"
+ where dotsToDashes = map (\c -> if c == '.' then '-' else c)
+
+hackageUrl :: String -> String -> String -> String
-- module should be of the form GHC-Hs-Decls instead of GHC.Hs.Decls
-hackageUrl pkg mdl id isSub =
- "https://hackage.haskell.org/package/"
- ++ pkg
- ++ "/docs/"
- ++ mdl
- ++ ".html#"
- ++ if isSub then "v" else "t" ++ ":" ++ id
+hackageUrl pkg mdl id = hackageModuleUrl pkg mdl ++ "#t:" ++ id
+
+hackageUrlProp :: ModPath -> DocName -> Properties
+hackageUrlProp (pkg, mdl) name =
+ hackageProp (hackageUrl pkg mdl (docNameToString name))
-- * Orphan instances for show
diff --git a/haddock-api/src/Haddock/Backends/Org/Types.hs b/haddock-api/src/Haddock/Backends/Org/Types.hs
index 81f2add5..3bfc8619 100644
--- a/haddock-api/src/Haddock/Backends/Org/Types.hs
+++ b/haddock-api/src/Haddock/Backends/Org/Types.hs
@@ -187,6 +187,9 @@ orgToString = fullRender (PageMode True) 0 1 txtPrinter ""
cIdProp :: String -> Properties
cIdProp cid = [("CUSTOM_ID", cid)]
+hackageProp :: String -> Properties
+hackageProp url = [("Hackage", url)]
+
cIdsProp :: [String] -> Properties
cIdsProp cids = map (\cid -> ("CUSTOM_ID", cid)) cids