aboutsummaryrefslogtreecommitdiff
path: root/haddock-api
diff options
context:
space:
mode:
authorAlan Zimmerman <alan.zimm@gmail.com>2018-04-19 14:04:04 +0200
committerAlan Zimmerman <alan.zimm@gmail.com>2018-04-27 15:36:53 +0200
commit271a9cb0c7a070deef8df2d4fb54ebe47a0bf560 (patch)
treedb4c5f3609760f44e3571a33419a726f42af6f54 /haddock-api
parent0d903e5e7ea877cbf6e8a7a84c9c8b6ef8c78ef6 (diff)
Match changes in GHC for TTG
Diffstat (limited to 'haddock-api')
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs21
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs18
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs43
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs49
-rw-r--r--haddock-api/src/Haddock/Convert.hs77
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs44
-rw-r--r--haddock-api/src/Haddock/Interface/AttachInstances.hs2
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs118
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs155
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs6
-rw-r--r--haddock-api/src/Haddock/Types.hs124
-rw-r--r--haddock-api/src/Haddock/Utils.hs26
13 files changed, 386 insertions, 299 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 09f62a19..2c7be079 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -126,12 +126,12 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl
, expItemFixities = fixities
} = ppDocumentation dflags dc ++ f decl
where
- f (TyClD d@DataDecl{}) = ppData dflags d subdocs
- f (TyClD d@SynDecl{}) = ppSynonym dflags d
- f (TyClD d@ClassDecl{}) = ppClass dflags d subdocs
- f (ForD (ForeignImport name typ _ _)) = [pp_sig dflags [name] (hsSigType typ)]
- f (ForD (ForeignExport name typ _ _)) = [pp_sig dflags [name] (hsSigType typ)]
- f (SigD sig) = ppSig dflags sig ++ ppFixities
+ f (TyClD _ d@DataDecl{}) = ppData dflags d subdocs
+ f (TyClD _ d@SynDecl{}) = ppSynonym dflags d
+ f (TyClD _ d@ClassDecl{}) = ppClass dflags d subdocs
+ f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags [name] (hsSigType typ)]
+ f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags [name] (hsSigType typ)]
+ f (SigD _ sig) = ppSig dflags sig ++ ppFixities
f _ = []
ppFixities = concatMap (ppFixity dflags) fixities
@@ -189,7 +189,7 @@ ppClass dflags decl subdocs =
, tcdTyVars = feqn_pats tfe
, tcdFixity = feqn_fixity tfe
, tcdRhs = feqn_rhs tfe
- , tcdFVs = emptyNameSet
+ , tcdSExt = emptyNameSet
}
@@ -241,8 +241,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 PlaceHolder x y)
- apps = foldl1 (\x y -> reL $ HsAppTy PlaceHolder x y)
+ funs = foldr1 (\x y -> reL $ HsFunTy NoExt x y)
+ apps = foldl1 (\x y -> reL $ HsAppTy NoExt x y)
typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds)
@@ -250,7 +250,7 @@ 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
- resType = apps $ map (reL . HsTyVar PlaceHolder NotPromoted . reL) $
+ resType = apps $ map (reL . HsTyVar NoExt NotPromoted . reL) $
(tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _ _) <- hsQTvExplicit $ tyClDeclTyVars dat]
ppCtor dflags _dat subdocs con@(ConDeclGADT { })
@@ -260,6 +260,7 @@ 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"
ppFixity :: DynFlags -> (Name, Fixity) -> [String]
ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExt [noLoc name] fixity) :: FixitySig GhcRn)]
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 19d638d9..56137f51 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -12,6 +12,7 @@ import qualified Haddock.Syb as Syb
import Haddock.Backends.Hyperlinker.Types
import qualified GHC
+import qualified Outputable as GHC
import Control.Applicative
import Control.Monad (guard)
@@ -146,9 +147,10 @@ decls (group, _, _, _) = concatMap ($ group)
where
typ (GHC.L _ t) = case t of
GHC.DataDecl { tcdLName = name } -> pure . decl $ name
- GHC.SynDecl name _ _ _ _ -> pure . decl $ name
- GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam
+ GHC.SynDecl _ name _ _ _ -> pure . decl $ name
+ GHC.FamDecl _ fam -> pure . decl $ GHC.fdLName fam
GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs
+ GHC.XTyClDecl {} -> GHC.panic "haddock:decls"
fun term = case cast term of
(Just (GHC.FunBind _ (GHC.L sspan name) _ _ _ :: GHC.HsBind GHC.GhcRn))
| GHC.isExternalName name -> pure (sspan, RtkDecl name)
@@ -159,10 +161,10 @@ decls (group, _, _, _) = concatMap ($ group)
++ everythingInRenamedSource fld cdcl
Nothing -> empty
ins term = case cast term of
- (Just ((GHC.DataFamInstD (GHC.DataFamInstDecl eqn))
+ (Just ((GHC.DataFamInstD _ (GHC.DataFamInstDecl eqn))
:: GHC.InstDecl GHC.GhcRn))
-> pure . tyref $ GHC.feqn_tycon $ GHC.hsib_body eqn
- (Just (GHC.TyFamInstD (GHC.TyFamInstDecl eqn))) ->
+ (Just (GHC.TyFamInstD _ (GHC.TyFamInstDecl eqn))) ->
pure . tyref $ GHC.feqn_tycon $ GHC.hsib_body eqn
_ -> empty
fld term = case cast term of
@@ -183,10 +185,10 @@ imports src@(_, imps, _, _) =
everythingInRenamedSource ie src ++ mapMaybe (imp . GHC.unLoc) imps
where
ie term = case cast term of
- (Just ((GHC.IEVar v) :: GHC.IE GHC.GhcRn)) -> pure $ var $ GHC.ieLWrappedName v
- (Just (GHC.IEThingAbs t)) -> pure $ typ $ GHC.ieLWrappedName t
- (Just (GHC.IEThingAll t)) -> pure $ typ $ GHC.ieLWrappedName t
- (Just (GHC.IEThingWith t _ vs _fls)) ->
+ (Just ((GHC.IEVar _ v) :: GHC.IE GHC.GhcRn)) -> pure $ var $ GHC.ieLWrappedName v
+ (Just (GHC.IEThingAbs _ t)) -> pure $ typ $ GHC.ieLWrappedName t
+ (Just (GHC.IEThingAll _ t)) -> pure $ typ $ GHC.ieLWrappedName t
+ (Just (GHC.IEThingWith _ t _ vs _fls)) ->
[typ $ GHC.ieLWrappedName t] ++ map (var . GHC.ieLWrappedName) vs
_ -> empty
typ (GHC.L sspan name) = (sspan, RtkType name)
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 4535979e..1b2515fa 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -216,7 +216,7 @@ processExports (e : es) =
isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsType DocNameI)
-isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig _ lnames t))
+isSimpleSig ExportDecl { expItemDecl = L _ (SigD _ (TypeSig _ lnames t))
, expItemMbDoc = (Documentation Nothing Nothing, argDocs) }
| Map.null argDocs = Just (map unLoc lnames, unLoc (hsSigWcType t))
isSimpleSig _ = Nothing
@@ -256,11 +256,11 @@ declNames :: LHsDecl DocNameI
, [DocName] -- ^ names being declared
)
declNames (L _ decl) = case decl of
- TyClD d -> (empty, [tcdName d])
- SigD (TypeSig _ lnames _ ) -> (empty, map unLoc lnames)
- SigD (PatSynSig _ lnames _) -> (text "pattern", map unLoc lnames)
- ForD (ForeignImport (L _ n) _ _ _) -> (empty, [n])
- ForD (ForeignExport (L _ n) _ _ _) -> (empty, [n])
+ TyClD _ d -> (empty, [tcdName d])
+ SigD _ (TypeSig _ lnames _ ) -> (empty, map unLoc lnames)
+ SigD _ (PatSynSig _ lnames _) -> (text "pattern", map unLoc lnames)
+ ForD _ (ForeignImport _ (L _ n) _ _) -> (empty, [n])
+ ForD _ (ForeignExport _ (L _ n) _ _) -> (empty, [n])
_ -> error "declaration not supported by declNames"
@@ -293,20 +293,20 @@ ppDecl :: LHsDecl DocNameI -- ^ decl to print
-> LaTeX
ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of
- TyClD d@FamDecl {} -> ppTyFam False doc d unicode
- TyClD d@DataDecl {} -> ppDataDecl pats instances subdocs (Just doc) d unicode
- TyClD d@SynDecl {} -> ppTySyn (doc, fnArgsDoc) d unicode
+ TyClD _ d@FamDecl {} -> ppTyFam False doc d unicode
+ TyClD _ d@DataDecl {} -> ppDataDecl pats instances subdocs (Just doc) d unicode
+ TyClD _ d@SynDecl {} -> ppTySyn (doc, fnArgsDoc) d unicode
-- Family instances happen via FamInst now
--- TyClD d@TySynonym{}
+-- TyClD _ d@TySynonym{}
-- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode
-- Family instances happen via FamInst now
- TyClD d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode
- SigD (TypeSig _ lnames ty) -> ppFunSig (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode
- SigD (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode
- ForD d -> ppFor (doc, fnArgsDoc) d unicode
- InstD _ -> empty
- DerivD _ -> empty
- _ -> error "declaration not supported by ppDecl"
+ TyClD _ d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode
+ SigD _ (TypeSig _ lnames ty) -> ppFunSig (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode
+ SigD _ (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode
+ ForD _ d -> ppFor (doc, fnArgsDoc) d unicode
+ InstD _ _ -> empty
+ DerivD _ _ -> empty
+ _ -> error "declaration not supported by ppDecl"
where
unicode = False
@@ -318,7 +318,7 @@ ppTyFam _ _ _ _ =
ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX
-ppFor doc (ForeignImport (L _ name) typ _ _) unicode =
+ppFor doc (ForeignImport _ (L _ name) typ _) unicode =
ppFunSig doc [name] (hsSigType typ) unicode
ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX"
-- error "foreign declarations are currently not supported by --latex"
@@ -647,7 +647,7 @@ ppDataDecl pats instances subdocs doc dataDecl unicode =
text "\\enspace" <+> emph (text "Bundled Patterns") <> text "\\par" $$
text "\\haddockbeginconstrs" $$
vcat [ empty <-> ppSideBySidePat lnames typ d unicode
- | (SigD (PatSynSig _ lnames typ), d) <- pats
+ | (SigD _ (PatSynSig _ lnames typ), d) <- pats
] $$
text "\\end{tabulary}\\par"
@@ -726,6 +726,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"
fieldPart = case (con, getConArgs con) of
-- Record style GADTs
@@ -759,6 +760,7 @@ 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"
-- don't use "con_doc con", in case it's reconstructed from a .hi file,
@@ -771,13 +773,14 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
-- | Pretty-print a record field
ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocNameI -> LaTeX
-ppSideBySideField subdocs unicode (ConDeclField names ltype _) =
+ppSideBySideField subdocs unicode (ConDeclField _ names ltype _) =
decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names))
<+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc
where
-- don't use cd_fld_doc for same reason we don't use con_doc above
-- 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"
-- | Pretty-print a bundled pattern synonym
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 00937245..464c166b 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -663,7 +663,7 @@ numberSectionHeadings = go 1
processExport :: Bool -> LinksInfo -> Bool -> Qualification
-> ExportItem DocNameI -> Maybe Html
-processExport _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances
+processExport _ _ _ _ ExportDecl { expItemDecl = L _ (InstD {}) } = Nothing -- Hide empty instances
processExport summary _ _ qual (ExportGroup lev id0 doc)
= nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) qual (mkMeta doc)
processExport summary links unicode qual (ExportDecl decl pats doc subdocs insts fixities splice)
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 5f253cbd..8ac3d91b 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -39,6 +39,7 @@ import GHC.Exts
import Name
import BooleanFormula
import RdrName ( rdrNameOcc )
+import Outputable ( panic )
-- | Pretty print a declaration
ppDecl :: Bool -- ^ print summary info only
@@ -54,18 +55,18 @@ ppDecl :: Bool -- ^ print summary info only
-> Qualification
-> Html
ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of
- TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual
- TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode qual
- TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual
- TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual
- SigD (TypeSig _ lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames
+ TyClD _ (FamDecl _ d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual
+ TyClD _ d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode qual
+ TyClD _ d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual
+ TyClD _ d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual
+ SigD _ (TypeSig _ lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames
(hsSigWcType lty) fixities splice unicode qual
- SigD (PatSynSig _ lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames
+ SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames
(hsSigType lty) fixities splice unicode qual
- ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual
- InstD _ -> noHtml
- DerivD _ -> noHtml
- _ -> error "declaration not supported by ppDecl"
+ ForD _ d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual
+ InstD _ _ -> noHtml
+ DerivD _ _ -> noHtml
+ _ -> error "declaration not supported by ppDecl"
ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
@@ -225,7 +226,7 @@ tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit
ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
-> ForeignDecl DocNameI -> [(DocName, Fixity)]
-> Splice -> Unicode -> Qualification -> Html
-ppFor summary links loc doc (ForeignImport (L _ name) typ _ _) fixities
+ppFor summary links loc doc (ForeignImport _ (L _ name) typ _) fixities
splice unicode qual
= ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode qual
ppFor _ _ _ _ _ _ _ _ _ = error "ppFor"
@@ -318,12 +319,14 @@ ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info
ClosedTypeFamily _ -> keyword "where ..."
_ -> mempty
)
+ppTyFamHeader _ _ (XFamilyDecl _) _ _ = panic "haddock;ppTyFamHeader"
ppResultSig :: FamilyResultSig DocNameI -> Unicode -> Qualification -> Html
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
+ NoSig _ -> noHtml
+ KindSig _ kind -> dcolon unicode <+> ppLKind unicode qual kind
+ TyVarSig _ (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr
+ XFamilyResultSig _ -> panic "haddock:ppResultSig"
ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocNameI
-> Html
@@ -367,6 +370,8 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode
= ( ppAppNameTypes (unLoc n) (map unLoc ts) unicode qual
<+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs)
, Nothing, [] )
+ ppTyFamEqn (XHsImplicitBndrs _) = panic "haddock:ppTyFam"
+ ppTyFamEqn (HsIB { hsib_body = XFamEqn _}) = panic "haddock:ppTyFam"
@@ -399,6 +404,7 @@ ppAssocType summ links doc (L loc decl) fixities splice unicode qual =
ppFamDeclBinderWithVars :: Bool -> Unicode -> Qualification -> FamilyDecl DocNameI -> Html
ppFamDeclBinderWithVars summ unicode qual (FamilyDecl { fdLName = lname, fdTyVars = tvs }) =
ppAppDocNameTyVarBndrs summ unicode qual (unLoc lname) (hsq_explicit tvs)
+ppFamDeclBinderWithVars _ _ _ (XFamilyDecl _) = panic "haddock:ppFamDeclBinderWithVars"
-- | Print a newtype / data binder and its variables
ppDataBinderWithVars :: Bool -> Unicode -> Qualification -> TyClDecl DocNameI -> Html
@@ -740,13 +746,14 @@ ppShortDataDecl summary dataInst dataDecl pats unicode qual
isH98 = case unLoc (head cons) of
ConDeclH98 {} -> True
ConDeclGADT{} -> False
+ XConDecl{} -> False
pats1 = [ hsep [ keyword "pattern"
, hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames
, dcolon unicode
, ppPatSigType unicode qual (hsSigType typ)
]
- | (SigD (PatSynSig _ lnames typ),_) <- pats
+ | (SigD _ (PatSynSig _ lnames typ),_) <- pats
]
@@ -772,6 +779,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats
isH98 = case unLoc (head cons) of
ConDeclH98 {} -> True
ConDeclGADT{} -> False
+ XConDecl{} -> False
header_ = topDeclElem links loc splice [docname] $
ppDataHeader summary dataDecl unicode qual <+> whereBit <+> fix
@@ -793,7 +801,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats
patternBit = subPatterns qual
[ ppSideBySidePat subfixs unicode qual lnames typ d
- | (SigD (PatSynSig _ lnames typ), d) <- pats
+ | (SigD _ (PatSynSig _ lnames typ), d) <- pats
, let subfixs = filter (\(n,_) -> any (\cn -> cn == n)
(map unLoc lnames)) fixities
]
@@ -854,6 +862,7 @@ ppShortConstrParts summary dataInst con unicode qual
, noHtml
, noHtml
)
+ XConDecl {} -> panic "haddock:ppShortConstrParts"
where
occ = map (nameOccName . getName . unLoc) $ getConNames con
@@ -923,6 +932,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con)
, ppLType unicode qual HideEmptyContexts (getGADTConType con)
, fixity
]
+ XConDecl{} -> panic "haddock:ppSideBySideConstr"
fieldPart = case (con, getConArgs con) of
-- Record style GADTs
@@ -951,6 +961,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con)
ConDeclGADT{} ->
ppSubSigLike unicode qual (unLoc (getGADTConType con))
argDocs subdocs (dcolon unicode) HideEmptyContexts
+ XConDecl{} -> panic "haddock:doConstrArgsWithDocs"
-- 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.
@@ -980,7 +991,7 @@ ppConstrHdr forall_ tvs ctxt unicode qual = ppForall +++ ppCtxt
-- | Pretty-print a record field
ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification
-> ConDeclField DocNameI -> SubDecl
-ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) =
+ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype _) =
( hsep (punctuate comma [ ppBinder False (rdrNameOcc field)
| L _ name <- names
, let field = (unLoc . rdrNameFieldOcc) name
@@ -994,12 +1005,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"
ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> Html
-ppShortField summary unicode qual (ConDeclField names ltype _)
+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"
-- | Pretty print an expanded pattern (for bundled patterns)
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index fd9f0089..b4804758 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -1,5 +1,5 @@
-{-# LANGUAGE CPP, PatternGuards #-}
+{-# LANGUAGE CPP, PatternGuards, TypeFamilies #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Convert
@@ -62,14 +62,14 @@ tyThingToLHsDecl 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 (synifyIdSig ImplicitizeForAll i)
+ AnId i -> allOK $ SigD noExt (synifyIdSig 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.)
ATyCon tc
| Just cl <- tyConClass_maybe tc -- classes are just a little tedious
-> let extractFamilyDecl :: TyClDecl a -> Either ErrMsg (LFamilyDecl a)
- extractFamilyDecl (FamDecl d) = return $ noLoc d
+ extractFamilyDecl (FamDecl _ d) = return $ noLoc d
extractFamilyDecl _ =
Left "tyThingToLHsDecl: impossible associated tycon"
@@ -77,7 +77,7 @@ tyThingToLHsDecl t = case t of
atFamDecls = map extractFamilyDecl (rights atTyClDecls)
tyClErrors = lefts atTyClDecls
famDeclErrors = lefts atFamDecls
- in withErrs (tyClErrors ++ famDeclErrors) . TyClD $ ClassDecl
+ in withErrs (tyClErrors ++ famDeclErrors) . TyClD noExt $ ClassDecl
{ tcdCtxt = synifyCtx (classSCTheta cl)
, tcdLName = synifyName cl
, tcdTyVars = synifyTyVars (tyConVisibleTyVars (classTyCon cl))
@@ -93,20 +93,20 @@ tyThingToLHsDecl t = case t of
, tcdATs = rights atFamDecls
, tcdATDefs = [] --ignore associated type defaults
, tcdDocs = [] --we don't have any docs at this point
- , tcdFVs = placeHolderNamesTc }
+ , tcdCExt = placeHolderNamesTc }
| otherwise
- -> synifyTyCon Nothing tc >>= allOK . TyClD
+ -> synifyTyCon Nothing tc >>= allOK . TyClD noExt
-- 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 (TypeSig noExt [synifyName dc]
+ AConLike (RealDataCon dc) -> allOK $ SigD noExt (TypeSig noExt [synifyName dc]
(synifySigWcType ImplicitizeForAll (dataConUserType dc)))
AConLike (PatSynCon ps) ->
- allOK . SigD $ PatSynSig noExt [synifyName ps] (synifyPatSynSigType ps)
+ allOK . SigD noExt $ PatSynSig noExt [synifyName ps] (synifyPatSynSigType ps)
where
withErrs e x = return (e, x)
allOK x = return (mempty, x)
@@ -119,9 +119,10 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
annot_typats = zipWith3 annotHsType (mkIsPolyTvs fam_tvs)
args_types_only typats
hs_rhs = synifyType WithinType rhs
- in HsIB { hsib_vars = map tyVarName tkvs
- , hsib_closed = True
- , hsib_body = FamEqn { feqn_tycon = name
+ in HsIB { hsib_ext = HsIBRn { hsib_vars = map tyVarName tkvs
+ , hsib_closed = True }
+ , hsib_body = FamEqn { feqn_ext = noExt
+ , feqn_tycon = name
, feqn_pats = annot_typats
, feqn_fixity = Prefix
, feqn_rhs = hs_rhs } }
@@ -132,13 +133,13 @@ synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl GhcRn)
synifyAxiom ax@(CoAxiom { co_ax_tc = tc })
| isOpenTypeFamilyTyCon tc
, Just branch <- coAxiomSingleBranch_maybe ax
- = return $ InstD
- $ TyFamInstD
+ = return $ InstD noExt
+ $ TyFamInstD noExt
$ TyFamInstDecl { tfid_eqn = synifyAxBranch tc branch }
| Just ax' <- isClosedSynFamilyTyConWithAxiom_maybe tc
, getUnique ax' == getUnique ax -- without the getUniques, type error
- = synifyTyCon (Just ax) tc >>= return . TyClD
+ = synifyTyCon (Just ax) tc >>= return . TyClD noExt
| otherwise
= Left "synifyAxiom: closed/open family confusion"
@@ -153,14 +154,17 @@ synifyTyCon _coax tc
let mk_hs_tv realKind fakeTyVar
= noLoc $ KindedTyVar noExt (noLoc (getName fakeTyVar))
(synifyKindSig realKind)
- in HsQTvs { hsq_implicit = [] -- No kind polymorphism
+ in HsQTvs { hsq_ext =
+ HsQTvsRn { hsq_implicit = [] -- No kind polymorphism
+ , hsq_dependent = emptyNameSet }
, hsq_explicit = zipWith mk_hs_tv (fst (splitFunTys (tyConKind tc)))
alphaTyVars --a, b, c... which are unfortunately all kind *
- , hsq_dependent = emptyNameSet }
+ }
, tcdFixity = Prefix
- , tcdDataDefn = HsDataDefn { dd_ND = DataType -- arbitrary lie, they are neither
+ , tcdDataDefn = HsDataDefn { dd_ext = noExt
+ , dd_ND = DataType -- arbitrary lie, they are neither
-- algebraic data nor newtype:
, dd_ctxt = noLoc []
, dd_cType = Nothing
@@ -168,8 +172,7 @@ synifyTyCon _coax tc
-- we have their kind accurately:
, dd_cons = [] -- No constructors
, dd_derivs = noLoc [] }
- , tcdDataCusk = False
- , tcdFVs = placeHolderNamesTc }
+ , tcdDExt = DataDeclRn False placeHolderNamesTc }
synifyTyCon _coax tc
| Just flav <- famTyConFlav_maybe tc
@@ -190,8 +193,9 @@ synifyTyCon _coax tc
-> mkFamDecl DataFamily
where
resultVar = famTcResVar tc
- mkFamDecl i = return $ FamDecl $
- FamilyDecl { fdInfo = i
+ mkFamDecl i = return $ FamDecl noExt $
+ FamilyDecl { fdExt = noExt
+ , fdInfo = i
, fdLName = synifyName tc
, fdTyVars = synifyTyVars (tyConVisibleTyVars tc)
, fdFixity = Prefix
@@ -204,11 +208,11 @@ synifyTyCon _coax tc
synifyTyCon coax tc
| Just ty <- synTyConRhs_maybe tc
- = return $ SynDecl { tcdLName = synifyName tc
+ = return $ SynDecl { tcdSExt = emptyNameSet
+ , tcdLName = synifyName tc
, tcdTyVars = synifyTyVars (tyConVisibleTyVars tc)
, tcdFixity = Prefix
- , tcdRhs = synifyType WithinType ty
- , tcdFVs = placeHolderNamesTc }
+ , tcdRhs = synifyType WithinType ty }
| otherwise =
-- (closed) newtype and data
let
@@ -241,7 +245,8 @@ synifyTyCon coax tc
cons = rights consRaw
-- "deriving" doesn't affect the signature, no need to specify any.
alg_deriv = noLoc []
- defn = HsDataDefn { dd_ND = alg_nd
+ defn = HsDataDefn { dd_ext = noExt
+ , dd_ND = alg_nd
, dd_ctxt = alg_ctx
, dd_cType = Nothing
, dd_kindSig = fmap synifyKindSig kindSig
@@ -251,7 +256,7 @@ synifyTyCon coax tc
[] -> return $
DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdFixity = Prefix
, tcdDataDefn = defn
- , tcdDataCusk = False, tcdFVs = placeHolderNamesTc }
+ , tcdDExt = DataDeclRn False placeHolderNamesTc }
dataConErrs -> Left $ unlines dataConErrs
synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity
@@ -264,9 +269,9 @@ synifyInjectivityAnn (Just lhs) tvs (Injective inj) =
synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig GhcRn
synifyFamilyResultSig Nothing kind =
- noLoc $ KindSig (synifyKindSig kind)
+ noLoc $ KindSig noExt (synifyKindSig kind)
synifyFamilyResultSig (Just name) kind =
- noLoc $ TyVarSig (noLoc $ KindedTyVar noExt (noLoc name) (synifyKindSig kind))
+ noLoc $ TyVarSig noExt (noLoc $ KindedTyVar noExt (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
@@ -297,7 +302,7 @@ synifyDataCon use_gadt_syntax dc =
field_tys = zipWith con_decl_field (dataConFieldLabels dc) linear_tys
con_decl_field fl synTy = noLoc $
- ConDeclField [noLoc $ FieldOcc (flSelector fl) (noLoc $ mkVarUnqual $ flLabel fl)] synTy
+ ConDeclField noExt [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!"
@@ -311,7 +316,8 @@ synifyDataCon use_gadt_syntax dc =
\hat ->
if use_gadt_syntax
then return $ noLoc $
- ConDeclGADT { con_names = [name]
+ ConDeclGADT { con_g_ext = noExt
+ , con_names = [name]
, con_forall = True
, con_qvars = synifyTyVars (univ_tvs ++ ex_tvs)
, con_mb_cxt = Just ctx
@@ -319,7 +325,8 @@ synifyDataCon use_gadt_syntax dc =
, con_res_ty = synifyType WithinType res_ty
, con_doc = Nothing }
else return $ noLoc $
- ConDeclH98 { con_name = name
+ ConDeclH98 { con_ext = noExt
+ , con_name = name
, con_forall = True
, con_ex_tvs = map synifyTyVar ex_tvs
, con_mb_cxt = Just ctx
@@ -341,9 +348,9 @@ synifyCtx = noLoc . map (synifyType WithinType)
synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn
-synifyTyVars ktvs = HsQTvs { hsq_implicit = []
- , hsq_explicit = map synifyTyVar ktvs
- , hsq_dependent = emptyNameSet }
+synifyTyVars ktvs = HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = []
+ , hsq_dependent = emptyNameSet }
+ , hsq_explicit = map synifyTyVar ktvs }
synifyTyVar :: TyVar -> LHsTyVarBndr GhcRn
synifyTyVar tv
@@ -546,7 +553,7 @@ synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead
, clsiTyVars = synifyTyVars (tyConVisibleTyVars cls_tycon)
, clsiSigs = map synifyClsIdSig $ classMethods cls
, clsiAssocTys = do
- (Right (FamDecl fam)) <- map (synifyTyCon Nothing) $ classATs cls
+ (Right (FamDecl _ fam)) <- map (synifyTyCon Nothing) $ classATs cls
pure $ mkPseudoFamilyDecl fam
}
}
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 14111a6a..2d254414 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -47,28 +47,36 @@ isConSym = isLexConSym . occNameFS
getMainDeclBinder :: HsDecl name -> [IdP name]
-getMainDeclBinder (TyClD d) = [tcdName d]
-getMainDeclBinder (ValD d) =
+getMainDeclBinder (TyClD _ d) = [tcdName d]
+getMainDeclBinder (ValD _ d) =
case collectHsBindBinders d of
[] -> []
(name:_) -> [name]
-getMainDeclBinder (SigD d) = sigNameNoLoc d
-getMainDeclBinder (ForD (ForeignImport name _ _ _)) = [unLoc name]
-getMainDeclBinder (ForD (ForeignExport _ _ _ _)) = []
+getMainDeclBinder (SigD _ d) = sigNameNoLoc d
+getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name]
+getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = []
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 (ClsInstD (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty)
-getInstLoc (DataFamInstD (DataFamInstDecl
+getInstLoc (ClsInstD _ (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty)
+getInstLoc (DataFamInstD _ (DataFamInstDecl
{ dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}})) = l
-getInstLoc (TyFamInstD (TyFamInstDecl
+getInstLoc (TyFamInstD _ (TyFamInstDecl
-- Since CoAxioms' Names refer to the whole line for type family instances
-- 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"
+
+
-- Useful when there is a signature with multiple names, e.g.
-- foo, bar :: Types..
@@ -124,16 +132,16 @@ isUserLSig _ = False
isClassD :: HsDecl a -> Bool
-isClassD (TyClD d) = isClassDecl d
+isClassD (TyClD _ d) = isClassDecl d
isClassD _ = False
isValD :: HsDecl a -> Bool
-isValD (ValD _) = True
+isValD (ValD _ _) = True
isValD _ = False
declATs :: HsDecl a -> [IdP a]
-declATs (TyClD d) | isClassDecl d = map (unL . fdLName . unL) $ tcdATs d
+declATs (TyClD _ d) | isClassDecl d = map (unL . fdLName . unL) $ tcdATs d
declATs _ = []
@@ -165,13 +173,13 @@ 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_xforall = PlaceHolder
+ | has_forall = noLoc (HsForAllTy { hst_xforall = NoExt
, hst_bndrs = hsQTvExplicit qtvs
, hst_body = theta_ty })
| otherwise = theta_ty
where
theta_ty | Just theta <- mcxt
- = noLoc (HsQualTy { hst_xqual = PlaceHolder, hst_ctxt = theta, hst_body = tau_ty })
+ = noLoc (HsQualTy { hst_xqual = NoExt, hst_ctxt = theta, hst_body = tau_ty })
| otherwise
= tau_ty
@@ -184,6 +192,7 @@ getGADTConType (ConDeclGADT { con_forall = has_forall
getGADTConType (ConDeclH98 {}) = panic "getGADTConType"
-- Should only be called on ConDeclGADT
+getGADTConType (XConDecl {}) = panic "getGADTConType"
-- -------------------------------------
@@ -196,13 +205,13 @@ getGADTConTypeG (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_xforall = PlaceHolder
+ | has_forall = noLoc (HsForAllTy { hst_xforall = NoExt
, hst_bndrs = hsQTvExplicit qtvs
, hst_body = theta_ty })
| otherwise = theta_ty
where
theta_ty | Just theta <- mcxt
- = noLoc (HsQualTy { hst_xqual = PlaceHolder, hst_ctxt = theta, hst_body = tau_ty })
+ = noLoc (HsQualTy { hst_xqual = NoExt, hst_ctxt = theta, hst_body = tau_ty })
| otherwise
= tau_ty
@@ -213,8 +222,9 @@ getGADTConTypeG (ConDeclGADT { con_forall = has_forall
mkFunTy a b = noLoc (HsFunTy noExt a b)
-getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConType"
+getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConTypeG"
-- Should only be called on ConDeclGADT
+getGADTConTypeG (XConDecl {}) = panic "getGADTConTypeG"
-------------------------------------------------------------------------------
-- * Located
@@ -286,7 +296,7 @@ parentMap d = [ (c, p) | (p, cs) <- families d, c <- cs ]
-- | The parents of a subordinate in a declaration
parents :: Name -> HsDecl GhcRn -> [Name]
-parents n (TyClD d) = [ p | (c, p) <- parentMap d, c == n ]
+parents n (TyClD _ d) = [ p | (c, p) <- parentMap d, c == n ]
parents _ _ = []
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index 4fd9d264..286907e5 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -87,7 +87,7 @@ attachToExportItem
-> Ghc (ExportItem GhcRn)
attachToExportItem index expInfo iface ifaceMap instIfaceMap export =
case attachFixities export of
- e@ExportDecl { expItemDecl = L eSpan (TyClD d) } -> do
+ e@ExportDecl { expItemDecl = L eSpan (TyClD _ d) } -> do
insts <-
let mb_instances = lookupNameEnv index (tcdName d)
cls_instances = maybeToList mb_instances >>= fst
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index c119f3c3..bc93449f 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -125,7 +125,7 @@ createInterface tm flags modMap instIfaceMap = do
$ map getName instances
++ map getName fam_instances
-- Locations of all TH splices
- splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ]
+ splices = [ l | L l (SpliceD _ _) <- hsmodDecls hsm ]
warningMap <- liftErrMsg (mkWarningMap dflags warnings gre exportedNames)
@@ -406,9 +406,9 @@ mkMaps dflags gre instances decls = do
instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ]
names :: SrcSpan -> HsDecl GhcRn -> [Name]
- names l (InstD d) = maybeToList (M.lookup loc instanceMap) -- See note [2].
+ names l (InstD _ d) = maybeToList (M.lookup loc instanceMap) -- See note [2].
where loc = case d of
- TyFamInstD _ -> l -- The CoAx's loc is the whole line, but only for TFs
+ TyFamInstD _ _ -> l -- The CoAx's loc is the whole line, but only for TFs
_ -> getInstLoc d
names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See note [2].
names _ decl = getMainDeclBinder decl
@@ -433,16 +433,16 @@ subordinates :: InstMap
-> HsDecl GhcRn
-> [(Name, [HsDocString], Map Int HsDocString)]
subordinates instMap decl = case decl of
- InstD (ClsInstD d) -> do
+ InstD _ (ClsInstD _ d) -> do
DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
FamEqn { feqn_tycon = L l _
, feqn_rhs = defn }}} <- unLoc <$> cid_datafam_insts d
[ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn
- InstD (DataFamInstD (DataFamInstDecl (HsIB { hsib_body = d })))
+ InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = d })))
-> dataSubs (feqn_rhs d)
- TyClD d | isClassDecl d -> classSubs d
- | isDataDecl d -> dataSubs (tcdDataDefn d)
+ TyClD _ d | isClassDecl d -> classSubs d
+ | isDataDecl d -> dataSubs (tcdDataDefn d)
_ -> []
where
classSubs dd = [ (name, doc, declTypeDocs d) | (L _ d, doc) <- classDecls dd
@@ -456,7 +456,7 @@ subordinates instMap decl = case decl of
| c <- cons, cname <- getConNames c ]
fields = [ (extFieldOcc n, maybeToList $ fmap unL doc, M.empty)
| RecCon flds <- map getConArgs cons
- , L _ (ConDeclField ns _ doc) <- (unLoc flds)
+ , L _ (ConDeclField _ ns _ doc) <- (unLoc flds)
, L _ n <- ns ]
derivs = [ (instName, [unL doc], M.empty)
| HsIB { hsib_body = L l (HsDocTy _ _ doc) }
@@ -481,11 +481,11 @@ conArgDocs con = case getConArgs con of
-- | Extract function argument docs from inside top-level decls.
declTypeDocs :: HsDecl GhcRn -> Map Int HsDocString
-declTypeDocs (SigD (TypeSig _ _ ty)) = typeDocs (unLoc (hsSigWcType ty))
-declTypeDocs (SigD (ClassOpSig _ _ _ ty)) = typeDocs (unLoc (hsSigType ty))
-declTypeDocs (SigD (PatSynSig _ _ ty)) = typeDocs (unLoc (hsSigType ty))
-declTypeDocs (ForD (ForeignImport _ ty _ _)) = typeDocs (unLoc (hsSigType ty))
-declTypeDocs (TyClD (SynDecl { tcdRhs = ty })) = typeDocs (unLoc ty)
+declTypeDocs (SigD _ (TypeSig _ _ ty)) = typeDocs (unLoc (hsSigWcType ty))
+declTypeDocs (SigD _ (ClassOpSig _ _ _ ty)) = typeDocs (unLoc (hsSigType ty))
+declTypeDocs (SigD _ (PatSynSig _ _ ty)) = typeDocs (unLoc (hsSigType ty))
+declTypeDocs (ForD _ (ForeignImport _ _ ty _)) = typeDocs (unLoc (hsSigType ty))
+declTypeDocs (TyClD _ (SynDecl { tcdRhs = ty })) = typeDocs (unLoc ty)
declTypeDocs _ = M.empty
-- | Extract function argument docs from inside types.
@@ -505,10 +505,10 @@ classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls
where
decls = docs ++ defs ++ sigs ++ ats
- docs = mkDecls tcdDocs DocD class_
- defs = mkDecls (bagToList . tcdMeths) ValD class_
- sigs = mkDecls tcdSigs SigD class_
- ats = mkDecls tcdATs (TyClD . FamDecl) class_
+ 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_
-- | The top-level declarations of a module that we care about,
@@ -526,14 +526,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 group_ ++
- mkDecls hs_derivds DerivD group_ ++
- mkDecls hs_defds DefD group_ ++
- mkDecls hs_fords ForD group_ ++
- mkDecls hs_docs DocD group_ ++
- mkDecls (tyClGroupInstDecls . hs_tyclds) InstD group_ ++
- mkDecls (typesigs . hs_valds) SigD group_ ++
- mkDecls (valbinds . hs_valds) ValD 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_
where
typesigs (XValBindsLR (NValBinds _ sigs)) = filter isUserLSig sigs
typesigs _ = error "expected ValBindsOut"
@@ -564,14 +564,14 @@ sortByLoc = sortBy (comparing getLoc)
filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
filterDecls = filter (isHandled . unL . fst)
where
- isHandled (ForD (ForeignImport {})) = True
+ isHandled (ForD _ (ForeignImport {})) = True
isHandled (TyClD {}) = True
isHandled (InstD {}) = True
isHandled (DerivD {}) = True
- isHandled (SigD d) = isUserLSig (reL d)
- isHandled (ValD _) = True
+ isHandled (SigD _ d) = isUserLSig (reL d)
+ isHandled (ValD {}) = True
-- we keep doc declarations to be able to get at named docs
- isHandled (DocD _) = True
+ isHandled (DocD {}) = True
isHandled _ = False
@@ -580,8 +580,8 @@ filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x
| x@(L loc d, doc) <- decls ]
where
- filterClass (TyClD c) =
- TyClD $ c { tcdSigs = filter (liftA2 (||) isUserLSig isMinimalLSig) $ tcdSigs c }
+ filterClass (TyClD x c) =
+ TyClD x $ c { tcdSigs = filter (liftA2 (||) isUserLSig isMinimalLSig) $ tcdSigs c }
filterClass _ = error "expected TyClD"
@@ -600,10 +600,10 @@ collectDocs = go Nothing []
where
go Nothing _ [] = []
go (Just prev) docs [] = finished prev docs []
- go prev docs (L _ (DocD (DocCommentNext str)) : ds)
+ go prev docs (L _ (DocD _ (DocCommentNext str)) : ds)
| Nothing <- prev = go Nothing (str:docs) ds
| Just decl <- prev = finished decl docs (go Nothing [str] ds)
- go prev docs (L _ (DocD (DocCommentPrev str)) : ds) = go prev (str:docs) ds
+ go prev docs (L _ (DocD _ (DocCommentPrev str)) : ds) = go prev (str:docs) ds
go Nothing docs (d:ds) = go (Just d) docs ds
go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds)
@@ -644,22 +644,22 @@ mkExportItems
decls maps fixMap splices instIfaceMap dflags allExports
Just exports -> liftM concat $ mapM lookupExport exports
where
- lookupExport (IEGroup lev docStr, _) = liftErrMsg $ do
+ lookupExport (IEGroup _ lev docStr, _) = liftErrMsg $ do
doc <- processDocString dflags gre docStr
return [ExportGroup lev "" doc]
- lookupExport (IEDoc docStr, _) = liftErrMsg $ do
+ lookupExport (IEDoc _ docStr, _) = liftErrMsg $ do
doc <- processDocStringParas dflags gre docStr
return [ExportDoc doc]
- lookupExport (IEDocNamed str, _) = liftErrMsg $
+ lookupExport (IEDocNamed _ str, _) = liftErrMsg $
findNamedDoc str [ unL d | d <- decls ] >>= \case
Nothing -> return []
Just docStr -> do
doc <- processDocStringParas dflags gre docStr
return [ExportDoc doc]
- lookupExport (IEModuleContents (L _ mod_name), _)
+ lookupExport (IEModuleContents _ (L _ mod_name), _)
-- only consider exporting a module if we are sure we
-- are really exporting the whole module and not some
-- subset. We also look through module aliases here.
@@ -696,7 +696,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
let t = availName avail
r <- findDecl avail
case r of
- ([L l (ValD _)], (doc, _)) -> do
+ ([L l (ValD _ _)], (doc, _)) -> do
-- Top-level binding without type signature
export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap
return [export]
@@ -721,17 +721,17 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
-- A single signature might refer to many names, but we
-- create an export item for a single name only. So we
-- modify the signature to contain only that single name.
- L loc (SigD sig) ->
+ 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 . fromJust $ filterSigNames (== t) sig
+ let newDecl = L loc . SigD noExt . fromJust $ filterSigNames (== t) sig
in availExportDecl avail newDecl docs_
- L loc (TyClD cl@ClassDecl{}) -> do
+ L loc (TyClD _ cl@ClassDecl{}) -> do
mdef <- liftGhcToErrMsgGhc $ minimalDef t
let sig = maybeToList $ fmap (noLoc . MinimalSig noExt NoSourceText . noLoc . fmap noLoc) mdef
availExportDecl avail
- (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_
+ (L loc $ TyClD noExt cl { tcdSigs = sig ++ tcdSigs cl }) docs_
_ -> availExportDecl avail decl docs_
@@ -994,7 +994,7 @@ fullModuleContents is_sig modMap thisMod semMod warnings exportedNames
for (getMainDeclBinder (unLoc decl)) $ \nm -> do
case lookupNameEnv availEnv nm of
Just avail
- | L _ (ValD valDecl) <- decl
+ | L _ (ValD _ valDecl) <- decl
, (name:_) <- collectHsBindBinders valDecl
, Just (L _ SigD{}:_) <- filter isSigD <$> M.lookup name declMap
-> pure []
@@ -1017,7 +1017,7 @@ extractDecl declMap name decl
| name `elem` getMainDeclBinder (unLoc decl) = decl
| otherwise =
case unLoc decl of
- TyClD d@ClassDecl {} ->
+ TyClD _ d@ClassDecl {} ->
let
matchesMethod =
[ lsig
@@ -1037,8 +1037,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 sig)
- (_, [L pos fam_decl]) -> L pos (TyClD (FamDecl fam_decl))
+ in L pos (SigD noExt sig)
+ (_, [L pos fam_decl]) -> L pos (TyClD noExt (FamDecl noExt fam_decl))
([], [])
| Just (famInstDecl:_) <- M.lookup name declMap
@@ -1047,21 +1047,21 @@ extractDecl declMap name decl
O.$$ O.nest 4 (O.ppr d)
O.$$ O.text "Matches:"
O.$$ O.nest 4 (O.ppr matchesMethod O.<+> O.ppr matchesAssociatedType))
- TyClD d@DataDecl {} ->
+ TyClD _ d@DataDecl {} ->
let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d))
in if isDataConName name
- then SigD <$> extractPatternSyn name n tyvar_tys (dd_cons (tcdDataDefn d))
- else SigD <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d))
- TyClD FamDecl {}
+ then SigD noExt <$> extractPatternSyn name n tyvar_tys (dd_cons (tcdDataDefn d))
+ else SigD noExt <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d))
+ TyClD _ FamDecl {}
| isValName name
, Just (famInst:_) <- M.lookup name declMap
-> extractDecl declMap name famInst
- InstD (DataFamInstD (DataFamInstDecl (HsIB { hsib_body =
+ InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body =
FamEqn { feqn_tycon = L _ n
, feqn_pats = tys
, feqn_rhs = defn }}))) ->
- SigD <$> extractRecSel name n tys (dd_cons defn)
- InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) ->
+ SigD noExt <$> extractRecSel name n tys (dd_cons defn)
+ InstD _ (ClsInstD _ ClsInstDecl { cid_datafam_insts = insts }) ->
let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d }))
<- insts
-- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (feqn_rhs d)
@@ -1071,7 +1071,7 @@ extractDecl declMap name decl
, extFieldOcc n == name
]
in case matches of
- [d0] -> extractDecl declMap name (noLoc . InstD $ DataFamInstD d0)
+ [d0] -> extractDecl declMap name (noLoc . InstD noExt $ DataFamInstD noExt d0)
_ -> error "internal: extractDecl (ClsInstD)"
_ -> error "internal: extractDecl"
@@ -1112,12 +1112,12 @@ 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 ->
+ 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)))))
_ -> extractRecSel nm t tvs rest
where
matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)]
- matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds
+ matching_fields flds = [ (l,f) | f@(L _ (ConDeclField _ ns _ _)) <- flds
, L l n <- ns, extFieldOcc n == nm ]
data_ty
-- ResTyGADT _ ty <- con_res con = ty
@@ -1142,8 +1142,8 @@ mkVisibleNames (_, _, _, instMap) exports opts
where subs = map fst (expItemSubDocs e)
patsyns = concatMap (getMainDeclBinder . fst) (expItemPats e)
name = case unLoc $ expItemDecl e of
- InstD d -> maybeToList $ M.lookup (getInstLoc d) instMap
- decl -> getMainDeclBinder decl
+ InstD _ d -> maybeToList $ M.lookup (getInstLoc d) instMap
+ decl -> getMainDeclBinder decl
exportName ExportNoDecl {} = [] -- we don't count these as visible, since
-- we don't want links to go to them.
exportName _ = []
@@ -1184,7 +1184,7 @@ findNamedDoc name = search
search [] = do
tell ["Cannot find documentation for: $" ++ name]
return Nothing
- search (DocD (DocCommentNamed name' doc) : rest)
+ search (DocD _ (DocCommentNamed name' doc) : rest)
| name == name' = return (Just doc)
| otherwise = search rest
search (_other_decl : rest) = search rest
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 0652ae47..5b588964 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -21,6 +21,7 @@ import Haddock.Types
import Bag (emptyBag)
import GHC hiding (NoLink)
import Name
+import Outputable ( panic )
import Control.Applicative
import Control.Monad hiding (mapM)
@@ -188,14 +189,15 @@ renameMaybeLKind :: Maybe (LHsKind GhcRn) -> RnM (Maybe (LHsKind DocNameI))
renameMaybeLKind = traverse renameLKind
renameFamilyResultSig :: LFamilyResultSig GhcRn -> RnM (LFamilyResultSig DocNameI)
-renameFamilyResultSig (L loc NoSig)
- = return (L loc NoSig)
-renameFamilyResultSig (L loc (KindSig ki))
+renameFamilyResultSig (L loc (NoSig _))
+ = return (L loc (NoSig noExt))
+renameFamilyResultSig (L loc (KindSig _ ki))
= do { ki' <- renameLKind ki
- ; return (L loc (KindSig ki')) }
-renameFamilyResultSig (L loc (TyVarSig bndr))
+ ; return (L loc (KindSig noExt ki')) }
+renameFamilyResultSig (L loc (TyVarSig _ bndr))
= do { bndr' <- renameLTyVarBndr bndr
- ; return (L loc (TyVarSig bndr')) }
+ ; return (L loc (TyVarSig noExt bndr')) }
+renameFamilyResultSig (L _ (XFamilyResultSig _)) = panic "haddock:renameFamilyResultSig"
renameInjectivityAnn :: LInjectivityAnn GhcRn -> RnM (LInjectivityAnn DocNameI)
renameInjectivityAnn (L loc (InjectivityAnn lhs rhs))
@@ -212,55 +214,55 @@ renameType t = case t of
HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do
tyvars' <- mapM renameLTyVarBndr tyvars
ltype' <- renameLType ltype
- return (HsForAllTy { hst_xforall = PlaceHolder, hst_bndrs = tyvars', hst_body = ltype' })
+ return (HsForAllTy { hst_xforall = NoExt, hst_bndrs = tyvars', hst_body = ltype' })
HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do
lcontext' <- renameLContext lcontext
ltype' <- renameLType ltype
- return (HsQualTy { hst_xqual = PlaceHolder, hst_ctxt = lcontext', hst_body = ltype' })
+ return (HsQualTy { hst_xqual = NoExt, hst_ctxt = lcontext', hst_body = ltype' })
- HsTyVar _ ip (L l n) -> return . HsTyVar PlaceHolder ip . L l =<< rename n
- HsBangTy _ b ltype -> return . HsBangTy PlaceHolder b =<< renameLType ltype
+ HsTyVar _ ip (L l n) -> return . HsTyVar NoExt ip . L l =<< rename n
+ HsBangTy _ b ltype -> return . HsBangTy NoExt b =<< renameLType ltype
HsAppTy _ a b -> do
a' <- renameLType a
b' <- renameLType b
- return (HsAppTy PlaceHolder a' b')
+ return (HsAppTy NoExt a' b')
HsFunTy _ a b -> do
a' <- renameLType a
b' <- renameLType b
- return (HsFunTy PlaceHolder a' b')
+ return (HsFunTy NoExt a' b')
- HsListTy _ ty -> return . (HsListTy PlaceHolder) =<< renameLType ty
- HsPArrTy _ ty -> return . (HsPArrTy PlaceHolder) =<< renameLType ty
- HsIParamTy _ n ty -> liftM (HsIParamTy PlaceHolder n) (renameLType ty)
- HsEqTy _ ty1 ty2 -> liftM2 (HsEqTy PlaceHolder) (renameLType ty1) (renameLType ty2)
+ HsListTy _ ty -> return . (HsListTy NoExt) =<< renameLType ty
+ HsPArrTy _ ty -> return . (HsPArrTy NoExt) =<< renameLType ty
+ HsIParamTy _ n ty -> liftM (HsIParamTy NoExt n) (renameLType ty)
+ HsEqTy _ ty1 ty2 -> liftM2 (HsEqTy NoExt) (renameLType ty1) (renameLType ty2)
- HsTupleTy _ b ts -> return . HsTupleTy PlaceHolder b =<< mapM renameLType ts
- HsSumTy _ ts -> HsSumTy PlaceHolder <$> mapM renameLType ts
+ HsTupleTy _ b ts -> return . HsTupleTy NoExt b =<< mapM renameLType ts
+ HsSumTy _ ts -> HsSumTy NoExt <$> mapM renameLType ts
HsOpTy _ a (L loc op) b -> do
op' <- rename op
a' <- renameLType a
b' <- renameLType b
- return (HsOpTy PlaceHolder a' (L loc op') b')
+ return (HsOpTy NoExt a' (L loc op') b')
- HsParTy _ ty -> return . (HsParTy PlaceHolder) =<< renameLType ty
+ HsParTy _ ty -> return . (HsParTy NoExt) =<< renameLType ty
HsKindSig _ ty k -> do
ty' <- renameLType ty
k' <- renameLKind k
- return (HsKindSig PlaceHolder ty' k')
+ return (HsKindSig NoExt ty' k')
HsDocTy _ ty doc -> do
ty' <- renameLType ty
doc' <- renameLDocHsSyn doc
- return (HsDocTy PlaceHolder ty' doc')
+ return (HsDocTy NoExt ty' doc')
- HsTyLit _ x -> return (HsTyLit PlaceHolder x)
+ HsTyLit _ x -> return (HsTyLit NoExt x)
- HsRecTy _ a -> HsRecTy PlaceHolder <$> mapM renameConDeclFieldField a
+ HsRecTy _ a -> HsRecTy NoExt <$> mapM renameConDeclFieldField a
(XHsType (NHsCoreTy a)) -> pure (XHsType (NHsCoreTy a))
HsExplicitListTy x i b -> HsExplicitListTy x i <$> mapM renameLType b
HsExplicitTupleTy x b -> HsExplicitTupleTy x <$> mapM renameLType b
@@ -269,10 +271,11 @@ renameType t = case t of
HsAppsTy _ _ -> error "renameType: HsAppsTy"
renameLHsQTyVars :: LHsQTyVars GhcRn -> RnM (LHsQTyVars DocNameI)
-renameLHsQTyVars (HsQTvs { hsq_implicit = _, hsq_explicit = tvs })
+renameLHsQTyVars (HsQTvs { hsq_explicit = tvs })
= do { tvs' <- mapM renameLTyVarBndr tvs
- ; return (HsQTvs { hsq_implicit = error "haddock:renameLHsQTyVars", hsq_explicit = tvs', hsq_dependent = error "haddock:renameLHsQTyVars" }) }
- -- This is rather bogus, but I'm not sure what else to do
+ ; return (HsQTvs { hsq_ext = noExt
+ , hsq_explicit = tvs' }) }
+renameLHsQTyVars (XLHsQTyVars _) = panic "haddock:renameLHsQTyVars"
renameLTyVarBndr :: LHsTyVarBndr GhcRn -> RnM (LHsTyVarBndr DocNameI)
renameLTyVarBndr (L loc (UserTyVar x (L l n)))
@@ -289,8 +292,8 @@ renameLContext (L loc context) = do
context' <- mapM renameLType context
return (L loc context')
-renameWildCardInfo :: HsWildCardInfo GhcRn -> RnM (HsWildCardInfo DocNameI)
-renameWildCardInfo (AnonWildCard (L l name)) = AnonWildCard . L l <$> rename name
+renameWildCardInfo :: HsWildCardInfo -> RnM HsWildCardInfo
+renameWildCardInfo (AnonWildCard (L l name)) = return (AnonWildCard (L l name))
renameInstHead :: InstHead GhcRn -> RnM (InstHead DocNameI)
renameInstHead InstHead {..} = do
@@ -321,21 +324,21 @@ renamePats = mapM
renameDecl :: HsDecl GhcRn -> RnM (HsDecl DocNameI)
renameDecl decl = case decl of
- TyClD d -> do
+ TyClD _ d -> do
d' <- renameTyClD d
- return (TyClD d')
- SigD s -> do
+ return (TyClD noExt d')
+ SigD _ s -> do
s' <- renameSig s
- return (SigD s')
- ForD d -> do
+ return (SigD noExt s')
+ ForD _ d -> do
d' <- renameForD d
- return (ForD d')
- InstD d -> do
+ return (ForD noExt d')
+ InstD _ d -> do
d' <- renameInstD d
- return (InstD d')
- DerivD d -> do
+ return (InstD noExt d')
+ DerivD _ d -> do
d' <- renameDerivD d
- return (DerivD d')
+ return (DerivD noExt d')
_ -> error "renameDecl"
renameLThing :: (a GhcRn -> RnM (a DocNameI)) -> Located (a GhcRn) -> RnM (Located (a DocNameI))
@@ -346,19 +349,21 @@ renameTyClD d = case d of
-- TyFamily flav lname ltyvars kind tckind -> do
FamDecl { tcdFam = decl } -> do
decl' <- renameFamilyDecl decl
- return (FamDecl { tcdFam = decl' })
+ return (FamDecl { tcdFExt = noExt, tcdFam = decl' })
- SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdRhs = rhs, tcdFVs = _fvs } -> do
+ SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdRhs = rhs } -> do
lname' <- renameL lname
tyvars' <- renameLHsQTyVars tyvars
rhs' <- renameLType rhs
- return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdFixity = fixity, tcdRhs = rhs', tcdFVs = placeHolderNames })
+ return (SynDecl { tcdSExt = noExt, tcdLName = lname', tcdTyVars = tyvars'
+ , tcdFixity = fixity, tcdRhs = rhs' })
- DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn, tcdFVs = _fvs } -> do
+ DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn } -> do
lname' <- renameL lname
tyvars' <- renameLHsQTyVars tyvars
defn' <- renameDataDefn defn
- return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdFixity = fixity, tcdDataDefn = defn', tcdDataCusk = PlaceHolder, tcdFVs = placeHolderNames })
+ return (DataDecl { tcdDExt = noExt, tcdLName = lname', tcdTyVars = tyvars'
+ , tcdFixity = fixity, tcdDataDefn = defn' })
ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars, tcdFixity = fixity
, tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do
@@ -373,7 +378,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 = [], tcdFVs = placeHolderNames })
+ , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdCExt = NoExt })
+ XTyClDecl _ -> panic "haddock:renameTyClD"
where
renameLFunDep (L loc (xs, ys)) = do
@@ -394,11 +400,12 @@ renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname
ltyvars' <- renameLHsQTyVars ltyvars
result' <- renameFamilyResultSig result
injectivity' <- renameMaybeInjectivityAnn injectivity
- return (FamilyDecl { fdInfo = info', fdLName = lname'
+ return (FamilyDecl { fdExt = noExt, fdInfo = info', fdLName = lname'
, fdTyVars = ltyvars'
, fdFixity = fixity
, fdResultSig = result'
, fdInjectivityAnn = injectivity' })
+renameFamilyDecl (XFamilyDecl _) = panic "renameFamilyDecl"
renamePseudoFamilyDecl :: PseudoFamilyDecl GhcRn
@@ -424,9 +431,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_ND = nd, dd_ctxt = lcontext', dd_cType = cType
+ return (HsDataDefn { dd_ext = noExt
+ , dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType
, dd_kindSig = k', dd_cons = cons'
, dd_derivs = noLoc [] })
+renameDataDefn (XHsDataDefn _) = panic "haddock:renameDataDefn"
renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI)
renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars
@@ -437,7 +446,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_name = lname', con_ex_tvs = ltyvars'
+ return (decl { con_ext = noExt, con_name = lname', con_ex_tvs = ltyvars'
, con_mb_cxt = lcontext'
, con_args = details', con_doc = mbldoc' })
@@ -451,9 +460,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_names = lnames', con_qvars = ltyvars'
+ return (decl { con_g_ext = noExt, 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"
renameDetails :: HsConDeclDetails GhcRn -> RnM (HsConDeclDetails DocNameI)
renameDetails (RecCon (L l fields)) = do
@@ -466,11 +476,12 @@ renameDetails (InfixCon a b) = do
return (InfixCon a' b')
renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI)
-renameConDeclFieldField (L l (ConDeclField names t doc)) = do
+renameConDeclFieldField (L l (ConDeclField _ names t doc)) = do
names' <- mapM renameLFieldOcc names
t' <- renameLType t
doc' <- mapM renameLDocHsSyn doc
- return $ L l (ConDeclField names' t' doc')
+ return $ L l (ConDeclField noExt names' t' doc')
+renameConDeclFieldField (L _ (XConDeclField _)) = panic "haddock:renameConDeclFieldField"
renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI)
renameLFieldOcc (L l (FieldOcc sel lbl)) = do
@@ -503,35 +514,39 @@ renameSig sig = case sig of
renameForD :: ForeignDecl GhcRn -> RnM (ForeignDecl DocNameI)
-renameForD (ForeignImport lname ltype co x) = do
+renameForD (ForeignImport _ lname ltype x) = do
lname' <- renameL lname
ltype' <- renameLSigType ltype
- return (ForeignImport lname' ltype' co x)
-renameForD (ForeignExport lname ltype co x) = do
+ return (ForeignImport noExt lname' ltype' x)
+renameForD (ForeignExport _ lname ltype x) = do
lname' <- renameL lname
ltype' <- renameLSigType ltype
- return (ForeignExport lname' ltype' co x)
+ return (ForeignExport noExt lname' ltype' x)
+renameForD (XForeignDecl _) = panic "haddock:renameForD"
renameInstD :: InstDecl GhcRn -> RnM (InstDecl DocNameI)
renameInstD (ClsInstD { cid_inst = d }) = do
d' <- renameClsInstD d
- return (ClsInstD { cid_inst = d' })
+ return (ClsInstD { cid_d_ext = noExt, cid_inst = d' })
renameInstD (TyFamInstD { tfid_inst = d }) = do
d' <- renameTyFamInstD d
- return (TyFamInstD { tfid_inst = d' })
+ return (TyFamInstD { tfid_ext = noExt, tfid_inst = d' })
renameInstD (DataFamInstD { dfid_inst = d }) = do
d' <- renameDataFamInstD d
- return (DataFamInstD { dfid_inst = d' })
+ return (DataFamInstD { dfid_ext = noExt, dfid_inst = d' })
+renameInstD (XInstDecl _) = panic "haddock:renameInstD"
renameDerivD :: DerivDecl GhcRn -> RnM (DerivDecl DocNameI)
renameDerivD (DerivDecl { deriv_type = ty
, deriv_strategy = strat
, deriv_overlap_mode = omode }) = do
ty' <- renameLSigWcType ty
- return (DerivDecl { deriv_type = ty'
+ return (DerivDecl { deriv_ext = noExt
+ , deriv_type = ty'
, deriv_strategy = strat
, deriv_overlap_mode = omode })
+renameDerivD (XDerivDecl _) = panic "haddock:renameDerivD"
renameClsInstD :: ClsInstDecl GhcRn -> RnM (ClsInstDecl DocNameI)
renameClsInstD (ClsInstDecl { cid_overlap_mode = omode
@@ -540,10 +555,11 @@ renameClsInstD (ClsInstDecl { cid_overlap_mode = omode
ltype' <- renameLSigType ltype
lATs' <- mapM (mapM renameTyFamInstD) lATs
lADTs' <- mapM (mapM renameDataFamInstD) lADTs
- return (ClsInstDecl { cid_overlap_mode = omode
+ return (ClsInstDecl { cid_ext = noExt, 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"
renameTyFamInstD :: TyFamInstDecl GhcRn -> RnM (TyFamInstDecl DocNameI)
@@ -563,10 +579,12 @@ renameTyFamInstEqn eqn
= do { tc' <- renameL tc
; pats' <- mapM renameLType pats
; rhs' <- renameLType rhs
- ; return (FamEqn { feqn_tycon = tc'
+ ; return (FamEqn { feqn_ext = noExt
+ , feqn_tycon = tc'
, feqn_pats = pats'
, feqn_fixity = fixity
, feqn_rhs = rhs' }) }
+ rename_ty_fam_eqn (XFamEqn _) = panic "haddock:renameTyFamInstEqn"
renameLTyFamDefltEqn :: LTyFamDefltEqn GhcRn -> RnM (LTyFamDefltEqn DocNameI)
renameLTyFamDefltEqn (L loc (FamEqn { feqn_tycon = tc, feqn_pats = tvs
@@ -574,10 +592,12 @@ renameLTyFamDefltEqn (L loc (FamEqn { feqn_tycon = tc, feqn_pats = tvs
= do { tc' <- renameL tc
; tvs' <- renameLHsQTyVars tvs
; rhs' <- renameLType rhs
- ; return (L loc (FamEqn { feqn_tycon = tc'
+ ; return (L loc (FamEqn { feqn_ext = noExt
+ , feqn_tycon = tc'
, feqn_pats = tvs'
, feqn_fixity = fixity
, feqn_rhs = rhs' })) }
+renameLTyFamDefltEqn (L _ (XFamEqn _)) = panic "haddock:renameLTyFamDefltEqn"
renameDataFamInstD :: DataFamInstDecl GhcRn -> RnM (DataFamInstDecl DocNameI)
renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn })
@@ -592,10 +612,12 @@ renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn })
= do { tc' <- renameL tc
; pats' <- mapM renameLType pats
; defn' <- renameDataDefn defn
- ; return (FamEqn { feqn_tycon = tc'
+ ; return (FamEqn { feqn_ext = noExt
+ , feqn_tycon = tc'
, feqn_pats = pats'
, feqn_fixity = fixity
, feqn_rhs = defn' }) }
+ rename_data_fam_eqn (XFamEqn _) = panic "haddock:renameDataFamInstD"
renameImplicit :: (in_thing -> RnM out_thing)
-> HsImplicitBndrs GhcRn in_thing
@@ -603,8 +625,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_vars = PlaceHolder
- , hsib_closed = PlaceHolder }) }
+ , hsib_ext = noExt }) }
+renameImplicit _ (XHsImplicitBndrs _) = panic "haddock:renameImplicit"
renameWc :: (in_thing -> RnM out_thing)
-> HsWildCardBndrs GhcRn in_thing
@@ -612,7 +634,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_wcs = PlaceHolder }) }
+ , hswc_ext = noExt }) }
+renameWc _ (XHsWildCardBndrs _) = panic "haddock:renameWc"
renameDocInstance :: DocInstance GhcRn -> RnM (DocInstance DocNameI)
renameDocInstance (inst, idoc, L l n) = do
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index b84a676f..c49663db 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -110,7 +110,7 @@ sugar = sugarOperators . sugarTuples . sugarLists
sugarLists :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p)
sugarLists (HsAppTy _ (L _ (HsTyVar _ _ (L _ name))) ltyp)
- | isBuiltInSyntax name' && strName == "[]" = HsListTy PlaceHolder ltyp
+ | isBuiltInSyntax name' && strName == "[]" = HsListTy NoExt ltyp
where
name' = getName name
strName = occNameString . nameOccName $ name'
@@ -124,7 +124,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 PlaceHolder HsBoxedTuple apps
+ | isBuiltInSyntax name' && suitable = HsTupleTy NoExt HsBoxedTuple apps
where
name' = getName name
strName = occNameString . nameOccName $ name'
@@ -137,7 +137,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
- | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy PlaceHolder la lb
+ | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy NoExt 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 2234894c..99fccf2a 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -381,11 +381,12 @@ mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl
}
where
mkType (KindedTyVar _ (L loc name) lkind) =
- HsKindSig PlaceHolder tvar lkind
+ HsKindSig NoExt tvar lkind
where
- tvar = L loc (HsTyVar PlaceHolder NotPromoted (L loc name))
- mkType (UserTyVar _ name) = HsTyVar PlaceHolder NotPromoted name
+ 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"
-- | An instance head that may have documentation and a source location.
@@ -652,54 +653,77 @@ instance Monad ErrMsgGhc where
-- * Pass sensitive types
-----------------------------------------------------------------------------
-type instance PostRn DocNameI NameSet = PlaceHolder
-type instance PostRn DocNameI Fixity = PlaceHolder
-type instance PostRn DocNameI Bool = PlaceHolder
-type instance PostRn DocNameI Name = DocName
-type instance PostRn DocNameI (Located Name) = Located DocName
-type instance PostRn DocNameI [Name] = PlaceHolder
-type instance PostRn DocNameI DocName = DocName
-
-type instance PostTc DocNameI Kind = PlaceHolder
-type instance PostTc DocNameI Type = PlaceHolder
-type instance PostTc DocNameI Coercion = PlaceHolder
-
-
-type instance XForAllTy DocNameI = PlaceHolder
-type instance XQualTy DocNameI = PlaceHolder
-type instance XTyVar DocNameI = PlaceHolder
-type instance XAppsTy DocNameI = PlaceHolder
-type instance XAppTy DocNameI = PlaceHolder
-type instance XFunTy DocNameI = PlaceHolder
-type instance XListTy DocNameI = PlaceHolder
-type instance XPArrTy DocNameI = PlaceHolder
-type instance XTupleTy DocNameI = PlaceHolder
-type instance XSumTy DocNameI = PlaceHolder
-type instance XOpTy DocNameI = PlaceHolder
-type instance XParTy DocNameI = PlaceHolder
-type instance XIParamTy DocNameI = PlaceHolder
-type instance XEqTy DocNameI = PlaceHolder
-type instance XKindSig DocNameI = PlaceHolder
-type instance XSpliceTy DocNameI = PlaceHolder
-type instance XDocTy DocNameI = PlaceHolder
-type instance XBangTy DocNameI = PlaceHolder
-type instance XRecTy DocNameI = PlaceHolder
-type instance XExplicitListTy DocNameI = PlaceHolder
-type instance XExplicitTupleTy DocNameI = PlaceHolder
-type instance XTyLit DocNameI = PlaceHolder
-type instance XWildCardTy DocNameI = HsWildCardInfo DocNameI
+type instance XForAllTy DocNameI = NoExt
+type instance XQualTy DocNameI = NoExt
+type instance XTyVar DocNameI = NoExt
+type instance XAppsTy DocNameI = NoExt
+type instance XAppTy DocNameI = NoExt
+type instance XFunTy DocNameI = NoExt
+type instance XListTy DocNameI = NoExt
+type instance XPArrTy 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 XEqTy 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 = HsWildCardInfo
type instance XXType DocNameI = NewHsTypeX
-type instance XUserTyVar DocNameI = PlaceHolder
-type instance XKindedTyVar DocNameI = PlaceHolder
-type instance XXTyVarBndr DocNameI = PlaceHolder
+type instance XUserTyVar DocNameI = NoExt
+type instance XKindedTyVar DocNameI = NoExt
+type instance XXTyVarBndr DocNameI = NoExt
type instance XFieldOcc DocNameI = DocName
-type instance XXFieldOcc DocNameI = PlaceHolder
-
-type instance XFixitySig DocNameI = PlaceHolder
-type instance XFixSig DocNameI = PlaceHolder
-type instance XPatSynSig DocNameI = PlaceHolder
-type instance XClassOpSig DocNameI = PlaceHolder
-type instance XTypeSig DocNameI = PlaceHolder
-type instance XMinimalSig DocNameI = PlaceHolder
+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 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
+
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 1ebf7ffa..e3cc9655 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -64,6 +64,7 @@ import GHC
import Name
import NameSet ( emptyNameSet )
import HsTypes (extFieldOcc)
+import Outputable ( panic )
import Control.Monad ( liftM )
import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr )
@@ -152,7 +153,7 @@ addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine
lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn]
lHsQTyVarsToTypes tvs
- = [ noLoc (HsTyVar PlaceHolder NotPromoted (noLoc (hsLTyVarName tv)))
+ = [ noLoc (HsTyVar NoExt NotPromoted (noLoc (hsLTyVarName tv)))
| tv <- hsQTvExplicit tvs ]
--------------------------------------------------------------------------------
@@ -162,10 +163,10 @@ lHsQTyVarsToTypes tvs
restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn
restrictTo names (L loc decl) = L loc $ case decl of
- TyClD d | isDataDecl d ->
- TyClD (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) })
- TyClD d | isClassDecl d ->
- TyClD (d { tcdSigs = restrictDecls names (tcdSigs d),
+ TyClD x d | isDataDecl d ->
+ TyClD x (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) })
+ TyClD x d | isClassDecl d ->
+ TyClD x (d { tcdSigs = restrictDecls names (tcdSigs d),
tcdATs = restrictATs names (tcdATs d) })
_ -> decl
@@ -178,6 +179,7 @@ restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons })
[] -> defn { dd_ND = DataType, dd_cons = [] }
[con] -> defn { dd_cons = [con] }
_ -> error "Should not happen"
+restrictDataDefn _ (XHsDataDefn _) = error "restrictDataDefn"
restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn]
restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
@@ -195,9 +197,10 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
InfixCon _ _ -> Just d
where
field_avail :: LConDeclField GhcRn -> Bool
- field_avail (L _ (ConDeclField fs _ _))
+ field_avail (L _ (ConDeclField _ fs _ _))
= all (\f -> extFieldOcc (unLoc f) `elem` names) fs
- field_types flds = [ t | ConDeclField _ t _ <- flds ]
+ field_avail (L _ (XConDeclField _)) = panic "haddock:field_avail"
+ field_types flds = [ t | ConDeclField _ _ t _ <- flds ]
keep _ = Nothing
@@ -208,13 +211,14 @@ restrictDecls names = mapMaybe (filterLSigNames (`elem` names))
restrictATs :: [Name] -> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn]
restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ]
-emptyHsQTvs :: LHsQTyVars Name
+emptyHsQTvs :: LHsQTyVars GhcRn
-- This function is here, rather than in HsTypes, because it *renamed*, but
-- does not necessarily have all the rigt kind variables. It is used
-- in Haddock just for printing, so it doesn't matter
-emptyHsQTvs = HsQTvs { hsq_implicit = error "haddock:emptyHsQTvs"
- , hsq_explicit = []
- , hsq_dependent = error "haddock:emptyHsQTvs" }
+emptyHsQTvs = HsQTvs { hsq_ext = HsQTvsRn
+ { hsq_implicit = error "haddock:emptyHsQTvs"
+ , hsq_dependent = error "haddock:emptyHsQTvs" }
+ , hsq_explicit = [] }
--------------------------------------------------------------------------------
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-21 10:36:50 +0000