From 658ad4af237f3da196cca083ad525375260e38a7 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Tue, 19 Mar 2019 17:46:02 -0400 Subject: Changes for #15247 --- haddock-api/src/Haddock/Backends/Hoogle.hs | 16 +-- haddock-api/src/Haddock/Backends/LaTeX.hs | 36 +++--- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 48 ++++---- haddock-api/src/Haddock/Convert.hs | 104 ++++++++-------- haddock-api/src/Haddock/GhcUtils.hs | 90 ++++++++------ haddock-api/src/Haddock/Interface/Create.hs | 68 +++++------ haddock-api/src/Haddock/Interface/Rename.hs | 134 ++++++++++----------- haddock-api/src/Haddock/Interface/Specialize.hs | 8 +- haddock-api/src/Haddock/Types.hs | 152 ++++++++++++------------ haddock-api/src/Haddock/Utils.hs | 12 +- 10 files changed, 347 insertions(+), 321 deletions(-) (limited to 'haddock-api/src') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 45318498..9298f262 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -196,7 +196,7 @@ ppFam dflags decl@(FamilyDecl { fdInfo = info }) -- for Hoogle, so pretend it doesn't have any. ClosedTypeFamily{} -> decl { fdInfo = OpenTypeFamily } _ -> decl -ppFam _ XFamilyDecl {} = panic "ppFam" +ppFam _ (XFamilyDecl nec) = noExtCon nec ppInstance :: DynFlags -> ClsInst -> [String] ppInstance dflags x = @@ -245,8 +245,8 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} [out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] | r <- map unLoc recs] - funs = foldr1 (\x y -> reL $ HsFunTy NoExt x y) - apps = foldl1 (\x y -> reL $ HsAppTy NoExt x y) + funs = foldr1 (\x y -> reL $ HsFunTy noExtField x y) + apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y) typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds) @@ -254,12 +254,12 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} -- docs for con_names on why it is a list to begin with. name = commaSeparate dflags . map unL $ getConNames con - tyVarArg (UserTyVar _ n) = HsTyVar NoExt NotPromoted n - tyVarArg (KindedTyVar _ n lty) = HsKindSig NoExt (reL (HsTyVar NoExt NotPromoted n)) lty + tyVarArg (UserTyVar _ n) = HsTyVar noExtField NotPromoted n + tyVarArg (KindedTyVar _ n lty) = HsKindSig noExtField (reL (HsTyVar noExtField NotPromoted n)) lty tyVarArg _ = panic "ppCtor" resType = apps $ map reL $ - (HsTyVar NoExt NotPromoted (reL (tcdName dat))) : + (HsTyVar noExtField NotPromoted (reL (tcdName dat))) : map (tyVarArg . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat) ppCtor dflags _dat subdocs con@(ConDeclGADT { }) @@ -269,10 +269,10 @@ ppCtor dflags _dat subdocs con@(ConDeclGADT { }) typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty) name = out dflags $ map unL $ getConNames con -ppCtor _ _ _ XConDecl {} = panic "haddock:ppCtor" +ppCtor _ _ _ (XConDecl nec) = noExtCon nec ppFixity :: DynFlags -> (Name, Fixity) -> [String] -ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExt [noLoc name] fixity) :: FixitySig GhcRn)] +ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExtField [noLoc name] fixity) :: FixitySig GhcRn)] --------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 9e2e52c3..6fd7969f 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -307,7 +307,7 @@ ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX ppFor doc (ForeignImport _ (L _ name) typ _) unicode = - ppFunSig doc [name] (hsSigType typ) unicode + ppFunSig doc [name] (hsSigTypeI typ) unicode ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" -- error "foreign declarations are currently not supported by --latex" @@ -349,8 +349,8 @@ ppFamDecl doc instances decl unicode = , equals , ppType unicode (unLoc rhs) ] - ppFamDeclEqn (XHsImplicitBndrs _) = panic "haddock:ppFamDecl" - ppFamDeclEqn (HsIB { hsib_body = XFamEqn _}) = panic "haddock:ppFamDecl" + ppFamDeclEqn (XHsImplicitBndrs nec) = noExtCon nec + ppFamDeclEqn (HsIB { hsib_body = XFamEqn nec}) = noExtCon nec instancesBit = ppDocInstances unicode instances @@ -358,7 +358,7 @@ ppFamDecl doc instances decl unicode = ppFamHeader :: FamilyDecl DocNameI -- ^ family header to print -> Bool -- ^ unicode -> LaTeX -ppFamHeader (XFamilyDecl _) _ = panic "haddock;ppFamHeader" +ppFamHeader (XFamilyDecl nec) _ = noExtCon nec ppFamHeader (FamilyDecl { fdLName = L _ name , fdTyVars = tvs , fdInfo = info @@ -378,7 +378,7 @@ ppFamHeader (FamilyDecl { fdLName = L _ name NoSig _ -> empty KindSig _ kind -> dcolon unicode <+> ppLKind unicode kind TyVarSig _ (L _ bndr) -> equals <+> ppHsTyVarBndr unicode bndr - XFamilyResultSig _ -> panic "haddock:ppFamHeader" + XFamilyResultSig nec -> noExtCon nec injAnn = case injectivity of Nothing -> empty @@ -440,7 +440,7 @@ ppLPatSig doc docnames ty unicode ) unicode where - typ = unLoc (hsSigType ty) + typ = unLoc (hsSigTypeI ty) names = map getName docnames -- | Pretty-print a type, adding documentation to the whole type and its @@ -523,11 +523,11 @@ ppTypeSig nms ty unicode = ppTyVars :: [LHsTyVarBndr DocNameI] -> [LaTeX] -ppTyVars = map (ppSymName . getName . hsLTyVarName) +ppTyVars = map (ppSymName . getName . hsLTyVarNameI) tyvarNames :: LHsQTyVars DocNameI -> [Name] -tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit +tyvarNames = map (getName . hsLTyVarNameI) . hsQTvExplicit declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX @@ -749,9 +749,9 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = where -- Find the name of a constructors in the decl (`getConName` always returns -- a non-empty list) - aConName = unLoc (head (getConNames con)) + aConName = unLoc (head (getConNamesI con)) - occ = map (nameOccName . getName . unLoc) $ getConNames con + occ = map (nameOccName . getName . unLoc) $ getConNamesI con ppOcc = cat (punctuate comma (map ppBinder occ)) ppOccInfix = cat (punctuate comma (map ppBinderInfix occ)) @@ -765,7 +765,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = ConDeclH98{ con_args = det , con_ex_tvs = vars , con_mb_cxt = cxt - } -> let tyVars = map (getName . hsLTyVarName) vars + } -> let tyVars = map (getName . hsLTyVarNameI) vars context = unLoc (fromMaybe (noLoc []) cxt) forall_ = False header_ = ppConstrHdr forall_ tyVars context unicode @@ -797,7 +797,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = -- ++AZ++ make this prepend "{..}" when it is a record style GADT , ppLType unicode (getGADTConType con) ] - XConDecl{} -> panic "haddock:ppSideBySideConstr" + XConDecl nec -> noExtCon nec fieldPart = case (con, getConArgs con) of -- Record style GADTs @@ -831,12 +831,12 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = [ l <+> text "\\enspace" <+> r | (l,r) <- ppSubSigLike unicode (unLoc (getGADTConType con)) argDocs subdocs (dcolon unicode) ] - XConDecl{} -> panic "haddock:doConstrArgsWithDocs" + XConDecl nec -> noExtCon nec -- 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 getConNames con of + mbDoc = case getConNamesI con of [] -> panic "empty con_names" (cn:_) -> lookup (unLoc cn) subdocs >>= fmap _doc . combineDocumentation . fst @@ -851,7 +851,7 @@ ppSideBySideField subdocs unicode (ConDeclField _ names ltype _) = -- don't use cd_fld_doc for same reason we don't use con_doc above -- Where there is more than one name, they all have the same documentation mbDoc = lookup (extFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst -ppSideBySideField _ _ (XConDeclField _) = panic "haddock:ppSideBySideField" +ppSideBySideField _ _ (XConDeclField nec) = noExtCon nec -- | Pretty-print a bundled pattern synonym @@ -871,7 +871,7 @@ ppSideBySidePat lnames typ (doc, argDocs) unicode = | otherwise = hsep [ keyword "pattern" , ppOcc , dcolon unicode - , ppLType unicode (hsSigType typ) + , ppLType unicode (hsSigTypeI typ) ] fieldPart @@ -881,7 +881,7 @@ ppSideBySidePat lnames typ (doc, argDocs) unicode = | (l,r) <- ppSubSigLike unicode (unLoc patTy) argDocs [] (dcolon unicode) ] - patTy = hsSigType typ + patTy = hsSigTypeI typ mDoc = fmap _doc $ combineDocumentation doc @@ -1018,7 +1018,7 @@ ppHsTyVarBndr :: Bool -> HsTyVarBndr DocNameI -> LaTeX ppHsTyVarBndr _ (UserTyVar _ (L _ name)) = ppDocName name ppHsTyVarBndr unicode (KindedTyVar _ (L _ name) kind) = parens (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind -ppHsTyVarBndr _ (XTyVarBndr _) = panic "haddock:ppHsTyVarBndr" +ppHsTyVarBndr _ (XTyVarBndr nec) = noExtCon nec ppLKind :: Bool -> LHsKind DocNameI -> LaTeX ppLKind unicode y = ppKind unicode (unLoc y) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 1a0db153..a24715a7 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -64,7 +64,7 @@ ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdoc SigD _ (TypeSig _ lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames (hsSigWcType lty) fixities splice unicode pkg qual SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames - (hsSigType lty) fixities splice unicode pkg qual + (hsSigTypeI lty) fixities splice unicode pkg qual ForD _ d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual InstD _ _ -> noHtml DerivD _ _ -> noHtml @@ -236,7 +236,7 @@ ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppFor summary links loc doc (ForeignImport _ (L _ name) typ _) fixities splice unicode pkg qual - = ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode pkg qual + = ppFunSig summary links loc doc [name] (hsSigTypeI typ) fixities splice unicode pkg qual ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor" @@ -327,8 +327,8 @@ ppFamDecl summary associated links instances fixities loc doc decl splice unicod , Nothing , [] ) - ppFamDeclEqn (XHsImplicitBndrs _) = panic "haddock:ppFamDecl" - ppFamDeclEqn (HsIB { hsib_body = XFamEqn _}) = panic "haddock:ppFamDecl" + ppFamDeclEqn (XHsImplicitBndrs nec) = noExtCon nec + ppFamDeclEqn (HsIB { hsib_body = XFamEqn nec}) = noExtCon nec -- | Print a pseudo family declaration @@ -353,7 +353,7 @@ ppFamHeader :: Bool -- ^ is a summary -> Bool -- ^ is an associated type -> FamilyDecl DocNameI -- ^ family declaration -> Unicode -> Qualification -> Html -ppFamHeader _ _ (XFamilyDecl _) _ _ = panic "haddock;ppFamHeader" +ppFamHeader _ _ (XFamilyDecl nec) _ _ = noExtCon nec ppFamHeader summary associated (FamilyDecl { fdInfo = info , fdResultSig = L _ result , fdInjectivityAnn = injectivity @@ -393,7 +393,7 @@ ppResultSig result unicode qual = case result of NoSig _ -> noHtml KindSig _ kind -> dcolon unicode <+> ppLKind unicode qual kind TyVarSig _ (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr - XFamilyResultSig _ -> panic "haddock:ppResultSig" + XFamilyResultSig nec -> noExtCon nec -------------------------------------------------------------------------------- @@ -518,7 +518,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t -- ToDo: add associated type defaults - [ ppFunSig summary links loc doc names (hsSigType typ) + [ ppFunSig summary links loc doc names (hsSigTypeI typ) [] splice unicode pkg qual | L _ (ClassOpSig _ False lnames typ) <- sigs , let doc = lookupAnySubdoc (head names) subdocs @@ -568,7 +568,7 @@ ppClassDecl summary links instances fixities loc d subdocs doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs subfixs = [ f | f@(n',_) <- fixities, n == n' ] ] - methodBit = subMethods [ ppFunSig summary links loc doc [name] (hsSigType typ) + methodBit = subMethods [ ppFunSig summary links loc doc [name] (hsSigTypeI typ) subfixs splice unicode pkg qual | L _ (ClassOpSig _ _ lnames typ) <- lsigs , name <- map unLoc lnames @@ -756,7 +756,7 @@ ppShortDataDecl summary dataInst dataDecl pats unicode qual pats1 = [ hsep [ keyword "pattern" , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames , dcolon unicode - , ppPatSigType unicode qual (hsSigType typ) + , ppPatSigType unicode qual (hsSigTypeI typ) ] | (SigD _ (PatSynSig _ lnames typ),_) <- pats ] @@ -802,7 +802,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats [ ppSideBySideConstr subdocs subfixs unicode pkg qual c | c <- cons , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) - (map unLoc (getConNames (unLoc c)))) fixities + (map unLoc (getConNamesI (unLoc c)))) fixities ] patternBit = subPatterns pkg qual @@ -830,7 +830,7 @@ ppShortConstrParts summary dataInst con unicode qual ConDeclH98{ con_args = det , con_ex_tvs = vars , con_mb_cxt = cxt - } -> let tyVars = map (getName . hsLTyVarName) vars + } -> let tyVars = map (getName . hsLTyVarNameI) vars context = unLoc (fromMaybe (noLoc []) cxt) forall_ = False header_ = ppConstrHdr forall_ tyVars context unicode qual @@ -868,10 +868,10 @@ ppShortConstrParts summary dataInst con unicode qual , noHtml , noHtml ) - XConDecl {} -> panic "haddock:ppShortConstrParts" + XConDecl nec -> noExtCon nec where - occ = map (nameOccName . getName . unLoc) $ getConNames con + occ = map (nameOccName . getName . unLoc) $ getConNamesI con ppOcc = hsep (punctuate comma (map (ppBinder summary) occ)) ppOccInfix = hsep (punctuate comma (map (ppBinderInfix summary) occ)) @@ -888,10 +888,10 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) ) where -- Find the name of a constructors in the decl (`getConName` always returns a non-empty list) - aConName = unLoc (head (getConNames con)) + aConName = unLoc (head (getConNamesI con)) fixity = ppFixities fixities qual - occ = map (nameOccName . getName . unLoc) $ getConNames con + occ = map (nameOccName . getName . unLoc) $ getConNamesI con ppOcc = hsep (punctuate comma (map (ppBinder False) occ)) ppOccInfix = hsep (punctuate comma (map (ppBinderInfix False) occ)) @@ -904,7 +904,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) ConDeclH98{ con_args = det , con_ex_tvs = vars , con_mb_cxt = cxt - } -> let tyVars = map (getName . hsLTyVarName) vars + } -> let tyVars = map (getName . hsLTyVarNameI) vars context = unLoc (fromMaybe (noLoc []) cxt) forall_ = False header_ = ppConstrHdr forall_ tyVars context unicode qual @@ -938,7 +938,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) , ppLType unicode qual HideEmptyContexts (getGADTConType con) , fixity ] - XConDecl{} -> panic "haddock:ppSideBySideConstr" + XConDecl nec -> noExtCon nec fieldPart = case (con, getConArgs con) of -- Record style GADTs @@ -967,11 +967,11 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) ConDeclGADT{} -> ppSubSigLike unicode qual (unLoc (getGADTConType con)) argDocs subdocs (dcolon unicode) HideEmptyContexts - XConDecl{} -> panic "haddock:doConstrArgsWithDocs" + XConDecl nec -> noExtCon nec -- 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 $ head $ getConNames con) subdocs >>= + mbDoc = lookup (unLoc $ head $ getConNamesI con) subdocs >>= combineDocumentation . fst @@ -1011,14 +1011,14 @@ ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype _) = -- don't use cd_fld_doc for same reason we don't use con_doc above -- Where there is more than one name, they all have the same documentation mbDoc = lookup (extFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst -ppSideBySideField _ _ _ (XConDeclField _) = panic "haddock:ppSideBySideField" +ppSideBySideField _ _ _ (XConDeclField nec) = noExtCon nec ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> Html ppShortField summary unicode qual (ConDeclField _ names ltype _) = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype -ppShortField _ _ _ (XConDeclField _) = panic "haddock:ppShortField" +ppShortField _ _ _ (XConDeclField nec) = noExtCon nec -- | Pretty print an expanded pattern (for bundled patterns) @@ -1041,7 +1041,7 @@ ppSideBySidePat fixities unicode qual lnames typ (doc, argDocs) = | otherwise = hsep [ keyword "pattern" , ppOcc , dcolon unicode - , ppPatSigType unicode qual (hsSigType typ) + , ppPatSigType unicode qual (hsSigTypeI typ) , fixity ] @@ -1051,7 +1051,7 @@ ppSideBySidePat fixities unicode qual lnames typ (doc, argDocs) = argDocs [] (dcolon unicode) emptyCtxt) ] - patTy = hsSigType typ + patTy = hsSigTypeI typ emptyCtxt = patSigContext patTy @@ -1125,7 +1125,7 @@ ppHsTyVarBndr _ qual (UserTyVar _ (L _ name)) = ppHsTyVarBndr unicode qual (KindedTyVar _ name kind) = parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> ppLKind unicode qual kind) -ppHsTyVarBndr _ _ (XTyVarBndr _) = panic "haddock:ppHsTyVarBndr" +ppHsTyVarBndr _ _ (XTyVarBndr nec) = noExtCon nec ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> Html ppLKind unicode qual y = ppKind unicode qual (unLoc y) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 8e6b0a4c..2e5d998c 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -74,7 +74,7 @@ tyThingToLHsDecl prr t = case t of -- in a future code version we could turn idVarDetails = foreign-call -- into a ForD instead of a SigD if we wanted. Haddock doesn't -- need to care. - AnId i -> allOK $ SigD noExt (synifyIdSig prr ImplicitizeForAll [] i) + AnId i -> allOK $ SigD noExtField (synifyIdSig prr ImplicitizeForAll [] i) -- type-constructors (e.g. Maybe) are complicated, put the definition -- later in the file (also it's used for class associated-types too.) @@ -89,7 +89,7 @@ tyThingToLHsDecl prr t = case t of extractFamDefDecl fd rhs = TyFamInstDecl $ HsIB { hsib_ext = hsq_ext (fdTyVars fd) , hsib_body = FamEqn - { feqn_ext = noExt + { feqn_ext = noExtField , feqn_tycon = fdLName fd , feqn_bndrs = Nothing , feqn_pats = map (HsValArg . hsLTyVarBndrToType) $ @@ -110,7 +110,7 @@ tyThingToLHsDecl prr t = case t of (atFamDecls, atDefFamDecls) = unzip (rights atTyClDecls) vs = tyConVisibleTyVars (classTyCon cl) - in withErrs (lefts atTyClDecls) . TyClD noExt $ ClassDecl + in withErrs (lefts atTyClDecls) . TyClD noExtField $ ClassDecl { tcdCtxt = synifyCtx (classSCTheta cl) , tcdLName = synifyName cl , tcdTyVars = synifyTyVars vs @@ -118,7 +118,7 @@ tyThingToLHsDecl prr t = case t of , tcdFDs = map (\ (l,r) -> noLoc (map (noLoc . getName) l, map (noLoc . getName) r) ) $ snd $ classTvsFds cl - , tcdSigs = noLoc (MinimalSig noExt NoSourceText . noLoc . fmap noLoc $ classMinimalDef cl) : + , tcdSigs = noLoc (MinimalSig noExtField NoSourceText . noLoc . fmap noLoc $ classMinimalDef cl) : [ noLoc tcdSig | clsOp <- classOpItems cl , tcdSig <- synifyTcIdSig vs clsOp ] @@ -129,18 +129,18 @@ tyThingToLHsDecl prr t = case t of , tcdDocs = [] --we don't have any docs at this point , tcdCExt = placeHolderNamesTc } | otherwise - -> synifyTyCon prr Nothing tc >>= allOK . TyClD noExt + -> synifyTyCon prr Nothing tc >>= allOK . TyClD noExtField -- type-constructors (e.g. Maybe) are complicated, put the definition -- later in the file (also it's used for class associated-types too.) ACoAxiom ax -> synifyAxiom ax >>= allOK -- a data-constructor alone just gets rendered as a function: - AConLike (RealDataCon dc) -> allOK $ SigD noExt (TypeSig noExt [synifyName dc] + AConLike (RealDataCon dc) -> allOK $ SigD noExtField (TypeSig noExtField [synifyName dc] (synifySigWcType ImplicitizeForAll [] (dataConUserType dc))) AConLike (PatSynCon ps) -> - allOK . SigD noExt $ PatSynSig noExt [synifyName ps] (synifyPatSynSigType ps) + allOK . SigD noExtField $ PatSynSig noExtField [synifyName ps] (synifyPatSynSigType ps) where withErrs e x = return (e, x) allOK x = return (mempty, x) @@ -154,7 +154,7 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) args_types_only typats hs_rhs = synifyType WithinType [] rhs in HsIB { hsib_ext = map tyVarName tkvs - , hsib_body = FamEqn { feqn_ext = noExt + , hsib_body = FamEqn { feqn_ext = noExtField , feqn_tycon = name , feqn_bndrs = Nothing -- TODO: this must change eventually @@ -168,13 +168,13 @@ synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl GhcRn) synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) | isOpenTypeFamilyTyCon tc , Just branch <- coAxiomSingleBranch_maybe ax - = return $ InstD noExt - $ TyFamInstD noExt + = return $ InstD noExtField + $ TyFamInstD noExtField $ TyFamInstDecl { tfid_eqn = synifyAxBranch tc branch } | Just ax' <- isClosedSynFamilyTyConWithAxiom_maybe tc , getUnique ax' == getUnique ax -- without the getUniques, type error - = synifyTyCon ShowRuntimeRep (Just ax) tc >>= return . TyClD noExt + = synifyTyCon ShowRuntimeRep (Just ax) tc >>= return . TyClD noExtField | otherwise = Left "synifyAxiom: closed/open family confusion" @@ -197,7 +197,7 @@ synifyTyCon prr _coax tc , tcdFixity = synifyFixity tc - , tcdDataDefn = HsDataDefn { dd_ext = noExt + , tcdDataDefn = HsDataDefn { dd_ext = noExtField , dd_ND = DataType -- arbitrary lie, they are neither -- algebraic data nor newtype: , dd_ctxt = noLoc [] @@ -210,8 +210,8 @@ synifyTyCon prr _coax tc where -- tyConTyVars doesn't work on fun/prim, but we can make them up: mk_hs_tv realKind fakeTyVar - | isLiftedTypeKind realKind = noLoc $ UserTyVar noExt (noLoc (getName fakeTyVar)) - | otherwise = noLoc $ KindedTyVar noExt (noLoc (getName fakeTyVar)) (synifyKindSig realKind) + | isLiftedTypeKind realKind = noLoc $ UserTyVar noExtField (noLoc (getName fakeTyVar)) + | otherwise = noLoc $ KindedTyVar noExtField (noLoc (getName fakeTyVar)) (synifyKindSig realKind) conKind = defaultType prr (tyConKind tc) tyVarKinds = fst . splitFunTys . snd . splitPiTysInvisible $ conKind @@ -235,8 +235,8 @@ synifyTyCon _prr _coax tc -> mkFamDecl DataFamily where resultVar = famTcResVar tc - mkFamDecl i = return $ FamDecl noExt $ - FamilyDecl { fdExt = noExt + mkFamDecl i = return $ FamDecl noExtField $ + FamilyDecl { fdExt = noExtField , fdInfo = i , fdLName = synifyName tc , fdTyVars = synifyTyVars (tyConVisibleTyVars tc) @@ -287,7 +287,7 @@ synifyTyCon _prr coax tc cons = rights consRaw -- "deriving" doesn't affect the signature, no need to specify any. alg_deriv = noLoc [] - defn = HsDataDefn { dd_ext = noExt + defn = HsDataDefn { dd_ext = noExtField , dd_ND = alg_nd , dd_ctxt = alg_ctx , dd_cType = Nothing @@ -332,10 +332,10 @@ synifyInjectivityAnn (Just lhs) tvs (Injective inj) = synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig GhcRn synifyFamilyResultSig Nothing kind - | isLiftedTypeKind kind = noLoc $ NoSig noExt - | otherwise = noLoc $ KindSig noExt (synifyKindSig kind) + | isLiftedTypeKind kind = noLoc $ NoSig noExtField + | otherwise = noLoc $ KindSig noExtField (synifyKindSig kind) synifyFamilyResultSig (Just name) kind = - noLoc $ TyVarSig noExt (noLoc $ KindedTyVar noExt (noLoc name) (synifyKindSig kind)) + noLoc $ TyVarSig noExtField (noLoc $ KindedTyVar noExtField (noLoc name) (synifyKindSig kind)) -- User beware: it is your responsibility to pass True (use_gadt_syntax) -- for any constructor that would be misrepresented by omitting its @@ -363,12 +363,12 @@ synifyDataCon use_gadt_syntax dc = let tySyn = synifyType WithinType [] ty in case bang of (HsSrcBang _ NoSrcUnpack NoSrcStrict) -> tySyn - bang' -> noLoc $ HsBangTy noExt bang' tySyn) + bang' -> noLoc $ HsBangTy noExtField bang' tySyn) arg_tys (dataConSrcBangs dc) field_tys = zipWith con_decl_field (dataConFieldLabels dc) linear_tys con_decl_field fl synTy = noLoc $ - ConDeclField noExt [noLoc $ FieldOcc (flSelector fl) (noLoc $ mkVarUnqual $ flLabel fl)] synTy + ConDeclField noExtField [noLoc $ FieldOcc (flSelector fl) (noLoc $ mkVarUnqual $ flLabel fl)] synTy Nothing hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of (True,True) -> Left "synifyDataCon: contradiction!" @@ -382,7 +382,7 @@ synifyDataCon use_gadt_syntax dc = \hat -> if use_gadt_syntax then return $ noLoc $ - ConDeclGADT { con_g_ext = noExt + ConDeclGADT { con_g_ext = noExtField , con_names = [name] , con_forall = noLoc $ not $ null user_tvs , con_qvars = synifyTyVars user_tvs @@ -391,7 +391,7 @@ synifyDataCon use_gadt_syntax dc = , con_res_ty = synifyType WithinType [] res_ty , con_doc = Nothing } else return $ noLoc $ - ConDeclH98 { con_ext = noExt + ConDeclH98 { con_ext = noExtField , con_name = name , con_forall = noLoc False , con_ex_tvs = map synifyTyVar ex_tvs @@ -415,7 +415,7 @@ synifyIdSig -> [TyVar] -- ^ free variables in the type to convert -> Id -- ^ the 'Id' from which to get the type signature -> Sig GhcRn -synifyIdSig prr s vs i = TypeSig noExt [synifyName i] (synifySigWcType s vs t) +synifyIdSig prr s vs i = TypeSig noExtField [synifyName i] (synifySigWcType s vs t) where t = defaultType prr (varType i) @@ -424,8 +424,8 @@ synifyIdSig prr s vs i = TypeSig noExt [synifyName i] (synifySigWcType s vs t) -- 'ClassOpSig'. synifyTcIdSig :: [TyVar] -> ClassOpItem -> [Sig GhcRn] synifyTcIdSig vs (i, dm) = - [ ClassOpSig noExt False [synifyName i] (mainSig (varType i)) ] ++ - [ ClassOpSig noExt True [noLoc dn] (defSig dt) + [ ClassOpSig noExtField False [synifyName i] (mainSig (varType i)) ] ++ + [ ClassOpSig noExtField True [noLoc dn] (defSig dt) | Just (dn, GenericDM dt) <- [dm] ] where mainSig t = synifySigType DeleteTopLevelQuantification vs t @@ -447,8 +447,8 @@ synifyTyVar = synifyTyVar' emptyVarSet synifyTyVar' :: VarSet -> TyVar -> LHsTyVarBndr GhcRn synifyTyVar' no_kinds tv | isLiftedTypeKind kind || tv `elemVarSet` no_kinds - = noLoc (UserTyVar noExt (noLoc name)) - | otherwise = noLoc (KindedTyVar noExt (noLoc name) (synifyKindSig kind)) + = noLoc (UserTyVar noExtField (noLoc name)) + | otherwise = noLoc (KindedTyVar noExtField (noLoc name) (synifyKindSig kind)) where kind = tyVarKind tv name = getName tv @@ -466,7 +466,7 @@ annotHsType True ty hs_ty | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty = let ki = typeKind ty hs_ki = synifyType WithinType [] ki - in noLoc (HsKindSig noExt hs_ty hs_ki) + in noLoc (HsKindSig noExtField hs_ty hs_ki) annotHsType _ _ hs_ty = hs_ty -- | For every type variable in the input, @@ -523,7 +523,7 @@ synifyType -> [TyVar] -- ^ free variables in the type to convert -> Type -- ^ the type to convert -> LHsType GhcRn -synifyType _ _ (TyVarTy tv) = noLoc $ HsTyVar noExt NotPromoted $ noLoc (getName tv) +synifyType _ _ (TyVarTy tv) = noLoc $ HsTyVar noExtField NotPromoted $ noLoc (getName tv) synifyType _ vs (TyConApp tc tys) = maybe_sig res_ty where @@ -533,62 +533,62 @@ synifyType _ vs (TyConApp tc tys) | tc `hasKey` tYPETyConKey , [TyConApp lev []] <- tys , lev `hasKey` liftedRepDataConKey - = noLoc (HsTyVar noExt NotPromoted (noLoc liftedTypeKindTyConName)) + = noLoc (HsTyVar noExtField NotPromoted (noLoc liftedTypeKindTyConName)) -- Use non-prefix tuple syntax where possible, because it looks nicer. | Just sort <- tyConTuple_maybe tc , tyConArity tc == tys_len - = noLoc $ HsTupleTy noExt + = noLoc $ HsTupleTy noExtField (case sort of BoxedTuple -> HsBoxedTuple ConstraintTuple -> HsConstraintTuple UnboxedTuple -> HsUnboxedTuple) (map (synifyType WithinType vs) vis_tys) - | isUnboxedSumTyCon tc = noLoc $ HsSumTy noExt (map (synifyType WithinType vs) vis_tys) + | isUnboxedSumTyCon tc = noLoc $ HsSumTy noExtField (map (synifyType WithinType vs) vis_tys) | Just dc <- isPromotedDataCon_maybe tc , isTupleDataCon dc , dataConSourceArity dc == length vis_tys - = noLoc $ HsExplicitTupleTy noExt (map (synifyType WithinType vs) vis_tys) + = noLoc $ HsExplicitTupleTy noExtField (map (synifyType WithinType vs) vis_tys) -- ditto for lists | getName tc == listTyConName, [ty] <- vis_tys = - noLoc $ HsListTy noExt (synifyType WithinType vs ty) + noLoc $ HsListTy noExtField (synifyType WithinType vs ty) | tc == promotedNilDataCon, [] <- vis_tys - = noLoc $ HsExplicitListTy noExt IsPromoted [] + = noLoc $ HsExplicitListTy noExtField IsPromoted [] | tc == promotedConsDataCon , [ty1, ty2] <- vis_tys = let hTy = synifyType WithinType vs ty1 in case synifyType WithinType vs ty2 of tTy | L _ (HsExplicitListTy _ IsPromoted tTy') <- stripKindSig tTy - -> noLoc $ HsExplicitListTy noExt IsPromoted (hTy : tTy') + -> noLoc $ HsExplicitListTy noExtField IsPromoted (hTy : tTy') | otherwise - -> noLoc $ HsOpTy noExt hTy (noLoc $ getName tc) tTy + -> noLoc $ HsOpTy noExtField hTy (noLoc $ getName tc) tTy -- ditto for implicit parameter tycons | tc `hasKey` ipClassKey , [name, ty] <- tys , Just x <- isStrLitTy name - = noLoc $ HsIParamTy noExt (noLoc $ HsIPName x) (synifyType WithinType vs ty) + = noLoc $ HsIParamTy noExtField (noLoc $ HsIPName x) (synifyType WithinType vs ty) -- and equalities | tc `hasKey` eqTyConKey , [ty1, ty2] <- tys - = noLoc $ HsOpTy noExt + = noLoc $ HsOpTy noExtField (synifyType WithinType vs ty1) (noLoc eqTyConName) (synifyType WithinType vs ty2) -- and infix type operators | isSymOcc (nameOccName (getName tc)) , ty1:ty2:tys_rest <- vis_tys - = mk_app_tys (HsOpTy noExt + = mk_app_tys (HsOpTy noExtField (synifyType WithinType vs ty1) (noLoc $ getName tc) (synifyType WithinType vs ty2)) tys_rest -- Most TyCons: | otherwise - = mk_app_tys (HsTyVar noExt prom $ noLoc (getName tc)) + = mk_app_tys (HsTyVar noExtField prom $ noLoc (getName tc)) vis_tys where prom = if isPromotedDataCon tc then IsPromoted else NotPromoted mk_app_tys ty_app ty_args = - foldl (\t1 t2 -> noLoc $ HsAppTy noExt t1 t2) + foldl (\t1 t2 -> noLoc $ HsAppTy noExtField t1 t2) (noLoc ty_app) (map (synifyType WithinType vs) $ filterOut isCoercionTy ty_args) @@ -601,23 +601,23 @@ synifyType _ vs (TyConApp tc tys) | tyConAppNeedsKindSig False tc tys_len = let full_kind = typeKind (mkTyConApp tc tys) full_kind' = synifyType WithinType vs full_kind - in noLoc $ HsKindSig noExt ty' full_kind' + in noLoc $ HsKindSig noExtField ty' full_kind' | otherwise = ty' synifyType s vs (AppTy t1 (CoercionTy {})) = synifyType s vs t1 synifyType _ vs (AppTy t1 t2) = let s1 = synifyType WithinType vs t1 s2 = synifyType WithinType vs t2 - in noLoc $ HsAppTy noExt s1 s2 + in noLoc $ HsAppTy noExtField s1 s2 synifyType s vs funty@(FunTy InvisArg _ _) = synifyForAllType s Inferred vs funty synifyType _ vs (FunTy VisArg t1 t2) = let s1 = synifyType WithinType vs t1 s2 = synifyType WithinType vs t2 - in noLoc $ HsFunTy noExt s1 s2 + in noLoc $ HsFunTy noExtField s1 s2 synifyType s vs forallty@(ForAllTy (Bndr _ argf) _ty) = synifyForAllType s argf vs forallty -synifyType _ _ (LitTy t) = noLoc $ HsTyLit noExt $ synifyTyLit t +synifyType _ _ (LitTy t) = noLoc $ HsTyLit noExtField $ synifyTyLit t synifyType s vs (CastTy t _) = synifyType s vs t synifyType _ _ (CoercionTy {}) = error "synifyType:Coercion" @@ -632,12 +632,12 @@ synifyForAllType synifyForAllType s argf vs ty = let (tvs, ctx, tau) = tcSplitSigmaTySameVisPreserveSynonyms argf ty sPhi = HsQualTy { hst_ctxt = synifyCtx ctx - , hst_xqual = noExt + , hst_xqual = noExtField , hst_body = synifyType WithinType (tvs' ++ vs) tau } sTy = HsForAllTy { hst_fvf = argToForallVisFlag argf , hst_bndrs = sTvs - , hst_xforall = noExt + , hst_xforall = noExtField , hst_body = noLoc sPhi } sTvs = map synifyTyVar tvs @@ -677,11 +677,11 @@ implicitForAll tycons vs tvs ctx synInner tau sPhi | null ctx = unLoc sRho | otherwise = HsQualTy { hst_ctxt = synifyCtx ctx - , hst_xqual = noExt + , hst_xqual = noExtField , hst_body = synInner (tvs' ++ vs) tau } sTy = HsForAllTy { hst_fvf = ForallInvis , hst_bndrs = sTvs - , hst_xforall = noExt + , hst_xforall = noExtField , hst_body = noLoc sPhi } no_kinds_needed = noKindTyVars tycons tau diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 1ed93b3c..b5613570 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -21,7 +21,7 @@ module Haddock.GhcUtils where import Control.Arrow import Data.Char ( isSpace ) -import Haddock.Types( DocNameI ) +import Haddock.Types( DocName, DocNameI ) import Exception import FV @@ -69,7 +69,7 @@ getMainDeclBinder _ = [] -- Extract the source location where an instance is defined. This is used -- to correlate InstDecls with their Instance/CoAxiom Names, via the -- instanceMap. -getInstLoc :: InstDecl name -> SrcSpan +getInstLoc :: InstDecl (GhcPass p) -> SrcSpan getInstLoc (ClsInstD _ (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty) getInstLoc (DataFamInstD _ (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}})) = l @@ -78,12 +78,12 @@ getInstLoc (TyFamInstD _ (TyFamInstDecl -- in particular, we need to dig a bit deeper to pull out the entire -- equation. This does not happen for data family instances, for some reason. { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = L l _ }}})) = l -getInstLoc (ClsInstD _ (XClsInstDecl _)) = panic "getInstLoc" -getInstLoc (DataFamInstD _ (DataFamInstDecl (HsIB _ (XFamEqn _)))) = panic "getInstLoc" -getInstLoc (TyFamInstD _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = panic "getInstLoc" -getInstLoc (XInstDecl _) = panic "getInstLoc" -getInstLoc (DataFamInstD _ (DataFamInstDecl (XHsImplicitBndrs _))) = panic "getInstLoc" -getInstLoc (TyFamInstD _ (TyFamInstDecl (XHsImplicitBndrs _))) = panic "getInstLoc" +getInstLoc (ClsInstD _ (XClsInstDecl nec)) = noExtCon nec +getInstLoc (DataFamInstD _ (DataFamInstDecl (HsIB _ (XFamEqn nec)))) = noExtCon nec +getInstLoc (TyFamInstD _ (TyFamInstDecl (HsIB _ (XFamEqn nec)))) = noExtCon nec +getInstLoc (XInstDecl nec) = noExtCon nec +getInstLoc (DataFamInstD _ (DataFamInstDecl (XHsImplicitBndrs nec))) = noExtCon nec +getInstLoc (TyFamInstD _ (TyFamInstDecl (XHsImplicitBndrs nec))) = noExtCon nec @@ -100,20 +100,20 @@ filterSigNames p orig@(InlineSig _ n _) = ifTrueJust (p $ unLoc n) orig filterSigNames p (FixSig _ (FixitySig _ ns ty)) = case filter (p . unLoc) ns of [] -> Nothing - filtered -> Just (FixSig noExt (FixitySig noExt filtered ty)) + filtered -> Just (FixSig noExtField (FixitySig noExtField filtered ty)) filterSigNames _ orig@(MinimalSig _ _ _) = Just orig filterSigNames p (TypeSig _ ns ty) = case filter (p . unLoc) ns of [] -> Nothing - filtered -> Just (TypeSig noExt filtered ty) + filtered -> Just (TypeSig noExtField filtered ty) filterSigNames p (ClassOpSig _ is_default ns ty) = case filter (p . unLoc) ns of [] -> Nothing - filtered -> Just (ClassOpSig noExt is_default filtered ty) + filtered -> Just (ClassOpSig noExtField is_default filtered ty) filterSigNames p (PatSynSig _ ns ty) = case filter (p . unLoc) ns of [] -> Nothing - filtered -> Just (PatSynSig noExt filtered ty) + filtered -> Just (PatSynSig noExtField filtered ty) filterSigNames _ _ = Nothing ifTrueJust :: Bool -> name -> Maybe name @@ -164,8 +164,28 @@ nubByName f ns = go emptyNameSet ns -- --------------------------------------------------------------------- --- This function is duplicated as getGADTConType and getGADTConTypeG, --- as I can't get the types to line up otherwise. AZ. +-- These functions are duplicated from the GHC API, as they must be +-- instantiated at DocNameI instead of (GhcPass _). + +hsTyVarNameI :: HsTyVarBndr DocNameI -> DocName +hsTyVarNameI (UserTyVar _ (L _ n)) = n +hsTyVarNameI (KindedTyVar _ (L _ n) _) = n +hsTyVarNameI (XTyVarBndr nec) = noExtCon nec + +hsLTyVarNameI :: LHsTyVarBndr DocNameI -> DocName +hsLTyVarNameI = hsTyVarNameI . unLoc + +getConNamesI :: ConDecl DocNameI -> [Located DocName] +getConNamesI ConDeclH98 {con_name = name} = [name] +getConNamesI ConDeclGADT {con_names = names} = names +getConNamesI (XConDecl nec) = noExtCon nec + +hsImplicitBodyI :: HsImplicitBndrs DocNameI thing -> thing +hsImplicitBodyI (HsIB { hsib_body = body }) = body +hsImplicitBodyI (XHsImplicitBndrs nec) = noExtCon nec + +hsSigTypeI :: LHsSigType DocNameI -> LHsType DocNameI +hsSigTypeI = hsImplicitBodyI getGADTConType :: ConDecl DocNameI -> LHsType DocNameI -- The full type of a GADT data constructor We really only get this in @@ -177,26 +197,26 @@ getGADTConType (ConDeclGADT { con_forall = L _ has_forall , con_mb_cxt = mcxt, con_args = args , con_res_ty = res_ty }) | has_forall = noLoc (HsForAllTy { hst_fvf = ForallInvis - , hst_xforall = NoExt + , hst_xforall = noExtField , hst_bndrs = hsQTvExplicit qtvs , hst_body = theta_ty }) | otherwise = theta_ty where theta_ty | Just theta <- mcxt - = noLoc (HsQualTy { hst_xqual = NoExt, hst_ctxt = theta, hst_body = tau_ty }) + = noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty }) | otherwise = tau_ty tau_ty = case args of - RecCon flds -> noLoc (HsFunTy noExt (noLoc (HsRecTy noExt (unLoc flds))) res_ty) + RecCon flds -> noLoc (HsFunTy noExtField (noLoc (HsRecTy noExtField (unLoc flds))) res_ty) PrefixCon pos_args -> foldr mkFunTy res_ty pos_args InfixCon arg1 arg2 -> arg1 `mkFunTy` (arg2 `mkFunTy` res_ty) - mkFunTy a b = noLoc (HsFunTy noExt a b) + mkFunTy a b = noLoc (HsFunTy noExtField a b) getGADTConType (ConDeclH98 {}) = panic "getGADTConType" -- Should only be called on ConDeclGADT -getGADTConType (XConDecl {}) = panic "getGADTConType" +getGADTConType (XConDecl nec) = noExtCon nec -- ------------------------------------- @@ -210,26 +230,26 @@ getGADTConTypeG (ConDeclGADT { con_forall = L _ has_forall , con_mb_cxt = mcxt, con_args = args , con_res_ty = res_ty }) | has_forall = noLoc (HsForAllTy { hst_fvf = ForallInvis - , hst_xforall = NoExt + , hst_xforall = noExtField , hst_bndrs = hsQTvExplicit qtvs , hst_body = theta_ty }) | otherwise = theta_ty where theta_ty | Just theta <- mcxt - = noLoc (HsQualTy { hst_xqual = NoExt, hst_ctxt = theta, hst_body = tau_ty }) + = noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty }) | otherwise = tau_ty tau_ty = case args of - RecCon flds -> noLoc (HsFunTy noExt (noLoc (HsRecTy noExt (unLoc flds))) res_ty) + RecCon flds -> noLoc (HsFunTy noExtField (noLoc (HsRecTy noExtField (unLoc flds))) res_ty) PrefixCon pos_args -> foldr mkFunTy res_ty pos_args InfixCon arg1 arg2 -> arg1 `mkFunTy` (arg2 `mkFunTy` res_ty) - mkFunTy a b = noLoc (HsFunTy noExt a b) + mkFunTy a b = noLoc (HsFunTy noExtField a b) getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConTypeG" -- Should only be called on ConDeclGADT -getGADTConTypeG (XConDecl {}) = panic "getGADTConTypeG" +getGADTConTypeG (XConDecl nec) = noExtCon nec ------------------------------------------------------------------------------- @@ -257,12 +277,12 @@ data Precedence -- -- We cannot add parens that may be required by fixities because we do not have -- any fixity information to work with in the first place :(. -reparenTypePrec :: (XParTy a ~ NoExt) => Precedence -> HsType a -> HsType a +reparenTypePrec :: (XParTy a ~ NoExtField) => Precedence -> HsType a -> HsType a reparenTypePrec = go where -- Shorter name for 'reparenType' - go :: (XParTy a ~ NoExt) => Precedence -> HsType a -> HsType a + go :: (XParTy a ~ NoExtField) => Precedence -> HsType a -> HsType a go _ (HsBangTy x b ty) = HsBangTy x b (reparenLType ty) go _ (HsTupleTy x con tys) = HsTupleTy x con (map reparenLType tys) go _ (HsSumTy x tys) = HsSumTy x (map reparenLType tys) @@ -295,34 +315,34 @@ reparenTypePrec = go go _ t@XHsType{} = t -- Located variant of 'go' - goL :: (XParTy a ~ NoExt) => Precedence -> LHsType a -> LHsType a + goL :: (XParTy a ~ NoExtField) => Precedence -> LHsType a -> LHsType a goL ctxt_prec = fmap (go ctxt_prec) -- Optionally wrap a type in parens - paren :: (XParTy a ~ NoExt) + paren :: (XParTy a ~ NoExtField) => Precedence -- Precedence of context -> Precedence -- Precedence of top-level operator -> HsType a -> HsType a -- Wrap in parens if (ctxt >= op) - paren ctxt_prec op_prec | ctxt_prec >= op_prec = HsParTy NoExt . noLoc + paren ctxt_prec op_prec | ctxt_prec >= op_prec = HsParTy noExtField . noLoc | otherwise = id -- | Add parenthesis around the types in a 'HsType' (see 'reparenTypePrec') -reparenType :: (XParTy a ~ NoExt) => HsType a -> HsType a +reparenType :: (XParTy a ~ NoExtField) => HsType a -> HsType a reparenType = reparenTypePrec PREC_TOP -- | Add parenthesis around the types in a 'LHsType' (see 'reparenTypePrec') -reparenLType :: (XParTy a ~ NoExt) => LHsType a -> LHsType a +reparenLType :: (XParTy a ~ NoExtField) => LHsType a -> LHsType a reparenLType = fmap reparenType -- | Add parenthesis around the types in a 'HsTyVarBndr' (see 'reparenTypePrec') -reparenTyVar :: (XParTy a ~ NoExt) => HsTyVarBndr a -> HsTyVarBndr a +reparenTyVar :: (XParTy a ~ NoExtField) => HsTyVarBndr a -> HsTyVarBndr a reparenTyVar (UserTyVar x n) = UserTyVar x n reparenTyVar (KindedTyVar x n kind) = KindedTyVar x n (reparenLType kind) reparenTyVar v@XTyVarBndr{} = v -- | Add parenthesis around the types in a 'ConDeclField' (see 'reparenTypePrec') -reparenConDeclField :: (XParTy a ~ NoExt) => ConDeclField a -> ConDeclField a +reparenConDeclField :: (XParTy a ~ NoExtField) => ConDeclField a -> ConDeclField a reparenConDeclField (ConDeclField x n t d) = ConDeclField x n (reparenLType t) d reparenConDeclField c@XConDeclField{} = c @@ -564,7 +584,7 @@ tryCppLine !loc !buf = spanSpace (S.prevChar buf '\n' == '\n') loc buf -- | Get free type variables in a 'Type' in their order of appearance. -- See [Ordering of implicit variables]. orderedFVs - :: VarSet -- ^ free variables to ignore + :: VarSet -- ^ free variables to ignore -> [Type] -- ^ types to traverse (in order) looking for free variables -> [TyVar] -- ^ free type variables, in the order they appear in orderedFVs vs tys = @@ -578,7 +598,7 @@ orderedFVs vs tys = -- For example, 'tyCoVarsOfTypeList' reports an incorrect order for the type -- of 'const :: a -> b -> a': -- --- >>> import Name +-- >>> import Name -- >>> import TyCoRep -- >>> import TysPrim -- >>> import Var diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index f17f3d7f..361c91de 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -526,10 +526,10 @@ classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])] classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls where decls = docs ++ defs ++ sigs ++ ats - docs = mkDecls tcdDocs (DocD noExt) class_ - defs = mkDecls (bagToList . tcdMeths) (ValD noExt) class_ - sigs = mkDecls tcdSigs (SigD noExt) class_ - ats = mkDecls tcdATs (TyClD noExt . FamDecl noExt) class_ + docs = mkDecls tcdDocs (DocD noExtField) class_ + defs = mkDecls (bagToList . tcdMeths) (ValD noExtField) class_ + sigs = mkDecls tcdSigs (SigD noExtField) class_ + ats = mkDecls tcdATs (TyClD noExtField . FamDecl noExtField) class_ -- | The top-level declarations of a module that we care about, @@ -548,14 +548,14 @@ mkFixMap group_ = M.fromList [ (n,f) -- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn] ungroup group_ = - mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExt) group_ ++ - mkDecls hs_derivds (DerivD noExt) group_ ++ - mkDecls hs_defds (DefD noExt) group_ ++ - mkDecls hs_fords (ForD noExt) group_ ++ - mkDecls hs_docs (DocD noExt) group_ ++ - mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExt) group_ ++ - mkDecls (typesigs . hs_valds) (SigD noExt) group_ ++ - mkDecls (valbinds . hs_valds) (ValD noExt) group_ + mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExtField) group_ ++ + mkDecls hs_derivds (DerivD noExtField) group_ ++ + mkDecls hs_defds (DefD noExtField) group_ ++ + mkDecls hs_fords (ForD noExtField) group_ ++ + mkDecls hs_docs (DocD noExtField) group_ ++ + mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExtField) group_ ++ + mkDecls (typesigs . hs_valds) (SigD noExtField) group_ ++ + mkDecls (valbinds . hs_valds) (ValD noExtField) group_ where typesigs (XValBindsLR (NValBinds _ sigs)) = filter isUserLSig sigs typesigs _ = error "expected ValBindsOut" @@ -747,14 +747,14 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames L loc (SigD _ sig) -> -- fromJust is safe since we already checked in guards -- that 't' is a name declared in this declaration. - let newDecl = L loc . SigD noExt . fromJust $ filterSigNames (== t) sig + let newDecl = L loc . SigD noExtField . fromJust $ filterSigNames (== t) sig in availExportDecl avail newDecl docs_ L loc (TyClD _ cl@ClassDecl{}) -> do mdef <- liftGhcToErrMsgGhc $ minimalDef t - let sig = maybeToList $ fmap (noLoc . MinimalSig noExt NoSourceText . noLoc . fmap noLoc) mdef + let sig = maybeToList $ fmap (noLoc . MinimalSig noExtField NoSourceText . noLoc . fmap noLoc) mdef availExportDecl avail - (L loc $ TyClD noExt cl { tcdSigs = sig ++ tcdSigs cl }) docs_ + (L loc $ TyClD noExtField cl { tcdSigs = sig ++ tcdSigs cl }) docs_ _ -> availExportDecl avail decl docs_ @@ -1068,8 +1068,8 @@ extractDecl declMap name decl 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 noExt sig) - (_, [L pos fam_decl]) -> L pos (TyClD noExt (FamDecl noExt fam_decl)) + in L pos (SigD noExtField sig) + (_, [L pos fam_decl]) -> L pos (TyClD noExtField (FamDecl noExtField fam_decl)) ([], []) | Just (famInstDecl:_) <- M.lookup name declMap @@ -1081,8 +1081,8 @@ extractDecl declMap name decl TyClD _ d@DataDecl {} -> let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d)) in if isDataConName name - then SigD noExt <$> extractPatternSyn name n (map HsValArg tyvar_tys) (dd_cons (tcdDataDefn d)) - else SigD noExt <$> extractRecSel name n (map HsValArg tyvar_tys) (dd_cons (tcdDataDefn d)) + then SigD noExtField <$> extractPatternSyn name n (map HsValArg tyvar_tys) (dd_cons (tcdDataDefn d)) + else SigD noExtField <$> extractRecSel name n (map HsValArg tyvar_tys) (dd_cons (tcdDataDefn d)) TyClD _ FamDecl {} | isValName name , Just (famInst:_) <- M.lookup name declMap @@ -1092,8 +1092,8 @@ extractDecl declMap name decl , feqn_pats = tys , feqn_rhs = defn }}))) -> if isDataConName name - then SigD noExt <$> extractPatternSyn name n tys (dd_cons defn) - else SigD noExt <$> extractRecSel name n tys (dd_cons defn) + then SigD noExtField <$> extractPatternSyn name n tys (dd_cons defn) + else SigD noExtField <$> extractRecSel name n tys (dd_cons defn) InstD _ (ClsInstD _ ClsInstDecl { cid_datafam_insts = insts }) | isDataConName name -> let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = @@ -1103,7 +1103,7 @@ extractDecl declMap name decl , name `elem` map unLoc (concatMap (getConNames . unLoc) (dd_cons dd)) ] in case matches of - [d0] -> extractDecl declMap name (noLoc (InstD noExt (DataFamInstD noExt d0))) + [d0] -> extractDecl declMap name (noLoc (InstD noExtField (DataFamInstD noExtField d0))) _ -> error "internal: extractDecl (ClsInstD)" | otherwise -> let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d })) @@ -1115,7 +1115,7 @@ extractDecl declMap name decl , extFieldOcc n == name ] in case matches of - [d0] -> extractDecl declMap name (noLoc . InstD noExt $ DataFamInstD noExt d0) + [d0] -> extractDecl declMap name (noLoc . InstD noExtField $ DataFamInstD noExtField d0) _ -> error "internal: extractDecl (ClsInstD)" _ -> O.pprPanic "extractDecl" $ O.text "Unhandled decl for" O.<+> O.ppr name O.<> O.text ":" @@ -1139,21 +1139,21 @@ extractPatternSyn nm t tvs cons = typ = longArrow args (data_ty con) typ' = case con of - ConDeclH98 { con_mb_cxt = Just cxt } -> noLoc (HsQualTy noExt cxt typ) + ConDeclH98 { con_mb_cxt = Just cxt } -> noLoc (HsQualTy noExtField cxt typ) _ -> typ - typ'' = noLoc (HsQualTy noExt (noLoc []) typ') - in PatSynSig noExt [noLoc nm] (mkEmptyImplicitBndrs typ'') + typ'' = noLoc (HsQualTy noExtField (noLoc []) typ') + in PatSynSig noExtField [noLoc nm] (mkEmptyImplicitBndrs typ'') longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn - longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExt x y)) output inputs + longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField x y)) output inputs data_ty con | ConDeclGADT{} <- con = con_res_ty con - | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs + | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExtField NotPromoted (noLoc t))) tvs where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn - mkAppTyArg f (HsValArg ty) = HsAppTy noExt f ty + mkAppTyArg f (HsValArg ty) = HsAppTy noExtField f ty mkAppTyArg f (HsTypeArg l ki) = HsAppKindTy l f ki - mkAppTyArg f (HsArgPar _) = HsParTy noExt f + mkAppTyArg f (HsArgPar _) = HsParTy noExtField f extractRecSel :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn @@ -1162,7 +1162,7 @@ extractRecSel _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm t tvs (L _ con : rest) = case getConArgs con of RecCon (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields -> - L l (TypeSig noExt [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExt data_ty (getBangType ty))))) + L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField data_ty (getBangType ty))))) _ -> extractRecSel nm t tvs rest where matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)] @@ -1171,11 +1171,11 @@ extractRecSel nm t tvs (L _ con : rest) = data_ty -- ResTyGADT _ ty <- con_res con = ty | ConDeclGADT{} <- con = con_res_ty con - | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs + | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExtField NotPromoted (noLoc t))) tvs where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn - mkAppTyArg f (HsValArg ty) = HsAppTy noExt f ty + mkAppTyArg f (HsValArg ty) = HsAppTy noExtField f ty mkAppTyArg f (HsTypeArg l ki) = HsAppKindTy l f ki - mkAppTyArg f (HsArgPar _) = HsParTy noExt f + mkAppTyArg f (HsArgPar _) = HsParTy noExtField f -- | Keep export items with docs. pruneExportItems :: [ExportItem GhcRn] -> [ExportItem GhcRn] diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 70a608ee..5b96c0a0 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -204,14 +204,14 @@ renameMaybeLKind = traverse renameLKind renameFamilyResultSig :: LFamilyResultSig GhcRn -> RnM (LFamilyResultSig DocNameI) renameFamilyResultSig (L loc (NoSig _)) - = return (L loc (NoSig noExt)) + = return (L loc (NoSig noExtField)) renameFamilyResultSig (L loc (KindSig _ ki)) = do { ki' <- renameLKind ki - ; return (L loc (KindSig noExt ki')) } + ; return (L loc (KindSig noExtField ki')) } renameFamilyResultSig (L loc (TyVarSig _ bndr)) = do { bndr' <- renameLTyVarBndr bndr - ; return (L loc (TyVarSig noExt bndr')) } -renameFamilyResultSig (L _ (XFamilyResultSig _)) = panic "haddock:renameFamilyResultSig" + ; return (L loc (TyVarSig noExtField bndr')) } +renameFamilyResultSig (L _ (XFamilyResultSig nec)) = noExtCon nec renameInjectivityAnn :: LInjectivityAnn GhcRn -> RnM (LInjectivityAnn DocNameI) renameInjectivityAnn (L loc (InjectivityAnn lhs rhs)) @@ -228,61 +228,61 @@ renameType t = case t of HsForAllTy { hst_fvf = fvf, hst_bndrs = tyvars, hst_body = ltype } -> do tyvars' <- mapM renameLTyVarBndr tyvars ltype' <- renameLType ltype - return (HsForAllTy { hst_fvf = fvf, hst_xforall = NoExt + return (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField , hst_bndrs = tyvars', hst_body = ltype' }) HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do lcontext' <- renameLContext lcontext ltype' <- renameLType ltype - return (HsQualTy { hst_xqual = NoExt, hst_ctxt = lcontext', hst_body = ltype' }) + return (HsQualTy { hst_xqual = noExtField, hst_ctxt = lcontext', hst_body = ltype' }) - HsTyVar _ ip (L l n) -> return . HsTyVar NoExt ip . L l =<< rename n - HsBangTy _ b ltype -> return . HsBangTy NoExt b =<< renameLType ltype + HsTyVar _ ip (L l n) -> return . HsTyVar noExtField ip . L l =<< rename n + HsBangTy _ b ltype -> return . HsBangTy noExtField b =<< renameLType ltype - HsStarTy _ isUni -> return (HsStarTy NoExt isUni) + HsStarTy _ isUni -> return (HsStarTy noExtField isUni) HsAppTy _ a b -> do a' <- renameLType a b' <- renameLType b - return (HsAppTy NoExt a' b') + return (HsAppTy noExtField a' b') HsAppKindTy _ a b -> do a' <- renameLType a b' <- renameLKind b - return (HsAppKindTy NoExt a' b') + return (HsAppKindTy noExtField a' b') HsFunTy _ a b -> do a' <- renameLType a b' <- renameLType b - return (HsFunTy NoExt a' b') + return (HsFunTy noExtField a' b') - HsListTy _ ty -> return . (HsListTy NoExt) =<< renameLType ty - HsIParamTy _ n ty -> liftM (HsIParamTy NoExt n) (renameLType ty) + HsListTy _ ty -> return . (HsListTy noExtField) =<< renameLType ty + HsIParamTy _ n ty -> liftM (HsIParamTy noExtField n) (renameLType ty) - HsTupleTy _ b ts -> return . HsTupleTy NoExt b =<< mapM renameLType ts - HsSumTy _ ts -> HsSumTy NoExt <$> mapM renameLType ts + HsTupleTy _ b ts -> return . HsTupleTy noExtField b =<< mapM renameLType ts + HsSumTy _ ts -> HsSumTy noExtField <$> mapM renameLType ts HsOpTy _ a (L loc op) b -> do op' <- rename op a' <- renameLType a b' <- renameLType b - return (HsOpTy NoExt a' (L loc op') b') + return (HsOpTy noExtField a' (L loc op') b') - HsParTy _ ty -> return . (HsParTy NoExt) =<< renameLType ty + HsParTy _ ty -> return . (HsParTy noExtField) =<< renameLType ty HsKindSig _ ty k -> do ty' <- renameLType ty k' <- renameLKind k - return (HsKindSig NoExt ty' k') + return (HsKindSig noExtField ty' k') HsDocTy _ ty doc -> do ty' <- renameLType ty doc' <- renameLDocHsSyn doc - return (HsDocTy NoExt ty' doc') + return (HsDocTy noExtField ty' doc') - HsTyLit _ x -> return (HsTyLit NoExt x) + HsTyLit _ x -> return (HsTyLit noExtField x) - HsRecTy _ a -> HsRecTy NoExt <$> mapM renameConDeclFieldField a + HsRecTy _ a -> HsRecTy noExtField <$> mapM renameConDeclFieldField a (XHsType (NHsCoreTy a)) -> pure (XHsType (NHsCoreTy a)) HsExplicitListTy i a b -> HsExplicitListTy i a <$> mapM renameLType b HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b @@ -303,9 +303,9 @@ renameHsSpliceTy _ = error "renameHsSpliceTy: not an HsSpliced" renameLHsQTyVars :: LHsQTyVars GhcRn -> RnM (LHsQTyVars DocNameI) renameLHsQTyVars (HsQTvs { hsq_explicit = tvs }) = do { tvs' <- mapM renameLTyVarBndr tvs - ; return (HsQTvs { hsq_ext = noExt + ; return (HsQTvs { hsq_ext = noExtField , hsq_explicit = tvs' }) } -renameLHsQTyVars (XLHsQTyVars _) = panic "haddock:renameLHsQTyVars" +renameLHsQTyVars (XLHsQTyVars nec) = noExtCon nec renameLTyVarBndr :: LHsTyVarBndr GhcRn -> RnM (LHsTyVarBndr DocNameI) renameLTyVarBndr (L loc (UserTyVar x (L l n))) @@ -353,19 +353,19 @@ renameDecl :: HsDecl GhcRn -> RnM (HsDecl DocNameI) renameDecl decl = case decl of TyClD _ d -> do d' <- renameTyClD d - return (TyClD noExt d') + return (TyClD noExtField d') SigD _ s -> do s' <- renameSig s - return (SigD noExt s') + return (SigD noExtField s') ForD _ d -> do d' <- renameForD d - return (ForD noExt d') + return (ForD noExtField d') InstD _ d -> do d' <- renameInstD d - return (InstD noExt d') + return (InstD noExtField d') DerivD _ d -> do d' <- renameDerivD d - return (DerivD noExt d') + return (DerivD noExtField d') _ -> error "renameDecl" renameLThing :: (a GhcRn -> RnM (a DocNameI)) -> Located (a GhcRn) -> RnM (Located (a DocNameI)) @@ -376,20 +376,20 @@ renameTyClD d = case d of -- TyFamily flav lname ltyvars kind tckind -> do FamDecl { tcdFam = decl } -> do decl' <- renameFamilyDecl decl - return (FamDecl { tcdFExt = noExt, tcdFam = decl' }) + return (FamDecl { tcdFExt = noExtField, tcdFam = decl' }) SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdRhs = rhs } -> do lname' <- renameL lname tyvars' <- renameLHsQTyVars tyvars rhs' <- renameLType rhs - return (SynDecl { tcdSExt = noExt, tcdLName = lname', tcdTyVars = tyvars' + return (SynDecl { tcdSExt = noExtField, tcdLName = lname', tcdTyVars = tyvars' , tcdFixity = fixity, tcdRhs = rhs' }) DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn } -> do lname' <- renameL lname tyvars' <- renameLHsQTyVars tyvars defn' <- renameDataDefn defn - return (DataDecl { tcdDExt = noExt, tcdLName = lname', tcdTyVars = tyvars' + return (DataDecl { tcdDExt = noExtField, tcdLName = lname', tcdTyVars = tyvars' , tcdFixity = fixity, tcdDataDefn = defn' }) ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars, tcdFixity = fixity @@ -405,8 +405,8 @@ renameTyClD d = case d of return (ClassDecl { tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars' , tcdFixity = fixity , tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag - , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdCExt = NoExt }) - XTyClDecl _ -> panic "haddock:renameTyClD" + , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdCExt = noExtField }) + XTyClDecl nec -> noExtCon nec where renameLFunDep (L loc (xs, ys)) = do @@ -427,12 +427,12 @@ renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname ltyvars' <- renameLHsQTyVars ltyvars result' <- renameFamilyResultSig result injectivity' <- renameMaybeInjectivityAnn injectivity - return (FamilyDecl { fdExt = noExt, fdInfo = info', fdLName = lname' + return (FamilyDecl { fdExt = noExtField, fdInfo = info', fdLName = lname' , fdTyVars = ltyvars' , fdFixity = fixity , fdResultSig = result' , fdInjectivityAnn = injectivity' }) -renameFamilyDecl (XFamilyDecl _) = panic "renameFamilyDecl" +renameFamilyDecl (XFamilyDecl nec) = noExtCon nec renamePseudoFamilyDecl :: PseudoFamilyDecl GhcRn @@ -458,11 +458,11 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType k' <- renameMaybeLKind k cons' <- mapM (mapM renameCon) cons -- I don't think we need the derivings, so we return Nothing - return (HsDataDefn { dd_ext = noExt + return (HsDataDefn { dd_ext = noExtField , dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType , dd_kindSig = k', dd_cons = cons' , dd_derivs = noLoc [] }) -renameDataDefn (XHsDataDefn _) = panic "haddock:renameDataDefn" +renameDataDefn (XHsDataDefn nec) = noExtCon nec renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI) renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars @@ -473,7 +473,7 @@ renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars lcontext' <- traverse renameLContext lcontext details' <- renameDetails details mbldoc' <- mapM renameLDocHsSyn mbldoc - return (decl { con_ext = noExt, con_name = lname', con_ex_tvs = ltyvars' + return (decl { con_ext = noExtField, con_name = lname', con_ex_tvs = ltyvars' , con_mb_cxt = lcontext' , con_args = details', con_doc = mbldoc' }) @@ -487,10 +487,10 @@ renameCon decl@(ConDeclGADT { con_names = lnames, con_qvars = ltyvars details' <- renameDetails details res_ty' <- renameLType res_ty mbldoc' <- mapM renameLDocHsSyn mbldoc - return (decl { con_g_ext = noExt, con_names = lnames', con_qvars = ltyvars' + return (decl { con_g_ext = noExtField, con_names = lnames', con_qvars = ltyvars' , con_mb_cxt = lcontext', con_args = details' , con_res_ty = res_ty', con_doc = mbldoc' }) -renameCon (XConDecl _) = panic "haddock:renameCon" +renameCon (XConDecl nec) = noExtCon nec renameDetails :: HsConDeclDetails GhcRn -> RnM (HsConDeclDetails DocNameI) renameDetails (RecCon (L l fields)) = do @@ -507,8 +507,8 @@ renameConDeclFieldField (L l (ConDeclField _ names t doc)) = do names' <- mapM renameLFieldOcc names t' <- renameLType t doc' <- mapM renameLDocHsSyn doc - return $ L l (ConDeclField noExt names' t' doc') -renameConDeclFieldField (L _ (XConDeclField _)) = panic "haddock:renameConDeclFieldField" + return $ L l (ConDeclField noExtField names' t' doc') +renameConDeclFieldField (L _ (XConDeclField nec)) = noExtCon nec renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI) renameLFieldOcc (L l (FieldOcc sel lbl)) = do @@ -521,21 +521,21 @@ renameSig sig = case sig of TypeSig _ lnames ltype -> do lnames' <- mapM renameL lnames ltype' <- renameLSigWcType ltype - return (TypeSig noExt lnames' ltype') + return (TypeSig noExtField lnames' ltype') ClassOpSig _ is_default lnames sig_ty -> do lnames' <- mapM renameL lnames ltype' <- renameLSigType sig_ty - return (ClassOpSig noExt is_default lnames' ltype') + return (ClassOpSig noExtField is_default lnames' ltype') PatSynSig _ lnames sig_ty -> do lnames' <- mapM renameL lnames sig_ty' <- renameLSigType sig_ty - return $ PatSynSig noExt lnames' sig_ty' + return $ PatSynSig noExtField lnames' sig_ty' FixSig _ (FixitySig _ lnames fixity) -> do lnames' <- mapM renameL lnames - return $ FixSig noExt (FixitySig noExt lnames' fixity) + return $ FixSig noExtField (FixitySig noExtField lnames' fixity) MinimalSig _ src (L l s) -> do s' <- traverse renameL s - return $ MinimalSig noExt src (L l s') + return $ MinimalSig noExtField src (L l s') -- we have filtered out all other kinds of signatures in Interface.Create _ -> error "expected TypeSig" @@ -544,25 +544,25 @@ renameForD :: ForeignDecl GhcRn -> RnM (ForeignDecl DocNameI) renameForD (ForeignImport _ lname ltype x) = do lname' <- renameL lname ltype' <- renameLSigType ltype - return (ForeignImport noExt lname' ltype' x) + return (ForeignImport noExtField lname' ltype' x) renameForD (ForeignExport _ lname ltype x) = do lname' <- renameL lname ltype' <- renameLSigType ltype - return (ForeignExport noExt lname' ltype' x) -renameForD (XForeignDecl _) = panic "haddock:renameForD" + return (ForeignExport noExtField lname' ltype' x) +renameForD (XForeignDecl nec) = noExtCon nec renameInstD :: InstDecl GhcRn -> RnM (InstDecl DocNameI) renameInstD (ClsInstD { cid_inst = d }) = do d' <- renameClsInstD d - return (ClsInstD { cid_d_ext = noExt, cid_inst = d' }) + return (ClsInstD { cid_d_ext = noExtField, cid_inst = d' }) renameInstD (TyFamInstD { tfid_inst = d }) = do d' <- renameTyFamInstD d - return (TyFamInstD { tfid_ext = noExt, tfid_inst = d' }) + return (TyFamInstD { tfid_ext = noExtField, tfid_inst = d' }) renameInstD (DataFamInstD { dfid_inst = d }) = do d' <- renameDataFamInstD d - return (DataFamInstD { dfid_ext = noExt, dfid_inst = d' }) -renameInstD (XInstDecl _) = panic "haddock:renameInstD" + return (DataFamInstD { dfid_ext = noExtField, dfid_inst = d' }) +renameInstD (XInstDecl nec) = noExtCon nec renameDerivD :: DerivDecl GhcRn -> RnM (DerivDecl DocNameI) renameDerivD (DerivDecl { deriv_type = ty @@ -570,11 +570,11 @@ renameDerivD (DerivDecl { deriv_type = ty , deriv_overlap_mode = omode }) = do ty' <- renameLSigWcType ty strat' <- mapM (mapM renameDerivStrategy) strat - return (DerivDecl { deriv_ext = noExt + return (DerivDecl { deriv_ext = noExtField , deriv_type = ty' , deriv_strategy = strat' , deriv_overlap_mode = omode }) -renameDerivD (XDerivDecl _) = panic "haddock:renameDerivD" +renameDerivD (XDerivDecl nec) = noExtCon nec renameDerivStrategy :: DerivStrategy GhcRn -> RnM (DerivStrategy DocNameI) renameDerivStrategy StockStrategy = pure StockStrategy @@ -589,11 +589,11 @@ renameClsInstD (ClsInstDecl { cid_overlap_mode = omode ltype' <- renameLSigType ltype lATs' <- mapM (mapM renameTyFamInstD) lATs lADTs' <- mapM (mapM renameDataFamInstD) lADTs - return (ClsInstDecl { cid_ext = noExt, cid_overlap_mode = omode + return (ClsInstDecl { cid_ext = noExtField, cid_overlap_mode = omode , cid_poly_ty = ltype', cid_binds = emptyBag , cid_sigs = [] , cid_tyfam_insts = lATs', cid_datafam_insts = lADTs' }) -renameClsInstD (XClsInstDecl _) = panic "haddock:renameClsInstD" +renameClsInstD (XClsInstDecl nec) = noExtCon nec renameTyFamInstD :: TyFamInstDecl GhcRn -> RnM (TyFamInstDecl DocNameI) @@ -615,13 +615,13 @@ renameTyFamInstEqn eqn ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs ; pats' <- mapM renameLTypeArg pats ; rhs' <- renameLType rhs - ; return (FamEqn { feqn_ext = noExt + ; return (FamEqn { feqn_ext = noExtField , feqn_tycon = tc' , feqn_bndrs = bndrs' , feqn_pats = pats' , feqn_fixity = fixity , feqn_rhs = rhs' }) } - rename_ty_fam_eqn (XFamEqn _) = panic "haddock:renameTyFamInstEqn" + rename_ty_fam_eqn (XFamEqn nec) = noExtCon nec renameTyFamDefltD :: TyFamDefltDecl GhcRn -> RnM (TyFamDefltDecl DocNameI) renameTyFamDefltD = renameTyFamInstD @@ -641,13 +641,13 @@ renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn }) ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs ; pats' <- mapM renameLTypeArg pats ; defn' <- renameDataDefn defn - ; return (FamEqn { feqn_ext = noExt + ; return (FamEqn { feqn_ext = noExtField , feqn_tycon = tc' , feqn_bndrs = bndrs' , feqn_pats = pats' , feqn_fixity = fixity , feqn_rhs = defn' }) } - rename_data_fam_eqn (XFamEqn _) = panic "haddock:renameDataFamInstD" + rename_data_fam_eqn (XFamEqn nec) = noExtCon nec renameImplicit :: (in_thing -> RnM out_thing) -> HsImplicitBndrs GhcRn in_thing @@ -655,8 +655,8 @@ renameImplicit :: (in_thing -> RnM out_thing) renameImplicit rn_thing (HsIB { hsib_body = thing }) = do { thing' <- rn_thing thing ; return (HsIB { hsib_body = thing' - , hsib_ext = noExt }) } -renameImplicit _ (XHsImplicitBndrs _) = panic "haddock:renameImplicit" + , hsib_ext = noExtField }) } +renameImplicit _ (XHsImplicitBndrs nec) = noExtCon nec renameWc :: (in_thing -> RnM out_thing) -> HsWildCardBndrs GhcRn in_thing @@ -664,8 +664,8 @@ renameWc :: (in_thing -> RnM out_thing) renameWc rn_thing (HsWC { hswc_body = thing }) = do { thing' <- rn_thing thing ; return (HsWC { hswc_body = thing' - , hswc_ext = noExt }) } -renameWc _ (XHsWildCardBndrs _) = panic "haddock:renameWc" + , hswc_ext = noExtField }) } +renameWc _ (XHsWildCardBndrs nec) = noExtCon nec renameDocInstance :: DocInstance GhcRn -> RnM (DocInstance DocNameI) renameDocInstance (inst, idoc, L l n, m) = do diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index e2908af4..03cc1b7e 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -76,7 +76,7 @@ specializeSig :: LHsQTyVars GhcRn -> [HsType GhcRn] -> Sig GhcRn -> Sig GhcRn specializeSig bndrs typs (TypeSig _ lnames typ) = - TypeSig noExt lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}}) + TypeSig noExtField lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}}) where true_type :: HsType GhcRn true_type = unLoc (hsSigWcType typ) @@ -112,7 +112,7 @@ sugar = sugarOperators . sugarTuples . sugarLists sugarLists :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) sugarLists (HsAppTy _ (L _ (HsTyVar _ _ (L _ name))) ltyp) - | getName name == listTyConName = HsListTy NoExt ltyp + | getName name == listTyConName = HsListTy noExtField ltyp sugarLists typ = typ @@ -123,7 +123,7 @@ sugarTuples typ = aux apps (HsAppTy _ (L _ ftyp) atyp) = aux (atyp:apps) ftyp aux apps (HsParTy _ (L _ typ')) = aux apps typ' aux apps (HsTyVar _ _ (L _ name)) - | isBuiltInSyntax name' && suitable = HsTupleTy NoExt HsBoxedTuple apps + | isBuiltInSyntax name' && suitable = HsTupleTy noExtField HsBoxedTuple apps where name' = getName name strName = getOccString name @@ -136,7 +136,7 @@ sugarTuples typ = sugarOperators :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb) | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb - | funTyConName == name' = HsFunTy NoExt la lb + | funTyConName == name' = HsFunTy noExtField la lb where name' = getName name sugarOperators typ = typ diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 4fbb308d..da221819 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -379,12 +379,12 @@ mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl } where mkType (KindedTyVar _ (L loc name) lkind) = - HsKindSig NoExt tvar lkind + HsKindSig noExtField tvar lkind where - tvar = L loc (HsTyVar NoExt NotPromoted (L loc name)) - mkType (UserTyVar _ name) = HsTyVar NoExt NotPromoted name - mkType (XTyVarBndr _ ) = panic "haddock:mkPseudoFamilyDecl" -mkPseudoFamilyDecl (XFamilyDecl {}) = panic "haddock:mkPseudoFamilyDecl" + tvar = L loc (HsTyVar noExtField NotPromoted (L loc name)) + mkType (UserTyVar _ name) = HsTyVar noExtField NotPromoted name + mkType (XTyVarBndr nec) = noExtCon nec +mkPseudoFamilyDecl (XFamilyDecl nec) = noExtCon nec -- | An instance head that may have documentation and a source location. @@ -668,79 +668,85 @@ instance MonadIO ErrMsgGhc where -- * Pass sensitive types ----------------------------------------------------------------------------- -type instance XForAllTy DocNameI = NoExt -type instance XQualTy DocNameI = NoExt -type instance XTyVar DocNameI = NoExt -type instance XStarTy DocNameI = NoExt -type instance XAppTy DocNameI = NoExt -type instance XAppKindTy DocNameI = NoExt -type instance XFunTy DocNameI = NoExt -type instance XListTy DocNameI = NoExt -type instance XTupleTy DocNameI = NoExt -type instance XSumTy DocNameI = NoExt -type instance XOpTy DocNameI = NoExt -type instance XParTy DocNameI = NoExt -type instance XIParamTy DocNameI = NoExt -type instance XKindSig DocNameI = NoExt -type instance XSpliceTy DocNameI = NoExt -type instance XDocTy DocNameI = NoExt -type instance XBangTy DocNameI = NoExt -type instance XRecTy DocNameI = NoExt -type instance XExplicitListTy DocNameI = NoExt -type instance XExplicitTupleTy DocNameI = NoExt -type instance XTyLit DocNameI = NoExt -type instance XWildCardTy DocNameI = NoExt +type instance XForAllTy DocNameI = NoExtField +type instance XQualTy DocNameI = NoExtField +type instance XTyVar DocNameI = NoExtField +type instance XStarTy DocNameI = NoExtField +type instance XAppTy DocNameI = NoExtField +type instance XAppKindTy DocNameI = NoExtField +type instance XFunTy DocNameI = NoExtField +type instance XListTy DocNameI = NoExtField +type instance XTupleTy DocNameI = NoExtField +type instance XSumTy DocNameI = NoExtField +type instance XOpTy DocNameI = NoExtField +type instance XParTy DocNameI = NoExtField +type instance XIParamTy DocNameI = NoExtField +type instance XKindSig DocNameI = NoExtField +type instance XSpliceTy DocNameI = NoExtField +type instance XDocTy DocNameI = NoExtField +type instance XBangTy DocNameI = NoExtField +type instance XRecTy DocNameI = NoExtField +type instance XExplicitListTy DocNameI = NoExtField +type instance XExplicitTupleTy DocNameI = NoExtField +type instance XTyLit DocNameI = NoExtField +type instance XWildCardTy DocNameI = NoExtField type instance XXType DocNameI = NewHsTypeX -type instance XUserTyVar DocNameI = NoExt -type instance XKindedTyVar DocNameI = NoExt -type instance XXTyVarBndr DocNameI = NoExt +type instance XUserTyVar DocNameI = NoExtField +type instance XKindedTyVar DocNameI = NoExtField +type instance XXTyVarBndr DocNameI = NoExtCon type instance XCFieldOcc DocNameI = DocName -type instance XXFieldOcc DocNameI = NoExt - -type instance XFixitySig DocNameI = NoExt -type instance XFixSig DocNameI = NoExt -type instance XPatSynSig DocNameI = NoExt -type instance XClassOpSig DocNameI = NoExt -type instance XTypeSig DocNameI = NoExt -type instance XMinimalSig DocNameI = NoExt - -type instance XForeignExport DocNameI = NoExt -type instance XForeignImport DocNameI = NoExt -type instance XConDeclGADT DocNameI = NoExt -type instance XConDeclH98 DocNameI = NoExt - -type instance XDerivD DocNameI = NoExt -type instance XInstD DocNameI = NoExt -type instance XForD DocNameI = NoExt -type instance XSigD DocNameI = NoExt -type instance XTyClD DocNameI = NoExt - -type instance XNoSig DocNameI = NoExt -type instance XCKindSig DocNameI = NoExt -type instance XTyVarSig DocNameI = NoExt - -type instance XCFamEqn DocNameI _ = NoExt - -type instance XCClsInstDecl DocNameI = NoExt -type instance XCDerivDecl DocNameI = NoExt +type instance XXFieldOcc DocNameI = NoExtField + +type instance XFixitySig DocNameI = NoExtField +type instance XFixSig DocNameI = NoExtField +type instance XPatSynSig DocNameI = NoExtField +type instance XClassOpSig DocNameI = NoExtField +type instance XTypeSig DocNameI = NoExtField +type instance XMinimalSig DocNameI = NoExtField + +type instance XForeignExport DocNameI = NoExtField +type instance XForeignImport DocNameI = NoExtField +type instance XConDeclGADT DocNameI = NoExtField +type instance XConDeclH98 DocNameI = NoExtField +type instance XXConDecl DocNameI = NoExtCon + +type instance XDerivD DocNameI = NoExtField +type instance XInstD DocNameI = NoExtField +type instance XForD DocNameI = NoExtField +type instance XSigD DocNameI = NoExtField +type instance XTyClD DocNameI = NoExtField + +type instance XNoSig DocNameI = NoExtField +type instance XCKindSig DocNameI = NoExtField +type instance XTyVarSig DocNameI = NoExtField +type instance XXFamilyResultSig DocNameI = NoExtCon + +type instance XCFamEqn DocNameI _ = NoExtField +type instance XXFamEqn DocNameI _ = NoExtCon + +type instance XCClsInstDecl DocNameI = NoExtField +type instance XCDerivDecl DocNameI = NoExtField type instance XViaStrategy DocNameI = LHsSigType DocNameI -type instance XDataFamInstD DocNameI = NoExt -type instance XTyFamInstD DocNameI = NoExt -type instance XClsInstD DocNameI = NoExt -type instance XCHsDataDefn DocNameI = NoExt -type instance XCFamilyDecl DocNameI = NoExt -type instance XClassDecl DocNameI = NoExt -type instance XDataDecl DocNameI = NoExt -type instance XSynDecl DocNameI = NoExt -type instance XFamDecl DocNameI = NoExt - -type instance XHsIB DocNameI _ = NoExt -type instance XHsWC DocNameI _ = NoExt - -type instance XHsQTvs DocNameI = NoExt -type instance XConDeclField DocNameI = NoExt +type instance XDataFamInstD DocNameI = NoExtField +type instance XTyFamInstD DocNameI = NoExtField +type instance XClsInstD DocNameI = NoExtField +type instance XCHsDataDefn DocNameI = NoExtField +type instance XCFamilyDecl DocNameI = NoExtField +type instance XClassDecl DocNameI = NoExtField +type instance XDataDecl DocNameI = NoExtField +type instance XSynDecl DocNameI = NoExtField +type instance XFamDecl DocNameI = NoExtField +type instance XXFamilyDecl DocNameI = NoExtCon + +type instance XHsIB DocNameI _ = NoExtField +type instance XHsWC DocNameI _ = NoExtField +type instance XXHsImplicitBndrs DocNameI _ = NoExtCon + +type instance XHsQTvs DocNameI = NoExtField +type instance XConDeclField DocNameI = NoExtField +type instance XXConDeclField DocNameI = NoExtCon type instance XXPat DocNameI = Located (Pat DocNameI) diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 493e2662..d817e4fa 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -135,17 +135,17 @@ mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs ty) addClassContext :: Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn -- Add the class context to a class-op signature addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype)) - = L pos (TypeSig noExt lname (mkEmptySigWcType (go (hsSigType ltype)))) + = L pos (TypeSig noExtField lname (mkEmptySigWcType (go (hsSigType ltype)))) -- The mkEmptySigWcType is suspicious where go (L loc (HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = ty })) - = L loc (HsForAllTy { hst_fvf = fvf, hst_xforall = noExt + = L loc (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField , hst_bndrs = tvs, hst_body = go ty }) go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty })) - = L loc (HsQualTy { hst_xqual = noExt + = L loc (HsQualTy { hst_xqual = noExtField , hst_ctxt = add_ctxt ctxt, hst_body = ty }) go (L loc ty) - = L loc (HsQualTy { hst_xqual = noExt + = L loc (HsQualTy { hst_xqual = noExtField , hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty }) extra_pred = nlHsTyConApp cls (lHsQTyVarsToTypes tvs0) @@ -155,7 +155,7 @@ addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn] lHsQTyVarsToTypes tvs - = [ noLoc (HsTyVar NoExt NotPromoted (noLoc (hsLTyVarName tv))) + = [ noLoc (HsTyVar noExtField NotPromoted (noLoc (hsLTyVarName tv))) | tv <- hsQTvExplicit tvs ] -------------------------------------------------------------------------------- @@ -201,7 +201,7 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] field_avail :: LConDeclField GhcRn -> Bool field_avail (L _ (ConDeclField _ fs _ _)) = all (\f -> extFieldOcc (unLoc f) `elem` names) fs - field_avail (L _ (XConDeclField _)) = panic "haddock:field_avail" + field_avail (L _ (XConDeclField nec)) = noExtCon nec field_types flds = [ t | ConDeclField _ _ t _ <- flds ] keep _ = Nothing -- cgit v1.2.3