From a8ca2ae8737d29145fe57a7709e59be8cb7a00dc Mon Sep 17 00:00:00 2001
From: Alan Zimmerman <alan.zimm@gmail.com>
Date: Mon, 2 Apr 2018 23:37:50 +0200
Subject: Match GHC for TTG implemented on HsBinds, D4581
---
haddock-api/src/Haddock/Backends/Hoogle.hs | 4 +-
.../src/Haddock/Backends/Hyperlinker/Ast.hs | 6 +--
haddock-api/src/Haddock/Backends/LaTeX.hs | 24 ++++++------
haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 20 +++++-----
haddock-api/src/Haddock/Convert.hs | 10 ++---
haddock-api/src/Haddock/GhcUtils.hs | 44 +++++++++++-----------
haddock-api/src/Haddock/Interface/Create.hs | 16 ++++----
haddock-api/src/Haddock/Interface/Rename.hs | 20 +++++-----
haddock-api/src/Haddock/Interface/Specialize.hs | 4 +-
haddock-api/src/Haddock/Types.hs | 7 ++++
haddock-api/src/Haddock/Utils.hs | 10 ++---
11 files changed, 86 insertions(+), 79 deletions(-)
(limited to 'haddock-api')
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 9e0b5102..09f62a19 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -138,7 +138,7 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl
ppExport _ _ = []
ppSigWithDoc :: DynFlags -> Sig GhcRn -> [(Name, DocForDecl Name)] -> [String]
-ppSigWithDoc dflags (TypeSig names sig) subdocs
+ppSigWithDoc dflags (TypeSig _ names sig) subdocs
= concatMap mkDocSig names
where
mkDocSig n = concatMap (ppDocumentation dflags) (getDoc n)
@@ -262,7 +262,7 @@ ppCtor dflags _dat subdocs con@(ConDeclGADT { })
name = out dflags $ map unL $ getConNames con
ppFixity :: DynFlags -> (Name, Fixity) -> [String]
-ppFixity dflags (name, fixity) = [out dflags ((FixitySig [noLoc name] fixity) :: FixitySig GhcRn)]
+ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExt [noLoc name] fixity) :: FixitySig GhcRn)]
---------------------------------------------------------------------
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 3d7575eb..19d638d9 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -114,7 +114,7 @@ binds = everythingInRenamedSource
(fun `Syb.combine` pat `Syb.combine` tvar)
where
fun term = case cast term of
- (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.GhcRn)) ->
+ (Just (GHC.FunBind _ (GHC.L sspan name) _ _ _ :: GHC.HsBind GHC.GhcRn)) ->
pure (sspan, RtkBind name)
_ -> empty
pat term = case cast term of
@@ -150,7 +150,7 @@ decls (group, _, _, _) = concatMap ($ group)
GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam
GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs
fun term = case cast term of
- (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.GhcRn))
+ (Just (GHC.FunBind _ (GHC.L sspan name) _ _ _ :: GHC.HsBind GHC.GhcRn))
| GHC.isExternalName name -> pure (sspan, RtkDecl name)
_ -> empty
con term = case cast term of
@@ -169,7 +169,7 @@ decls (group, _, _, _) = concatMap ($ group)
Just (field :: GHC.ConDeclField GHC.GhcRn)
-> map (decl . fmap GHC.extFieldOcc) $ GHC.cd_fld_names field
Nothing -> empty
- sig (GHC.L _ (GHC.TypeSig names _)) = map decl names
+ sig (GHC.L _ (GHC.TypeSig _ names _)) = map decl names
sig _ = []
decl (GHC.L sspan name) = (sspan, RtkDecl name)
tyref (GHC.L sspan name) = (sspan, RtkType name)
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 1229a8d3..4535979e 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -216,7 +216,7 @@ processExports (e : es) =
isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsType DocNameI)
-isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames t))
+isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig _ lnames t))
, expItemMbDoc = (Documentation Nothing Nothing, argDocs) }
| Map.null argDocs = Just (map unLoc lnames, unLoc (hsSigWcType t))
isSimpleSig _ = Nothing
@@ -257,8 +257,8 @@ declNames :: LHsDecl DocNameI
)
declNames (L _ decl) = case decl of
TyClD d -> (empty, [tcdName d])
- SigD (TypeSig lnames _ ) -> (empty, map unLoc lnames)
- SigD (PatSynSig lnames _) -> (text "pattern", map unLoc lnames)
+ SigD (TypeSig _ lnames _ ) -> (empty, map unLoc lnames)
+ SigD (PatSynSig _ lnames _) -> (text "pattern", map unLoc lnames)
ForD (ForeignImport (L _ n) _ _ _) -> (empty, [n])
ForD (ForeignExport (L _ n) _ _ _) -> (empty, [n])
_ -> error "declaration not supported by declNames"
@@ -300,13 +300,13 @@ ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of
-- TyClD d@TySynonym{}
-- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode
-- Family instances happen via FamInst now
- TyClD d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode
- SigD (TypeSig lnames ty) -> ppFunSig (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode
- SigD (PatSynSig lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode
- ForD d -> ppFor (doc, fnArgsDoc) d unicode
- InstD _ -> empty
- DerivD _ -> empty
- _ -> error "declaration not supported by ppDecl"
+ TyClD d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode
+ SigD (TypeSig _ lnames ty) -> ppFunSig (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode
+ SigD (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode
+ ForD d -> ppFor (doc, fnArgsDoc) d unicode
+ InstD _ -> empty
+ DerivD _ -> empty
+ _ -> error "declaration not supported by ppDecl"
where
unicode = False
@@ -548,7 +548,7 @@ ppClassDecl instances doc subdocs
methodTable =
text "\\haddockpremethods{}\\textbf{Methods}" $$
vcat [ ppFunSig doc names (hsSigWcType typ) unicode
- | L _ (TypeSig lnames typ) <- lsigs
+ | L _ (TypeSig _ lnames typ) <- lsigs
, let doc = lookupAnySubdoc (head names) subdocs
names = map unLoc lnames ]
-- FIXME: is taking just the first name ok? Is it possible that
@@ -647,7 +647,7 @@ ppDataDecl pats instances subdocs doc dataDecl unicode =
text "\\enspace" <+> emph (text "Bundled Patterns") <> text "\\par" $$
text "\\haddockbeginconstrs" $$
vcat [ empty <-> ppSideBySidePat lnames typ d unicode
- | (SigD (PatSynSig lnames typ), d) <- pats
+ | (SigD (PatSynSig _ lnames typ), d) <- pats
] $$
text "\\end{tabulary}\\par"
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index a4f2a4a5..5f253cbd 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -58,9 +58,9 @@ ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdoc
TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode qual
TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual
TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual
- SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames
+ SigD (TypeSig _ lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames
(hsSigWcType lty) fixities splice unicode qual
- SigD (PatSynSig lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames
+ SigD (PatSynSig _ lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames
(hsSigType lty) fixities splice unicode qual
ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual
InstD _ -> noHtml
@@ -513,7 +513,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t
[ ppFunSig summary links loc doc names (hsSigWcType typ)
[] splice unicode qual
- | L _ (TypeSig lnames typ) <- sigs
+ | L _ (TypeSig _ lnames typ) <- sigs
, let doc = lookupAnySubdoc (head names) subdocs
names = map unLoc lnames ]
-- FIXME: is taking just the first name ok? Is it possible that
@@ -561,7 +561,7 @@ ppClassDecl summary links instances fixities loc d subdocs
methodBit = subMethods [ ppFunSig summary links loc doc names (hsSigType typ)
subfixs splice unicode qual
- | L _ (ClassOpSig _ lnames typ) <- lsigs
+ | L _ (ClassOpSig _ _ lnames typ) <- lsigs
, let doc = lookupAnySubdoc (head names) subdocs
subfixs = [ f | n <- names
, f@(n',_) <- fixities
@@ -570,15 +570,15 @@ ppClassDecl summary links instances fixities loc d subdocs
-- N.B. taking just the first name is ok. Signatures with multiple names
-- are expanded so that each name gets its own signature.
- minimalBit = case [ s | MinimalSig _ (L _ s) <- sigs ] of
+ minimalBit = case [ s | MinimalSig _ _ (L _ s) <- sigs ] of
-- Miminal complete definition = every shown method
And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] ==
- sort [getName n | TypeSig ns _ <- sigs, L _ n <- ns]
+ sort [getName n | TypeSig _ ns _ <- sigs, L _ n <- ns]
-> noHtml
-- Minimal complete definition = the only shown method
Var (L _ n) : _ | [getName n] ==
- [getName n' | L _ (TypeSig ns _) <- lsigs, L _ n' <- ns]
+ [getName n' | L _ (TypeSig _ ns _) <- lsigs, L _ n' <- ns]
-> noHtml
-- Minimal complete definition = nothing
@@ -679,7 +679,7 @@ ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification
-> [Sig DocNameI]
-> [Html]
ppInstanceSigs links splice unicode qual sigs = do
- TypeSig lnames typ <- sigs
+ TypeSig _ lnames typ <- sigs
let names = map unLoc lnames
L _ rtyp = hsSigWcType typ
-- Instance methods signatures are synified and thus don't have a useful
@@ -746,7 +746,7 @@ ppShortDataDecl summary dataInst dataDecl pats unicode qual
, dcolon unicode
, ppPatSigType unicode qual (hsSigType typ)
]
- | (SigD (PatSynSig lnames typ),_) <- pats
+ | (SigD (PatSynSig _ lnames typ),_) <- pats
]
@@ -793,7 +793,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats
patternBit = subPatterns qual
[ ppSideBySidePat subfixs unicode qual lnames typ d
- | (SigD (PatSynSig lnames typ), d) <- pats
+ | (SigD (PatSynSig _ lnames typ), d) <- pats
, let subfixs = filter (\(n,_) -> any (\cn -> cn == n)
(map unLoc lnames)) fixities
]
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index fac448a2..fd9f0089 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -85,7 +85,7 @@ tyThingToLHsDecl t = case t of
, tcdFDs = map (\ (l,r) -> noLoc
(map (noLoc . getName) l, map (noLoc . getName) r) ) $
snd $ classTvsFds cl
- , tcdSigs = noLoc (MinimalSig NoSourceText . noLoc . fmap noLoc $ classMinimalDef cl) :
+ , tcdSigs = noLoc (MinimalSig noExt NoSourceText . noLoc . fmap noLoc $ classMinimalDef cl) :
map (noLoc . synifyTcIdSig DeleteTopLevelQuantification)
(classMethods cl)
, tcdMeths = emptyBag --ignore default method definitions, they don't affect signature
@@ -102,11 +102,11 @@ tyThingToLHsDecl t = case t of
ACoAxiom ax -> synifyAxiom ax >>= allOK
-- a data-constructor alone just gets rendered as a function:
- AConLike (RealDataCon dc) -> allOK $ SigD (TypeSig [synifyName dc]
+ AConLike (RealDataCon dc) -> allOK $ SigD (TypeSig noExt [synifyName dc]
(synifySigWcType ImplicitizeForAll (dataConUserType dc)))
AConLike (PatSynCon ps) ->
- allOK . SigD $ PatSynSig [synifyName ps] (synifyPatSynSigType ps)
+ allOK . SigD $ PatSynSig noExt [synifyName ps] (synifyPatSynSigType ps)
where
withErrs e x = return (e, x)
allOK x = return (mempty, x)
@@ -331,10 +331,10 @@ synifyName n = L (srcLocSpan (getSrcLoc n)) (getName n)
synifyIdSig :: SynifyTypeState -> Id -> Sig GhcRn
-synifyIdSig s i = TypeSig [synifyName i] (synifySigWcType s (varType i))
+synifyIdSig s i = TypeSig noExt [synifyName i] (synifySigWcType s (varType i))
synifyTcIdSig :: SynifyTypeState -> Id -> Sig GhcRn
-synifyTcIdSig s i = ClassOpSig False [synifyName i] (synifySigType s (varType i))
+synifyTcIdSig s i = ClassOpSig noExt False [synifyName i] (synifySigType s (varType i))
synifyCtx :: [PredType] -> LHsContext GhcRn
synifyCtx = noLoc . map (synifyType WithinType)
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 48a9f99e..14111a6a 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -74,30 +74,30 @@ getInstLoc (TyFamInstD (TyFamInstDecl
-- foo, bar :: Types..
-- but only one of the names is exported and we have to change the
-- type signature to only include the exported names.
-filterLSigNames :: (IdP name -> Bool) -> LSig name -> Maybe (LSig name)
+filterLSigNames :: (IdP (GhcPass p) -> Bool) -> LSig (GhcPass p) -> Maybe (LSig (GhcPass p))
filterLSigNames p (L loc sig) = L loc <$> (filterSigNames p sig)
-filterSigNames :: (IdP name -> Bool) -> Sig name -> Maybe (Sig name)
-filterSigNames p orig@(SpecSig n _ _) = ifTrueJust (p $ unLoc n) orig
-filterSigNames p orig@(InlineSig n _) = ifTrueJust (p $ unLoc n) orig
-filterSigNames p (FixSig (FixitySig ns ty)) =
+filterSigNames :: (IdP (GhcPass p) -> Bool) -> Sig (GhcPass p) -> Maybe (Sig (GhcPass p))
+filterSigNames p orig@(SpecSig _ n _ _) = ifTrueJust (p $ unLoc n) orig
+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 (FixitySig filtered ty))
-filterSigNames _ orig@(MinimalSig _ _) = Just orig
-filterSigNames p (TypeSig ns ty) =
+ filtered -> Just (FixSig noExt (FixitySig noExt filtered ty))
+filterSigNames _ orig@(MinimalSig _ _ _) = Just orig
+filterSigNames p (TypeSig _ ns ty) =
case filter (p . unLoc) ns of
[] -> Nothing
- filtered -> Just (TypeSig filtered ty)
-filterSigNames p (ClassOpSig is_default ns ty) =
+ filtered -> Just (TypeSig noExt filtered ty)
+filterSigNames p (ClassOpSig _ is_default ns ty) =
case filter (p . unLoc) ns of
[] -> Nothing
- filtered -> Just (ClassOpSig is_default filtered ty)
-filterSigNames p (PatSynSig ns ty) =
+ filtered -> Just (ClassOpSig noExt is_default filtered ty)
+filterSigNames p (PatSynSig _ ns ty) =
case filter (p . unLoc) ns of
[] -> Nothing
- filtered -> Just (PatSynSig filtered ty)
-filterSigNames _ _ = Nothing
+ filtered -> Just (PatSynSig noExt filtered ty)
+filterSigNames _ _ = Nothing
ifTrueJust :: Bool -> name -> Maybe name
ifTrueJust True = Just
@@ -107,13 +107,13 @@ sigName :: LSig name -> [IdP name]
sigName (L _ sig) = sigNameNoLoc sig
sigNameNoLoc :: Sig name -> [IdP name]
-sigNameNoLoc (TypeSig ns _) = map unLoc ns
-sigNameNoLoc (ClassOpSig _ ns _) = map unLoc ns
-sigNameNoLoc (PatSynSig ns _) = map unLoc ns
-sigNameNoLoc (SpecSig n _ _) = [unLoc n]
-sigNameNoLoc (InlineSig n _) = [unLoc n]
-sigNameNoLoc (FixSig (FixitySig ns _)) = map unLoc ns
-sigNameNoLoc _ = []
+sigNameNoLoc (TypeSig _ ns _) = map unLoc ns
+sigNameNoLoc (ClassOpSig _ _ ns _) = map unLoc ns
+sigNameNoLoc (PatSynSig _ ns _) = map unLoc ns
+sigNameNoLoc (SpecSig _ n _ _) = [unLoc n]
+sigNameNoLoc (InlineSig _ n _) = [unLoc n]
+sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map unLoc ns
+sigNameNoLoc _ = []
-- | Was this signature given by the user?
isUserLSig :: LSig name -> Bool
@@ -258,7 +258,7 @@ instance Parent (TyClDecl GhcRn) where
$ (dd_cons . tcdDataDefn) $ d
| isClassDecl d =
map (unL . fdLName . unL) (tcdATs d) ++
- [ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ]
+ [ unL n | L _ (TypeSig _ ns _) <- tcdSigs d, n <- ns ]
| otherwise = []
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 88b8bc67..c119f3c3 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -481,9 +481,9 @@ conArgDocs con = case getConArgs con of
-- | Extract function argument docs from inside top-level decls.
declTypeDocs :: HsDecl GhcRn -> Map Int HsDocString
-declTypeDocs (SigD (TypeSig _ ty)) = typeDocs (unLoc (hsSigWcType ty))
-declTypeDocs (SigD (ClassOpSig _ _ ty)) = typeDocs (unLoc (hsSigType ty))
-declTypeDocs (SigD (PatSynSig _ ty)) = typeDocs (unLoc (hsSigType ty))
+declTypeDocs (SigD (TypeSig _ _ ty)) = typeDocs (unLoc (hsSigWcType ty))
+declTypeDocs (SigD (ClassOpSig _ _ _ ty)) = typeDocs (unLoc (hsSigType ty))
+declTypeDocs (SigD (PatSynSig _ _ ty)) = typeDocs (unLoc (hsSigType ty))
declTypeDocs (ForD (ForeignImport _ ty _ _)) = typeDocs (unLoc (hsSigType ty))
declTypeDocs (TyClD (SynDecl { tcdRhs = ty })) = typeDocs (unLoc ty)
declTypeDocs _ = M.empty
@@ -519,7 +519,7 @@ topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup
-- | Extract a map of fixity declarations only
mkFixMap :: HsGroup GhcRn -> FixMap
mkFixMap group_ = M.fromList [ (n,f)
- | L _ (FixitySig ns f) <- hs_fixds group_,
+ | L _ (FixitySig _ ns f) <- hs_fixds group_,
L _ n <- ns ]
@@ -729,7 +729,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
L loc (TyClD cl@ClassDecl{}) -> do
mdef <- liftGhcToErrMsgGhc $ minimalDef t
- let sig = maybeToList $ fmap (noLoc . MinimalSig NoSourceText . noLoc . fmap noLoc) mdef
+ let sig = maybeToList $ fmap (noLoc . MinimalSig noExt NoSourceText . noLoc . fmap noLoc) mdef
availExportDecl avail
(L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_
@@ -1022,7 +1022,7 @@ extractDecl declMap name decl
matchesMethod =
[ lsig
| lsig <- tcdSigs d
- , ClassOpSig False _ _ <- pure $ unLoc lsig
+ , ClassOpSig _ False _ _ <- pure $ unLoc lsig
-- Note: exclude `default` declarations (see #505)
, name `elem` sigName lsig
]
@@ -1097,7 +1097,7 @@ extractPatternSyn nm t tvs cons =
ConDeclH98 { con_mb_cxt = Just cxt } -> noLoc (HsQualTy noExt cxt typ)
_ -> typ
typ'' = noLoc (HsQualTy noExt (noLoc []) typ')
- in PatSynSig [noLoc nm] (mkEmptyImplicitBndrs typ'')
+ in PatSynSig noExt [noLoc nm] (mkEmptyImplicitBndrs typ'')
longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn
longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExt x y)) output inputs
@@ -1113,7 +1113,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 [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExt data_ty (getBangType ty)))))
+ L l (TypeSig noExt [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExt data_ty (getBangType ty)))))
_ -> extractRecSel nm t tvs rest
where
matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)]
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index c8d9cb7d..0652ae47 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -480,24 +480,24 @@ renameLFieldOcc (L _ (XFieldOcc _)) = error "haddock:renameLFieldOcc"
renameSig :: Sig GhcRn -> RnM (Sig DocNameI)
renameSig sig = case sig of
- TypeSig lnames ltype -> do
+ TypeSig _ lnames ltype -> do
lnames' <- mapM renameL lnames
ltype' <- renameLSigWcType ltype
- return (TypeSig lnames' ltype')
- ClassOpSig is_default lnames sig_ty -> do
+ return (TypeSig noExt lnames' ltype')
+ ClassOpSig _ is_default lnames sig_ty -> do
lnames' <- mapM renameL lnames
ltype' <- renameLSigType sig_ty
- return (ClassOpSig is_default lnames' ltype')
- PatSynSig lnames sig_ty -> do
+ return (ClassOpSig noExt is_default lnames' ltype')
+ PatSynSig _ lnames sig_ty -> do
lnames' <- mapM renameL lnames
sig_ty' <- renameLSigType sig_ty
- return $ PatSynSig lnames' sig_ty'
- FixSig (FixitySig lnames fixity) -> do
+ return $ PatSynSig noExt lnames' sig_ty'
+ FixSig _ (FixitySig _ lnames fixity) -> do
lnames' <- mapM renameL lnames
- return $ FixSig (FixitySig lnames' fixity)
- MinimalSig src (L l s) -> do
+ return $ FixSig noExt (FixitySig noExt lnames' fixity)
+ MinimalSig _ src (L l s) -> do
s' <- traverse renameL s
- return $ MinimalSig src (L l s')
+ return $ MinimalSig noExt src (L l s')
-- we have filtered out all other kinds of signatures in Interface.Create
_ -> error "expected TypeSig"
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 18d93fae..b84a676f 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -73,8 +73,8 @@ specializePseudoFamilyDecl bndrs typs decl =
specializeSig :: LHsQTyVars GhcRn -> [HsType GhcRn]
-> Sig GhcRn
-> Sig GhcRn
-specializeSig bndrs typs (TypeSig lnames typ) =
- TypeSig lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}})
+specializeSig bndrs typs (TypeSig _ lnames typ) =
+ TypeSig noExt lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}})
where
true_type :: HsType GhcRn
true_type = unLoc (hsSigWcType typ)
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index b4b16d62..2234894c 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -696,3 +696,10 @@ type instance XXTyVarBndr DocNameI = PlaceHolder
type instance XFieldOcc DocNameI = DocName
type instance XXFieldOcc DocNameI = PlaceHolder
+
+type instance XFixitySig DocNameI = PlaceHolder
+type instance XFixSig DocNameI = PlaceHolder
+type instance XPatSynSig DocNameI = PlaceHolder
+type instance XClassOpSig DocNameI = PlaceHolder
+type instance XTypeSig DocNameI = PlaceHolder
+type instance XMinimalSig DocNameI = PlaceHolder
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 5de539c0..1ebf7ffa 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -131,18 +131,18 @@ 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 lname (mkEmptySigWcType (go (hsSigType ltype))))
+addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype))
+ = L pos (TypeSig noExt lname (mkEmptySigWcType (go (hsSigType ltype))))
-- The mkEmptySigWcType is suspicious
where
go (L loc (HsForAllTy { hst_bndrs = tvs, hst_body = ty }))
- = L loc (HsForAllTy { hst_xforall = PlaceHolder
+ = L loc (HsForAllTy { hst_xforall = noExt
, hst_bndrs = tvs, hst_body = go ty })
go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty }))
- = L loc (HsQualTy { hst_xqual = PlaceHolder
+ = L loc (HsQualTy { hst_xqual = noExt
, hst_ctxt = add_ctxt ctxt, hst_body = ty })
go (L loc ty)
- = L loc (HsQualTy { hst_xqual = PlaceHolder
+ = L loc (HsQualTy { hst_xqual = noExt
, hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty })
extra_pred = nlHsTyConApp cls (lHsQTyVarsToTypes tvs0)
--
cgit v1.2.3