Adding hackage url to top level decl properties

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