From 107ef5a33b0d33063b4b709582ca081916b46098 Mon Sep 17 00:00:00 2001
From: Alexander Biehl <alexbiehl@gmail.com>
Date: Fri, 19 Jan 2018 15:33:30 +0100
Subject: extractDecl: Extract associated types correctly (#736)
---
haddock-api/src/Haddock/Interface/Create.hs | 32 +++++++++++++++++++----------
1 file changed, 21 insertions(+), 11 deletions(-)
(limited to 'haddock-api')
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index f673e23b..bd990170 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -1014,21 +1014,31 @@ extractDecl name decl
| otherwise =
case unLoc decl of
TyClD d@ClassDecl {} ->
- let matches = [ lsig
- | lsig <- tcdSigs d
- , ClassOpSig False _ _ <- pure $ unLoc lsig
- -- Note: exclude `default` declarations (see #505)
- , name `elem` sigName lsig
- ]
+ let
+ matchesMethod =
+ [ lsig
+ | lsig <- tcdSigs d
+ , ClassOpSig False _ _ <- pure $ unLoc lsig
+ -- Note: exclude `default` declarations (see #505)
+ , name `elem` sigName lsig
+ ]
+
+ matchesAssociatedType =
+ [ lfam_decl
+ | lfam_decl <- tcdATs d
+ , name == unLoc (fdLName (unLoc lfam_decl))
+ ]
+
-- TODO: document fixity
- in case matches of
- [s0] -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d)
- L pos sig = addClassContext n tyvar_names s0
- in L pos (SigD sig)
+ in case (matchesMethod, matchesAssociatedType) of
+ ([s0], _) -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d)
+ L pos sig = addClassContext n tyvar_names s0
+ in L pos (SigD sig)
+ (_, [L pos fam_decl]) -> L pos (TyClD (FamDecl fam_decl))
_ -> O.pprPanic "extractDecl" (O.text "Ambiguous decl for" O.<+> O.ppr name O.<+> O.text "in class:"
O.$$ O.nest 4 (O.ppr d)
O.$$ O.text "Matches:"
- O.$$ O.nest 4 (O.ppr matches))
+ O.$$ O.nest 4 (O.ppr matchesMethod O.<+> O.ppr matchesAssociatedType))
TyClD d@DataDecl {} ->
let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d))
in if isDataConName name
--
cgit v1.2.3