diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Haddock/Interface/Create.hs | 34 |
1 files changed, 24 insertions, 10 deletions
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index f1262d9f..fb1038f2 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -767,21 +767,33 @@ extractDecl name mdl decl | name `elem` getMainDeclBinder (unLoc decl) = decl | otherwise = case unLoc decl of - TyClD d | isClassDecl d -> + TyClD d@ClassDecl {} -> let matches = [ sig | sig <- tcdSigs d, name `elem` sigName sig, isVanillaLSig sig ] -- TODO: document fixity in case matches of - [s0] -> let (n, tyvar_names) = name_and_tyvars d + [s0] -> let (n, tyvar_names) = (tcdName d, getTyVars d) L pos sig = extractClassDecl n tyvar_names s0 in L pos (SigD sig) - _ -> error "internal: extractDecl" - TyClD d | isDataDecl d -> - let (n, tyvar_names) = name_and_tyvars d - L pos sig = extractRecSel name mdl n tyvar_names (dd_cons (tcdDataDefn d)) - in L pos (SigD sig) + _ -> error "internal: extractDecl (ClassDecl)" + TyClD d@DataDecl {} -> + let (n, tyvar_names) = (tcdName d, map toTypeNoLoc $ getTyVars d) + in SigD <$> extractRecSel name mdl n tyvar_names (dd_cons (tcdDataDefn d)) + InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n + , dfid_pats = HsWB { hswb_cts = tys } + , dfid_defn = defn }) -> + SigD <$> extractRecSel name mdl n tys (dd_cons defn) + InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) -> + let matches = [ d | L _ d <- insts + , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d) + , ConDeclField { cd_fld_name = L _ n } <- rec + , n == name + ] + in case matches of + [d0] -> extractDecl name mdl (noLoc . InstD $ DataFamInstD d0) + _ -> error "internal: extractDecl (ClsInstD)" _ -> error "internal: extractDecl" where - name_and_tyvars d = (tcdName d, hsLTyVarLocNames (tyClDeclTyVars d)) + getTyVars = hsLTyVarLocNames . tyClDeclTyVars toTypeNoLoc :: Located Name -> LHsType Name @@ -799,7 +811,7 @@ extractClassDecl c tvs0 (L pos (TypeSig lname ltype)) = case ltype of extractClassDecl _ _ _ = error "extractClassDecl: unexpected decl" -extractRecSel :: Name -> Module -> Name -> [Located Name] -> [LConDecl Name] +extractRecSel :: Name -> Module -> Name -> [LHsType Name] -> [LConDecl Name] -> LSig Name extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found" @@ -810,7 +822,9 @@ extractRecSel nm mdl t tvs (L _ con : rest) = _ -> extractRecSel nm mdl t tvs rest where matching_fields flds = [ f | f@(ConDeclField n _ _) <- flds, unLoc n == nm ] - data_ty = foldl (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) (map toTypeNoLoc tvs) + data_ty + | ResTyGADT ty <- con_res con = ty + | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs -- | Keep export items with docs. |