aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs16
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs36
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs48
-rw-r--r--haddock-api/src/Haddock/Convert.hs104
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs90
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs68
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs134
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs8
-rw-r--r--haddock-api/src/Haddock/Types.hs152
-rw-r--r--haddock-api/src/Haddock/Utils.hs12
10 files changed, 347 insertions, 321 deletions
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 04:33:03 +0000