From 24841386cff6fdccc11accf9daa815c2c7444d65 Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Mon, 27 Nov 2017 13:24:01 +0000 Subject: Track changes to follow Trac #14529 This tracks the refactoring of HsDecl.ConDecl. --- haddock-api/src/Haddock/Backends/Hoogle.hs | 7 ++- haddock-api/src/Haddock/Backends/LaTeX.hs | 74 ++------------------------ haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 38 ++++++------- haddock-api/src/Haddock/Convert.hs | 26 ++++----- haddock-api/src/Haddock/GhcUtils.hs | 31 ++++++++++- haddock-api/src/Haddock/Interface/Create.hs | 16 +++--- haddock-api/src/Haddock/Interface/Rename.hs | 46 +++++++++------- haddock-api/src/Haddock/Utils.hs | 20 +------ 8 files changed, 105 insertions(+), 153 deletions(-) (limited to 'haddock-api') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index f1d8ddb2..ee81a83c 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -231,7 +231,7 @@ lookupCon dflags subdocs (L _ name) = case lookup name subdocs of ppCtor :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> ConDecl GhcRn -> [String] ppCtor dflags dat subdocs con@ConDeclH98 {} -- AZ:TODO get rid of the concatMap - = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConDetails con) + = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConArgs con) where f (PrefixCon args) = [typeSig name $ args ++ [resType]] f (InfixCon a1 a2) = f $ PrefixCon [a1,a2] @@ -252,15 +252,14 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} resType = apps $ map (reL . HsTyVar NotPromoted . reL) $ (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvExplicit $ tyClDeclTyVars dat] -ppCtor dflags _dat subdocs con@ConDeclGADT {} +ppCtor dflags _dat subdocs con@(ConDeclGADT { }) = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f where - f = [typeSig name (hsib_body $ con_type con)] + f = [typeSig name (getGADTConType con)] typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty) name = out dflags $ map unL $ getConNames con - ppFixity :: DynFlags -> (Name, Fixity) -> [String] ppFixity dflags (name, fixity) = [out dflags ((FixitySig [noLoc name] fixity) :: FixitySig GhcRn)] diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index d79e0e6c..793e40d8 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -631,7 +631,7 @@ ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX -> LConDecl DocNameI -> LaTeX ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclH98 {})) = leader <-> - case con_details con of + case con_args con of PrefixCon args -> decltt (hsep ((header_ unicode <+> ppOcc) : @@ -660,8 +660,8 @@ ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclH98 {})) = ppOcc = case occ of [one] -> ppBinder one _ -> cat (punctuate comma (map ppBinder occ)) - tyVars = tyvarNames (fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con)) - context = unLoc (fromMaybe (noLoc []) (con_cxt con)) + tyVars = map (getName . hsLTyVarName) (con_ex_tvs con) + context = unLoc (fromMaybe (noLoc []) (con_mb_cxt 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. @@ -672,7 +672,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclH98 {})) = ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclGADT {})) = leader <-> - doGADTCon (hsib_body $ con_type con) + doGADTCon (getGADTConType con) where doGADTCon resTy = decltt (ppOcc <+> dcolon unicode <+> @@ -690,72 +690,6 @@ ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclGADT {})) = [] -> panic "empty con_names" (cn:_) -> lookup (unLoc cn) subdocs >>= fmap _doc . combineDocumentation . fst -{- old - -ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX - -> LConDecl DocName -> LaTeX -ppSideBySideConstr subdocs unicode leader (L loc con) = - leader <-> - case con_res con of - ResTyH98 -> case con_details con of - - PrefixCon args -> - decltt (hsep ((header_ unicode <+> ppOcc) : - map (ppLParendType unicode) args)) - <-> rDoc mbDoc <+> nl - - RecCon (L _ fields) -> - (decltt (header_ unicode <+> ppOcc) - <-> rDoc mbDoc <+> nl) - $$ - doRecordFields fields - - InfixCon arg1 arg2 -> - decltt (hsep [ header_ unicode <+> ppLParendType unicode arg1, - ppOcc, - ppLParendType unicode arg2 ]) - <-> rDoc mbDoc <+> nl - - ResTyGADT _ resTy -> case con_details con of - -- prefix & infix could also use hsConDeclArgTys if it seemed to - -- simplify the code. - PrefixCon args -> doGADTCon args resTy - cd@(RecCon (L _ fields)) -> doGADTCon (hsConDeclArgTys cd) resTy <+> nl $$ - doRecordFields fields - InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy - - where - doRecordFields fields = - vcat (map (ppSideBySideField subdocs unicode) (map unLoc fields)) - - doGADTCon args resTy = decltt (ppOcc <+> dcolon unicode <+> - ppLType unicode (mk_forall $ mk_phi $ - foldr mkFunTy resTy args) - ) <-> rDoc mbDoc - - - header_ = ppConstrHdr (con_explicit con) tyVars context - 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) - - mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvExplicit ltvs) ty) - | otherwise = ty - mk_phi ty | null context = ty - | otherwise = L loc (HsQualTy (con_cxt con) ty) - - -- 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 = 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 DocNameI -> LaTeX ppSideBySideField subdocs unicode (ConDeclField names ltype _) = diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 3b85f96c..bf71fec4 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -769,7 +769,7 @@ ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot -- incorporated into the declaration ppShortConstrParts :: Bool -> Bool -> ConDecl DocNameI -> Unicode -> Qualification -> (Html, Html, Html) ppShortConstrParts summary dataInst con unicode qual = case con of - ConDeclH98{} -> case con_details con of + ConDeclH98{} -> case con_args con of PrefixCon args -> (header_ unicode qual +++ hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts) args), noHtml, noHtml) @@ -782,17 +782,18 @@ ppShortConstrParts summary dataInst con unicode qual = case con of ppOccInfix, ppLParendType unicode qual HideEmptyContexts arg2], noHtml, noHtml) - ConDeclGADT {} -> (ppOcc <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts resTy,noHtml,noHtml) + ConDeclGADT {} -> (ppOcc <+> dcolon unicode + <+> ppLType unicode qual HideEmptyContexts (getGADTConType con) + , noHtml, noHtml) where - resTy = hsib_body (con_type con) - - doRecordFields fields = shortSubDecls dataInst (map (ppShortField summary unicode qual) (map unLoc fields)) + doRecordFields fields = shortSubDecls dataInst $ + map (ppShortField summary unicode qual) (map unLoc fields) header_ = ppConstrHdr forall_ tyVars context - occ = map (nameOccName . getName . unLoc) $ getConNames con + occ = map (nameOccName . getName . unLoc) $ getConNames con - ppOcc = case occ of + ppOcc = case occ of [one] -> ppBinder summary one _ -> hsep (punctuate comma (map (ppBinder summary) occ)) @@ -800,9 +801,9 @@ ppShortConstrParts summary dataInst con unicode qual = case con of [one] -> ppBinderInfix summary one _ -> hsep (punctuate comma (map (ppBinderInfix summary) occ)) - ltvs = fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con) - tyVars = tyvarNames ltvs - lcontext = fromMaybe (noLoc []) (con_cxt con) + -- Used for H98 syntax only + tyVars = map (getName . hsLTyVarName) (con_ex_tvs con) + lcontext = fromMaybe (noLoc []) (con_mb_cxt con) context = unLoc lcontext forall_ = False @@ -827,7 +828,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, fieldPart) where decl = case con of - ConDeclH98{} -> case con_details con of + ConDeclH98{} -> case con_args con of PrefixCon args -> hsep ((header_ +++ ppOcc) : map (ppLParendType unicode qual HideEmptyContexts) args) @@ -841,11 +842,9 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) ppLParendType unicode qual HideEmptyContexts arg2] <+> fixity - ConDeclGADT{} -> doGADTCon resTy - - resTy = hsib_body (con_type con) + ConDeclGADT{} -> doGADTCon (getGADTConType con) - fieldPart = case getConDetails con of + fieldPart = case getConArgs con of RecCon (L _ fields) -> [doRecordFields fields] _ -> [] @@ -860,9 +859,9 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) fixity = ppFixities fixities qual header_ = ppConstrHdr forall_ tyVars context unicode qual - occ = map (nameOccName . getName . unLoc) $ getConNames con + occ = map (nameOccName . getName . unLoc) $ getConNames con - ppOcc = case occ of + ppOcc = case occ of [one] -> ppBinder False one _ -> hsep (punctuate comma (map (ppBinder False) occ)) @@ -870,8 +869,9 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) [one] -> ppBinderInfix False one _ -> hsep (punctuate comma (map (ppBinderInfix False) occ)) - tyVars = tyvarNames (fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con)) - context = unLoc (fromMaybe (noLoc []) (con_cxt con)) + -- Used for H98 syntax only + tyVars = map (getName . hsLTyVarName) (con_ex_tvs con) + context = unLoc (fromMaybe (noLoc []) (con_mb_cxt con)) forall_ = False -- 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. diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index fc808568..37fad036 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -284,10 +284,6 @@ synifyDataCon use_gadt_syntax dc = -- con_qvars means a different thing depending on gadt-syntax (univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc - qvars = if use_gadt_syntax - then synifyTyVars (univ_tvs ++ ex_tvs) - else synifyTyVars ex_tvs - -- skip any EqTheta, use 'orig'inal syntax ctx = synifyCtx theta @@ -310,21 +306,25 @@ synifyDataCon use_gadt_syntax dc = (False,True) -> case linear_tys of [a,b] -> return $ InfixCon a b _ -> Left "synifyDataCon: infix with non-2 args?" - gadt_ty = HsIB [] (synifyType WithinType res_ty) False -- finally we get synifyDataCon's result! in hs_arg_tys >>= \hat -> if use_gadt_syntax then return $ noLoc $ - ConDeclGADT { con_names = [name] - , con_type = gadt_ty - , con_doc = Nothing } + ConDeclGADT { con_names = [name] + , con_forall = True + , con_qvars = synifyTyVars (univ_tvs ++ ex_tvs) + , con_mb_cxt = Just ctx + , con_args = hat + , con_res_ty = synifyType WithinType res_ty + , con_doc = Nothing } else return $ noLoc $ - ConDeclH98 { con_name = name - , con_qvars = Just qvars - , con_cxt = Just ctx - , con_details = hat - , con_doc = Nothing } + ConDeclH98 { con_name = name + , con_forall = True + , con_ex_tvs = map synifyTyVar ex_tvs + , con_mb_cxt = Just ctx + , con_args = hat + , con_doc = Nothing } synifyName :: NamedThing n => n -> Located Name synifyName n = L (srcLocSpan (getSrcLoc n)) (getName n) diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index a1009c1f..4963d2f8 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -17,6 +17,7 @@ module Haddock.GhcUtils where import Control.Arrow +import Haddock.Types( DocNameI ) import Exception import Outputable @@ -148,6 +149,32 @@ nubByName f ns = go emptyNameSet ns where y = f x +getGADTConType :: ConDecl p -> LHsType p +-- The full type of a GADT data constructor We really only get this in +-- order to pretty-print it, and currently only in Haddock's code. So +-- we are cavalier about locations and extensions, hence the +-- 'undefined's +getGADTConType (ConDeclGADT { con_forall = has_forall + , con_qvars = qtvs + , con_mb_cxt = mcxt, con_args = args + , con_res_ty = res_ty }) + | has_forall = noLoc (HsForAllTy { hst_bndrs = hsQTvExplicit qtvs + , hst_body = theta_ty }) + | otherwise = theta_ty + where + theta_ty | Just theta <- mcxt + = noLoc (HsQualTy { hst_ctxt = theta, hst_body = tau_ty }) + | otherwise + = tau_ty + + tau_ty = case args of + RecCon flds -> noLoc (HsFunTy (noLoc (HsRecTy (unLoc flds))) res_ty) + PrefixCon pos_args -> foldr (\ a b -> noLoc (HsFunTy a b)) res_ty pos_args + InfixCon {} -> panic "InfixCon for GADT" + +getGADTConType (ConDeclH98 {}) = panic "getGADTConType" + -- Should only be called on ConDeclGADT + ------------------------------------------------------------------------------- -- * Located ------------------------------------------------------------------------------- @@ -179,7 +206,7 @@ class Parent a where instance Parent (ConDecl GhcRn) where children con = - case getConDetails con of + case con_args con of RecCon fields -> map (selectorFieldOcc . unL) $ concatMap (cd_fld_names . unL) (unL fields) _ -> [] @@ -259,3 +286,5 @@ setStubDir f d = d{ stubDir = Just f, includePaths = f : includePaths d } -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file -- \#included from the .hc file when compiling with -fvia-C. setOutputDir f = setObjectDir f . setHiDir f . setStubDir f + + diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 27456998..52a983a8 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -61,7 +61,7 @@ import TcRnTypes import FastString (concatFS) import BasicTypes ( StringLiteral(..), SourceText(..) ) import qualified Outputable as O -import HsDecls ( getConDetails ) +import HsDecls ( getConArgs ) -- | Use a 'TypecheckedModule' to produce an 'Interface'. @@ -455,7 +455,7 @@ subordinates instMap decl = case decl of constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, M.empty) | c <- cons, cname <- getConNames c ] fields = [ (selectorFieldOcc n, maybeToList $ fmap unL doc, M.empty) - | RecCon flds <- map getConDetails cons + | RecCon flds <- map getConArgs cons , L _ (ConDeclField ns _ doc) <- (unLoc flds) , L _ n <- ns ] derivs = [ (instName, [unL doc], M.empty) @@ -1028,7 +1028,7 @@ extractDecl name decl let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d })) <- insts -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (feqn_rhs d) - , RecCon rec <- map (getConDetails . unLoc) (dd_cons (feqn_rhs d)) + , RecCon rec <- map (getConArgs . unLoc) (dd_cons (feqn_rhs d)) , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) , L _ n <- ns , selectorFieldOcc n == name @@ -1050,14 +1050,14 @@ extractPatternSyn nm t tvs cons = extract :: ConDecl GhcRn -> Sig GhcRn extract con = let args = - case getConDetails con of + case getConArgs con of PrefixCon args' -> args' RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields InfixCon arg1 arg2 -> [arg1, arg2] typ = longArrow args (data_ty con) typ' = case con of - ConDeclH98 { con_cxt = Just cxt } -> noLoc (HsQualTy cxt typ) + ConDeclH98 { con_mb_cxt = Just cxt } -> noLoc (HsQualTy cxt typ) _ -> typ typ'' = noLoc (HsQualTy (noLoc []) typ') in PatSynSig [noLoc nm] (mkEmptyImplicitBndrs typ'') @@ -1066,7 +1066,7 @@ extractPatternSyn nm t tvs cons = longArrow inputs output = foldr (\x y -> noLoc (HsFunTy x y)) output inputs data_ty con - | ConDeclGADT{} <- con = hsib_body $ con_type con + | ConDeclGADT{} <- con = con_res_ty con | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs extractRecSel :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn] @@ -1074,7 +1074,7 @@ extractRecSel :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn] extractRecSel _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm t tvs (L _ con : rest) = - case getConDetails con of + case getConArgs con of RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields -> L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy data_ty (getBangType ty))))) _ -> extractRecSel nm t tvs rest @@ -1084,7 +1084,7 @@ extractRecSel nm t tvs (L _ con : rest) = , L l n <- ns, selectorFieldOcc n == nm ] data_ty -- ResTyGADT _ ty <- con_res con = ty - | ConDeclGADT{} <- con = hsib_body $ con_type con + | ConDeclGADT{} <- con = con_res_ty con | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs -- | Keep export items with docs. diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 7023a908..fadd0553 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -428,35 +428,41 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType , dd_derivs = noLoc [] }) renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI) -renameCon decl@(ConDeclH98 { con_name = lname, con_qvars = ltyvars - , con_cxt = lcontext, con_details = details +renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars + , con_mb_cxt = lcontext, con_args = details , con_doc = mbldoc }) = do lname' <- renameL lname - ltyvars' <- traverse renameLHsQTyVars ltyvars + ltyvars' <- mapM renameLTyVarBndr ltyvars lcontext' <- traverse renameLContext lcontext details' <- renameDetails details mbldoc' <- mapM renameLDocHsSyn mbldoc - return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext' - , con_details = details', con_doc = mbldoc' }) + return (decl { con_name = lname', con_ex_tvs = ltyvars' + , con_mb_cxt = lcontext' + , con_args = details', con_doc = mbldoc' }) - where - renameDetails (RecCon (L l fields)) = do - fields' <- mapM renameConDeclFieldField fields - return (RecCon (L l fields')) - renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps - renameDetails (InfixCon a b) = do - a' <- renameLType a - b' <- renameLType b - return (InfixCon a' b') - -renameCon decl@(ConDeclGADT { con_names = lnames - , con_type = lty +renameCon decl@(ConDeclGADT { con_names = lnames, con_qvars = ltyvars + , con_mb_cxt = lcontext, con_args = details + , con_res_ty = res_ty , con_doc = mbldoc }) = do lnames' <- mapM renameL lnames - lty' <- renameLSigType lty + ltyvars' <- renameLHsQTyVars ltyvars + lcontext' <- traverse renameLContext lcontext + details' <- renameDetails details + res_ty' <- renameLType res_ty mbldoc' <- mapM renameLDocHsSyn mbldoc - return (decl { con_names = lnames' - , con_type = lty', con_doc = mbldoc' }) + return (decl { con_names = lnames', con_qvars = ltyvars' + , con_mb_cxt = lcontext', con_args = details' + , con_res_ty = res_ty', con_doc = mbldoc' }) + +renameDetails :: HsConDeclDetails GhcRn -> RnM (HsConDeclDetails DocNameI) +renameDetails (RecCon (L l fields)) = do + fields' <- mapM renameConDeclFieldField fields + return (RecCon (L l fields')) +renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps +renameDetails (InfixCon a b) = do + a' <- renameLType a + b' <- renameLType b + return (InfixCon a' b') renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI) renameConDeclFieldField (L l (ConDeclField names t doc)) = do diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 84f58ab8..1993fb5d 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -180,33 +180,17 @@ restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn] restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] where keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) = - case getConDetails h98d of + case con_args d of PrefixCon _ -> Just d RecCon fields | all field_avail (unL fields) -> Just d - | otherwise -> Just (h98d { con_details = PrefixCon (field_types (map unL (unL fields))) }) + | otherwise -> Just (d { con_args = PrefixCon (field_types (map unL (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 - h98d = h98ConDecl d - h98ConDecl c@ConDeclH98{} = c - h98ConDecl c@ConDeclGADT{} = c' - where - (details,_res_ty,cxt,tvs) = gadtDeclDetails (con_type c) - c' :: ConDecl GhcRn - c' = ConDeclH98 - { con_name = head (con_names c) - , con_qvars = Just $ HsQTvs { hsq_implicit = mempty - , hsq_explicit = tvs - , hsq_dependent = emptyNameSet } - , con_cxt = Just cxt - , con_details = details - , con_doc = con_doc c - } - field_avail :: LConDeclField GhcRn -> Bool field_avail (L _ (ConDeclField fs _ _)) = all (\f -> selectorFieldOcc (unLoc f) `elem` names) fs -- cgit v1.2.3