From 5a86381db3d73b4b68fdaae5c150a84e91e80c09 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 29 Jun 2015 16:10:03 +0200 Subject: Make hyperlinker generate correct anchors for data constructors. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 275f10e9..c32bb722 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -107,17 +107,22 @@ binds = -- | Obtain details map for top-level declarations. decls :: GHC.RenamedSource -> DetailsMap decls (group, _, _, _) = concatMap ($ group) - [ map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds + [ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds , everything (<|>) fun ] where - typ (GHC.L _ t) = - let (GHC.L sspan name) = GHC.tcdLName t - in (sspan, RtkDecl name) + typ (GHC.L _ t) = case t of + GHC.DataDecl (GHC.L sspan name) _ defn _ -> + [(sspan, RtkDecl name)] ++ concatMap con (GHC.dd_cons defn) + _ -> + let (GHC.L sspan name) = GHC.tcdLName t + in pure (sspan, RtkDecl name) fun term = case cast term of (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) | GHC.isExternalName name -> pure (sspan, RtkDecl name) _ -> empty + con (GHC.L _ t) = flip map (GHC.con_names t) $ + \(GHC.L sspan name) -> (sspan, RtkDecl name) -- | Obtain details map for import declarations. -- -- cgit v1.2.3