aboutsummaryrefslogtreecommitdiff
path: root/haddock-api
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api')
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs14
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs29
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs61
-rw-r--r--haddock-api/src/Haddock/Convert.hs7
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs33
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs31
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs26
-rw-r--r--haddock-api/src/Haddock/Utils.hs7
8 files changed, 120 insertions, 88 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index c8085fa9..7acb3137 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -184,21 +184,21 @@ lookupCon dflags subdocs (L _ name) = case lookup name subdocs of
_ -> []
ppCtor :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String]
-ppCtor dflags dat subdocs con = lookupCon dflags subdocs (con_name con)
- ++ f (con_details con)
+ppCtor dflags dat subdocs con
+ = concatMap (lookupCon dflags subdocs) (con_names con) ++ f (con_details con)
where
f (PrefixCon args) = [typeSig name $ args ++ [resType]]
f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]
- f (RecCon recs) = f (PrefixCon $ map cd_fld_type recs) ++ concat
- [lookupCon dflags subdocs (cd_fld_name r) ++
- [out dflags (unL $ cd_fld_name r) `typeSig` [resType, cd_fld_type r]]
- | r <- recs]
+ f (RecCon recs) = f (PrefixCon $ map cd_fld_type (map unLoc recs)) ++ concat
+ [(concatMap (lookupCon dflags subdocs) (cd_fld_names r)) ++
+ [out dflags (map unL $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]
+ | r <- map unLoc recs]
funs = foldr1 (\x y -> reL $ HsFunTy (makeExplicitL x) (makeExplicitL y))
apps = foldl1 (\x y -> reL $ HsAppTy x y)
typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (makeExplicit $ unL $ funs flds)
- name = out dflags $ unL $ con_name con
+ name = out dflags $ map unL $ con_names con
resType = case con_res con of
ResTyH98 -> apps $ map (reL . HsTyVar) $
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 309e0f76..b636ef6b 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -26,6 +26,7 @@ import OccName
import Name ( nameOccName )
import RdrName ( rdrNameOcc )
import FastString ( unpackFS, unpackLitString, zString )
+import Outputable ( panic)
import qualified Data.Map as Map
import System.Directory
@@ -631,19 +632,19 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
ResTyH98 -> case con_details con of
PrefixCon args ->
- decltt (hsep ((header_ unicode <+> ppBinder occ) :
+ decltt (hsep ((header_ unicode <+> ppOcc) :
map (ppLParendType unicode) args))
<-> rDoc mbDoc <+> nl
RecCon fields ->
- (decltt (header_ unicode <+> ppBinder occ)
+ (decltt (header_ unicode <+> ppOcc)
<-> rDoc mbDoc <+> nl)
$$
doRecordFields fields
InfixCon arg1 arg2 ->
decltt (hsep [ header_ unicode <+> ppLParendType unicode arg1,
- ppBinder occ,
+ ppOcc,
ppLParendType unicode arg2 ])
<-> rDoc mbDoc <+> nl
@@ -657,34 +658,40 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
where
doRecordFields fields =
- vcat (map (ppSideBySideField subdocs unicode) fields)
+ vcat (map (ppSideBySideField subdocs unicode) (map unLoc fields))
- doGADTCon args resTy = decltt (ppBinder occ <+> dcolon unicode <+> hsep [
+ doGADTCon args resTy = decltt (ppOcc <+> dcolon unicode <+> hsep [
ppForAll forall ltvs (con_cxt con) unicode,
ppLType unicode (foldr mkFunTy resTy args) ]
) <-> rDoc mbDoc
header_ = ppConstrHdr forall tyVars context
- occ = nameOccName . getName . unLoc . con_name $ con
+ occ = map (nameOccName . getName . unLoc) $ con_names con
+ ppOcc = case occ of
+ [one] -> ppBinder one
+ _ -> cat (punctuate comma (map ppBinder occ))
ltvs = con_qvars con
tyVars = tyvarNames (con_qvars con)
context = unLoc (con_cxt con)
forall = con_explicit con
-- don't use "con_doc con", in case it's reconstructed from a .hi file,
-- or also because we want Haddock to do the doc-parsing, not GHC.
- mbDoc = lookup (unLoc $ con_name con) subdocs
- >>= fmap _doc . combineDocumentation . fst
+ mbDoc = case con_names con of
+ [] -> panic "empty con_names"
+ (cn:_) -> lookup (unLoc cn) subdocs >>=
+ fmap _doc . combineDocumentation . fst
mkFunTy a b = noLoc (HsFunTy a b)
ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> LaTeX
-ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) =
- decltt (ppBinder (nameOccName . getName $ name)
+ppSideBySideField subdocs unicode (ConDeclField names ltype _) =
+ decltt (cat (punctuate comma (map (ppBinder . nameOccName . getName . unL) names))
<+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc
where
-- don't use cd_fld_doc for same reason we don't use con_doc above
- mbDoc = lookup name subdocs >>= fmap _doc . combineDocumentation . fst
+ -- Where there is more than one name, they all have the same documentation
+ mbDoc = lookup (unL $ head names) subdocs >>= fmap _doc . combineDocumentation . fst
-- {-
-- ppHsFullConstr :: HsConDecl -> LaTeX
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index ae01ab6e..f3e29d9d 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -578,7 +578,8 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl
constrBit = subConstructors qual
[ ppSideBySideConstr subdocs subfixs unicode qual c
| c <- cons
- , let subfixs = filter (\(n,_) -> n == unLoc (con_name (unLoc c))) fixities
+ , let subfixs = filter (\(n,_) -> any (\cn -> cn == n)
+ (map unLoc (con_names (unLoc c)))) fixities
]
instancesBit = ppInstances instances docname unicode qual
@@ -597,15 +598,15 @@ ppShortConstrParts :: Bool -> Bool -> ConDecl DocName -> Unicode -> Qualificatio
ppShortConstrParts summary dataInst con unicode qual = case con_res con of
ResTyH98 -> case con_details con of
PrefixCon args ->
- (header_ unicode qual +++ hsep (ppBinder summary occ
+ (header_ unicode qual +++ hsep (ppOcc
: map (ppLParendType unicode qual) args), noHtml, noHtml)
RecCon fields ->
- (header_ unicode qual +++ ppBinder summary occ <+> char '{',
+ (header_ unicode qual +++ ppOcc <+> char '{',
doRecordFields fields,
char '}')
InfixCon arg1 arg2 ->
(header_ unicode qual +++ hsep [ppLParendType unicode qual arg1,
- ppBinderInfix summary occ, ppLParendType unicode qual arg2],
+ ppOccInfix, ppLParendType unicode qual arg2],
noHtml, noHtml)
ResTyGADT resTy -> case con_details con of
@@ -616,20 +617,29 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of
-- Constr :: (Context) => { field :: a, field2 :: b } -> Ty (a, b)
-- (except each field gets its own line in docs, to match
-- non-GADT records)
- RecCon fields -> (ppBinder summary occ <+> dcolon unicode <+>
+ RecCon fields -> (ppOcc <+> dcolon unicode <+>
ppForAllCon forall_ ltvs lcontext unicode qual <+> char '{',
doRecordFields fields,
char '}' <+> arrow unicode <+> ppLType unicode qual resTy)
InfixCon arg1 arg2 -> (doGADTCon [arg1, arg2] resTy, noHtml, noHtml)
where
- doRecordFields fields = shortSubDecls dataInst (map (ppShortField summary unicode qual) fields)
- doGADTCon args resTy = ppBinder summary occ <+> dcolon unicode <+> hsep [
+ doRecordFields fields = shortSubDecls dataInst (map (ppShortField summary unicode qual) (map unLoc fields))
+ doGADTCon args resTy = ppOcc <+> dcolon unicode <+> hsep [
ppForAllCon forall_ ltvs lcontext unicode qual,
ppLType unicode qual (foldr mkFunTy resTy args) ]
header_ = ppConstrHdr forall_ tyVars context
- occ = nameOccName . getName . unLoc . con_name $ con
+ occ = map (nameOccName . getName . unLoc) $ con_names con
+
+ ppOcc = case occ of
+ [one] -> ppBinder summary one
+ _ -> hsep (punctuate comma (map (ppBinder summary) occ))
+
+ ppOccInfix = case occ of
+ [one] -> ppBinderInfix summary one
+ _ -> hsep (punctuate comma (map (ppBinderInfix summary) occ))
+
ltvs = con_qvars con
tyVars = tyvarNames ltvs
lcontext = con_cxt con
@@ -660,15 +670,15 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, field
decl = case con_res con of
ResTyH98 -> case con_details con of
PrefixCon args ->
- hsep ((header_ +++ ppBinder False occ)
+ hsep ((header_ +++ ppOcc)
: map (ppLParendType unicode qual) args)
<+> fixity
- RecCon _ -> header_ +++ ppBinder False occ <+> fixity
+ RecCon _ -> header_ +++ ppOcc <+> fixity
InfixCon arg1 arg2 ->
hsep [header_ +++ ppLParendType unicode qual arg1,
- ppBinderInfix False occ,
+ ppOccInfix,
ppLParendType unicode qual arg2]
<+> fixity
@@ -684,40 +694,51 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, field
_ -> []
doRecordFields fields = subFields qual
- (map (ppSideBySideField subdocs unicode qual) fields)
+ (map (ppSideBySideField subdocs unicode qual) (map unLoc fields))
doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html
- doGADTCon args resTy = ppBinder False occ <+> dcolon unicode
+ doGADTCon args resTy = ppOcc <+> dcolon unicode
<+> hsep [ppForAllCon forall_ ltvs (con_cxt con) unicode qual,
ppLType unicode qual (foldr mkFunTy resTy args) ]
<+> fixity
fixity = ppFixities fixities qual
header_ = ppConstrHdr forall_ tyVars context unicode qual
- occ = nameOccName . getName . unLoc . con_name $ con
+ occ = map (nameOccName . getName . unLoc) $ con_names con
+
+ ppOcc = case occ of
+ [one] -> ppBinder False one
+ _ -> hsep (punctuate comma (map (ppBinder False) occ))
+
+ ppOccInfix = case occ of
+ [one] -> ppBinderInfix False one
+ _ -> hsep (punctuate comma (map (ppBinderInfix False) occ))
+
ltvs = con_qvars con
tyVars = tyvarNames (con_qvars con)
context = unLoc (con_cxt con)
forall_ = con_explicit con
-- don't use "con_doc con", in case it's reconstructed from a .hi file,
-- or also because we want Haddock to do the doc-parsing, not GHC.
- mbDoc = lookup (unLoc $ con_name con) subdocs >>= combineDocumentation . fst
+ mbDoc = lookup (unLoc $ head $ con_names con) subdocs >>=
+ combineDocumentation . fst
mkFunTy a b = noLoc (HsFunTy a b)
ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification
-> ConDeclField DocName -> SubDecl
-ppSideBySideField subdocs unicode qual (ConDeclField (L _ name) ltype _) =
- (ppBinder False (nameOccName . getName $ name) <+> dcolon unicode <+> ppLType unicode qual ltype,
+ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) =
+ (hsep (punctuate comma (map ((ppBinder False) . nameOccName . getName . unL) names)) <+> dcolon unicode <+> ppLType unicode qual ltype,
mbDoc,
[])
where
-- don't use cd_fld_doc for same reason we don't use con_doc above
- mbDoc = lookup name subdocs >>= combineDocumentation . fst
+ -- Where there is more than one name, they all have the same documentation
+ mbDoc = lookup (unL $ head names) subdocs >>= combineDocumentation . fst
ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocName -> Html
-ppShortField summary unicode qual (ConDeclField (L _ name) ltype _)
- = ppBinder summary (nameOccName . getName $ name)
+ppShortField summary unicode qual (ConDeclField names ltype _)
+ = hsep (punctuate comma (map ((ppBinder summary) . nameOccName . getName . unL) names))
<+> dcolon unicode <+> ppLType unicode qual ltype
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 8940d935..1c87d196 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -274,8 +274,8 @@ synifyDataCon use_gadt_syntax dc =
-- HsNoBang never appears, it's implied instead.
)
arg_tys (dataConStrictMarks dc)
- field_tys = zipWith (\field synTy -> ConDeclField
- (synifyName field) synTy Nothing)
+ field_tys = zipWith (\field synTy -> noLoc $ ConDeclField
+ [synifyName field] synTy Nothing)
(dataConFieldLabels dc) linear_tys
hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of
(True,True) -> Left "synifyDataCon: contradiction!"
@@ -289,12 +289,11 @@ synifyDataCon use_gadt_syntax dc =
else ResTyH98
-- finally we get synifyDataCon's result!
in hs_arg_tys >>=
- \hat -> return . noLoc $ ConDecl name Implicit {-we don't know nor care-}
+ \hat -> return . noLoc $ ConDecl [name] Implicit -- we don't know nor care
qvars ctx hat hs_res_ty Nothing
-- we don't want any "deprecated GADT syntax" warnings!
False
-
synifyName :: NamedThing n => n -> Located Name
synifyName = noLoc . getName
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 43112ff3..e64d298f 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -100,7 +100,10 @@ filterLSigNames p (L loc sig) = L loc <$> (filterSigNames p sig)
filterSigNames :: (name -> Bool) -> Sig name -> Maybe (Sig name)
filterSigNames p orig@(SpecSig n _ _) = ifTrueJust (p $ unLoc n) orig
filterSigNames p orig@(InlineSig n _) = ifTrueJust (p $ unLoc n) orig
-filterSigNames p orig@(FixSig (FixitySig n _)) = ifTrueJust (p $ unLoc n) orig
+filterSigNames p (FixSig (FixitySig ns ty)) =
+ case filter (p . unLoc) ns of
+ [] -> Nothing
+ filtered -> Just (FixSig (FixitySig filtered ty))
filterSigNames _ orig@(MinimalSig _) = Just orig
filterSigNames p (TypeSig ns ty) =
case filter (p . unLoc) ns of
@@ -116,12 +119,12 @@ sigName :: LSig name -> [name]
sigName (L _ sig) = sigNameNoLoc sig
sigNameNoLoc :: Sig name -> [name]
-sigNameNoLoc (TypeSig ns _) = map unLoc ns
-sigNameNoLoc (PatSynSig n _ _ _ _) = [unLoc n]
-sigNameNoLoc (SpecSig n _ _) = [unLoc n]
-sigNameNoLoc (InlineSig n _) = [unLoc n]
-sigNameNoLoc (FixSig (FixitySig n _)) = [unLoc n]
-sigNameNoLoc _ = []
+sigNameNoLoc (TypeSig ns _) = map unLoc ns
+sigNameNoLoc (PatSynSig n _ _ _ _) = [unLoc n]
+sigNameNoLoc (SpecSig n _ _) = [unLoc n]
+sigNameNoLoc (InlineSig n _) = [unLoc n]
+sigNameNoLoc (FixSig (FixitySig ns _)) = map unLoc ns
+sigNameNoLoc _ = []
isTyClD :: HsDecl a -> Bool
@@ -195,11 +198,6 @@ instance Traversable (GenLocated l) where
instance NamedThing (TyClDecl Name) where
getName = tcdName
-
-instance NamedThing (ConDecl Name) where
- getName = unL . con_name
-
-
-------------------------------------------------------------------------------
-- * Subordinates
-------------------------------------------------------------------------------
@@ -212,13 +210,13 @@ class Parent a where
instance Parent (ConDecl Name) where
children con =
case con_details con of
- RecCon fields -> map (unL . cd_fld_name) fields
+ RecCon fields -> map unL $ concatMap (cd_fld_names . unL) fields
_ -> []
-
instance Parent (TyClDecl Name) where
children d
- | isDataDecl d = map (unL . con_name . unL) . dd_cons . tcdDataDefn $ d
+ | isDataDecl d = map unL $ concatMap (con_names . unL)
+ $ (dd_cons . tcdDataDefn) $ d
| isClassDecl d =
map (unL . fdLName . unL) (tcdATs d) ++
[ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ]
@@ -230,11 +228,14 @@ family :: (NamedThing a, Parent a) => a -> (Name, [Name])
family = getName &&& children
+familyConDecl :: ConDecl Name -> [(Name, [Name])]
+familyConDecl d = zip (map unL (con_names d)) (repeat $ children d)
+
-- | A mapping from the parent (main-binder) to its children and from each
-- child to its grand-children, recursively.
families :: TyClDecl Name -> [(Name, [Name])]
families d
- | isDataDecl d = family d : map (family . unL) (dd_cons (tcdDataDefn d))
+ | isDataDecl d = family d : concatMap (familyConDecl . unL) (dd_cons (tcdDataDefn d))
| isClassDecl d = [family d]
| otherwise = []
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index da17ccc7..922fdcf7 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -194,8 +194,8 @@ moduleWarning dflags gre (WarnAll w) = Just $ parseWarning dflags gre w
parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> Doc Name
parseWarning dflags gre w = force $ case w of
- DeprecatedTxt msg -> format "Deprecated: " (concatFS msg)
- WarningTxt msg -> format "Warning: " (concatFS msg)
+ DeprecatedTxt msg -> format "Deprecated: " (concatFS $ map unLoc msg)
+ WarningTxt msg -> format "Warning: " (concatFS $ map unLoc msg)
where
format x xs = DocWarning . DocParagraph . DocAppend (DocString x)
. processDocString dflags gre $ HsDocString xs
@@ -331,11 +331,12 @@ subordinates instMap decl = case decl of
dataSubs dd = constrs ++ fields
where
cons = map unL $ (dd_cons dd)
- constrs = [ (unL $ con_name c, maybeToList $ fmap unL $ con_doc c, M.empty)
- | c <- cons ]
+ constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, M.empty)
+ | c <- cons, cname <- con_names c ]
fields = [ (unL n, maybeToList $ fmap unL doc, M.empty)
| RecCon flds <- map con_details cons
- , ConDeclField n _ doc <- flds ]
+ , L _ (ConDeclField ns _ doc) <- flds
+ , n <- ns ]
-- | Extract function argument docs from inside types.
typeDocs :: HsDecl Name -> Map Int HsDocString
@@ -381,7 +382,8 @@ topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup
-- | Extract a map of fixity declarations only
mkFixMap :: HsGroup Name -> FixMap
mkFixMap group_ = M.fromList [ (n,f)
- | L _ (FixitySig (L _ n) f) <- hs_fixds group_ ]
+ | L _ (FixitySig ns f) <- hs_fixds group_,
+ L _ n <- ns ]
-- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.
@@ -501,11 +503,11 @@ mkExportItems
Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls
Just exports -> liftM concat $ mapM lookupExport exports
where
- lookupExport (IEVar x) = declWith x
- lookupExport (IEThingAbs t) = declWith t
- lookupExport (IEThingAll t) = declWith t
- lookupExport (IEThingWith t _) = declWith t
- lookupExport (IEModuleContents m) =
+ lookupExport (IEVar (L _ x)) = declWith x
+ lookupExport (IEThingAbs t) = declWith t
+ lookupExport (IEThingAll (L _ t)) = declWith t
+ lookupExport (IEThingWith (L _ t) _) = declWith t
+ lookupExport (IEModuleContents (L _ m)) =
moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices
lookupExport (IEGroup lev docStr) = return $
return . ExportGroup lev "" $ processDocString dflags gre docStr
@@ -791,7 +793,8 @@ extractDecl name mdl decl
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
+ , ConDeclField { cd_fld_names = ns } <- map unLoc rec
+ , L _ n <- ns
, n == name
]
in case matches of
@@ -823,11 +826,11 @@ extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"
extractRecSel nm mdl t tvs (L _ con : rest) =
case con_details con of
- RecCon fields | (ConDeclField n ty _ : _) <- matching_fields fields ->
+ RecCon fields | ((n,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields ->
L (getLoc n) (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty))))
_ -> extractRecSel nm mdl t tvs rest
where
- matching_fields flds = [ f | f@(ConDeclField n _ _) <- flds, unLoc n == nm ]
+ matching_fields flds = [ (n,f) | f@(L _ (ConDeclField ns _ _)) <- flds, n <- ns, unLoc n == nm ]
data_ty
| ResTyGADT ty <- con_res con = ty
| otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index a5717a58..77159472 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -259,7 +259,6 @@ renameLContext (L loc context) = do
context' <- mapM renameLType context
return (L loc context')
-
renameInstHead :: InstHead Name -> RnM (InstHead DocName)
renameInstHead (className, k, types, rest) = do
className' <- rename className
@@ -364,19 +363,22 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType
, dd_kindSig = k', dd_cons = cons', dd_derivs = Nothing })
renameCon :: ConDecl Name -> RnM (ConDecl DocName)
-renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars
+renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars
, con_cxt = lcontext, con_details = details
, con_res = restype, con_doc = mbldoc }) = do
- lname' <- renameL lname
+ lnames' <- mapM renameL lnames
ltyvars' <- renameLTyVarBndrs ltyvars
lcontext' <- renameLContext lcontext
details' <- renameDetails details
restype' <- renameResType restype
mbldoc' <- mapM renameLDocHsSyn mbldoc
- return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext'
+ return (decl { con_names = lnames', con_qvars = ltyvars', con_cxt = lcontext'
, con_details = details', con_res = restype', con_doc = mbldoc' })
+
where
- renameDetails (RecCon fields) = return . RecCon =<< mapM renameConDeclFieldField fields
+ renameDetails (RecCon fields) = do
+ fields' <- mapM renameConDeclFieldField fields
+ return (RecCon fields')
renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps
renameDetails (InfixCon a b) = do
a' <- renameLType a
@@ -387,12 +389,12 @@ renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars
renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t
-renameConDeclFieldField :: ConDeclField Name -> RnM (ConDeclField DocName)
-renameConDeclFieldField (ConDeclField name t doc) = do
- name' <- renameL name
+renameConDeclFieldField :: LConDeclField Name -> RnM (LConDeclField DocName)
+renameConDeclFieldField (L l (ConDeclField names t doc)) = do
+ names' <- mapM renameL names
t' <- renameLType t
doc' <- mapM renameLDocHsSyn doc
- return (ConDeclField name' t' doc')
+ return $ L l (ConDeclField names' t' doc')
renameSig :: Sig Name -> RnM (Sig DocName)
@@ -408,9 +410,9 @@ renameSig sig = case sig of
lprov' <- renameLContext lprov
lty' <- renameLType lty
return $ PatSynSig lname' (flag, qtvs') lreq' lprov' lty'
- FixSig (FixitySig lname fixity) -> do
- lname' <- renameL lname
- return $ FixSig (FixitySig lname' fixity)
+ FixSig (FixitySig lnames fixity) -> do
+ lnames' <- mapM renameL lnames
+ return $ FixSig (FixitySig lnames' fixity)
MinimalSig s -> MinimalSig <$> traverse renameL s
-- we have filtered out all other kinds of signatures in Interface.Create
_ -> error "expected TypeSig"
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index c4f8eb97..9a821b2e 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -150,24 +150,23 @@ restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons })
restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name]
restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
where
- keep d | unLoc (con_name d) `elem` names =
+ keep d | any (\n -> n `elem` names) (map unLoc $ con_names d) =
case con_details d of
PrefixCon _ -> Just d
RecCon fields
| all field_avail fields -> Just d
- | otherwise -> Just (d { con_details = PrefixCon (field_types fields) })
+ | otherwise -> Just (d { con_details = PrefixCon (field_types (map unL fields)) })
-- if we have *all* the field names available, then
-- keep the record declaration. Otherwise degrade to
-- a constructor declaration. This isn't quite right, but
-- it's the best we can do.
InfixCon _ _ -> Just d
where
- field_avail (ConDeclField n _ _) = unLoc n `elem` names
+ field_avail (L _ (ConDeclField ns _ _)) = all (\n -> unLoc n `elem` names) ns
field_types flds = [ t | ConDeclField _ t _ <- flds ]
keep _ = Nothing
-
restrictDecls :: [Name] -> [LSig Name] -> [LSig Name]
restrictDecls names = mapMaybe (filterLSigNames (`elem` names))
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-21 22:54:10 +0000