From 79629515c0fd71baf182a487df94cb5eaa27ab47 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Fri, 21 Nov 2014 11:23:09 -0600 Subject: Follow API changes in D426 Signed-off-by: Austin Seipp Conflicts: haddock-api/src/Haddock/Backends/LaTeX.hs haddock-api/src/Haddock/Backends/Xhtml/Decl.hs haddock-api/src/Haddock/Convert.hs --- haddock-api/src/Haddock/Backends/Hoogle.hs | 14 +++--- haddock-api/src/Haddock/Backends/LaTeX.hs | 29 +++++++----- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 61 +++++++++++++++++--------- haddock-api/src/Haddock/Convert.hs | 7 ++- haddock-api/src/Haddock/GhcUtils.hs | 33 +++++++------- haddock-api/src/Haddock/Interface/Create.hs | 31 +++++++------ haddock-api/src/Haddock/Interface/Rename.hs | 26 ++++++----- haddock-api/src/Haddock/Utils.hs | 7 ++- 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)) -- cgit v1.2.3