diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index e9433d730dec3ec71e0e22c9478b2d047b0b753a..730f4f5ce555eadaea971292c6e33587f2930b75 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -194,6 +194,7 @@ test-suite spec
, exceptions
, filepath
, ghc-boot
+ , ghc-boot-th
, transformers
build-tool-depends:
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 1a0cccf7c4a7487fd301146c6e66e828124192d7..e70a705fbef1dc7498fcdf3c8e61122f2cc27caa 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -72,7 +72,7 @@ ppModule dflags unit_state iface =
---------------------------------------------------------------------
-- Utility functions
-dropHsDocTy :: HsSigType (GhcPass p) -> HsSigType (GhcPass p)
+dropHsDocTy :: HsSigType GhcRn -> HsSigType GhcRn
dropHsDocTy = drop_sig_ty
where
drop_sig_ty (HsSig x a b) = HsSig x a (drop_lty b)
@@ -94,8 +94,7 @@ dropHsDocTy = drop_sig_ty
drop_ty (HsDocTy _ a _) = drop_ty $ unL a
drop_ty x = x
-outHsSigType :: (OutputableBndrId p, NoGhcTcPass p ~ p)
- => DynFlags -> HsSigType (GhcPass p) -> String
+outHsSigType :: DynFlags -> HsSigType GhcRn -> String
outHsSigType dflags = out dflags . reparenSigType . dropHsDocTy
@@ -154,13 +153,13 @@ ppSigWithDoc dflags sig subdocs = case sig of
PatSynSig _ names t -> concatMap (mkDocSig "pattern " t) names
_ -> []
where
- mkDocSig leader typ n = mkSubdoc dflags n subdocs
- [leader ++ pp_sig dflags [n] typ]
+ mkDocSig leader typ n = mkSubdocN dflags n subdocs
+ [leader ++ pp_sig dflags [n] typ]
ppSig :: DynFlags -> Sig GhcRn -> [String]
ppSig dflags x = ppSigWithDoc dflags x []
-pp_sig :: DynFlags -> [Located Name] -> LHsSigType GhcRn -> String
+pp_sig :: DynFlags -> [LocatedN Name] -> LHsSigType GhcRn -> String
pp_sig dflags names (L _ typ) =
operator prettyNames ++ " :: " ++ outHsSigType dflags typ
where
@@ -187,7 +186,7 @@ ppClass dflags decl subdocs =
pprTyFam :: LFamilyDecl GhcRn -> SDoc
pprTyFam (L _ at) = vcat' $ map text $
- mkSubdoc dflags (fdLName at) subdocs (ppFam dflags at)
+ mkSubdocN dflags (fdLName at) subdocs (ppFam dflags at)
whereWrapper elems = vcat'
[ text "where" <+> lbrace
@@ -222,7 +221,7 @@ ppSynonym dflags x = [out dflags x]
ppData :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> [String]
ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs
- = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=noLoc [] }} :
+ = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=[] }} :
concatMap (ppCtor dflags decl subdocs . unLoc) (dd_cons defn)
where
@@ -235,7 +234,7 @@ ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs
ppData _ _ _ = panic "ppData"
-- | for constructors, and named-fields...
-lookupCon :: DynFlags -> [(Name, DocForDecl Name)] -> Located Name -> [String]
+lookupCon :: DynFlags -> [(Name, DocForDecl Name)] -> LocatedN Name -> [String]
lookupCon dflags subdocs (L _ name) = case lookup name subdocs of
Just (d, _) -> ppDocumentation dflags d
_ -> []
@@ -248,11 +247,11 @@ ppCtor dflags dat subdocs con@ConDeclH98 { con_args = con_args' }
f (PrefixCon _ args) = [typeSig name $ (map hsScaledThing args) ++ [resType]]
f (InfixCon a1 a2) = f $ PrefixCon [] [a1,a2]
f (RecCon (L _ recs)) = f (PrefixCon [] $ map (hsLinear . cd_fld_type . unLoc) recs) ++ concat
- [(concatMap (lookupCon dflags subdocs . noLoc . extFieldOcc . unLoc) (cd_fld_names r)) ++
+ [(concatMap (lookupCon dflags subdocs . noLocA . extFieldOcc . unLoc) (cd_fld_names r)) ++
[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 noExtField (HsUnrestrictedArrow NormalSyntax) x y)
+ funs = foldr1 (\x y -> reL $ HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) x y)
apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y)
typeSig nm flds = operator nm ++ " :: " ++
@@ -262,12 +261,12 @@ ppCtor dflags dat subdocs con@ConDeclH98 { con_args = con_args' }
-- docs for con_names on why it is a list to begin with.
name = commaSeparate dflags . map unL $ getConNames con
- tyVarArg (UserTyVar _ _ n) = HsTyVar noExtField NotPromoted n
- tyVarArg (KindedTyVar _ _ n lty) = HsKindSig noExtField (reL (HsTyVar noExtField NotPromoted n)) lty
+ tyVarArg (UserTyVar _ _ n) = HsTyVar noAnn NotPromoted n
+ tyVarArg (KindedTyVar _ _ n lty) = HsKindSig noAnn (reL (HsTyVar noAnn NotPromoted n)) lty
tyVarArg _ = panic "ppCtor"
resType = apps $ map reL $
- (HsTyVar noExtField NotPromoted (reL (tcdName dat))) :
+ (HsTyVar noAnn NotPromoted (reL (tcdName dat))) :
map (tyVarArg . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat)
ppCtor dflags _dat subdocs (ConDeclGADT { con_names = names
@@ -281,15 +280,15 @@ ppCtor dflags _dat subdocs (ConDeclGADT { con_names = names
name = out dflags $ map unL names
con_sig_ty = HsSig noExtField outer_bndrs theta_ty where
theta_ty = case mcxt of
- Just theta -> noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = Just theta, hst_body = tau_ty })
+ Just theta -> noLocA (HsQualTy { hst_xqual = noExtField, hst_ctxt = Just theta, hst_body = tau_ty })
Nothing -> tau_ty
tau_ty = foldr mkFunTy res_ty $
case args of PrefixConGADT pos_args -> map hsScaledThing pos_args
RecConGADT (L _ flds) -> map (cd_fld_type . unL) flds
- mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b)
+ mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) a b)
ppFixity :: DynFlags -> (Name, Fixity) -> [String]
-ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExtField [noLoc name] fixity) :: FixitySig GhcRn)]
+ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExtField [noLocA name] fixity) :: FixitySig GhcRn)]
---------------------------------------------------------------------
@@ -312,7 +311,10 @@ docWith dflags header d
lines header ++ ["" | header /= "" && isJust d] ++
maybe [] (showTags . markup (markupTag dflags)) d
-mkSubdoc :: DynFlags -> Located Name -> [(Name, DocForDecl Name)] -> [String] -> [String]
+mkSubdocN :: DynFlags -> LocatedN Name -> [(Name, DocForDecl Name)] -> [String] -> [String]
+mkSubdocN dflags n subdocs s = mkSubdoc dflags (n2l n) subdocs s
+
+mkSubdoc :: DynFlags -> LocatedA Name -> [(Name, DocForDecl Name)] -> [String] -> [String]
mkSubdoc dflags n subdocs s = concatMap (ppDocumentation dflags) getDoc ++ s
where
getDoc = maybe [] (return . fst) (lookup (unLoc n) subdocs)
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 2def35ae9c3be434437a8f606b8b442b1aa6dbaf..d9a2e0cd6e93cab211ba9361e730a3d06488fd4f 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -360,7 +360,7 @@ classify tok =
-- the GHC lexer for more), so we have to manually reverse this. The
-- following is a hammer: it smashes _all_ pragma-like block comments into
-- pragmas.
- ITblockComment c
+ ITblockComment c _
| isPrefixOf "{-#" c
, isSuffixOf "#-}" c -> TkPragma
| otherwise -> TkComment
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index e2e16947e76d21307d3e69c06c3a30aae8a0c24b..abf882f0b7b342ad862c79085ecb56c47e31cb62 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -390,10 +390,11 @@ ppFamHeader (FamilyDecl { fdLName = L _ name
injAnn = case injectivity of
Nothing -> empty
- Just (L _ (InjectivityAnn lhs rhs)) -> hsep ( decltt (text "|")
- : ppLDocName lhs
- : arrow unicode
- : map ppLDocName rhs)
+ Just (L _ (InjectivityAnn _ lhs rhs)) -> hsep ( decltt (text "|")
+ : ppLDocName lhs
+ : arrow unicode
+ : map ppLDocName rhs)
+ Just _ -> empty
@@ -597,8 +598,8 @@ rDoc = maybeDoc . fmap latexStripTrailingWhitespace
-------------------------------------------------------------------------------
-ppClassHdr :: Bool -> Maybe (Located [LHsType DocNameI]) -> DocName
- -> LHsQTyVars DocNameI -> [Located ([Located DocName], [Located DocName])]
+ppClassHdr :: Bool -> Maybe (LocatedC [LHsType DocNameI]) -> DocName
+ -> LHsQTyVars DocNameI -> [LHsFunDep DocNameI]
-> Bool -> LaTeX
ppClassHdr summ lctxt n tvs fds unicode =
keyword "class"
@@ -606,14 +607,16 @@ ppClassHdr summ lctxt n tvs fds unicode =
<+> ppAppDocNameNames summ n (tyvarNames tvs)
<+> ppFds fds unicode
-
-ppFds :: [Located ([Located DocName], [Located DocName])] -> Bool -> LaTeX
+-- ppFds :: [Located ([LocatedA DocName], [LocatedA DocName])] -> Bool -> LaTeX
+ppFds :: [LHsFunDep DocNameI] -> Bool -> LaTeX
ppFds fds unicode =
if null fds then empty else
char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds))
where
- fundep (vars1,vars2) = hsep (map (ppDocName . unLoc) vars1) <+> arrow unicode <+>
+ fundep (FunDep _ vars1 vars2)
+ = hsep (map (ppDocName . unLoc) vars1) <+> arrow unicode <+>
hsep (map (ppDocName . unLoc) vars2)
+ fundep (XFunDep _) = error "ppFds"
-- TODO: associated type defaults, docs on default methods
@@ -804,7 +807,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
decl = case con of
ConDeclH98{ con_args = det
, con_ex_tvs = tyVars
- , con_forall = L _ forall_
+ , con_forall = forall_
, con_mb_cxt = cxt
} -> let context = fromMaybeContext cxt
header_ = ppConstrHdr forall_ tyVars context unicode
@@ -893,7 +896,7 @@ ppSideBySideField subdocs unicode (ConDeclField _ names ltype _) =
-- | Pretty-print a bundled pattern synonym
-ppSideBySidePat :: [Located DocName] -- ^ pattern name(s)
+ppSideBySidePat :: [LocatedN DocName] -- ^ pattern name(s)
-> LHsSigType DocNameI -- ^ type of pattern(s)
-> DocForDecl DocName -- ^ doc map
-> Bool -- ^ unicode
@@ -1036,7 +1039,7 @@ sumParens = ubxparens . hsep . punctuate (text " |")
-- Stolen from Html and tweaked for LaTeX generation
-------------------------------------------------------------------------------
-ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocNameI) -> LaTeX
+ppLType, ppLParendType, ppLFunLhType :: Bool -> LHsType DocNameI -> LaTeX
ppLType unicode y = ppType unicode (unLoc y)
ppLParendType unicode y = ppParendType unicode (unLoc y)
ppLFunLhType unicode y = ppFunLhType unicode (unLoc y)
@@ -1104,9 +1107,9 @@ ppr_mono_ty (HsFunTy _ mult ty1 ty2) u
= sep [ ppr_mono_lty ty1 u
, arr <+> ppr_mono_lty ty2 u ]
where arr = case mult of
- HsLinearArrow _ -> lollipop u
+ HsLinearArrow _ _ -> lollipop u
HsUnrestrictedArrow _ -> arrow u
- HsExplicitMult _ m -> multAnnotation <> ppr_mono_lty m u <+> arrow u
+ HsExplicitMult _ _ m -> multAnnotation <> ppr_mono_lty m u <+> arrow u
ppr_mono_ty (HsBangTy _ b ty) u = ppBang b <> ppLParendType u ty
ppr_mono_ty (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name
@@ -1187,7 +1190,7 @@ ppOccName = text . occNameString
ppDocName :: DocName -> LaTeX
ppDocName = ppOccName . nameOccName . getName
-ppLDocName :: Located DocName -> LaTeX
+ppLDocName :: GenLocated l DocName -> LaTeX
ppLDocName (L _ d) = ppDocName d
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 1bdbf81bb3a9280cc2bdb4b0ca3da455f41fd97a..d390a95ac0215751533a06565097b82459870951 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -49,8 +49,7 @@ import qualified Data.Map as Map hiding ( Map )
import qualified Data.Set as Set hiding ( Set )
import Data.Ord ( comparing )
-import GHC.Driver.Session (Language(..))
-import GHC hiding ( NoLink, moduleInfo,LexicalFixity(..) )
+import GHC hiding ( NoLink, moduleInfo,LexicalFixity(..), anchor )
import GHC.Types.Name
import GHC.Unit.State
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index e48f9bdd009765ecc1042e7ae0fcc81c15dd9a53..8de1b1b85d8b6a80dd4eaf87c962e321672da971 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -58,22 +58,22 @@ ppDecl :: Bool -- ^ print summary info only
-> Qualification
-> Html
ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode pkg qual = case decl of
- TyClD _ (FamDecl _ d) -> ppFamDecl summ False links instances fixities loc mbDoc d splice unicode pkg qual
- TyClD _ d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode pkg qual
- TyClD _ d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode pkg qual
- TyClD _ d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode pkg qual
- SigD _ (TypeSig _ lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames
+ TyClD _ (FamDecl _ d) -> ppFamDecl summ False links instances fixities (locA loc) mbDoc d splice unicode pkg qual
+ TyClD _ d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs (locA loc) mbDoc d pats splice unicode pkg qual
+ TyClD _ d@(SynDecl {}) -> ppTySyn summ links fixities (locA loc) (mbDoc, fnArgsDoc) d splice unicode pkg qual
+ TyClD _ d@(ClassDecl {}) -> ppClassDecl summ links instances fixities (locA loc) mbDoc subdocs d splice unicode pkg qual
+ SigD _ (TypeSig _ lnames lty) -> ppLFunSig summ links (locA loc) (mbDoc, fnArgsDoc) lnames
(dropWildCards lty) fixities splice unicode pkg qual
- SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames
+ SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links (locA loc) (mbDoc, fnArgsDoc) lnames
lty fixities splice unicode pkg qual
- ForD _ d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual
+ ForD _ d -> ppFor summ links (locA loc) (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual
InstD _ _ -> noHtml
DerivD _ _ -> noHtml
_ -> error "declaration not supported by ppDecl"
ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
- [Located DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] ->
+ [LocatedN DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] ->
Splice -> Unicode -> Maybe Package -> Qualification -> Html
ppLFunSig summary links loc doc lnames lty fixities splice unicode pkg qual =
ppFunSig summary links loc noHtml doc (map unLoc lnames) lty fixities
@@ -90,7 +90,7 @@ ppFunSig summary links loc leader doc docnames typ fixities splice unicode pkg q
-- | Pretty print a pattern synonym
ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
- -> [Located DocName] -- ^ names of patterns in declaration
+ -> [LocatedN DocName] -- ^ names of patterns in declaration
-> LHsSigType DocNameI -- ^ type of patterns in declaration
-> [(DocName, Fixity)]
-> Splice -> Unicode -> Maybe Package -> Qualification -> Html
@@ -249,7 +249,7 @@ ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars
sig_type = mkHsImplicitSigTypeI ltype
hdr = hsep ([keyword "type", ppBinder summary occ]
++ ppTyVars unicode qual (hsQTvExplicit ltyvars))
- full = hdr <+> equals <+> ppPatSigType unicode qual (noLoc sig_type)
+ full = hdr <+> equals <+> ppPatSigType unicode qual (noLocA sig_type)
occ = nameOccName . getName $ name
fixs
| summary = noHtml
@@ -330,7 +330,7 @@ ppPseudoFamDecl links splice
, pfdTyVars = tvs
, pfdLName = L loc name })
unicode qual =
- topDeclElem links loc splice [name] leader
+ topDeclElem links (locA loc) splice [name] leader
where
leader = hsep [ ppFamilyLeader True info
, ppAppNameTypes name (map unLoc tvs) unicode qual
@@ -361,10 +361,11 @@ ppFamHeader summary associated (FamilyDecl { fdInfo = info
injAnn = case injectivity of
Nothing -> noHtml
- Just (L _ (InjectivityAnn lhs rhs)) -> hsep ( keyword "|"
- : ppLDocName qual Raw lhs
- : arrow unicode
- : map (ppLDocName qual Raw) rhs)
+ Just (L _ (InjectivityAnn _ lhs rhs)) -> hsep ( keyword "|"
+ : ppLDocName qual Raw lhs
+ : arrow unicode
+ : map (ppLDocName qual Raw) rhs)
+ Just _ -> error "ppFamHeader:XInjectivityAnn"
-- | Print the keywords that begin the family declaration
ppFamilyLeader :: Bool -> FamilyInfo DocNameI -> Html
@@ -474,8 +475,8 @@ ppHsContext cxt unicode qual = parenList (map (ppType unicode qual HideEmptyCont
-------------------------------------------------------------------------------
-ppClassHdr :: Bool -> Maybe (Located [LHsType DocNameI]) -> DocName
- -> LHsQTyVars DocNameI -> [Located ([Located DocName], [Located DocName])]
+ppClassHdr :: Bool -> Maybe (LocatedC [LHsType DocNameI]) -> DocName
+ -> LHsQTyVars DocNameI -> [LHsFunDep DocNameI]
-> Unicode -> Qualification -> Html
ppClassHdr summ lctxt n tvs fds unicode qual =
keyword "class"
@@ -484,12 +485,13 @@ ppClassHdr summ lctxt n tvs fds unicode qual =
<+> ppFds fds unicode qual
-ppFds :: [Located ([Located DocName], [Located DocName])] -> Unicode -> Qualification -> Html
+ppFds :: [LHsFunDep DocNameI] -> Unicode -> Qualification -> Html
ppFds fds unicode qual =
if null fds then noHtml else
char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds))
where
- fundep (vars1,vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2
+ fundep (FunDep _ vars1 vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2
+ fundep (XFunDep _) = error "ppFds"
ppVars = hsep . map ((ppDocName qual Prefix True) . unLoc)
ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocNameI -> SrcSpan
@@ -572,9 +574,9 @@ ppClassDecl summary links instances fixities loc d subdocs
lookupDAT name = Map.lookup (getName name) defaultAssocTys
defaultAssocTys = Map.fromList
[ (getName name, (vs, typ))
- | L _ (TyFamInstDecl (FamEqn { feqn_rhs = typ
- , feqn_tycon = L _ name
- , feqn_pats = vs })) <- atsDefs
+ | L _ (TyFamInstDecl _ (FamEqn { feqn_rhs = typ
+ , feqn_tycon = L _ name
+ , feqn_pats = vs })) <- atsDefs
]
-- Methods
@@ -723,7 +725,7 @@ ppInstanceSigs links splice unicode qual sigs = do
L _ rtyp = dropWildCards typ
-- Instance methods signatures are synified and thus don't have a useful
-- SrcSpan value. Use the methods name location instead.
- return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLoc $ head $ lnames) names rtyp
+ return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLocA $ head $ lnames) names rtyp
lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
@@ -828,7 +830,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 (getConNamesI (unLoc c)))) fixities
+ (map unL (getConNamesI (unLoc c)))) fixities
]
patternBit = subPatterns pkg qual
@@ -855,7 +857,7 @@ ppShortConstrParts summary dataInst con unicode qual
= case con of
ConDeclH98{ con_args = det
, con_ex_tvs = tyVars
- , con_forall = L _ forall_
+ , con_forall = forall_
, con_mb_cxt = cxt
} -> let context = fromMaybeContext cxt
header_ = ppConstrHdr forall_ tyVars context unicode qual
@@ -895,7 +897,7 @@ ppShortConstrParts summary dataInst con unicode qual
)
where
- occ = map (nameOccName . getName . unLoc) $ getConNamesI con
+ occ = map (nameOccName . getName . unL) $ getConNamesI con
ppOcc = hsep (punctuate comma (map (ppBinder summary) occ))
ppOccInfix = hsep (punctuate comma (map (ppBinderInfix summary) occ))
@@ -912,10 +914,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 (getConNamesI con))
+ aConName = unL (head (getConNamesI con))
fixity = ppFixities fixities qual
- occ = map (nameOccName . getName . unLoc) $ getConNamesI con
+ occ = map (nameOccName . getName . unL) $ getConNamesI con
ppOcc = hsep (punctuate comma (map (ppBinder False) occ))
ppOccInfix = hsep (punctuate comma (map (ppBinderInfix False) occ))
@@ -927,7 +929,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
decl = case con of
ConDeclH98{ con_args = det
, con_ex_tvs = tyVars
- , con_forall = L _ forall_
+ , con_forall = forall_
, con_mb_cxt = cxt
} -> let context = fromMaybeContext cxt
header_ = ppConstrHdr forall_ tyVars context unicode qual
@@ -994,7 +996,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
-- don't use "con_doc con", in case it's reconstructed from a .hi file,
-- or also because we want Haddock to do the doc-parsing, not GHC.
- mbDoc = lookup (unLoc $ head $ getConNamesI con) subdocs >>=
+ mbDoc = lookup (unL $ head $ getConNamesI con) subdocs >>=
combineDocumentation . fst
@@ -1044,7 +1046,7 @@ ppShortField summary unicode qual (ConDeclField _ names ltype _)
-- | Pretty print an expanded pattern (for bundled patterns)
ppSideBySidePat :: [(DocName, Fixity)] -> Unicode -> Qualification
- -> [Located DocName] -- ^ pattern name(s)
+ -> [LocatedN DocName] -- ^ pattern name(s)
-> LHsSigType DocNameI -- ^ type of pattern(s)
-> DocForDecl DocName -- ^ doc map
-> SubDecl
@@ -1121,7 +1123,7 @@ sumParens = ubxSumList
-- * Rendering of HsType
--------------------------------------------------------------------------------
-ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> Located (HsType DocNameI) -> Html
+ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> LHsType DocNameI -> Html
ppLType unicode qual emptyCtxts y = ppType unicode qual emptyCtxts (unLoc y)
ppLParendType unicode qual emptyCtxts y = ppParendType unicode qual emptyCtxts (unLoc y)
ppLFunLhType unicode qual emptyCtxts y = ppFunLhType unicode qual emptyCtxts (unLoc y)
@@ -1153,7 +1155,7 @@ instance RenderableBndrFlag () where
ppHsTyVarBndr _ qual (UserTyVar _ _ (L _ name)) =
ppDocName qual Raw False name
ppHsTyVarBndr unicode qual (KindedTyVar _ _ name kind) =
- parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+>
+ parens (ppDocName qual Raw False (unL name) <+> dcolon unicode <+>
ppLKind unicode qual kind)
instance RenderableBndrFlag Specificity where
@@ -1162,10 +1164,10 @@ instance RenderableBndrFlag Specificity where
ppHsTyVarBndr _ qual (UserTyVar _ InferredSpec (L _ name)) =
braces $ ppDocName qual Raw False name
ppHsTyVarBndr unicode qual (KindedTyVar _ SpecifiedSpec name kind) =
- parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+>
+ parens (ppDocName qual Raw False (unL name) <+> dcolon unicode <+>
ppLKind unicode qual kind)
ppHsTyVarBndr unicode qual (KindedTyVar _ InferredSpec name kind) =
- braces (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+>
+ braces (ppDocName qual Raw False (unL name) <+> dcolon unicode <+>
ppLKind unicode qual kind)
ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> Html
@@ -1246,9 +1248,9 @@ ppr_mono_ty (HsFunTy _ mult ty1 ty2) u q e =
, arr <+> ppr_mono_lty ty2 u q e
]
where arr = case mult of
- HsLinearArrow _ -> lollipop u
+ HsLinearArrow _ _ -> lollipop u
HsUnrestrictedArrow _ -> arrow u
- HsExplicitMult _ m -> multAnnotation <> ppr_mono_lty m u q e <+> arrow u
+ HsExplicitMult _ _ m -> multAnnotation <> ppr_mono_lty m u q e <+> arrow u
ppr_mono_ty (HsTupleTy _ con tys) u q _ =
tupleParens con (map (ppLType u q HideEmptyContexts) tys)
@@ -1283,7 +1285,7 @@ ppr_mono_ty (HsOpTy _ ty1 op ty2) unicode qual _
-- `(:)` is valid in type signature only as constructor to promoted list
-- and needs to be quoted in code so we explicitly quote it here too.
ppr_op
- | (getOccString . getName . unLoc) op == ":" = promoQuote ppr_op'
+ | (getOccString . getName . unL) op == ":" = promoQuote ppr_op'
| otherwise = ppr_op'
ppr_op' = ppLDocName qual Infix op
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
index 7670b1939a9ada5bec0f20e731d4ba43248db796..b8f5ac0fa2653d316cbf6929a91141f91fa253cc 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -31,7 +31,7 @@ import Haddock.Doc (combineDocumentation, emptyMetaDoc,
import Text.XHtml hiding ( name, p, quote )
import Data.Maybe (fromMaybe)
-import GHC
+import GHC hiding (anchor)
import GHC.Types.Name
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index d61d6d9bb8e7347717e7a717933931c77d28a5b9..8f04a21f01d9b9f911381c23c4bb0b8003565480 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -51,7 +51,7 @@ import Text.XHtml hiding ( name, title, quote )
import Data.Maybe (fromMaybe)
import GHC.Data.FastString ( unpackFS )
-import GHC
+import GHC hiding (anchor)
import GHC.Types.Name (nameOccName)
--------------------------------------------------------------------------------
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
index b324fa38366ca863a8f6e891f9d6d5ab43c635d9..6dfc60fae611a5e9c26c68fd9d8f59cc2a5b0c7e 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
@@ -27,7 +27,7 @@ import Text.XHtml hiding ( name, p, quote )
import qualified Data.Map as M
import Data.List ( stripPrefix )
-import GHC hiding (LexicalFixity(..))
+import GHC hiding (LexicalFixity(..), anchor)
import GHC.Types.Name
import GHC.Types.Name.Reader
import GHC.Data.FastString (unpackFS)
@@ -57,9 +57,10 @@ ppUncheckedLink _ x = linkIdOcc' mdl (Just occ) << occHtml
occHtml = toHtml (showWrapped (occNameString . snd) x) -- TODO: apply ppQualifyName
-- The Bool indicates if it is to be rendered in infix notation
-ppLDocName :: Qualification -> Notation -> Located DocName -> Html
+ppLDocName :: Qualification -> Notation -> GenLocated l DocName -> Html
ppLDocName qual notation (L _ d) = ppDocName qual notation True d
+
ppDocName :: Qualification -> Notation -> Bool -> DocName -> Html
ppDocName qual notation insertAnchors docName =
case docName of
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index a87ba7ced1db1c22b7501e6c2bdc8f52526fc62b..19630077b100b659d87e1cfa7c6c10544ef9a7f5 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -22,7 +22,7 @@ module Haddock.Convert (
#include "HsVersions.h"
import GHC.Data.Bag ( emptyBag )
-import GHC.Types.Basic ( TupleSort(..), PromotionFlag(..), DefMethSpec(..) )
+import GHC.Types.Basic ( TupleSort(..), PromotionFlag(..), DefMethSpec(..), TopLevelFlag(..) )
import GHC.Types.SourceText (SourceText(..))
import GHC.Types.Fixity (LexicalFixity(..))
import GHC.Core.Class
@@ -53,7 +53,6 @@ import GHC.Utils.Panic ( assertPanic )
import GHC.Types.Var
import GHC.Types.Var.Set
import GHC.Types.SrcLoc
-import GHC.Parser.Annotation (IsUnicodeSyntax(..))
import Haddock.Types
import Haddock.Interface.Specialize
@@ -92,20 +91,20 @@ tyThingToLHsDecl prr t = case t of
extractFamilyDecl _ =
Left "tyThingToLHsDecl: impossible associated tycon"
- cvt :: HsTyVarBndr flag (GhcPass p) -> HsType (GhcPass p)
+ cvt :: HsTyVarBndr flag GhcRn -> HsType GhcRn
-- Without this signature, we trigger GHC#18932
- cvt (UserTyVar _ _ n) = HsTyVar noExtField NotPromoted n
- cvt (KindedTyVar _ _ (L name_loc n) kind) = HsKindSig noExtField
- (L name_loc (HsTyVar noExtField NotPromoted (L name_loc n))) kind
+ cvt (UserTyVar _ _ n) = HsTyVar noAnn NotPromoted n
+ cvt (KindedTyVar _ _ (L name_loc n) kind) = HsKindSig noAnn
+ (L (na2la name_loc) (HsTyVar noAnn NotPromoted (L name_loc n))) kind
-- | Convert a LHsTyVarBndr to an equivalent LHsType.
- hsLTyVarBndrToType :: LHsTyVarBndr flag (GhcPass p) -> LHsType (GhcPass p)
+ hsLTyVarBndrToType :: LHsTyVarBndr flag GhcRn -> LHsType GhcRn
hsLTyVarBndrToType = mapLoc cvt
extractFamDefDecl :: FamilyDecl GhcRn -> Type -> TyFamDefltDecl GhcRn
extractFamDefDecl fd rhs =
- TyFamInstDecl $ FamEqn
- { feqn_ext = noExtField
+ TyFamInstDecl noAnn $ FamEqn
+ { feqn_ext = noAnn
, feqn_tycon = fdLName fd
, feqn_bndrs = HsOuterImplicit{hso_ximplicit = hsq_ext (fdTyVars fd)}
, feqn_pats = map (HsValArg . hsLTyVarBndrToType) $
@@ -119,8 +118,8 @@ tyThingToLHsDecl prr t = case t of
extractAtItem (ATI at_tc def) = do
tyDecl <- synifyTyCon prr Nothing at_tc
famDecl <- extractFamilyDecl tyDecl
- let defEqnTy = fmap (noLoc . extractFamDefDecl famDecl . fst) def
- pure (noLoc famDecl, defEqnTy)
+ let defEqnTy = fmap (noLocA . extractFamDefDecl famDecl . fst) def
+ pure (noLocA famDecl, defEqnTy)
atTyClDecls = map extractAtItem (classATItems cl)
(atFamDecls, atDefFamDecls) = unzip (rights atTyClDecls)
@@ -128,14 +127,14 @@ tyThingToLHsDecl prr t = case t of
in withErrs (lefts atTyClDecls) . TyClD noExtField $ ClassDecl
{ tcdCtxt = synifyCtx (classSCTheta cl)
- , tcdLName = synifyName cl
+ , tcdLName = synifyNameN cl
, tcdTyVars = synifyTyVars vs
, tcdFixity = synifyFixity cl
- , tcdFDs = map (\ (l,r) -> noLoc
- (map (noLoc . getName) l, map (noLoc . getName) r) ) $
+ , tcdFDs = map (\ (l,r) -> noLocA
+ (FunDep noAnn (map (noLocA . getName) l) (map (noLocA . getName) r)) ) $
snd $ classTvsFds cl
- , tcdSigs = noLoc (MinimalSig noExtField NoSourceText . noLoc . fmap noLoc $ classMinimalDef cl) :
- [ noLoc tcdSig
+ , tcdSigs = noLocA (MinimalSig noAnn NoSourceText . noLocA . fmap noLocA $ classMinimalDef cl) :
+ [ noLocA tcdSig
| clsOp <- classOpItems cl
, tcdSig <- synifyTcIdSig vs clsOp ]
, tcdMeths = emptyBag --ignore default method definitions, they don't affect signature
@@ -152,25 +151,25 @@ tyThingToLHsDecl prr t = case t of
ACoAxiom ax -> synifyAxiom ax >>= allOK
-- a data-constructor alone just gets rendered as a function:
- AConLike (RealDataCon dc) -> allOK $ SigD noExtField (TypeSig noExtField [synifyName dc]
+ AConLike (RealDataCon dc) -> allOK $ SigD noExtField (TypeSig noAnn [synifyNameN dc]
(synifySigWcType ImplicitizeForAll [] (dataConWrapperType dc)))
AConLike (PatSynCon ps) ->
- allOK . SigD noExtField $ PatSynSig noExtField [synifyName ps] (synifyPatSynSigType ps)
+ allOK . SigD noExtField $ PatSynSig noAnn [synifyNameN ps] (synifyPatSynSigType ps)
where
withErrs e x = return (e, x)
allOK x = return (mempty, x)
synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn GhcRn
synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
- = let name = synifyName tc
+ = let name = synifyNameN tc
args_types_only = filterOutInvisibleTypes tc args
typats = map (synifyType WithinType []) args_types_only
annot_typats = zipWith3 annotHsType args_poly args_types_only typats
hs_rhs = synifyType WithinType [] rhs
outer_bndrs = HsOuterImplicit{hso_ximplicit = map tyVarName tkvs}
-- TODO: this must change eventually
- in FamEqn { feqn_ext = noExtField
+ in FamEqn { feqn_ext = noAnn
, feqn_tycon = name
, feqn_bndrs = outer_bndrs
, feqn_pats = map HsValArg annot_typats
@@ -185,7 +184,7 @@ synifyAxiom ax@(CoAxiom { co_ax_tc = tc })
, Just branch <- coAxiomSingleBranch_maybe ax
= return $ InstD noExtField
$ TyFamInstD noExtField
- $ TyFamInstDecl { tfid_eqn = synifyAxBranch tc branch }
+ $ TyFamInstDecl { tfid_xtn = noAnn, tfid_eqn = synifyAxBranch tc branch }
| Just ax' <- isClosedSynFamilyTyConWithAxiom_maybe tc
, getUnique ax' == getUnique ax -- without the getUniques, type error
@@ -203,7 +202,7 @@ synifyTyCon
synifyTyCon prr _coax tc
| isFunTyCon tc || isPrimTyCon tc
= return $
- DataDecl { tcdLName = synifyName tc
+ DataDecl { tcdLName = synifyNameN tc
, tcdTyVars = HsQTvs { hsq_ext = [] -- No kind polymorphism
, hsq_explicit = zipWith mk_hs_tv
(map scaledThing tyVarKinds)
@@ -212,7 +211,7 @@ synifyTyCon prr _coax tc
, tcdFixity = synifyFixity tc
- , tcdDataDefn = HsDataDefn { dd_ext = noExtField
+ , tcdDataDefn = HsDataDefn { dd_ext = noAnn
, dd_ND = DataType -- arbitrary lie, they are neither
-- algebraic data nor newtype:
, dd_ctxt = Nothing
@@ -220,13 +219,13 @@ synifyTyCon prr _coax tc
, dd_kindSig = synifyDataTyConReturnKind tc
-- we have their kind accurately:
, dd_cons = [] -- No constructors
- , dd_derivs = noLoc [] }
+ , dd_derivs = [] }
, tcdDExt = DataDeclRn False emptyNameSet }
where
-- tyConTyVars doesn't work on fun/prim, but we can make them up:
mk_hs_tv realKind fakeTyVar
- | isLiftedTypeKind realKind = noLoc $ UserTyVar noExtField () (noLoc (getName fakeTyVar))
- | otherwise = noLoc $ KindedTyVar noExtField () (noLoc (getName fakeTyVar)) (synifyKindSig realKind)
+ | isLiftedTypeKind realKind = noLocA $ UserTyVar noAnn () (noLocA (getName fakeTyVar))
+ | otherwise = noLocA $ KindedTyVar noAnn () (noLocA (getName fakeTyVar)) (synifyKindSig realKind)
conKind = defaultType prr (tyConKind tc)
tyVarKinds = fst . splitFunTys . snd . splitInvisPiTys $ conKind
@@ -239,7 +238,7 @@ synifyTyCon _prr _coax tc
ClosedSynFamilyTyCon mb
| Just (CoAxiom { co_ax_branches = branches }) <- mb
-> mkFamDecl $ ClosedTypeFamily $ Just
- $ map (noLoc . synifyAxBranch tc) (fromBranches branches)
+ $ map (noLocA . synifyAxBranch tc) (fromBranches branches)
| otherwise
-> mkFamDecl $ ClosedTypeFamily $ Just []
BuiltInSynFamTyCon {}
@@ -251,9 +250,10 @@ synifyTyCon _prr _coax tc
where
resultVar = famTcResVar tc
mkFamDecl i = return $ FamDecl noExtField $
- FamilyDecl { fdExt = noExtField
+ FamilyDecl { fdExt = noAnn
, fdInfo = i
- , fdLName = synifyName tc
+ , fdTopLevel = TopLevel
+ , fdLName = synifyNameN tc
, fdTyVars = synifyTyVars (tyConVisibleTyVars tc)
, fdFixity = synifyFixity tc
, fdResultSig =
@@ -266,7 +266,7 @@ synifyTyCon _prr _coax tc
synifyTyCon _prr coax tc
| Just ty <- synTyConRhs_maybe tc
= return $ SynDecl { tcdSExt = emptyNameSet
- , tcdLName = synifyName tc
+ , tcdLName = synifyNameN tc
, tcdTyVars = synifyTyVars (tyConVisibleTyVars tc)
, tcdFixity = synifyFixity tc
, tcdRhs = synifyType WithinType [] ty }
@@ -276,9 +276,9 @@ synifyTyCon _prr coax tc
alg_nd = if isNewTyCon tc then NewType else DataType
alg_ctx = synifyCtx (tyConStupidTheta tc)
name = case coax of
- Just a -> synifyName a -- Data families are named according to their
+ Just a -> synifyNameN a -- Data families are named according to their
-- CoAxioms, not their TyCons
- _ -> synifyName tc
+ _ -> synifyNameN tc
tyvars = synifyTyVars (tyConVisibleTyVars tc)
kindSig = synifyDataTyConReturnKind tc
-- The data constructors.
@@ -301,8 +301,8 @@ synifyTyCon _prr coax tc
consRaw = map (synifyDataCon use_gadt_syntax) (tyConDataCons tc)
cons = rights consRaw
-- "deriving" doesn't affect the signature, no need to specify any.
- alg_deriv = noLoc []
- defn = HsDataDefn { dd_ext = noExtField
+ alg_deriv = []
+ defn = HsDataDefn { dd_ext = noAnn
, dd_ND = alg_nd
, dd_ctxt = alg_ctx
, dd_cType = Nothing
@@ -342,15 +342,15 @@ synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity
synifyInjectivityAnn Nothing _ _ = Nothing
synifyInjectivityAnn _ _ NotInjective = Nothing
synifyInjectivityAnn (Just lhs) tvs (Injective inj) =
- let rhs = map (noLoc . tyVarName) (filterByList inj tvs)
- in Just $ noLoc $ InjectivityAnn (noLoc lhs) rhs
+ let rhs = map (noLocA . tyVarName) (filterByList inj tvs)
+ in Just $ noLoc $ InjectivityAnn noAnn (noLocA lhs) rhs
synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig GhcRn
synifyFamilyResultSig Nothing kind
| isLiftedTypeKind kind = noLoc $ NoSig noExtField
| otherwise = noLoc $ KindSig noExtField (synifyKindSig kind)
synifyFamilyResultSig (Just name) kind =
- noLoc $ TyVarSig noExtField (noLoc $ KindedTyVar noExtField () (noLoc name) (synifyKindSig kind))
+ noLoc $ TyVarSig noExtField (noLocA $ KindedTyVar noAnn () (noLocA 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
@@ -364,7 +364,7 @@ synifyDataCon use_gadt_syntax dc =
-- infix *syntax*.
use_infix_syntax = dataConIsInfix dc
use_named_field_syntax = not (null field_tys)
- name = synifyName dc
+ name = synifyNameN dc
-- con_qvars means a different thing depending on gadt-syntax
(_univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc
user_tvbndrs = dataConUserTyVarBinders dc -- Used for GADT data constructors
@@ -384,18 +384,18 @@ synifyDataCon use_gadt_syntax dc =
let tySyn = synifyType WithinType [] (scaledThing ty)
in case bang of
(HsSrcBang _ NoSrcUnpack NoSrcStrict) -> tySyn
- bang' -> noLoc $ HsBangTy noExtField bang' tySyn)
+ bang' -> noLocA $ HsBangTy noAnn bang' tySyn)
arg_tys (dataConSrcBangs dc)
field_tys = zipWith con_decl_field (dataConFieldLabels dc) linear_tys
- con_decl_field fl synTy = noLoc $
- ConDeclField noExtField [noLoc $ FieldOcc (flSelector fl) (noLoc $ mkVarUnqual $ flLabel fl)] synTy
+ con_decl_field fl synTy = noLocA $
+ ConDeclField noAnn [noLoc $ FieldOcc (flSelector fl) (noLocA $ mkVarUnqual $ flLabel fl)] synTy
Nothing
mk_h98_arg_tys :: Either ErrMsg (HsConDeclH98Details GhcRn)
mk_h98_arg_tys = case (use_named_field_syntax, use_infix_syntax) of
(True,True) -> Left "synifyDataCon: contradiction!"
- (True,False) -> return $ RecCon (noLoc field_tys)
+ (True,False) -> return $ RecCon (noLocA field_tys)
(False,False) -> return $ PrefixCon noTypeArgs (map hsUnrestricted linear_tys)
(False,True) -> case linear_tys of
[a,b] -> return $ InfixCon (hsUnrestricted a) (hsUnrestricted b)
@@ -403,34 +403,37 @@ synifyDataCon use_gadt_syntax dc =
mk_gadt_arg_tys :: HsConDeclGADTDetails GhcRn
mk_gadt_arg_tys
- | use_named_field_syntax = RecConGADT (noLoc field_tys)
+ | use_named_field_syntax = RecConGADT (noLocA field_tys)
| otherwise = PrefixConGADT (map hsUnrestricted linear_tys)
-- finally we get synifyDataCon's result!
in if use_gadt_syntax
then do
let hat = mk_gadt_arg_tys
- return $ noLoc $ ConDeclGADT
- { con_g_ext = noExtField
+ return $ noLocA $ ConDeclGADT
+ { con_g_ext = noAnn
, con_names = [name]
- , con_bndrs = noLoc outer_bndrs
+ , con_bndrs = noLocA outer_bndrs
, con_mb_cxt = ctx
, con_g_args = hat
, con_res_ty = synifyType WithinType [] res_ty
, con_doc = Nothing }
else do
hat <- mk_h98_arg_tys
- return $ noLoc $ ConDeclH98
- { con_ext = noExtField
+ return $ noLocA $ ConDeclH98
+ { con_ext = noAnn
, con_name = name
- , con_forall = noLoc False
+ , con_forall = False
, con_ex_tvs = map (synifyTyVarBndr . (mkTyCoVarBinder InferredSpec)) ex_tvs
, con_mb_cxt = ctx
, con_args = hat
, con_doc = Nothing }
-synifyName :: NamedThing n => n -> Located Name
-synifyName n = L (srcLocSpan (getSrcLoc n)) (getName n)
+synifyNameN :: NamedThing n => n -> LocatedN Name
+synifyNameN n = L (noAnnSrcSpan $ srcLocSpan (getSrcLoc n)) (getName n)
+
+-- synifyName :: NamedThing n => n -> LocatedA Name
+-- synifyName n = L (noAnnSrcSpan $ srcLocSpan (getSrcLoc n)) (getName n)
-- | Guess the fixity of a something with a name. This isn't quite right, since
-- a user can always declare an infix name in prefix form or a prefix name in
@@ -445,7 +448,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 noExtField [synifyName i] (synifySigWcType s vs t)
+synifyIdSig prr s vs i = TypeSig noAnn [synifyNameN i] (synifySigWcType s vs t)
where
t = defaultType prr (varType i)
@@ -454,15 +457,15 @@ synifyIdSig prr s vs i = TypeSig noExtField [synifyName i] (synifySigWcType s vs
-- 'ClassOpSig'.
synifyTcIdSig :: [TyVar] -> ClassOpItem -> [Sig GhcRn]
synifyTcIdSig vs (i, dm) =
- [ ClassOpSig noExtField False [synifyName i] (mainSig (varType i)) ] ++
- [ ClassOpSig noExtField True [noLoc dn] (defSig dt)
+ [ ClassOpSig noAnn False [synifyNameN i] (mainSig (varType i)) ] ++
+ [ ClassOpSig noAnn True [noLocA dn] (defSig dt)
| Just (dn, GenericDM dt) <- [dm] ]
where
mainSig t = synifySigType DeleteTopLevelQuantification vs t
defSig t = synifySigType ImplicitizeForAll vs t
synifyCtx :: [PredType] -> Maybe (LHsContext GhcRn)
-synifyCtx ts = Just (noLoc ( map (synifyType WithinType []) ts))
+synifyCtx ts = Just (noLocA ( map (synifyType WithinType []) ts))
synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn
@@ -483,8 +486,8 @@ synifyTyVarBndr' no_kinds (Bndr tv spec) = synify_ty_var no_kinds spec tv
synify_ty_var :: VarSet -> flag -> TyVar -> LHsTyVarBndr flag GhcRn
synify_ty_var no_kinds flag tv
| isLiftedTypeKind kind || tv `elemVarSet` no_kinds
- = noLoc (UserTyVar noExtField flag (noLoc name))
- | otherwise = noLoc (KindedTyVar noExtField flag (noLoc name) (synifyKindSig kind))
+ = noLocA (UserTyVar noAnn flag (noLocA name))
+ | otherwise = noLocA (KindedTyVar noAnn flag (noLocA name) (synifyKindSig kind))
where
kind = tyVarKind tv
name = getName tv
@@ -501,7 +504,7 @@ annotHsType True ty hs_ty
| not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty
= let ki = typeKind ty
hs_ki = synifyType WithinType [] ki
- in noLoc (HsKindSig noExtField hs_ty hs_ki)
+ in noLocA (HsKindSig noAnn hs_ty hs_ki)
annotHsType _ _ hs_ty = hs_ty
-- | For every argument type that a type constructor accepts,
@@ -567,7 +570,7 @@ synifyType
-> [TyVar] -- ^ free variables in the type to convert
-> Type -- ^ the type to convert
-> LHsType GhcRn
-synifyType _ _ (TyVarTy tv) = noLoc $ HsTyVar noExtField NotPromoted $ noLoc (getName tv)
+synifyType _ _ (TyVarTy tv) = noLocA $ HsTyVar noAnn NotPromoted $ noLocA (getName tv)
synifyType _ vs (TyConApp tc tys)
= maybe_sig res_ty
where
@@ -578,63 +581,63 @@ synifyType _ vs (TyConApp tc tys)
, [TyConApp rep [TyConApp lev []]] <- tys
, rep `hasKey` boxedRepDataConKey
, lev `hasKey` liftedDataConKey
- = noLoc (HsTyVar noExtField NotPromoted (noLoc liftedTypeKindTyConName))
+ = noLocA (HsTyVar noAnn NotPromoted (noLocA liftedTypeKindTyConName))
-- Use non-prefix tuple syntax where possible, because it looks nicer.
| Just sort <- tyConTuple_maybe tc
, tyConArity tc == tys_len
- = noLoc $ HsTupleTy noExtField
+ = noLocA $ HsTupleTy noAnn
(case sort of
BoxedTuple -> HsBoxedOrConstraintTuple
ConstraintTuple -> HsBoxedOrConstraintTuple
UnboxedTuple -> HsUnboxedTuple)
(map (synifyType WithinType vs) vis_tys)
- | isUnboxedSumTyCon tc = noLoc $ HsSumTy noExtField (map (synifyType WithinType vs) vis_tys)
+ | isUnboxedSumTyCon tc = noLocA $ HsSumTy noAnn (map (synifyType WithinType vs) vis_tys)
| Just dc <- isPromotedDataCon_maybe tc
, isTupleDataCon dc
, dataConSourceArity dc == length vis_tys
- = noLoc $ HsExplicitTupleTy noExtField (map (synifyType WithinType vs) vis_tys)
+ = noLocA $ HsExplicitTupleTy noExtField (map (synifyType WithinType vs) vis_tys)
-- ditto for lists
| getName tc == listTyConName, [ty] <- vis_tys =
- noLoc $ HsListTy noExtField (synifyType WithinType vs ty)
+ noLocA $ HsListTy noAnn (synifyType WithinType vs ty)
| tc == promotedNilDataCon, [] <- vis_tys
- = noLoc $ HsExplicitListTy noExtField IsPromoted []
+ = noLocA $ 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 noExtField IsPromoted (hTy : tTy')
+ -> noLocA $ HsExplicitListTy noExtField IsPromoted (hTy : tTy')
| otherwise
- -> noLoc $ HsOpTy noExtField hTy (noLoc $ getName tc) tTy
+ -> noLocA $ HsOpTy noExtField hTy (noLocA $ getName tc) tTy
-- ditto for implicit parameter tycons
| tc `hasKey` ipClassKey
, [name, ty] <- tys
, Just x <- isStrLitTy name
- = noLoc $ HsIParamTy noExtField (noLoc $ HsIPName x) (synifyType WithinType vs ty)
+ = noLocA $ HsIParamTy noAnn (noLoc $ HsIPName x) (synifyType WithinType vs ty)
-- and equalities
| tc `hasKey` eqTyConKey
, [ty1, ty2] <- tys
- = noLoc $ HsOpTy noExtField
+ = noLocA $ HsOpTy noExtField
(synifyType WithinType vs ty1)
- (noLoc eqTyConName)
+ (noLocA eqTyConName)
(synifyType WithinType vs ty2)
-- and infix type operators
| isSymOcc (nameOccName (getName tc))
, ty1:ty2:tys_rest <- vis_tys
= mk_app_tys (HsOpTy noExtField
(synifyType WithinType vs ty1)
- (noLoc $ getName tc)
+ (noLocA $ getName tc)
(synifyType WithinType vs ty2))
tys_rest
-- Most TyCons:
| otherwise
- = mk_app_tys (HsTyVar noExtField prom $ noLoc (getName tc))
+ = mk_app_tys (HsTyVar noAnn prom $ noLocA (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 noExtField t1 t2)
- (noLoc ty_app)
+ foldl (\t1 t2 -> noLocA $ HsAppTy noExtField t1 t2)
+ (noLocA ty_app)
(map (synifyType WithinType vs) $
filterOut isCoercionTy ty_args)
@@ -646,7 +649,7 @@ 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 noExtField ty' full_kind'
+ in noLocA $ HsKindSig noAnn ty' full_kind'
| otherwise = ty'
synifyType _ vs ty@(AppTy {}) = let
@@ -656,19 +659,19 @@ synifyType _ vs ty@(AppTy {}) = let
filterOut isCoercionTy $
filterByList (map isVisibleArgFlag $ appTyArgFlags ty_head ty_args)
ty_args
- in foldl (\t1 t2 -> noLoc $ HsAppTy noExtField t1 t2) ty_head' ty_args'
+ in foldl (\t1 t2 -> noLocA $ HsAppTy noExtField t1 t2) ty_head' ty_args'
synifyType s vs funty@(FunTy InvisArg _ _ _) = synifySigmaType s vs funty
synifyType _ vs (FunTy VisArg w t1 t2) = let
s1 = synifyType WithinType vs t1
s2 = synifyType WithinType vs t2
w' = synifyMult vs w
- in noLoc $ HsFunTy noExtField w' s1 s2
+ in noLocA $ HsFunTy noAnn w' s1 s2
synifyType s vs forallty@(ForAllTy (Bndr _ argf) _ty) =
case argf of
Required -> synifyVisForAllType vs forallty
Invisible _ -> synifySigmaType s vs forallty
-synifyType _ _ (LitTy t) = noLoc $ HsTyLit noExtField $ synifyTyLit t
+synifyType _ _ (LitTy t) = noLocA $ HsTyLit noExtField $ synifyTyLit t
synifyType s vs (CastTy t _) = synifyType s vs t
synifyType _ _ (CoercionTy {}) = error "synifyType:Coercion"
@@ -686,9 +689,9 @@ synifyVisForAllType vs ty =
-- absence of an explicit forall
tvs' = orderedFVs (mkVarSet vs) [rho]
- in noLoc $ HsForAllTy { hst_tele = mkHsForAllVisTele sTvs
- , hst_xforall = noExtField
- , hst_body = synifyType WithinType (tvs' ++ vs) rho }
+ in noLocA $ HsForAllTy { hst_tele = mkHsForAllVisTele noAnn sTvs
+ , hst_xforall = noExtField
+ , hst_body = synifyType WithinType (tvs' ++ vs) rho }
-- | Process a 'Type' which starts with an invisible @forall@ or a constraint
-- into an 'HsType'
@@ -703,9 +706,9 @@ synifySigmaType s vs ty =
, hst_xqual = noExtField
, hst_body = synifyType WithinType (tvs' ++ vs) tau }
- sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele sTvs
+ sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele noAnn sTvs
, hst_xforall = noExtField
- , hst_body = noLoc sPhi }
+ , hst_body = noLocA sPhi }
sTvs = map synifyTyVarBndr tvs
@@ -718,8 +721,8 @@ synifySigmaType s vs ty =
-- Put a forall in if there are any type variables
WithinType
- | not (null tvs) -> noLoc sTy
- | otherwise -> noLoc sPhi
+ | not (null tvs) -> noLocA sTy
+ | otherwise -> noLocA sPhi
ImplicitizeForAll -> implicitForAll [] vs tvs ctx (synifyType WithinType) tau
@@ -735,9 +738,9 @@ implicitForAll
-> Type -- ^ inner type
-> LHsType GhcRn
implicitForAll tycons vs tvs ctx synInner tau
- | any (isHsKindedTyVar . unLoc) sTvs = noLoc sTy
- | tvs' /= (binderVars tvs) = noLoc sTy
- | otherwise = noLoc sPhi
+ | any (isHsKindedTyVar . unLoc) sTvs = noLocA sTy
+ | tvs' /= (binderVars tvs) = noLocA sTy
+ | otherwise = noLocA sPhi
where
sRho = synInner (tvs' ++ vs) tau
sPhi | null ctx = unLoc sRho
@@ -745,9 +748,9 @@ implicitForAll tycons vs tvs ctx synInner tau
= HsQualTy { hst_ctxt = synifyCtx ctx
, hst_xqual = noExtField
, hst_body = synInner (tvs' ++ vs) tau }
- sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele sTvs
+ sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele noAnn sTvs
, hst_xforall = noExtField
- , hst_body = noLoc sPhi }
+ , hst_body = noLocA sPhi }
no_kinds_needed = noKindTyVars tycons tau
sTvs = map (synifyTyVarBndr' no_kinds_needed) tvs
@@ -796,9 +799,9 @@ noKindTyVars _ _ = emptyVarSet
synifyMult :: [TyVar] -> Mult -> HsArrow GhcRn
synifyMult vs t = case t of
- One -> HsLinearArrow NormalSyntax
+ One -> HsLinearArrow NormalSyntax Nothing
Many -> HsUnrestrictedArrow NormalSyntax
- ty -> HsExplicitMult NormalSyntax (synifyType WithinType vs ty)
+ ty -> HsExplicitMult NormalSyntax Nothing (synifyType WithinType vs ty)
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 41801710ba85f97e13df9c0e83cfd96e396190c4..b8db6dfd34909605eb7176105c571a43a6205b35 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -26,7 +26,7 @@ import Control.Arrow
import Data.Char ( isSpace )
import Data.Maybe ( mapMaybe, fromMaybe )
-import Haddock.Types( DocName, DocNameI )
+import Haddock.Types( DocName, DocNameI, XRecCond )
import GHC.Utils.FV as FV
import GHC.Utils.Outputable ( Outputable )
@@ -44,7 +44,6 @@ import GHC.Types.Var.Set ( VarSet, emptyVarSet )
import GHC.Types.Var.Env ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv )
import GHC.Core.TyCo.Rep ( Type(..) )
import GHC.Core.Type ( isRuntimeRepVar )
-import GHC.Parser.Annotation (IsUnicodeSyntax(..))
import GHC.Builtin.Types( liftedRepTy )
import GHC.Data.StringBuffer ( StringBuffer )
@@ -75,20 +74,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 noExtField (FixitySig noExtField filtered ty))
+ filtered -> Just (FixSig noAnn (FixitySig noExtField filtered ty))
filterSigNames _ orig@(MinimalSig _ _ _) = Just orig
filterSigNames p (TypeSig _ ns ty) =
case filter (p . unLoc) ns of
[] -> Nothing
- filtered -> Just (TypeSig noExtField filtered ty)
+ filtered -> Just (TypeSig noAnn filtered ty)
filterSigNames p (ClassOpSig _ is_default ns ty) =
case filter (p . unLoc) ns of
[] -> Nothing
- filtered -> Just (ClassOpSig noExtField is_default filtered ty)
+ filtered -> Just (ClassOpSig noAnn is_default filtered ty)
filterSigNames p (PatSynSig _ ns ty) =
case filter (p . unLoc) ns of
[] -> Nothing
- filtered -> Just (PatSynSig noExtField filtered ty)
+ filtered -> Just (PatSynSig noAnn filtered ty)
filterSigNames _ _ = Nothing
ifTrueJust :: Bool -> name -> Maybe name
@@ -127,7 +126,7 @@ hsTyVarNameI (KindedTyVar _ _ (L _ n) _) = n
hsLTyVarNameI :: LHsTyVarBndr flag DocNameI -> DocName
hsLTyVarNameI = hsTyVarNameI . unLoc
-getConNamesI :: ConDecl DocNameI -> [Located DocName]
+getConNamesI :: ConDecl DocNameI -> [LocatedN DocName]
getConNamesI ConDeclH98 {con_name = name} = [name]
getConNamesI ConDeclGADT {con_names = names} = names
@@ -167,21 +166,22 @@ getGADTConType :: ConDecl DocNameI -> LHsSigType DocNameI
getGADTConType (ConDeclGADT { con_bndrs = L _ outer_bndrs
, con_mb_cxt = mcxt, con_g_args = args
, con_res_ty = res_ty })
- = noLoc (HsSig { sig_ext = noExtField
- , sig_bndrs = outer_bndrs
- , sig_body = theta_ty })
+ = noLocA (HsSig { sig_ext = noExtField
+ , sig_bndrs = outer_bndrs
+ , sig_body = theta_ty })
where
theta_ty | Just theta <- mcxt
- = noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = Just theta, hst_body = tau_ty })
+ = noLocA (HsQualTy { hst_xqual = noAnn, hst_ctxt = Just theta, hst_body = tau_ty })
| otherwise
= tau_ty
-- tau_ty :: LHsType DocNameI
tau_ty = case args of
- RecConGADT flds -> mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty
+ RecConGADT flds -> mkFunTy (noLocA (HsRecTy noAnn (unLoc flds))) res_ty
PrefixConGADT pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args)
- mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b)
+ mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI
+ mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) a b)
getGADTConType (ConDeclH98 {}) = panic "getGADTConType"
-- Should only be called on ConDeclGADT
@@ -197,10 +197,10 @@ getMainDeclBinderI (ForD _ (ForeignImport _ name _ _)) = [unLoc name]
getMainDeclBinderI (ForD _ (ForeignExport _ _ _ _)) = []
getMainDeclBinderI _ = []
-familyDeclLNameI :: FamilyDecl DocNameI -> Located DocName
+familyDeclLNameI :: FamilyDecl DocNameI -> LocatedN DocName
familyDeclLNameI (FamilyDecl { fdLName = n }) = n
-tyClDeclLNameI :: TyClDecl DocNameI -> Located DocName
+tyClDeclLNameI :: TyClDecl DocNameI -> LocatedN DocName
tyClDeclLNameI (FamDecl { tcdFam = fd }) = familyDeclLNameI fd
tyClDeclLNameI (SynDecl { tcdLName = ln }) = ln
tyClDeclLNameI (DataDecl { tcdLName = ln }) = ln
@@ -212,7 +212,7 @@ tcdNameI = unLoc . tyClDeclLNameI
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 noExtField lname (mkEmptyWildCardBndrs (go_sig_ty ltype)))
+ = L pos (TypeSig noAnn lname (mkEmptyWildCardBndrs (go_sig_ty ltype)))
where
go_sig_ty (L loc (HsSig { sig_bndrs = bndrs, sig_body = ty }))
= L loc (HsSig { sig_ext = noExtField
@@ -230,14 +230,14 @@ addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype))
extra_pred = nlHsTyConApp Prefix cls (lHsQTyVarsToTypes tvs0)
- add_ctxt Nothing = Just $ noLoc [extra_pred]
+ add_ctxt Nothing = Just $ noLocA [extra_pred]
add_ctxt (Just (L loc preds)) = Just $ L loc (extra_pred : preds)
addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine
lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsTypeArg GhcRn]
lHsQTyVarsToTypes tvs
- = [ HsValArg $ noLoc (HsTyVar noExtField NotPromoted (noLoc (hsLTyVarName tv)))
+ = [ HsValArg $ noLocA (HsTyVar noAnn NotPromoted (noLocA (hsLTyVarName tv)))
| tv <- hsQTvExplicit tvs ]
@@ -332,14 +332,13 @@ 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 :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a
- , MapXRec a, UnXRec a, WrapXRec a )
+reparenTypePrec :: forall a. (XRecCond a)
=> Precedence -> HsType a -> HsType a
reparenTypePrec = go
where
-- Shorter name for 'reparenType'
- go :: Precedence -> HsType a -> HsType a
+ go :: XParTy a ~ ApiAnn' AnnParen => 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)
@@ -361,6 +360,7 @@ reparenTypePrec = go
Nothing -> Nothing
Just c -> Just $ mapXRec @a (\xs -> map (goL (p' xs)) xs) c
in paren p PREC_CTX $ HsQualTy x ctxt' (goL PREC_TOP ty)
+ -- = paren p PREC_FUN $ HsQualTy x (fmap (mapXRec @a (map reparenLType)) ctxt) (reparenLType ty)
go p (HsFunTy x w ty1 ty2)
= paren p PREC_FUN $ HsFunTy x w (goL PREC_FUN ty1) (goL PREC_TOP ty2)
go p (HsAppTy x fun_ty arg_ty)
@@ -378,40 +378,35 @@ reparenTypePrec = go
go _ t@XHsType{} = t
-- Located variant of 'go'
- goL :: Precedence -> LHsType a -> LHsType a
+ goL :: XParTy a ~ ApiAnn' AnnParen => Precedence -> LHsType a -> LHsType a
goL ctxt_prec = mapXRec @a (go ctxt_prec)
-- Optionally wrap a type in parens
- paren :: Precedence -- Precedence of context
+ paren :: XParTy a ~ ApiAnn' AnnParen
+ => 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 noExtField . wrapXRec @a
+ paren ctxt_prec op_prec | ctxt_prec >= op_prec = HsParTy noAnn . wrapXRec @a
| otherwise = id
-- | Add parenthesis around the types in a 'HsType' (see 'reparenTypePrec')
-reparenType :: ( XParTy a ~ NoExtField, NoGhcTc a ~ a
- , MapXRec a, UnXRec a, WrapXRec a )
- => HsType a -> HsType a
+reparenType :: XRecCond a => HsType a -> HsType a
reparenType = reparenTypePrec PREC_TOP
-- | Add parenthesis around the types in a 'LHsType' (see 'reparenTypePrec')
-reparenLType :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a
- , MapXRec a, UnXRec a, WrapXRec a )
- => LHsType a -> LHsType a
+reparenLType :: forall a. (XRecCond a) => LHsType a -> LHsType a
reparenLType = mapXRec @a reparenType
-- | Add parentheses around the types in an 'HsSigType' (see 'reparenTypePrec')
-reparenSigType :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a
- , MapXRec a, UnXRec a, WrapXRec a )
+reparenSigType :: forall a. ( XRecCond a )
=> HsSigType a -> HsSigType a
reparenSigType (HsSig x bndrs body) =
HsSig x (reparenOuterTyVarBndrs bndrs) (reparenLType body)
reparenSigType v@XHsSigType{} = v
-- | Add parentheses around the types in an 'HsOuterTyVarBndrs' (see 'reparenTypePrec')
-reparenOuterTyVarBndrs :: forall flag a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a
- , MapXRec a, UnXRec a, WrapXRec a )
+reparenOuterTyVarBndrs :: forall flag a. ( XRecCond a )
=> HsOuterTyVarBndrs flag a -> HsOuterTyVarBndrs flag a
reparenOuterTyVarBndrs imp@HsOuterImplicit{} = imp
reparenOuterTyVarBndrs (HsOuterExplicit x exp_bndrs) =
@@ -419,8 +414,7 @@ reparenOuterTyVarBndrs (HsOuterExplicit x exp_bndrs) =
reparenOuterTyVarBndrs v@XHsOuterTyVarBndrs{} = v
-- | Add parentheses around the types in an 'HsForAllTelescope' (see 'reparenTypePrec')
-reparenHsForAllTelescope :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a
- , MapXRec a, UnXRec a, WrapXRec a )
+reparenHsForAllTelescope :: forall a. (XRecCond a )
=> HsForAllTelescope a -> HsForAllTelescope a
reparenHsForAllTelescope (HsForAllVis x bndrs) =
HsForAllVis x (map (mapXRec @a reparenTyVar) bndrs)
@@ -429,17 +423,13 @@ reparenHsForAllTelescope (HsForAllInvis x bndrs) =
reparenHsForAllTelescope v@XHsForAllTelescope{} = v
-- | Add parenthesis around the types in a 'HsTyVarBndr' (see 'reparenTypePrec')
-reparenTyVar :: ( XParTy a ~ NoExtField, NoGhcTc a ~ a
- , MapXRec a, UnXRec a, WrapXRec a )
- => HsTyVarBndr flag a -> HsTyVarBndr flag a
+reparenTyVar :: (XRecCond a) => HsTyVarBndr flag a -> HsTyVarBndr flag a
reparenTyVar (UserTyVar x flag n) = UserTyVar x flag n
reparenTyVar (KindedTyVar x flag n kind) = KindedTyVar x flag n (reparenLType kind)
reparenTyVar v@XTyVarBndr{} = v
-- | Add parenthesis around the types in a 'ConDeclField' (see 'reparenTypePrec')
-reparenConDeclField :: ( XParTy a ~ NoExtField, NoGhcTc a ~ a
- , MapXRec a, UnXRec a, WrapXRec a )
- => ConDeclField a -> ConDeclField a
+reparenConDeclField :: (XRecCond a) => ConDeclField a -> ConDeclField a
reparenConDeclField (ConDeclField x n t d) = ConDeclField x n (reparenLType t) d
reparenConDeclField c@XConDeclField{} = c
@@ -449,13 +439,15 @@ reparenConDeclField c@XConDeclField{} = c
-------------------------------------------------------------------------------
-unL :: Located a -> a
+unL :: GenLocated l a -> a
unL (L _ x) = x
-
-reL :: a -> Located a
+reL :: a -> GenLocated l a
reL = L undefined
+mapMA :: Monad m => (a -> m b) -> LocatedAn an a -> m (Located b)
+mapMA f (L al a) = L (locA al) <$> f a
+
-------------------------------------------------------------------------------
-- * NamedThing instances
-------------------------------------------------------------------------------
@@ -763,4 +755,4 @@ defaultRuntimeRepVars = go emptyVarEnv
go _ ty@(CoercionTy {}) = ty
fromMaybeContext :: Maybe (LHsContext DocNameI) -> HsContext DocNameI
-fromMaybeContext mctxt = unLoc $ fromMaybe (noLoc []) mctxt
+fromMaybeContext mctxt = unLoc $ fromMaybe (noLocA []) mctxt
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index b42ae1a3e3b67dd4571439010b7f18d5bf679710..02e7ed3829a36ce27ba73f793cd9c461e61da708 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -311,7 +311,7 @@ processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env
undocumentedExports :: [String]
undocumentedExports =
- [ formatName s n
+ [ formatName (locA s) n
| ExportDecl { expItemDecl = L s n
, expItemMbDoc = (Documentation Nothing _, _)
} <- ifaceExportItems interface
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index 6bc8b8c8dead16cfca877bdf36616af046269645..e8a79b2b50bfc34a2613a0cd585a271295bc8807 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -30,14 +30,11 @@ import qualified Data.Set as Set
import GHC.Data.FastString (unpackFS)
import GHC.Core.Class
-import GHC.Driver.Session
import GHC.Core (isOrphan)
-import GHC.Utils.Error
import GHC.Core.FamInstEnv
import GHC
import GHC.Core.InstEnv
import GHC.Unit.Module.Env ( ModuleSet, moduleSetElts )
-import GHC.Utils.Monad (liftIO)
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Utils.Outputable (text, sep, (<+>))
@@ -104,7 +101,7 @@ attachToExportItem index expInfo getInstDoc getFixity export =
fam_instances = maybeToList mb_instances >>= snd
fam_insts = [ ( synFamInst
, getInstDoc n
- , spanNameE n synFamInst (L eSpan (tcdName d))
+ , spanNameE n synFamInst (L (locA eSpan) (tcdName d))
, nameModule_maybe n
)
| i <- sortBy (comparing instFam) fam_instances
@@ -116,7 +113,7 @@ attachToExportItem index expInfo getInstDoc getFixity export =
]
cls_insts = [ ( synClsInst
, getInstDoc n
- , spanName n synClsInst (L eSpan (tcdName d))
+ , spanName n synClsInst (L (locA eSpan) (tcdName d))
, nameModule_maybe n
)
| let is = [ (instanceSig i, getName i) | i <- cls_instances ]
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 4e788260d2fd755ced6df8f45e733fce829726de..a280c0b264395b6015ae216f49a70314336c7707 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -79,6 +79,8 @@ import GHC.Unit.Module.Warnings (WarningTxt (..), Warnings (..))
import GHC.Unit.State (PackageName (..), UnitState, lookupModuleInAllUnits)
import qualified GHC.Utils.Outputable as O
import GHC.Utils.Panic (pprPanic)
+import GHC.HsToCore.Docs hiding (mkMaps)
+import GHC.Unit.Module.Warnings
newtype IfEnv m = IfEnv
{
@@ -200,7 +202,7 @@ createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do
loc_splices :: [SrcSpan]
loc_splices = case tcg_rn_decls of
Nothing -> []
- Just HsGroup { hs_splcds } -> [ loc | L loc _ <- hs_splcds ]
+ Just HsGroup { hs_splcds } -> [ locA loc | L loc _ <- hs_splcds ]
decls <- case tcg_rn_decls of
Nothing -> do
@@ -530,7 +532,7 @@ mkMaps dflags pkgName gre instances decls thDocs = do
, [(Name, IntMap (MDoc Name))]
, [(Name, [LHsDecl GhcRn])]
)
- mappings (ldecl@(L (RealSrcSpan l _) decl), docStrs) = do
+ mappings (ldecl@(L (SrcSpanAnn _ (RealSrcSpan l _)) decl), docStrs) = do
let declDoc :: [HsDocString] -> IntMap HsDocString
-> ErrMsgM (Maybe (MDoc Name), IntMap (MDoc Name))
declDoc strs m = do
@@ -559,7 +561,7 @@ mkMaps dflags pkgName gre instances decls thDocs = do
seqList subDocs `seq`
seqList subArgs `seq`
pure (dm, am, cm)
- mappings (L (UnhelpfulSpan _) _, _) = pure ([], [], [])
+ mappings (L (SrcSpanAnn _ (UnhelpfulSpan _)) _, _) = pure ([], [], [])
instanceMap :: Map RealSrcSpan Name
instanceMap = M.fromList [(l, n) | n <- instances, RealSrcSpan l _ <- [getSrcSpan n] ]
@@ -570,7 +572,7 @@ mkMaps dflags pkgName gre instances decls thDocs = do
-- The CoAx's loc is the whole line, but only for TFs. The
-- workaround is to dig into the family instance declaration and
-- get the identifier with the right location.
- TyFamInstD _ (TyFamInstDecl d') -> getLoc (feqn_tycon d')
+ TyFamInstD _ (TyFamInstDecl _ d') -> getLocA (feqn_tycon d')
_ -> getInstLoc d
names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See note [2].
names _ decl = getMainDeclBinder decl
@@ -701,7 +703,8 @@ 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
+ let l = locA l'
-- Top-level binding without type signature
export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap
return [export]
@@ -734,7 +737,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
L loc (TyClD _ ClassDecl {..}) -> do
mdef <- minimalDef t
- let sig = maybeToList $ fmap (noLoc . MinimalSig noExtField NoSourceText . noLoc . fmap noLoc) mdef
+ let sig = maybeToList $ fmap (noLocA . MinimalSig noAnn NoSourceText . noLocA . fmap noLocA) mdef
availExportDecl avail
(L loc $ TyClD noExtField ClassDecl { tcdSigs = sig ++ tcdSigs, .. }) docs_
@@ -892,7 +895,7 @@ hiDecl dflags t = do
Just x -> case tyThingToLHsDecl ShowRuntimeRep x of
Left m -> liftErrMsg (tell [bugWarn m]) >> return Nothing
Right (m, t') -> liftErrMsg (tell $ map bugWarn m)
- >> return (Just $ noLoc t')
+ >> return (Just $ noLocA t')
where
warnLine x = O.text "haddock-bug:" O.<+> O.text x O.<>
O.comma O.<+> O.quotes (O.ppr t) O.<+>
@@ -912,7 +915,7 @@ hiValExportItem dflags name nLoc doc splice fixity = do
Nothing -> return (ExportNoDecl name [])
Just decl -> return (ExportDecl (fixSpan decl) [] doc [] [] fixities splice)
where
- fixSpan (L l t) = L (SrcLoc.combineSrcSpans l nLoc) t
+ fixSpan (L (SrcSpanAnn a l) t) = L (SrcSpanAnn a (SrcLoc.combineSrcSpans l nLoc)) t
fixities = case fixity of
Just f -> [(name, f)]
Nothing -> []
@@ -1101,7 +1104,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 noExtField (DataFamInstD noExtField d0)))
+ [d0] -> extractDecl declMap name (noLocA (InstD noExtField (DataFamInstD noExtField d0)))
_ -> Left "internal: extractDecl (ClsInstD)"
| otherwise ->
let matches = [ d' | L _ d'@(DataFamInstDecl d )
@@ -1113,7 +1116,7 @@ extractDecl declMap name decl
, extFieldOcc n == name
]
in case matches of
- [d0] -> extractDecl declMap name (noLoc . InstD noExtField $ DataFamInstD noExtField d0)
+ [d0] -> extractDecl declMap name (noLocA . InstD noExtField $ DataFamInstD noExtField d0)
_ -> Left "internal: extractDecl (ClsInstD)"
_ -> Left ("extractDecl: Unhandled decl for " ++ getOccString name)
@@ -1143,21 +1146,21 @@ extractPatternSyn nm t tvs cons =
typ = longArrow args (data_ty con)
typ' =
case con of
- ConDeclH98 { con_mb_cxt = Just cxt } -> noLoc (HsQualTy noExtField (Just cxt) typ)
+ ConDeclH98 { con_mb_cxt = Just cxt } -> noLocA (HsQualTy noExtField (Just cxt) typ)
_ -> typ
- typ'' = noLoc (HsQualTy noExtField (Just (noLoc [])) typ')
- in PatSynSig noExtField [noLoc nm] (mkEmptySigType typ'')
+ typ'' = noLocA (HsQualTy noExtField Nothing typ')
+ in PatSynSig noAnn [noLocA nm] (mkEmptySigType typ'')
longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn
- longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x y)) output inputs
+ longArrow inputs output = foldr (\x y -> noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) x y)) output inputs
data_ty con
| ConDeclGADT{} <- con = con_res_ty con
- | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExtField NotPromoted (noLoc t))) tvs
+ | otherwise = foldl' (\x y -> noLocA (mkAppTyArg x y)) (noLocA (HsTyVar noAnn NotPromoted (noLocA t))) tvs
where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn
mkAppTyArg f (HsValArg ty) = HsAppTy noExtField f ty
mkAppTyArg f (HsTypeArg l ki) = HsAppKindTy l f ki
- mkAppTyArg f (HsArgPar _) = HsParTy noExtField f
+ mkAppTyArg f (HsArgPar _) = HsParTy noAnn f
extractRecSel :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn]
-> Either ErrMsg (LSig GhcRn)
@@ -1166,7 +1169,7 @@ extractRecSel _ _ _ [] = Left "extractRecSel: selector not found"
extractRecSel nm t tvs (L _ con : rest) =
case getRecConArgs_maybe con of
Just (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields ->
- pure (L l (TypeSig noExtField [noLoc nm] (mkEmptyWildCardBndrs $ mkEmptySigType (noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty))))))
+ pure (L (noAnnSrcSpan l) (TypeSig noAnn [noLocA nm] (mkEmptyWildCardBndrs $ mkEmptySigType (noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty))))))
_ -> extractRecSel nm t tvs rest
where
matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)]
@@ -1175,11 +1178,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 noExtField NotPromoted (noLoc t))) tvs
+ | otherwise = foldl' (\x y -> noLocA (mkAppTyArg x y)) (noLocA (HsTyVar noAnn NotPromoted (noLocA t))) tvs
where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn
mkAppTyArg f (HsValArg ty) = HsAppTy noExtField f ty
mkAppTyArg f (HsTypeArg l ki) = HsAppKindTy l f ki
- mkAppTyArg f (HsArgPar _) = HsParTy noExtField f
+ mkAppTyArg f (HsArgPar _) = HsParTy noAnn 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 b62f79ce51781638e4c987083af23582ff6f95fc..2833df497aec3665dfeee0ded4cd0b1b87040936 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -34,6 +34,7 @@ import qualified Data.Map as Map hiding ( Map )
import qualified Data.Set as Set
import Prelude hiding (mapM)
import GHC.HsToCore.Docs
+import GHC.Types.Basic ( TopLevelFlag(..) )
-- | Traverse docstrings and ASTs in the Haddock interface, renaming 'Name' to
-- 'DocName'.
@@ -173,10 +174,9 @@ rename :: Name -> RnM DocName
rename = lookupRn
-renameL :: Located Name -> RnM (Located DocName)
+renameL :: GenLocated l Name -> RnM (GenLocated l DocName)
renameL = mapM rename
-
renameExportItems :: [ExportItem GhcRn] -> RnM [ExportItem DocNameI]
renameExportItems = mapM renameExportItem
@@ -235,10 +235,10 @@ renameFamilyResultSig (L loc (TyVarSig _ bndr))
; return (L loc (TyVarSig noExtField bndr')) }
renameInjectivityAnn :: LInjectivityAnn GhcRn -> RnM (LInjectivityAnn DocNameI)
-renameInjectivityAnn (L loc (InjectivityAnn lhs rhs))
+renameInjectivityAnn (L loc (InjectivityAnn _ lhs rhs))
= do { lhs' <- renameL lhs
; rhs' <- mapM renameL rhs
- ; return (L loc (InjectivityAnn lhs' rhs')) }
+ ; return (L loc (InjectivityAnn noExtField lhs' rhs')) }
renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
-> RnM (Maybe (LInjectivityAnn DocNameI))
@@ -246,75 +246,75 @@ renameMaybeInjectivityAnn = traverse renameInjectivityAnn
renameArrow :: HsArrow GhcRn -> RnM (HsArrow DocNameI)
renameArrow (HsUnrestrictedArrow u) = return (HsUnrestrictedArrow u)
-renameArrow (HsLinearArrow u) = return (HsLinearArrow u)
-renameArrow (HsExplicitMult u p) = HsExplicitMult u <$> renameLType p
+renameArrow (HsLinearArrow u a) = return (HsLinearArrow u a)
+renameArrow (HsExplicitMult u a p) = HsExplicitMult u a <$> renameLType p
renameType :: HsType GhcRn -> RnM (HsType DocNameI)
renameType t = case t of
HsForAllTy { hst_tele = tele, hst_body = ltype } -> do
tele' <- renameHsForAllTelescope tele
ltype' <- renameLType ltype
- return (HsForAllTy { hst_xforall = noExtField
+ return (HsForAllTy { hst_xforall = noAnn
, hst_tele = tele', hst_body = ltype' })
HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do
lcontext' <- traverse renameLContext lcontext
ltype' <- renameLType ltype
- return (HsQualTy { hst_xqual = noExtField, hst_ctxt = lcontext', hst_body = ltype' })
+ return (HsQualTy { hst_xqual = noAnn, hst_ctxt = lcontext', hst_body = ltype' })
- HsTyVar _ ip (L l n) -> return . HsTyVar noExtField ip . L l =<< rename n
- HsBangTy _ b ltype -> return . HsBangTy noExtField b =<< renameLType ltype
+ HsTyVar _ ip (L l n) -> return . HsTyVar noAnn ip . L l =<< rename n
+ HsBangTy _ b ltype -> return . HsBangTy noAnn b =<< renameLType ltype
- HsStarTy _ isUni -> return (HsStarTy noExtField isUni)
+ HsStarTy _ isUni -> return (HsStarTy noAnn isUni)
HsAppTy _ a b -> do
a' <- renameLType a
b' <- renameLType b
- return (HsAppTy noExtField a' b')
+ return (HsAppTy noAnn a' b')
HsAppKindTy _ a b -> do
a' <- renameLType a
b' <- renameLKind b
- return (HsAppKindTy noExtField a' b')
+ return (HsAppKindTy noAnn a' b')
HsFunTy _ w a b -> do
a' <- renameLType a
b' <- renameLType b
w' <- renameArrow w
- return (HsFunTy noExtField w' a' b')
+ return (HsFunTy noAnn w' a' b')
- HsListTy _ ty -> return . (HsListTy noExtField) =<< renameLType ty
- HsIParamTy _ n ty -> liftM (HsIParamTy noExtField n) (renameLType ty)
+ HsListTy _ ty -> return . (HsListTy noAnn) =<< renameLType ty
+ HsIParamTy _ n ty -> liftM (HsIParamTy noAnn n) (renameLType ty)
- HsTupleTy _ b ts -> return . HsTupleTy noExtField b =<< mapM renameLType ts
- HsSumTy _ ts -> HsSumTy noExtField <$> mapM renameLType ts
+ HsTupleTy _ b ts -> return . HsTupleTy noAnn b =<< mapM renameLType ts
+ HsSumTy _ ts -> HsSumTy noAnn <$> mapM renameLType ts
HsOpTy _ a (L loc op) b -> do
op' <- rename op
a' <- renameLType a
b' <- renameLType b
- return (HsOpTy noExtField a' (L loc op') b')
+ return (HsOpTy noAnn a' (L loc op') b')
- HsParTy _ ty -> return . (HsParTy noExtField) =<< renameLType ty
+ HsParTy _ ty -> return . (HsParTy noAnn) =<< renameLType ty
HsKindSig _ ty k -> do
ty' <- renameLType ty
k' <- renameLKind k
- return (HsKindSig noExtField ty' k')
+ return (HsKindSig noAnn ty' k')
HsDocTy _ ty doc -> do
ty' <- renameLType ty
doc' <- renameLDocHsSyn doc
- return (HsDocTy noExtField ty' doc')
+ return (HsDocTy noAnn ty' doc')
- HsTyLit _ x -> return (HsTyLit noExtField x)
+ HsTyLit _ x -> return (HsTyLit noAnn x)
- HsRecTy _ a -> HsRecTy noExtField <$> mapM renameConDeclFieldField a
+ HsRecTy _ a -> HsRecTy noAnn <$> mapM renameConDeclFieldField a
XHsType a -> pure (XHsType a)
- HsExplicitListTy i a b -> HsExplicitListTy i a <$> mapM renameLType b
- HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b
+ HsExplicitListTy _ a b -> HsExplicitListTy noAnn a <$> mapM renameLType b
+ HsExplicitTupleTy _ b -> HsExplicitTupleTy noAnn <$> mapM renameLType b
HsSpliceTy _ s -> renameHsSpliceTy s
- HsWildCardTy a -> pure (HsWildCardTy a)
+ HsWildCardTy _ -> pure (HsWildCardTy noAnn)
renameSigType :: HsSigType GhcRn -> RnM (HsSigType DocNameI)
renameSigType (HsSig { sig_bndrs = bndrs, sig_body = body }) = do
@@ -341,21 +341,21 @@ renameLHsQTyVars (HsQTvs { hsq_explicit = tvs })
renameHsForAllTelescope :: HsForAllTelescope GhcRn -> RnM (HsForAllTelescope DocNameI)
renameHsForAllTelescope tele = case tele of
- HsForAllVis x bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs
- pure $ HsForAllVis x bndrs'
- HsForAllInvis x bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs
- pure $ HsForAllInvis x bndrs'
+ HsForAllVis _ bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs
+ pure $ HsForAllVis noExtField bndrs'
+ HsForAllInvis _ bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs
+ pure $ HsForAllInvis noExtField bndrs'
renameLTyVarBndr :: LHsTyVarBndr flag GhcRn -> RnM (LHsTyVarBndr flag DocNameI)
-renameLTyVarBndr (L loc (UserTyVar x fl (L l n)))
+renameLTyVarBndr (L loc (UserTyVar _ fl (L l n)))
= do { n' <- rename n
- ; return (L loc (UserTyVar x fl (L l n'))) }
-renameLTyVarBndr (L loc (KindedTyVar x fl (L lv n) kind))
+ ; return (L loc (UserTyVar noExtField fl (L l n'))) }
+renameLTyVarBndr (L loc (KindedTyVar _ fl (L lv n) kind))
= do { n' <- rename n
; kind' <- renameLKind kind
- ; return (L loc (KindedTyVar x fl (L lv n') kind')) }
+ ; return (L loc (KindedTyVar noExtField fl (L lv n') kind')) }
-renameLContext :: Located [LHsType GhcRn] -> RnM (Located [LHsType DocNameI])
+renameLContext :: LocatedC [LHsType GhcRn] -> RnM (LocatedC [LHsType DocNameI])
renameLContext (L loc context) = do
context' <- mapM renameLType context
return (L loc context')
@@ -406,8 +406,8 @@ renameDecl decl = case decl of
return (DerivD noExtField d')
_ -> error "renameDecl"
-renameLThing :: (a GhcRn -> RnM (a DocNameI)) -> Located (a GhcRn) -> RnM (Located (a DocNameI))
-renameLThing fn (L loc x) = return . L loc =<< fn x
+renameLThing :: (a GhcRn -> RnM (a DocNameI)) -> LocatedAn an (a GhcRn) -> RnM (Located (a DocNameI))
+renameLThing fn (L loc x) = return . L (locA loc) =<< fn x
renameTyClD :: TyClDecl GhcRn -> RnM (TyClDecl DocNameI)
renameTyClD d = case d of
@@ -446,12 +446,13 @@ renameTyClD d = case d of
, tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdCExt = noExtField })
where
- renameLFunDep (L loc (xs, ys)) = do
+ renameLFunDep :: LHsFunDep GhcRn -> RnM (LHsFunDep DocNameI)
+ renameLFunDep (L loc (FunDep _ xs ys)) = do
xs' <- mapM rename (map unLoc xs)
ys' <- mapM rename (map unLoc ys)
- return (L loc (map noLoc xs', map noLoc ys'))
+ return (L (locA loc) (FunDep noExtField (map noLocA xs') (map noLocA ys')))
- renameLSig (L loc sig) = return . L loc =<< renameSig sig
+ renameLSig (L loc sig) = return . L (locA loc) =<< renameSig sig
renameFamilyDecl :: FamilyDecl GhcRn -> RnM (FamilyDecl DocNameI)
renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname
@@ -464,7 +465,8 @@ renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname
ltyvars' <- renameLHsQTyVars ltyvars
result' <- renameFamilyResultSig result
injectivity' <- renameMaybeInjectivityAnn injectivity
- return (FamilyDecl { fdExt = noExtField, fdInfo = info', fdLName = lname'
+ return (FamilyDecl { fdExt = noExtField, fdInfo = info', fdTopLevel = TopLevel
+ , fdLName = lname'
, fdTyVars = ltyvars'
, fdFixity = fixity
, fdResultSig = result'
@@ -492,12 +494,12 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType
, dd_kindSig = k, dd_cons = cons }) = do
lcontext' <- traverse renameLContext lcontext
k' <- renameMaybeLKind k
- cons' <- mapM (mapM renameCon) cons
+ cons' <- mapM (mapMA renameCon) cons
-- I don't think we need the derivings, so we return Nothing
return (HsDataDefn { dd_ext = noExtField
, dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType
, dd_kindSig = k', dd_cons = cons'
- , dd_derivs = noLoc [] })
+ , dd_derivs = [] })
renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI)
renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars
@@ -537,7 +539,7 @@ renameH98Details :: HsConDeclH98Details GhcRn
-> RnM (HsConDeclH98Details DocNameI)
renameH98Details (RecCon (L l fields)) = do
fields' <- mapM renameConDeclFieldField fields
- return (RecCon (L l fields'))
+ return (RecCon (L (locA l) fields'))
renameH98Details (PrefixCon ts ps) = PrefixCon ts <$> mapM renameHsScaled ps
renameH98Details (InfixCon a b) = do
a' <- renameHsScaled a
@@ -548,7 +550,7 @@ renameGADTDetails :: HsConDeclGADTDetails GhcRn
-> RnM (HsConDeclGADTDetails DocNameI)
renameGADTDetails (RecConGADT (L l fields)) = do
fields' <- mapM renameConDeclFieldField fields
- return (RecConGADT (L l fields'))
+ return (RecConGADT (L (locA l) fields'))
renameGADTDetails (PrefixConGADT ps) = PrefixConGADT <$> mapM renameHsScaled ps
renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI)
@@ -556,7 +558,7 @@ renameConDeclFieldField (L l (ConDeclField _ names t doc)) = do
names' <- mapM renameLFieldOcc names
t' <- renameLType t
doc' <- mapM renameLDocHsSyn doc
- return $ L l (ConDeclField noExtField names' t' doc')
+ return $ L (locA l) (ConDeclField noExtField names' t' doc')
renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI)
renameLFieldOcc (L l (FieldOcc sel lbl)) = do
@@ -621,10 +623,10 @@ renameDerivD (DerivDecl { deriv_type = ty
, deriv_overlap_mode = omode })
renameDerivStrategy :: DerivStrategy GhcRn -> RnM (DerivStrategy DocNameI)
-renameDerivStrategy StockStrategy = pure StockStrategy
-renameDerivStrategy AnyclassStrategy = pure AnyclassStrategy
-renameDerivStrategy NewtypeStrategy = pure NewtypeStrategy
-renameDerivStrategy (ViaStrategy ty) = ViaStrategy <$> renameLSigType ty
+renameDerivStrategy (StockStrategy a) = pure (StockStrategy a)
+renameDerivStrategy (AnyclassStrategy a) = pure (AnyclassStrategy a)
+renameDerivStrategy (NewtypeStrategy a) = pure (NewtypeStrategy a)
+renameDerivStrategy (ViaStrategy ty) = ViaStrategy <$> renameLSigType ty
renameClsInstD :: ClsInstDecl GhcRn -> RnM (ClsInstDecl DocNameI)
renameClsInstD (ClsInstDecl { cid_overlap_mode = omode
@@ -642,7 +644,7 @@ renameClsInstD (ClsInstDecl { cid_overlap_mode = omode
renameTyFamInstD :: TyFamInstDecl GhcRn -> RnM (TyFamInstDecl DocNameI)
renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
= do { eqn' <- renameTyFamInstEqn eqn
- ; return (TyFamInstDecl { tfid_eqn = eqn' }) }
+ ; return (TyFamInstDecl { tfid_xtn = noExtField, tfid_eqn = eqn' }) }
renameTyFamInstEqn :: TyFamInstEqn GhcRn -> RnM (TyFamInstEqn DocNameI)
renameTyFamInstEqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 5ef5d92d2a397e4c914350937d2bb6a807d53df9..16f00fdab8f1ea739d81a5cb2695599beccb0a4c 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -19,7 +19,6 @@ import GHC
import GHC.Types.Name
import GHC.Data.FastString
import GHC.Builtin.Types ( listTyConName, unrestrictedFunTyConName )
-import GHC.Parser.Annotation (IsUnicodeSyntax(..))
import Control.Monad
import Control.Monad.Trans.State
@@ -75,7 +74,7 @@ specializeSig :: LHsQTyVars GhcRn -> [HsType GhcRn]
-> Sig GhcRn
-> Sig GhcRn
specializeSig bndrs typs (TypeSig _ lnames typ) =
- TypeSig noExtField lnames (typ {hswc_body = noLoc typ'})
+ TypeSig noAnn lnames (typ {hswc_body = noLocA typ'})
where
true_type :: HsSigType GhcRn
true_type = unLoc (dropWildCards typ)
@@ -111,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)
- | getName name == listTyConName = HsListTy noExtField ltyp
+ | getName name == listTyConName = HsListTy noAnn ltyp
sugarLists typ = typ
@@ -122,7 +121,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 noExtField HsBoxedOrConstraintTuple apps
+ | isBuiltInSyntax name' && suitable = HsTupleTy noAnn HsBoxedOrConstraintTuple apps
where
name' = getName name
strName = getOccString name
@@ -132,10 +131,10 @@ sugarTuples typ =
aux _ _ = typ
-sugarOperators :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p)
+sugarOperators :: HsType GhcRn -> HsType GhcRn
sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb)
| isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb
- | unrestrictedFunTyConName == name' = HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) la lb
+ | unrestrictedFunTyConName == name' = HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) la lb
where
name' = getName name
sugarOperators typ = typ
@@ -286,7 +285,7 @@ renameType (HsQualTy x lctxt lt) =
HsQualTy x
<$> renameMContext lctxt
<*> renameLType lt
-renameType (HsTyVar x ip name) = HsTyVar x ip <$> located renameName name
+renameType (HsTyVar x ip name) = HsTyVar x ip <$> locatedN renameName name
renameType t@(HsStarTy _ _) = pure t
renameType (HsAppTy x lf la) = HsAppTy x <$> renameLType lf <*> renameLType la
renameType (HsAppKindTy x lt lk) = HsAppKindTy x <$> renameLType lt <*> renameLKind lk
@@ -295,7 +294,7 @@ renameType (HsListTy x lt) = HsListTy x <$> renameLType lt
renameType (HsTupleTy x srt lt) = HsTupleTy x srt <$> mapM renameLType lt
renameType (HsSumTy x lt) = HsSumTy x <$> mapM renameLType lt
renameType (HsOpTy x la lop lb) =
- HsOpTy x <$> renameLType la <*> located renameName lop <*> renameLType lb
+ HsOpTy x <$> renameLType la <*> locatedN renameName lop <*> renameLType lb
renameType (HsParTy x lt) = HsParTy x <$> renameLType lt
renameType (HsIParamTy x ip lt) = HsIParamTy x ip <$> renameLType lt
renameType (HsKindSig x lt lk) = HsKindSig x <$> renameLType lt <*> pure lk
@@ -312,7 +311,7 @@ renameType t@(HsTyLit _ _) = pure t
renameType (HsWildCardTy wc) = pure (HsWildCardTy wc)
renameHsArrow :: HsArrow GhcRn -> Rename (IdP GhcRn) (HsArrow GhcRn)
-renameHsArrow (HsExplicitMult u p) = HsExplicitMult u <$> renameLType p
+renameHsArrow (HsExplicitMult u a p) = HsExplicitMult u a <$> renameLType p
renameHsArrow mult = pure mult
@@ -342,9 +341,9 @@ renameForAllTelescope (HsForAllInvis x bndrs) =
HsForAllInvis x <$> mapM renameLBinder bndrs
renameBinder :: HsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr flag GhcRn)
-renameBinder (UserTyVar x fl lname) = UserTyVar x fl <$> located renameName lname
+renameBinder (UserTyVar x fl lname) = UserTyVar x fl <$> locatedN renameName lname
renameBinder (KindedTyVar x fl lname lkind) =
- KindedTyVar x fl <$> located renameName lname <*> located renameType lkind
+ KindedTyVar x fl <$> locatedN renameName lname <*> located renameType lkind
renameLBinder :: LHsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (LHsTyVarBndr flag GhcRn)
renameLBinder = located renameBinder
@@ -397,9 +396,12 @@ alternativeNames name =
str = nameRepString name
-located :: Functor f => (a -> f b) -> Located a -> f (Located b)
+located :: Functor f => (a -> f b) -> GenLocated l a -> f (GenLocated l b)
located f (L loc e) = L loc <$> f e
+locatedN :: Functor f => (a -> f b) -> LocatedN a -> f (LocatedN b)
+locatedN f (L loc e) = L loc <$> f e
+
tyVarName :: HsTyVarBndr flag GhcRn -> IdP GhcRn
tyVarName (UserTyVar _ _ name) = unLoc name
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 83c9dd725c12b37cd65481c816ae704c55ec7996..5c6f09a33a7b5ddec99ae0511acaced9aeb8aa7e 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies, RecordWildCards #-}
+{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
@@ -46,6 +47,7 @@ import Data.Void (Void)
import Documentation.Haddock.Types
import GHC.Types.Basic (PromotionFlag(..))
import GHC.Types.Fixity (Fixity(..))
+import GHC.Types.Var (Specificity)
import GHC
import GHC.Driver.Session (Language)
@@ -406,13 +408,13 @@ instance (OutputableBndrId p)
-- 'PseudoFamilyDecl' type is introduced.
data PseudoFamilyDecl name = PseudoFamilyDecl
{ pfdInfo :: FamilyInfo name
- , pfdLName :: Located (IdP name)
+ , pfdLName :: LocatedN (IdP name)
, pfdTyVars :: [LHsType name]
, pfdKindSig :: LFamilyResultSig name
}
-mkPseudoFamilyDecl :: FamilyDecl (GhcPass p) -> PseudoFamilyDecl (GhcPass p)
+mkPseudoFamilyDecl :: FamilyDecl GhcRn -> PseudoFamilyDecl GhcRn
mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl
{ pfdInfo = fdInfo
, pfdLName = fdLName
@@ -420,12 +422,12 @@ mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl
, pfdKindSig = fdResultSig
}
where
- mkType :: HsTyVarBndr flag (GhcPass p) -> HsType (GhcPass p)
+ mkType :: HsTyVarBndr flag GhcRn -> HsType GhcRn
mkType (KindedTyVar _ _ (L loc name) lkind) =
- HsKindSig noExtField tvar lkind
+ HsKindSig noAnn tvar lkind
where
- tvar = L loc (HsTyVar noExtField NotPromoted (L loc name))
- mkType (UserTyVar _ _ name) = HsTyVar noExtField NotPromoted name
+ tvar = L (na2la loc) (HsTyVar noAnn NotPromoted (L loc name))
+ mkType (UserTyVar _ _ name) = HsTyVar noAnn NotPromoted name
-- | An instance head that may have documentation and a source location.
@@ -694,36 +696,69 @@ liftErrMsg = writer . runWriter
-- * Pass sensitive types
-----------------------------------------------------------------------------
-type instance XRec DocNameI a = Located a
+type instance XRec DocNameI a = GenLocated (Anno a) a
instance UnXRec DocNameI where
unXRec = unLoc
instance MapXRec DocNameI where
mapXRec = fmap
-instance WrapXRec DocNameI where
- wrapXRec = noLoc
-
-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
+instance WrapXRec DocNameI (HsType DocNameI) where
+ wrapXRec = noLocA
+
+type instance Anno DocName = SrcSpanAnnN
+type instance Anno (HsTyVarBndr flag DocNameI) = SrcSpanAnnA
+type instance Anno [LocatedA (HsType DocNameI)] = SrcSpanAnnC
+type instance Anno (HsType DocNameI) = SrcSpanAnnA
+type instance Anno (DataFamInstDecl DocNameI) = SrcSpanAnnA
+type instance Anno (DerivStrategy DocNameI) = SrcSpan
+type instance Anno (FieldOcc DocNameI) = SrcSpan
+type instance Anno (ConDeclField DocNameI) = SrcSpan
+type instance Anno (Located (ConDeclField DocNameI)) = SrcSpan
+type instance Anno [Located (ConDeclField DocNameI)] = SrcSpan
+type instance Anno (ConDecl DocNameI) = SrcSpan
+type instance Anno (FunDep DocNameI) = SrcSpan
+type instance Anno (TyFamInstDecl DocNameI) = SrcSpanAnnA
+type instance Anno [LocatedA (TyFamInstDecl DocNameI)] = SrcSpanAnnL
+type instance Anno (FamilyDecl DocNameI) = SrcSpan
+type instance Anno (Sig DocNameI) = SrcSpan
+type instance Anno (InjectivityAnn DocNameI) = SrcSpan
+type instance Anno (HsDecl DocNameI) = SrcSpanAnnA
+type instance Anno (FamilyResultSig DocNameI) = SrcSpan
+type instance Anno (HsOuterTyVarBndrs Specificity DocNameI) = SrcSpanAnnA
+type instance Anno (HsSigType DocNameI) = SrcSpanAnnA
+
+type XRecCond a
+ = ( XParTy a ~ ApiAnn' AnnParen
+ -- , XParTy (NoGhcTc a) ~ ApiAnn' AnnParen
+ -- , NoGhcTcPass (NoGhcTcPass a) ~ NoGhcTcPass a
+ -- , IsPass a
+ , NoGhcTc a ~ a
+ , MapXRec a
+ , UnXRec a
+ , WrapXRec a (HsType a)
+ )
+
+type instance XForAllTy DocNameI = ApiAnn
+type instance XQualTy DocNameI = ApiAnn
+type instance XTyVar DocNameI = ApiAnn
+type instance XStarTy DocNameI = ApiAnn
+type instance XAppTy DocNameI = ApiAnn
+type instance XAppKindTy DocNameI = ApiAnn
+type instance XFunTy DocNameI = ApiAnn
+type instance XListTy DocNameI = ApiAnn' AnnParen
+type instance XTupleTy DocNameI = ApiAnn' AnnParen
+type instance XSumTy DocNameI = ApiAnn' AnnParen
+type instance XOpTy DocNameI = ApiAnn
+type instance XParTy DocNameI = ApiAnn' AnnParen
+type instance XIParamTy DocNameI = ApiAnn
+type instance XKindSig DocNameI = ApiAnn
type instance XSpliceTy DocNameI = Void -- see `renameHsSpliceTy`
-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 XDocTy DocNameI = ApiAnn
+type instance XBangTy DocNameI = ApiAnn
+type instance XRecTy DocNameI = ApiAnn
+type instance XExplicitListTy DocNameI = ApiAnn
+type instance XExplicitTupleTy DocNameI = ApiAnn
+type instance XTyLit DocNameI = ApiAnn
+type instance XWildCardTy DocNameI = ApiAnn
type instance XXType DocNameI = HsCoreTy
type instance XHsForAllVis DocNameI = NoExtField
@@ -766,6 +801,9 @@ type instance XXFamEqn DocNameI _ = NoExtCon
type instance XCClsInstDecl DocNameI = NoExtField
type instance XCDerivDecl DocNameI = NoExtField
+type instance XStockStrategy DocNameI = NoExtField
+type instance XAnyClassStrategy DocNameI = NoExtField
+type instance XNewtypeStrategy DocNameI = NoExtField
type instance XViaStrategy DocNameI = LHsSigType DocNameI
type instance XDataFamInstD DocNameI = NoExtField
type instance XTyFamInstD DocNameI = NoExtField
@@ -793,3 +831,9 @@ type instance XConDeclField DocNameI = NoExtField
type instance XXConDeclField DocNameI = NoExtCon
type instance XXPat DocNameI = NoExtCon
+
+type instance XCInjectivityAnn DocNameI = NoExtField
+
+type instance XCFunDep DocNameI = NoExtField
+
+type instance XCTyFamInstDecl DocNameI = NoExtField