From 24841386cff6fdccc11accf9daa815c2c7444d65 Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simonpj@microsoft.com>
Date: Mon, 27 Nov 2017 13:24:01 +0000
Subject: Track changes to follow Trac #14529
This tracks the refactoring of HsDecl.ConDecl.
---
haddock-api/src/Haddock/GhcUtils.hs | 31 ++++++++++++++++++++++++++++++-
1 file changed, 30 insertions(+), 1 deletion(-)
(limited to 'haddock-api/src/Haddock/GhcUtils.hs')
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index a1009c1f..4963d2f8 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -17,6 +17,7 @@ module Haddock.GhcUtils where
import Control.Arrow
+import Haddock.Types( DocNameI )
import Exception
import Outputable
@@ -148,6 +149,32 @@ nubByName f ns = go emptyNameSet ns
where
y = f x
+getGADTConType :: ConDecl p -> LHsType p
+-- The full type of a GADT data constructor We really only get this in
+-- order to pretty-print it, and currently only in Haddock's code. So
+-- we are cavalier about locations and extensions, hence the
+-- 'undefined's
+getGADTConType (ConDeclGADT { con_forall = has_forall
+ , con_qvars = qtvs
+ , con_mb_cxt = mcxt, con_args = args
+ , con_res_ty = res_ty })
+ | has_forall = noLoc (HsForAllTy { hst_bndrs = hsQTvExplicit qtvs
+ , hst_body = theta_ty })
+ | otherwise = theta_ty
+ where
+ theta_ty | Just theta <- mcxt
+ = noLoc (HsQualTy { hst_ctxt = theta, hst_body = tau_ty })
+ | otherwise
+ = tau_ty
+
+ tau_ty = case args of
+ RecCon flds -> noLoc (HsFunTy (noLoc (HsRecTy (unLoc flds))) res_ty)
+ PrefixCon pos_args -> foldr (\ a b -> noLoc (HsFunTy a b)) res_ty pos_args
+ InfixCon {} -> panic "InfixCon for GADT"
+
+getGADTConType (ConDeclH98 {}) = panic "getGADTConType"
+ -- Should only be called on ConDeclGADT
+
-------------------------------------------------------------------------------
-- * Located
-------------------------------------------------------------------------------
@@ -179,7 +206,7 @@ class Parent a where
instance Parent (ConDecl GhcRn) where
children con =
- case getConDetails con of
+ case con_args con of
RecCon fields -> map (selectorFieldOcc . unL) $
concatMap (cd_fld_names . unL) (unL fields)
_ -> []
@@ -259,3 +286,5 @@ setStubDir f d = d{ stubDir = Just f, includePaths = f : includePaths d }
-- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file
-- \#included from the .hc file when compiling with -fvia-C.
setOutputDir f = setObjectDir f . setHiDir f . setStubDir f
+
+
--
cgit v1.2.3
From 48ee5587b574105a231072999b06aa56c37292c4 Mon Sep 17 00:00:00 2001
From: Ryan Scott <ryan.gl.scott@gmail.com>
Date: Fri, 19 Jan 2018 04:44:02 -0500
Subject: Fix #732 (#733)
---
haddock-api/src/Haddock/GhcUtils.hs | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
(limited to 'haddock-api/src/Haddock/GhcUtils.hs')
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 4963d2f8..17c92688 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -169,8 +169,8 @@ getGADTConType (ConDeclGADT { con_forall = has_forall
tau_ty = case args of
RecCon flds -> noLoc (HsFunTy (noLoc (HsRecTy (unLoc flds))) res_ty)
- PrefixCon pos_args -> foldr (\ a b -> noLoc (HsFunTy a b)) res_ty pos_args
- InfixCon {} -> panic "InfixCon for GADT"
+ PrefixCon pos_args -> foldr nlHsFunTy res_ty pos_args
+ InfixCon arg1 arg2 -> arg1 `nlHsFunTy` (arg2 `nlHsFunTy` res_ty)
getGADTConType (ConDeclH98 {}) = panic "getGADTConType"
-- Should only be called on ConDeclGADT
--
cgit v1.2.3
From 4804e39144dc0ded9b38dbb3442b6016ac719a1a Mon Sep 17 00:00:00 2001
From: Tamar Christina <Mistuke@users.noreply.github.com>
Date: Mon, 19 Feb 2018 04:34:49 +0000
Subject: Haddock: support splitted include paths. (#689)
---
haddock-api/src/Haddock/GhcUtils.hs | 4 +++-
1 file changed, 3 insertions(+), 1 deletion(-)
(limited to 'haddock-api/src/Haddock/GhcUtils.hs')
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 17c92688..b3260fd5 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -28,6 +28,7 @@ import Module
import HscTypes
import GHC
import Class
+import DynFlags
moduleString :: Module -> String
@@ -282,7 +283,8 @@ minimalDef n = do
setObjectDir, setHiDir, setStubDir, setOutputDir :: String -> DynFlags -> DynFlags
setObjectDir f d = d{ objectDir = Just f}
setHiDir f d = d{ hiDir = Just f}
-setStubDir f d = d{ stubDir = Just f, includePaths = f : includePaths d }
+setStubDir f d = d{ stubDir = Just f
+ , includePaths = addGlobalInclude (includePaths d) [f] }
-- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file
-- \#included from the .hc file when compiling with -fvia-C.
setOutputDir f = setObjectDir f . setHiDir f . setStubDir f
--
cgit v1.2.3
From c84939c8428a9e9ae0753e75ca6b48fcbbc1ecd6 Mon Sep 17 00:00:00 2001
From: Alan Zimmerman <alan.zimm@gmail.com>
Date: Sun, 8 Apr 2018 16:21:27 +0200
Subject: Match GHC changes for TTG
---
haddock-api/src/Haddock/Backends/Hoogle.hs | 38 ++---
.../src/Haddock/Backends/Hyperlinker/Ast.hs | 16 +-
haddock-api/src/Haddock/Backends/LaTeX.hs | 52 +++----
haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 71 ++++-----
haddock-api/src/Haddock/Convert.hs | 54 ++++---
haddock-api/src/Haddock/GhcUtils.hs | 54 ++++++-
haddock-api/src/Haddock/Interface/Create.hs | 34 ++---
haddock-api/src/Haddock/Interface/Rename.hs | 72 ++++-----
haddock-api/src/Haddock/Interface/Specialize.hs | 162 ++++++++++-----------
haddock-api/src/Haddock/Types.hs | 44 +++++-
haddock-api/src/Haddock/Utils.hs | 15 +-
11 files changed, 343 insertions(+), 269 deletions(-)
(limited to 'haddock-api/src/Haddock/GhcUtils.hs')
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 2feb0fb9..9e0b5102 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -74,18 +74,18 @@ dropHsDocTy :: HsType a -> HsType a
dropHsDocTy = f
where
g (L src x) = L src (f x)
- f (HsForAllTy a e) = HsForAllTy a (g e)
- f (HsQualTy a e) = HsQualTy a (g e)
- f (HsBangTy a b) = HsBangTy a (g b)
- f (HsAppTy a b) = HsAppTy (g a) (g b)
- f (HsFunTy a b) = HsFunTy (g a) (g b)
- f (HsListTy a) = HsListTy (g a)
- f (HsPArrTy a) = HsPArrTy (g a)
- f (HsTupleTy a b) = HsTupleTy a (map g b)
- f (HsOpTy a b c) = HsOpTy (g a) b (g c)
- f (HsParTy a) = HsParTy (g a)
- f (HsKindSig a b) = HsKindSig (g a) b
- f (HsDocTy a _) = f $ unL a
+ f (HsForAllTy x a e) = HsForAllTy x a (g e)
+ f (HsQualTy x a e) = HsQualTy x a (g e)
+ f (HsBangTy x a b) = HsBangTy x a (g b)
+ f (HsAppTy x a b) = HsAppTy x (g a) (g b)
+ f (HsFunTy x a b) = HsFunTy x (g a) (g b)
+ f (HsListTy x a) = HsListTy x (g a)
+ f (HsPArrTy x a) = HsPArrTy x (g a)
+ f (HsTupleTy x a b) = HsTupleTy x a (map g b)
+ f (HsOpTy x a b c) = HsOpTy x (g a) b (g c)
+ f (HsParTy x a) = HsParTy x (g a)
+ f (HsKindSig x a b) = HsKindSig x (g a) b
+ f (HsDocTy _ a _) = f $ unL a
f x = x
outHsType :: (a ~ GhcPass p, OutputableBndrId a)
@@ -237,12 +237,12 @@ ppCtor dflags dat subdocs con@ConDeclH98 {}
f (PrefixCon args) = [typeSig name $ args ++ [resType]]
f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]
f (RecCon (L _ recs)) = f (PrefixCon $ map cd_fld_type (map unLoc recs)) ++ concat
- [(concatMap (lookupCon dflags subdocs . noLoc . selectorFieldOcc . unLoc) (cd_fld_names r)) ++
- [out dflags (map (selectorFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]
+ [(concatMap (lookupCon dflags subdocs . noLoc . 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 x y)
- apps = foldl1 (\x y -> reL $ HsAppTy x y)
+ funs = foldr1 (\x y -> reL $ HsFunTy PlaceHolder x y)
+ apps = foldl1 (\x y -> reL $ HsAppTy PlaceHolder x y)
typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds)
@@ -250,13 +250,13 @@ ppCtor dflags dat subdocs con@ConDeclH98 {}
-- docs for con_names on why it is a list to begin with.
name = commaSeparate dflags . map unL $ getConNames con
- resType = apps $ map (reL . HsTyVar NotPromoted . reL) $
- (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvExplicit $ tyClDeclTyVars dat]
+ resType = apps $ map (reL . HsTyVar PlaceHolder NotPromoted . reL) $
+ (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _ _) <- hsQTvExplicit $ tyClDeclTyVars dat]
ppCtor dflags _dat subdocs con@(ConDeclGADT { })
= concatMap (lookupCon dflags subdocs) (getConNames con) ++ f
where
- f = [typeSig name (getGADTConType con)]
+ f = [typeSig name (getGADTConTypeG con)]
typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty)
name = out dflags $ map unL $ getConNames con
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 57ff72ff..3d7575eb 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -84,9 +84,9 @@ variables =
everythingInRenamedSource (var `Syb.combine` rec)
where
var term = case cast term of
- (Just ((GHC.L sspan (GHC.HsVar name)) :: GHC.LHsExpr GHC.GhcRn)) ->
+ (Just ((GHC.L sspan (GHC.HsVar _ name)) :: GHC.LHsExpr GHC.GhcRn)) ->
pure (sspan, RtkVar (GHC.unLoc name))
- (Just (GHC.L _ (GHC.RecordCon (GHC.L sspan name) _ _ _))) ->
+ (Just (GHC.L _ (GHC.RecordCon _ (GHC.L sspan name) _))) ->
pure (sspan, RtkVar name)
_ -> empty
rec term = case cast term of
@@ -99,7 +99,7 @@ types :: GHC.RenamedSource -> LTokenDetails
types = everythingInRenamedSource ty
where
ty term = case cast term of
- (Just ((GHC.L sspan (GHC.HsTyVar _ name)) :: GHC.LHsType GHC.GhcRn)) ->
+ (Just ((GHC.L sspan (GHC.HsTyVar _ _ name)) :: GHC.LHsType GHC.GhcRn)) ->
pure (sspan, RtkType (GHC.unLoc name))
_ -> empty
@@ -118,11 +118,11 @@ binds = everythingInRenamedSource
pure (sspan, RtkBind name)
_ -> empty
pat term = case cast term of
- (Just ((GHC.L sspan (GHC.VarPat name)) :: GHC.LPat GHC.GhcRn)) ->
+ (Just ((GHC.L sspan (GHC.VarPat _ name)) :: GHC.LPat GHC.GhcRn)) ->
pure (sspan, RtkBind (GHC.unLoc name))
(Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) ->
[(sspan, RtkVar name)] ++ everythingInRenamedSource rec recs
- (Just (GHC.L _ (GHC.AsPat (GHC.L sspan name) _))) ->
+ (Just (GHC.L _ (GHC.AsPat _ (GHC.L sspan name) _))) ->
pure (sspan, RtkBind name)
_ -> empty
rec term = case cast term of
@@ -130,9 +130,9 @@ binds = everythingInRenamedSource
pure (sspan, RtkVar name)
_ -> empty
tvar term = case cast term of
- (Just ((GHC.L sspan (GHC.UserTyVar name)) :: GHC.LHsTyVarBndr GHC.GhcRn)) ->
+ (Just ((GHC.L sspan (GHC.UserTyVar _ name)) :: GHC.LHsTyVarBndr GHC.GhcRn)) ->
pure (sspan, RtkBind (GHC.unLoc name))
- (Just (GHC.L _ (GHC.KindedTyVar (GHC.L sspan name) _))) ->
+ (Just (GHC.L _ (GHC.KindedTyVar _ (GHC.L sspan name) _))) ->
pure (sspan, RtkBind name)
_ -> empty
@@ -167,7 +167,7 @@ decls (group, _, _, _) = concatMap ($ group)
_ -> empty
fld term = case cast term of
Just (field :: GHC.ConDeclField GHC.GhcRn)
- -> map (decl . fmap GHC.selectorFieldOcc) $ GHC.cd_fld_names field
+ -> map (decl . fmap GHC.extFieldOcc) $ GHC.cd_fld_names field
Nothing -> empty
sig (GHC.L _ (GHC.TypeSig names _)) = map decl names
sig _ = []
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 51e183c7..1229a8d3 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -412,22 +412,22 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ
arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs
do_args :: Int -> LaTeX -> HsType DocNameI -> [(LaTeX, LaTeX)]
- do_args _n leader (HsForAllTy tvs ltype)
+ do_args _n leader (HsForAllTy _ tvs ltype)
= [ ( decltt leader
, decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]))
<+> ppLType unicode ltype
) ]
- do_args n leader (HsQualTy lctxt ltype)
+ do_args n leader (HsQualTy _ lctxt ltype)
= (decltt leader, ppLContextNoArrow lctxt unicode <+> nl)
: do_largs n (darrow unicode) ltype
- do_args n leader (HsFunTy (L _ (HsRecTy fields)) r)
+ do_args n leader (HsFunTy _ (L _ (HsRecTy _ fields)) r)
= [ (decltt ldr, latex <+> nl)
| (L _ field, ldr) <- zip fields (leader <+> gadtOpen : repeat gadtComma)
, let latex = ppSideBySideField subdocs unicode field
]
++ do_largs (n+1) (gadtEnd <+> arrow unicode) r
- do_args n leader (HsFunTy lt r)
+ do_args n leader (HsFunTy _ lt r)
= (decltt leader, decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl)
: do_largs (n+1) (arrow unicode) r
do_args n leader t
@@ -777,7 +777,7 @@ ppSideBySideField subdocs unicode (ConDeclField names ltype _) =
where
-- don't use cd_fld_doc for same reason we don't use con_doc above
-- Where there is more than one name, they all have the same documentation
- mbDoc = lookup (selectorFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst
+ mbDoc = lookup (extFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst
-- | Pretty-print a bundled pattern synonym
@@ -957,57 +957,57 @@ ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode
ppr_mono_ty :: Int -> HsType DocNameI -> Bool -> LaTeX
-ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode
+ppr_mono_ty ctxt_prec (HsForAllTy _ tvs ty) unicode
= maybeParen ctxt_prec pREC_FUN $
sep [ hsep (forallSymbol unicode : ppTyVars tvs) <> dot
, ppr_mono_lty pREC_TOP ty unicode ]
-ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode
+ppr_mono_ty ctxt_prec (HsQualTy _ ctxt ty) unicode
= maybeParen ctxt_prec pREC_FUN $
sep [ ppLContext ctxt unicode
, ppr_mono_lty pREC_TOP ty unicode ]
-ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty
-ppr_mono_ty _ (HsTyVar NotPromoted (L _ name)) _ = ppDocName name
-ppr_mono_ty _ (HsTyVar Promoted (L _ name)) _ = char '\'' <> ppDocName name
-ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u = ppr_fun_ty ctxt_prec ty1 ty2 u
-ppr_mono_ty _ (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys)
-ppr_mono_ty _ (HsSumTy tys) u = sumParens (map (ppLType u) tys)
-ppr_mono_ty _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind)
-ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty u)
-ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u)
-ppr_mono_ty _ (HsIParamTy (L _ n) ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u)
+ppr_mono_ty _ (HsBangTy _ b ty) u = ppBang b <> ppLParendType u ty
+ppr_mono_ty _ (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name
+ppr_mono_ty _ (HsTyVar _ Promoted (L _ name)) _ = char '\'' <> ppDocName name
+ppr_mono_ty ctxt_prec (HsFunTy _ ty1 ty2) u = ppr_fun_ty ctxt_prec ty1 ty2 u
+ppr_mono_ty _ (HsTupleTy _ con tys) u = tupleParens con (map (ppLType u) tys)
+ppr_mono_ty _ (HsSumTy _ tys) u = sumParens (map (ppLType u) tys)
+ppr_mono_ty _ (HsKindSig _ ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind)
+ppr_mono_ty _ (HsListTy _ ty) u = brackets (ppr_mono_lty pREC_TOP ty u)
+ppr_mono_ty _ (HsPArrTy _ ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u)
+ppr_mono_ty _ (HsIParamTy _ (L _ n) ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u)
ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy"
ppr_mono_ty _ (HsRecTy {}) _ = text "{..}"
-ppr_mono_ty _ (HsCoreTy {}) _ = error "ppr_mono_ty HsCoreTy"
-ppr_mono_ty _ (HsExplicitListTy Promoted _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys
-ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) u = brackets $ hsep $ punctuate comma $ map (ppLType u) tys
+ppr_mono_ty _ (XHsType (NHsCoreTy {})) _ = error "ppr_mono_ty HsCoreTy"
+ppr_mono_ty _ (HsExplicitListTy _ Promoted tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys
+ppr_mono_ty _ (HsExplicitListTy _ NotPromoted tys) u = brackets $ hsep $ punctuate comma $ map (ppLType u) tys
ppr_mono_ty _ (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys
-ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode
+ppr_mono_ty ctxt_prec (HsEqTy _ ty1 ty2) unicode
= maybeParen ctxt_prec pREC_OP $
ppr_mono_lty pREC_OP ty1 unicode <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode
-ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode
+ppr_mono_ty ctxt_prec (HsAppTy _ fun_ty arg_ty) unicode
= maybeParen ctxt_prec pREC_CON $
hsep [ppr_mono_lty pREC_FUN fun_ty unicode, ppr_mono_lty pREC_CON arg_ty unicode]
-ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode
+ppr_mono_ty ctxt_prec (HsOpTy _ ty1 op ty2) unicode
= maybeParen ctxt_prec pREC_FUN $
ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode
where
ppr_op = if not (isSymOcc occName) then char '`' <> ppLDocName op <> char '`' else ppLDocName op
occName = nameOccName . getName . unLoc $ op
-ppr_mono_ty ctxt_prec (HsParTy ty) unicode
+ppr_mono_ty ctxt_prec (HsParTy _ ty) unicode
-- = parens (ppr_mono_lty pREC_TOP ty)
= ppr_mono_lty ctxt_prec ty unicode
-ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode
+ppr_mono_ty ctxt_prec (HsDocTy _ ty _) unicode
= ppr_mono_lty ctxt_prec ty unicode
ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ = char '_'
-ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u
+ppr_mono_ty _ (HsTyLit _ t) u = ppr_tylit t u
ppr_mono_ty _ (HsAppsTy {}) _ = panic "ppr_mono_ty:HsAppsTy"
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index fcc52a99..a4f2a4a5 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -146,26 +146,26 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ
do_largs n leader (L _ t) = do_args n leader t
do_args :: Int -> Html -> HsType DocNameI -> [SubDecl]
- do_args n leader (HsForAllTy tvs ltype)
+ do_args n leader (HsForAllTy _ tvs ltype)
= do_largs n leader' ltype
where
leader' = leader <+> ppForAll tvs unicode qual
- do_args n leader (HsQualTy lctxt ltype)
+ do_args n leader (HsQualTy _ lctxt ltype)
| null (unLoc lctxt)
= do_largs n leader ltype
| otherwise
= (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, [])
: do_largs n (darrow unicode) ltype
- do_args n leader (HsFunTy (L _ (HsRecTy fields)) r)
+ do_args n leader (HsFunTy _ (L _ (HsRecTy _ fields)) r)
= [ (ldr <+> html, mdoc, subs)
| (L _ field, ldr) <- zip fields (leader <+> gadtOpen : repeat gadtComma)
, let (html, mdoc, subs) = ppSideBySideField subdocs unicode qual field
]
++ do_largs (n+1) (gadtEnd <+> arrow unicode) r
- do_args n leader (HsFunTy lt r)
+ do_args n leader (HsFunTy _ lt r)
= (leader <+> ppLFunLhType unicode qual emptyCtxts lt, argDoc n, [])
: do_largs (n+1) (arrow unicode) r
@@ -186,7 +186,7 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ
ppForAll :: [LHsTyVarBndr DocNameI] -> Unicode -> Qualification -> Html
ppForAll tvs unicode qual =
- case [ppKTv n k | L _ (KindedTyVar (L _ n) k) <- tvs] of
+ case [ppKTv n k | L _ (KindedTyVar _ (L _ n) k) <- tvs] of
[] -> noHtml
ts -> forallSymbol unicode <+> hsep ts +++ dot
where ppKTv n k = parens $
@@ -993,7 +993,7 @@ ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) =
where
-- don't use cd_fld_doc for same reason we don't use con_doc above
-- Where there is more than one name, they all have the same documentation
- mbDoc = lookup (selectorFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst
+ mbDoc = lookup (extFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst
ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> Html
@@ -1114,11 +1114,12 @@ ppParendType unicode qual emptyCtxts ty = ppr_mono_ty pREC_CON ty unicode qual e
ppFunLhType unicode qual emptyCtxts ty = ppr_mono_ty pREC_FUN ty unicode qual emptyCtxts
ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocNameI -> Html
-ppHsTyVarBndr _ qual (UserTyVar (L _ name)) =
+ppHsTyVarBndr _ qual (UserTyVar _ (L _ name)) =
ppDocName qual Raw False name
-ppHsTyVarBndr unicode qual (KindedTyVar name kind) =
+ppHsTyVarBndr unicode qual (KindedTyVar _ name kind) =
parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+>
ppLKind unicode qual kind)
+ppHsTyVarBndr _ _ (XTyVarBndr _) = error "haddock:ppHsTyVarBndr"
ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> Html
ppLKind unicode qual y = ppKind unicode qual (unLoc y)
@@ -1133,16 +1134,16 @@ patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmp
hasNonEmptyContext :: LHsType name -> Bool
hasNonEmptyContext t =
case unLoc t of
- HsForAllTy _ s -> hasNonEmptyContext s
- HsQualTy cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True
- HsFunTy _ s -> hasNonEmptyContext s
+ HsForAllTy _ _ s -> hasNonEmptyContext s
+ HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True
+ HsFunTy _ _ s -> hasNonEmptyContext s
_ -> False
isFirstContextEmpty :: LHsType name -> Bool
isFirstContextEmpty t =
case unLoc t of
- HsForAllTy _ s -> isFirstContextEmpty s
- HsQualTy cxt _ -> null (unLoc cxt)
- HsFunTy _ s -> isFirstContextEmpty s
+ HsForAllTy _ _ s -> isFirstContextEmpty s
+ HsQualTy _ cxt _ -> null (unLoc cxt)
+ HsFunTy _ _ s -> isFirstContextEmpty s
_ -> False
@@ -1160,50 +1161,50 @@ ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)
ppr_mono_ty :: Int -> HsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
-ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode qual emptyCtxts
+ppr_mono_ty ctxt_prec (HsForAllTy _ tvs ty) unicode qual emptyCtxts
= maybeParen ctxt_prec pREC_FUN $
ppForAllPart unicode qual tvs <+> ppr_mono_lty pREC_TOP ty unicode qual emptyCtxts
-ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual emptyCtxts
+ppr_mono_ty ctxt_prec (HsQualTy _ ctxt ty) unicode qual emptyCtxts
= maybeParen ctxt_prec pREC_FUN $
ppLContext ctxt unicode qual emptyCtxts <+> ppr_mono_lty pREC_TOP ty unicode qual emptyCtxts
-- UnicodeSyntax alternatives
-ppr_mono_ty _ (HsTyVar _ (L _ name)) True _ _
+ppr_mono_ty _ (HsTyVar _ _ (L _ name)) True _ _
| getOccString (getName name) == "*" = toHtml "★"
| getOccString (getName name) == "(->)" = toHtml "(→)"
-ppr_mono_ty _ (HsBangTy b ty) u q _ = ppBang b +++ ppLParendType u q HideEmptyContexts ty
-ppr_mono_ty _ (HsTyVar _ (L _ name)) _ q _ = ppDocName q Prefix True name
-ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q e = ppr_fun_ty ctxt_prec ty1 ty2 u q e
-ppr_mono_ty _ (HsTupleTy con tys) u q _ = tupleParens con (map (ppLType u q HideEmptyContexts) tys)
-ppr_mono_ty _ (HsSumTy tys) u q _ = sumParens (map (ppLType u q HideEmptyContexts) tys)
-ppr_mono_ty _ (HsKindSig ty kind) u q e =
+ppr_mono_ty _ (HsBangTy _ b ty) u q _ = ppBang b +++ ppLParendType u q HideEmptyContexts ty
+ppr_mono_ty _ (HsTyVar _ _ (L _ name)) _ q _ = ppDocName q Prefix True name
+ppr_mono_ty ctxt_prec (HsFunTy _ ty1 ty2) u q e = ppr_fun_ty ctxt_prec ty1 ty2 u q e
+ppr_mono_ty _ (HsTupleTy _ con tys) u q _ = tupleParens con (map (ppLType u q HideEmptyContexts) tys)
+ppr_mono_ty _ (HsSumTy _ tys) u q _ = sumParens (map (ppLType u q HideEmptyContexts) tys)
+ppr_mono_ty _ (HsKindSig _ ty kind) u q e =
parens (ppr_mono_lty pREC_TOP ty u q e <+> dcolon u <+> ppLKind u q kind)
-ppr_mono_ty _ (HsListTy ty) u q _ = brackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts)
-ppr_mono_ty _ (HsPArrTy ty) u q _ = pabrackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts)
-ppr_mono_ty ctxt_prec (HsIParamTy (L _ n) ty) u q _ =
+ppr_mono_ty _ (HsListTy _ ty) u q _ = brackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts)
+ppr_mono_ty _ (HsPArrTy _ ty) u q _ = pabrackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts)
+ppr_mono_ty ctxt_prec (HsIParamTy _ (L _ n) ty) u q _ =
maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q HideEmptyContexts
ppr_mono_ty _ (HsSpliceTy {}) _ _ _ = error "ppr_mono_ty HsSpliceTy"
ppr_mono_ty _ (HsRecTy {}) _ _ _ = toHtml "{..}"
-- Can now legally occur in ConDeclGADT, the output here is to provide a
-- placeholder in the signature, which is followed by the field
-- declarations.
-ppr_mono_ty _ (HsCoreTy {}) _ _ _ = error "ppr_mono_ty HsCoreTy"
-ppr_mono_ty _ (HsExplicitListTy Promoted _ tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys
-ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys
+ppr_mono_ty _ (XHsType (NHsCoreTy {})) _ _ _ = error "ppr_mono_ty HsCoreTy"
+ppr_mono_ty _ (HsExplicitListTy _ Promoted tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys
+ppr_mono_ty _ (HsExplicitListTy _ NotPromoted tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys
ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q _ = promoQuote $ parenList $ map (ppLType u q HideEmptyContexts) tys
ppr_mono_ty _ (HsAppsTy {}) _ _ _ = error "ppr_mono_ty HsAppsTy"
-ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual _
+ppr_mono_ty ctxt_prec (HsEqTy _ ty1 ty2) unicode qual _
= maybeParen ctxt_prec pREC_CTX $
ppr_mono_lty pREC_OP ty1 unicode qual HideEmptyContexts <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode qual HideEmptyContexts
-ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual _
+ppr_mono_ty ctxt_prec (HsAppTy _ fun_ty arg_ty) unicode qual _
= maybeParen ctxt_prec pREC_CON $
hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual HideEmptyContexts, ppr_mono_lty pREC_CON arg_ty unicode qual HideEmptyContexts]
-ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual _
+ppr_mono_ty ctxt_prec (HsOpTy _ ty1 op ty2) unicode qual _
= maybeParen ctxt_prec pREC_FUN $
ppr_mono_lty pREC_OP ty1 unicode qual HideEmptyContexts <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual HideEmptyContexts
where
@@ -1214,15 +1215,15 @@ ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual _
| otherwise = ppr_op'
ppr_op' = ppLDocName qual Infix op
-ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual emptyCtxts
+ppr_mono_ty ctxt_prec (HsParTy _ ty) unicode qual emptyCtxts
-- = parens (ppr_mono_lty pREC_TOP ty)
= ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts
-ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual emptyCtxts
+ppr_mono_ty ctxt_prec (HsDocTy _ ty _) unicode qual emptyCtxts
= ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts
ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ _ = char '_'
-ppr_mono_ty _ (HsTyLit n) _ _ _ = ppr_tylit n
+ppr_mono_ty _ (HsTyLit _ n) _ _ _ = ppr_tylit n
ppr_tylit :: HsTyLit -> Html
ppr_tylit (HsNumTy _ n) = toHtml (show n)
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 37fad036..fac448a2 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -151,7 +151,7 @@ synifyTyCon _coax tc
DataDecl { tcdLName = synifyName tc
, tcdTyVars = -- tyConTyVars doesn't work on fun/prim, but we can make them up:
let mk_hs_tv realKind fakeTyVar
- = noLoc $ KindedTyVar (noLoc (getName fakeTyVar))
+ = noLoc $ KindedTyVar noExt (noLoc (getName fakeTyVar))
(synifyKindSig realKind)
in HsQTvs { hsq_implicit = [] -- No kind polymorphism
, hsq_explicit = zipWith mk_hs_tv (fst (splitFunTys (tyConKind tc)))
@@ -266,7 +266,7 @@ synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig GhcRn
synifyFamilyResultSig Nothing kind =
noLoc $ KindSig (synifyKindSig kind)
synifyFamilyResultSig (Just name) kind =
- noLoc $ TyVarSig (noLoc $ KindedTyVar (noLoc name) (synifyKindSig kind))
+ noLoc $ TyVarSig (noLoc $ KindedTyVar noExt (noLoc name) (synifyKindSig kind))
-- User beware: it is your responsibility to pass True (use_gadt_syntax)
-- for any constructor that would be misrepresented by omitting its
@@ -292,12 +292,12 @@ synifyDataCon use_gadt_syntax dc =
let tySyn = synifyType WithinType ty
in case bang of
(HsSrcBang _ NoSrcUnpack NoSrcStrict) -> tySyn
- bang' -> noLoc $ HsBangTy bang' tySyn)
+ bang' -> noLoc $ HsBangTy noExt bang' tySyn)
arg_tys (dataConSrcBangs dc)
field_tys = zipWith con_decl_field (dataConFieldLabels dc) linear_tys
con_decl_field fl synTy = noLoc $
- ConDeclField [noLoc $ FieldOcc (noLoc $ mkVarUnqual $ flLabel fl) (flSelector fl)] synTy
+ ConDeclField [noLoc $ FieldOcc (flSelector fl) (noLoc $ mkVarUnqual $ flLabel fl)] synTy
Nothing
hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of
(True,True) -> Left "synifyDataCon: contradiction!"
@@ -347,8 +347,8 @@ synifyTyVars ktvs = HsQTvs { hsq_implicit = []
synifyTyVar :: TyVar -> LHsTyVarBndr GhcRn
synifyTyVar tv
- | isLiftedTypeKind kind = noLoc (UserTyVar (noLoc name))
- | otherwise = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind))
+ | isLiftedTypeKind kind = noLoc (UserTyVar noExt (noLoc name))
+ | otherwise = noLoc (KindedTyVar noExt (noLoc name) (synifyKindSig kind))
where
kind = tyVarKind tv
name = getName tv
@@ -365,7 +365,7 @@ annotHsType True ty hs_ty
| not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty
= let ki = typeKind ty
hs_ki = synifyType WithinType ki
- in noLoc (HsKindSig hs_ty hs_ki)
+ in noLoc (HsKindSig noExt hs_ty hs_ki)
annotHsType _ _ hs_ty = hs_ty
-- | For every type variable in the input,
@@ -410,7 +410,7 @@ synifyPatSynSigType :: PatSyn -> LHsSigType GhcRn
synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps)
synifyType :: SynifyTypeState -> Type -> LHsType GhcRn
-synifyType _ (TyVarTy tv) = noLoc $ HsTyVar NotPromoted $ noLoc (getName tv)
+synifyType _ (TyVarTy tv) = noLoc $ HsTyVar noExt NotPromoted $ noLoc (getName tv)
synifyType _ (TyConApp tc tys)
= maybe_sig res_ty
where
@@ -420,41 +420,43 @@ synifyType _ (TyConApp tc tys)
| tc `hasKey` tYPETyConKey
, [TyConApp lev []] <- tys
, lev `hasKey` liftedRepDataConKey
- = noLoc (HsTyVar NotPromoted (noLoc starKindTyConName))
+ = noLoc (HsTyVar noExt NotPromoted (noLoc starKindTyConName))
-- Use non-prefix tuple syntax where possible, because it looks nicer.
| Just sort <- tyConTuple_maybe tc
, tyConArity tc == length tys
- = noLoc $ HsTupleTy (case sort of
+ = noLoc $ HsTupleTy noExt
+ (case sort of
BoxedTuple -> HsBoxedTuple
ConstraintTuple -> HsConstraintTuple
UnboxedTuple -> HsUnboxedTuple)
(map (synifyType WithinType) vis_tys)
-- ditto for lists
| getName tc == listTyConName, [ty] <- tys =
- noLoc $ HsListTy (synifyType WithinType ty)
+ noLoc $ HsListTy noExt (synifyType WithinType ty)
-- ditto for implicit parameter tycons
| tc `hasKey` ipClassKey
, [name, ty] <- tys
, Just x <- isStrLitTy name
- = noLoc $ HsIParamTy (noLoc $ HsIPName x) (synifyType WithinType ty)
+ = noLoc $ HsIParamTy noExt (noLoc $ HsIPName x) (synifyType WithinType ty)
-- and equalities
| tc `hasKey` eqTyConKey
, [ty1, ty2] <- tys
- = noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2)
+ = noLoc $ HsEqTy noExt (synifyType WithinType ty1) (synifyType WithinType ty2)
-- and infix type operators
| isSymOcc (nameOccName (getName tc))
, ty1:ty2:tys_rest <- vis_tys
- = mk_app_tys (HsOpTy (synifyType WithinType ty1)
+ = mk_app_tys (HsOpTy noExt
+ (synifyType WithinType ty1)
(noLoc $ getName tc)
(synifyType WithinType ty2))
tys_rest
-- Most TyCons:
| otherwise
- = mk_app_tys (HsTyVar NotPromoted $ noLoc (getName tc))
+ = mk_app_tys (HsTyVar noExt NotPromoted $ noLoc (getName tc))
vis_tys
where
mk_app_tys ty_app ty_args =
- foldl (\t1 t2 -> noLoc $ HsAppTy t1 t2)
+ foldl (\t1 t2 -> noLoc $ HsAppTy noExt t1 t2)
(noLoc ty_app)
(map (synifyType WithinType) $
filterOut isCoercionTy ty_args)
@@ -468,7 +470,7 @@ synifyType _ (TyConApp tc tys)
| needs_kind_sig
= let full_kind = typeKind (mkTyConApp tc tys)
full_kind' = synifyType WithinType full_kind
- in noLoc $ HsKindSig ty' full_kind'
+ in noLoc $ HsKindSig noExt ty' full_kind'
| otherwise = ty'
needs_kind_sig :: Bool
@@ -489,22 +491,24 @@ synifyType s (AppTy t1 (CoercionTy {})) = synifyType s t1
synifyType _ (AppTy t1 t2) = let
s1 = synifyType WithinType t1
s2 = synifyType WithinType t2
- in noLoc $ HsAppTy s1 s2
+ in noLoc $ HsAppTy noExt s1 s2
synifyType _ (FunTy t1 t2) = let
s1 = synifyType WithinType t1
s2 = synifyType WithinType t2
- in noLoc $ HsFunTy s1 s2
+ in noLoc $ HsFunTy noExt s1 s2
synifyType s forallty@(ForAllTy _tv _ty) =
let (tvs, ctx, tau) = tcSplitSigmaTy forallty
sPhi = HsQualTy { hst_ctxt = synifyCtx ctx
+ , hst_xqual = noExt
, hst_body = synifyType WithinType tau }
in case s of
DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau
WithinType -> noLoc $ HsForAllTy { hst_bndrs = map synifyTyVar tvs
+ , hst_xforall = noExt
, hst_body = noLoc sPhi }
ImplicitizeForAll -> noLoc sPhi
-synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t
+synifyType _ (LitTy t) = noLoc $ HsTyLit noExt $ synifyTyLit t
synifyType s (CastTy t _) = synifyType s t
synifyType _ (CoercionTy {}) = error "synifyType:Coercion"
@@ -517,10 +521,12 @@ synifyPatSynType ps = let
-- possible by taking theta = [], as that will print no context at all
| otherwise = req_theta
sForAll [] s = s
- sForAll tvs s = HsForAllTy { hst_bndrs = map synifyTyVar tvs
- , hst_body = noLoc s }
- sQual theta s = HsQualTy { hst_ctxt = synifyCtx theta
- , hst_body = noLoc s }
+ sForAll tvs s = HsForAllTy { hst_bndrs = map synifyTyVar tvs
+ , hst_xforall = noExt
+ , hst_body = noLoc s }
+ sQual theta s = HsQualTy { hst_ctxt = synifyCtx theta
+ , hst_xqual = noExt
+ , hst_body = noLoc s }
sTau = unLoc $ synifyType WithinType $ mkFunTys arg_tys res_ty
in noLoc $ sForAll univ_tvs $ sQual req_theta' $ sForAll ex_tvs $ sQual prov_theta sTau
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index b3260fd5..48a9f99e 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE BangPatterns, FlexibleInstances, ViewPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK hide #-}
-----------------------------------------------------------------------------
@@ -150,7 +151,12 @@ nubByName f ns = go emptyNameSet ns
where
y = f x
-getGADTConType :: ConDecl p -> LHsType p
+-- ---------------------------------------------------------------------
+
+-- This function is duplicated as getGADTConType and getGADTConTypeG,
+-- as I can't get the types to line up otherwise. AZ.
+
+getGADTConType :: ConDecl DocNameI -> LHsType DocNameI
-- The full type of a GADT data constructor We really only get this in
-- order to pretty-print it, and currently only in Haddock's code. So
-- we are cavalier about locations and extensions, hence the
@@ -159,23 +165,57 @@ getGADTConType (ConDeclGADT { con_forall = has_forall
, con_qvars = qtvs
, con_mb_cxt = mcxt, con_args = args
, con_res_ty = res_ty })
- | has_forall = noLoc (HsForAllTy { hst_bndrs = hsQTvExplicit qtvs
+ | has_forall = noLoc (HsForAllTy { hst_xforall = PlaceHolder
+ , hst_bndrs = hsQTvExplicit qtvs
, hst_body = theta_ty })
| otherwise = theta_ty
where
theta_ty | Just theta <- mcxt
- = noLoc (HsQualTy { hst_ctxt = theta, hst_body = tau_ty })
+ = noLoc (HsQualTy { hst_xqual = PlaceHolder, hst_ctxt = theta, hst_body = tau_ty })
| otherwise
= tau_ty
tau_ty = case args of
- RecCon flds -> noLoc (HsFunTy (noLoc (HsRecTy (unLoc flds))) res_ty)
- PrefixCon pos_args -> foldr nlHsFunTy res_ty pos_args
- InfixCon arg1 arg2 -> arg1 `nlHsFunTy` (arg2 `nlHsFunTy` res_ty)
+ RecCon flds -> noLoc (HsFunTy noExt (noLoc (HsRecTy noExt (unLoc flds))) res_ty)
+ PrefixCon pos_args -> foldr mkFunTy res_ty pos_args
+ InfixCon arg1 arg2 -> arg1 `mkFunTy` (arg2 `mkFunTy` res_ty)
+
+ mkFunTy a b = noLoc (HsFunTy noExt a b)
getGADTConType (ConDeclH98 {}) = panic "getGADTConType"
-- Should only be called on ConDeclGADT
+-- -------------------------------------
+
+getGADTConTypeG :: ConDecl (GhcPass p) -> LHsType (GhcPass p)
+-- The full type of a GADT data constructor We really only get this in
+-- order to pretty-print it, and currently only in Haddock's code. So
+-- we are cavalier about locations and extensions, hence the
+-- 'undefined's
+getGADTConTypeG (ConDeclGADT { con_forall = has_forall
+ , con_qvars = qtvs
+ , con_mb_cxt = mcxt, con_args = args
+ , con_res_ty = res_ty })
+ | has_forall = noLoc (HsForAllTy { hst_xforall = PlaceHolder
+ , hst_bndrs = hsQTvExplicit qtvs
+ , hst_body = theta_ty })
+ | otherwise = theta_ty
+ where
+ theta_ty | Just theta <- mcxt
+ = noLoc (HsQualTy { hst_xqual = PlaceHolder, hst_ctxt = theta, hst_body = tau_ty })
+ | otherwise
+ = tau_ty
+
+ tau_ty = case args of
+ RecCon flds -> noLoc (HsFunTy noExt (noLoc (HsRecTy noExt (unLoc flds))) res_ty)
+ PrefixCon pos_args -> foldr mkFunTy res_ty pos_args
+ InfixCon arg1 arg2 -> arg1 `mkFunTy` (arg2 `mkFunTy` res_ty)
+
+ mkFunTy a b = noLoc (HsFunTy noExt a b)
+
+getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConType"
+ -- Should only be called on ConDeclGADT
+
-------------------------------------------------------------------------------
-- * Located
-------------------------------------------------------------------------------
@@ -208,7 +248,7 @@ class Parent a where
instance Parent (ConDecl GhcRn) where
children con =
case con_args con of
- RecCon fields -> map (selectorFieldOcc . unL) $
+ RecCon fields -> map (extFieldOcc . unL) $
concatMap (cd_fld_names . unL) (unL fields)
_ -> []
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 4866f76b..88b8bc67 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -454,12 +454,12 @@ subordinates instMap decl = case decl of
cons = map unL $ (dd_cons dd)
constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, conArgDocs c)
| c <- cons, cname <- getConNames c ]
- fields = [ (selectorFieldOcc n, maybeToList $ fmap unL doc, M.empty)
+ fields = [ (extFieldOcc n, maybeToList $ fmap unL doc, M.empty)
| RecCon flds <- map getConArgs cons
, L _ (ConDeclField ns _ doc) <- (unLoc flds)
, L _ n <- ns ]
derivs = [ (instName, [unL doc], M.empty)
- | HsIB { hsib_body = L l (HsDocTy _ doc) }
+ | HsIB { hsib_body = L l (HsDocTy _ _ doc) }
<- concatMap (unLoc . deriv_clause_tys . unLoc) $
unLoc $ dd_derivs dd
, Just instName <- [M.lookup l instMap] ]
@@ -471,7 +471,7 @@ conArgDocs con = case getConArgs con of
InfixCon arg1 arg2 -> go 0 ([unLoc arg1, unLoc arg2] ++ ret)
RecCon _ -> go 1 ret
where
- go n (HsDocTy _ (L _ ds) : tys) = M.insert n ds $ go (n+1) tys
+ go n (HsDocTy _ _ (L _ ds) : tys) = M.insert n ds $ go (n+1) tys
go n (_ : tys) = go (n+1) tys
go _ [] = M.empty
@@ -494,9 +494,9 @@ typeDocs = go 0
where
go n (HsForAllTy { hst_body = ty }) = go n (unLoc ty)
go n (HsQualTy { hst_body = ty }) = go n (unLoc ty)
- go n (HsFunTy (L _ (HsDocTy _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty
- go n (HsFunTy _ ty) = go (n+1) (unLoc ty)
- go n (HsDocTy _ (L _ doc)) = M.singleton n doc
+ go n (HsFunTy _ (L _ (HsDocTy _ _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty
+ go n (HsFunTy _ _ ty) = go (n+1) (unLoc ty)
+ go n (HsDocTy _ _ (L _ doc)) = M.singleton n doc
go _ _ = M.empty
-- | All the sub declarations of a class (that we handle), ordered by
@@ -535,10 +535,10 @@ ungroup group_ =
mkDecls (typesigs . hs_valds) SigD group_ ++
mkDecls (valbinds . hs_valds) ValD group_
where
- typesigs (ValBindsOut _ sigs) = filter isUserLSig sigs
+ typesigs (XValBindsLR (NValBinds _ sigs)) = filter isUserLSig sigs
typesigs _ = error "expected ValBindsOut"
- valbinds (ValBindsOut binds _) = concatMap bagToList . snd . unzip $ binds
+ valbinds (XValBindsLR (NValBinds binds _)) = concatMap bagToList . snd . unzip $ binds
valbinds _ = error "expected ValBindsOut"
@@ -1068,7 +1068,7 @@ extractDecl declMap name decl
, RecCon rec <- map (getConArgs . unLoc) (dd_cons (feqn_rhs d))
, ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec)
, L _ n <- ns
- , selectorFieldOcc n == name
+ , extFieldOcc n == name
]
in case matches of
[d0] -> extractDecl declMap name (noLoc . InstD $ DataFamInstD d0)
@@ -1094,17 +1094,17 @@ extractPatternSyn nm t tvs cons =
typ = longArrow args (data_ty con)
typ' =
case con of
- ConDeclH98 { con_mb_cxt = Just cxt } -> noLoc (HsQualTy cxt typ)
+ ConDeclH98 { con_mb_cxt = Just cxt } -> noLoc (HsQualTy noExt cxt typ)
_ -> typ
- typ'' = noLoc (HsQualTy (noLoc []) typ')
+ typ'' = noLoc (HsQualTy noExt (noLoc []) typ')
in PatSynSig [noLoc nm] (mkEmptyImplicitBndrs typ'')
- longArrow :: [LHsType name] -> LHsType name -> LHsType name
- longArrow inputs output = foldr (\x y -> noLoc (HsFunTy x y)) output inputs
+ longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn
+ longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExt x y)) output inputs
data_ty con
| ConDeclGADT{} <- con = con_res_ty con
- | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs
+ | otherwise = foldl' (\x y -> noLoc (HsAppTy noExt x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs
extractRecSel :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn]
-> LSig GhcRn
@@ -1113,16 +1113,16 @@ 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 data_ty (getBangType ty)))))
+ L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExt data_ty (getBangType ty)))))
_ -> extractRecSel nm t tvs rest
where
matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)]
matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds
- , L l n <- ns, selectorFieldOcc n == nm ]
+ , L l n <- ns, extFieldOcc n == nm ]
data_ty
-- ResTyGADT _ ty <- con_res con = ty
| ConDeclGADT{} <- con = con_res_ty con
- | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs
+ | otherwise = foldl' (\x y -> noLoc (HsAppTy noExt x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs
-- | 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 6a0a20cf..c8d9cb7d 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -212,61 +212,61 @@ renameType t = case t of
HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do
tyvars' <- mapM renameLTyVarBndr tyvars
ltype' <- renameLType ltype
- return (HsForAllTy { hst_bndrs = tyvars', hst_body = ltype' })
+ return (HsForAllTy { hst_xforall = PlaceHolder, hst_bndrs = tyvars', hst_body = ltype' })
HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do
lcontext' <- renameLContext lcontext
ltype' <- renameLType ltype
- return (HsQualTy { hst_ctxt = lcontext', hst_body = ltype' })
+ return (HsQualTy { hst_xqual = PlaceHolder, hst_ctxt = lcontext', hst_body = ltype' })
- HsTyVar ip (L l n) -> return . HsTyVar ip . L l =<< rename n
- HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype
+ HsTyVar _ ip (L l n) -> return . HsTyVar PlaceHolder ip . L l =<< rename n
+ HsBangTy _ b ltype -> return . HsBangTy PlaceHolder b =<< renameLType ltype
- HsAppTy a b -> do
+ HsAppTy _ a b -> do
a' <- renameLType a
b' <- renameLType b
- return (HsAppTy a' b')
+ return (HsAppTy PlaceHolder a' b')
- HsFunTy a b -> do
+ HsFunTy _ a b -> do
a' <- renameLType a
b' <- renameLType b
- return (HsFunTy a' b')
+ return (HsFunTy PlaceHolder a' b')
- HsListTy ty -> return . HsListTy =<< renameLType ty
- HsPArrTy ty -> return . HsPArrTy =<< renameLType ty
- HsIParamTy n ty -> liftM (HsIParamTy n) (renameLType ty)
- HsEqTy ty1 ty2 -> liftM2 HsEqTy (renameLType ty1) (renameLType ty2)
+ HsListTy _ ty -> return . (HsListTy PlaceHolder) =<< renameLType ty
+ HsPArrTy _ ty -> return . (HsPArrTy PlaceHolder) =<< renameLType ty
+ HsIParamTy _ n ty -> liftM (HsIParamTy PlaceHolder n) (renameLType ty)
+ HsEqTy _ ty1 ty2 -> liftM2 (HsEqTy PlaceHolder) (renameLType ty1) (renameLType ty2)
- HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts
- HsSumTy ts -> HsSumTy <$> mapM renameLType ts
+ HsTupleTy _ b ts -> return . HsTupleTy PlaceHolder b =<< mapM renameLType ts
+ HsSumTy _ ts -> HsSumTy PlaceHolder <$> mapM renameLType ts
- HsOpTy a (L loc op) b -> do
+ HsOpTy _ a (L loc op) b -> do
op' <- rename op
a' <- renameLType a
b' <- renameLType b
- return (HsOpTy a' (L loc op') b')
+ return (HsOpTy PlaceHolder a' (L loc op') b')
- HsParTy ty -> return . HsParTy =<< renameLType ty
+ HsParTy _ ty -> return . (HsParTy PlaceHolder) =<< renameLType ty
- HsKindSig ty k -> do
+ HsKindSig _ ty k -> do
ty' <- renameLType ty
k' <- renameLKind k
- return (HsKindSig ty' k')
+ return (HsKindSig PlaceHolder ty' k')
- HsDocTy ty doc -> do
+ HsDocTy _ ty doc -> do
ty' <- renameLType ty
doc' <- renameLDocHsSyn doc
- return (HsDocTy ty' doc')
+ return (HsDocTy PlaceHolder ty' doc')
- HsTyLit x -> return (HsTyLit x)
+ HsTyLit _ x -> return (HsTyLit PlaceHolder x)
- HsRecTy a -> HsRecTy <$> mapM renameConDeclFieldField a
- HsCoreTy a -> pure (HsCoreTy a)
- HsExplicitListTy i a b -> HsExplicitListTy i a <$> mapM renameLType b
- HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b
- HsSpliceTy _ _ -> error "renameType: HsSpliceTy"
- HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a
- HsAppsTy _ -> error "renameType: HsAppsTy"
+ HsRecTy _ a -> HsRecTy PlaceHolder <$> mapM renameConDeclFieldField a
+ (XHsType (NHsCoreTy a)) -> pure (XHsType (NHsCoreTy a))
+ HsExplicitListTy x i b -> HsExplicitListTy x i <$> mapM renameLType b
+ HsExplicitTupleTy x b -> HsExplicitTupleTy x <$> mapM renameLType b
+ HsSpliceTy _ _ -> error "renameType: HsSpliceTy"
+ HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a
+ HsAppsTy _ _ -> error "renameType: HsAppsTy"
renameLHsQTyVars :: LHsQTyVars GhcRn -> RnM (LHsQTyVars DocNameI)
renameLHsQTyVars (HsQTvs { hsq_implicit = _, hsq_explicit = tvs })
@@ -275,13 +275,14 @@ renameLHsQTyVars (HsQTvs { hsq_implicit = _, hsq_explicit = tvs })
-- This is rather bogus, but I'm not sure what else to do
renameLTyVarBndr :: LHsTyVarBndr GhcRn -> RnM (LHsTyVarBndr DocNameI)
-renameLTyVarBndr (L loc (UserTyVar (L l n)))
+renameLTyVarBndr (L loc (UserTyVar x (L l n)))
= do { n' <- rename n
- ; return (L loc (UserTyVar (L l n'))) }
-renameLTyVarBndr (L loc (KindedTyVar (L lv n) kind))
+ ; return (L loc (UserTyVar x (L l n'))) }
+renameLTyVarBndr (L loc (KindedTyVar x (L lv n) kind))
= do { n' <- rename n
; kind' <- renameLKind kind
- ; return (L loc (KindedTyVar (L lv n') kind')) }
+ ; return (L loc (KindedTyVar x (L lv n') kind')) }
+renameLTyVarBndr (L _ (XTyVarBndr _ )) = error "haddock:renameLTyVarBndr"
renameLContext :: Located [LHsType GhcRn] -> RnM (Located [LHsType DocNameI])
renameLContext (L loc context) = do
@@ -472,9 +473,10 @@ renameConDeclFieldField (L l (ConDeclField names t doc)) = do
return $ L l (ConDeclField names' t' doc')
renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI)
-renameLFieldOcc (L l (FieldOcc lbl sel)) = do
+renameLFieldOcc (L l (FieldOcc sel lbl)) = do
sel' <- rename sel
- return $ L l (FieldOcc lbl sel')
+ return $ L l (FieldOcc sel' lbl)
+renameLFieldOcc (L _ (XFieldOcc _)) = error "haddock:renameLFieldOcc"
renameSig :: Sig GhcRn -> RnM (Sig DocNameI)
renameSig sig = case sig of
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 6d2888d3..18d93fae 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -28,20 +28,18 @@ import Data.Set (Set)
import qualified Data.Set as Set
-- | Instantiate all occurrences of given names with corresponding types.
-specialize :: forall name a. (Ord (IdP name), DataId name, NamedThing (IdP name))
- => Data a
- => [(IdP name, HsType name)] -> a -> a
+specialize :: Data a => [(Name, HsType GhcRn)] -> a -> a
specialize specs = go
where
go :: forall x. Data x => x -> x
- go = everywhereButType @name $ mkT $ sugar . strip_kind_sig . specialize_ty_var
+ go = everywhereButType @Name $ mkT $ sugar . strip_kind_sig . specialize_ty_var
strip_kind_sig :: HsType name -> HsType name
- strip_kind_sig (HsKindSig (L _ t) _) = t
+ strip_kind_sig (HsKindSig _ (L _ t) _) = t
strip_kind_sig typ = typ
- specialize_ty_var :: HsType name -> HsType name
- specialize_ty_var (HsTyVar _ (L _ name'))
+ specialize_ty_var :: HsType GhcRn -> HsType GhcRn
+ specialize_ty_var (HsTyVar _ _ (L _ name'))
| Just t <- Map.lookup name' spec_map = t
specialize_ty_var typ = typ
-- This is a tricky recursive definition that is guaranteed to terminate
@@ -54,35 +52,33 @@ specialize specs = go
--
-- Again, it is just a convenience function around 'specialize'. Note that
-- length of type list should be the same as the number of binders.
-specializeTyVarBndrs :: (Ord (IdP name), DataId name, NamedThing (IdP name))
- => Data a
- => LHsQTyVars name -> [HsType name]
+specializeTyVarBndrs :: Data a
+ => LHsQTyVars GhcRn -> [HsType GhcRn]
-> a -> a
specializeTyVarBndrs bndrs typs =
specialize $ zip bndrs' typs
where
bndrs' = map (bname . unLoc) . hsq_explicit $ bndrs
- bname (UserTyVar (L _ name)) = name
- bname (KindedTyVar (L _ name) _) = name
+ bname (UserTyVar _ (L _ name)) = name
+ bname (KindedTyVar _ (L _ name) _) = name
+ bname (XTyVarBndr _) = error "haddock:specializeTyVarBndrs"
-specializePseudoFamilyDecl :: (Ord (IdP name), DataId name, NamedThing (IdP name))
- => LHsQTyVars name -> [HsType name]
- -> PseudoFamilyDecl name
- -> PseudoFamilyDecl name
+specializePseudoFamilyDecl :: LHsQTyVars GhcRn -> [HsType GhcRn]
+ -> PseudoFamilyDecl GhcRn
+ -> PseudoFamilyDecl GhcRn
specializePseudoFamilyDecl bndrs typs decl =
decl {pfdTyVars = map (specializeTyVarBndrs bndrs typs) (pfdTyVars decl)}
-specializeSig :: forall name . (Ord (IdP name), DataId name, SetName (IdP name), NamedThing (IdP name))
- => LHsQTyVars name -> [HsType name]
- -> Sig name
- -> Sig name
+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'}})
where
- true_type :: HsType name
+ true_type :: HsType GhcRn
true_type = unLoc (hsSigWcType typ)
- typ' :: HsType name
+ typ' :: HsType GhcRn
typ' = rename fv $ specializeTyVarBndrs bndrs typs true_type
fv = foldr Set.union Set.empty . map freeVariables $ typs
specializeSig _ _ sig = sig
@@ -90,8 +86,7 @@ specializeSig _ _ sig = sig
-- | Make all details of instance head (signatures, associated types)
-- specialized to that particular instance type.
-specializeInstHead :: (Ord (IdP name), DataId name, SetName (IdP name), NamedThing (IdP name))
- => InstHead name -> InstHead name
+specializeInstHead :: InstHead GhcRn -> InstHead GhcRn
specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } =
ihd { ihdInstType = instType' }
where
@@ -110,27 +105,26 @@ specializeInstHead ihd = ihd
-- and tuple literals resulting in types like @[] a@ or @(,,) a b c@. This
-- can be fixed using 'sugar' function, that will turn such types into @[a]@
-- and @(a, b, c)@.
-sugar :: forall name. (NamedThing (IdP name), DataId name)
- => HsType name -> HsType name
+sugar :: HsType GhcRn -> HsType GhcRn
sugar = sugarOperators . sugarTuples . sugarLists
-sugarLists :: NamedThing (IdP name) => HsType name -> HsType name
-sugarLists (HsAppTy (L _ (HsTyVar _ (L _ name))) ltyp)
- | isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp
+sugarLists :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p)
+sugarLists (HsAppTy _ (L _ (HsTyVar _ _ (L _ name))) ltyp)
+ | isBuiltInSyntax name' && strName == "[]" = HsListTy PlaceHolder ltyp
where
name' = getName name
strName = occNameString . nameOccName $ name'
sugarLists typ = typ
-sugarTuples :: NamedThing (IdP name) => HsType name -> HsType name
+sugarTuples :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p)
sugarTuples typ =
aux [] typ
where
- 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 HsBoxedTuple apps
+ aux apps (HsAppTy _ (L _ ftyp) atyp) = aux (atyp:apps) ftyp
+ aux apps (HsParTy _ (L _ typ')) = aux apps typ'
+ aux apps (HsTyVar _ _ (L _ name))
+ | isBuiltInSyntax name' && suitable = HsTupleTy PlaceHolder HsBoxedTuple apps
where
name' = getName name
strName = occNameString . nameOccName $ name'
@@ -140,10 +134,10 @@ sugarTuples typ =
aux _ _ = typ
-sugarOperators :: NamedThing (IdP name) => HsType name -> HsType name
-sugarOperators (HsAppTy (L _ (HsAppTy (L _ (HsTyVar _ (L l name))) la)) lb)
+sugarOperators :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p)
+sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb)
| isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb
- | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy la lb
+ | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy PlaceHolder la lb
where
name' = getName name
sugarOperators typ = typ
@@ -208,15 +202,14 @@ setInternalOccName occ name =
-- | Compute set of free variables of given type.
-freeVariables :: forall name. (NamedThing (IdP name), DataId name)
- => HsType name -> Set Name
+freeVariables :: HsType GhcRn -> Set Name
freeVariables =
everythingWithState Set.empty Set.union query
where
- query term ctx = case cast term :: Maybe (HsType name) of
- Just (HsForAllTy bndrs _) ->
+ query term ctx = case cast term :: Maybe (HsType GhcRn) of
+ Just (HsForAllTy _ bndrs _) ->
(Set.empty, Set.union ctx (bndrsNames bndrs))
- Just (HsTyVar _ (L _ name))
+ Just (HsTyVar _ _ (L _ name))
| getName name `Set.member` ctx -> (Set.empty, ctx)
| otherwise -> (Set.singleton $ getName name, ctx)
_ -> (Set.empty, ctx)
@@ -231,8 +224,7 @@ freeVariables =
-- different type variable than latter one. Applying 'rename' function
-- will fix that type to be visually unambiguous again (making it something
-- like @(a -> b0) -> b@).
-rename :: (Eq (IdP name), DataId name, SetName (IdP name))
- => Set Name-> HsType name -> HsType name
+rename :: Set Name -> HsType GhcRn -> HsType GhcRn
rename fv typ = evalState (renameType typ) env
where
env = RenameEnv
@@ -252,63 +244,58 @@ data RenameEnv name = RenameEnv
}
-renameType :: (Eq (IdP name), SetName (IdP name))
- => HsType name -> Rename (IdP name) (HsType name)
-renameType (HsForAllTy bndrs lt) =
- HsForAllTy
+renameType :: HsType GhcRn -> Rename (IdP GhcRn) (HsType GhcRn)
+renameType (HsForAllTy x bndrs lt) =
+ HsForAllTy x
<$> mapM (located renameBinder) bndrs
<*> renameLType lt
-renameType (HsQualTy lctxt lt) =
- HsQualTy
+renameType (HsQualTy x lctxt lt) =
+ HsQualTy x
<$> located renameContext lctxt
<*> renameLType lt
-renameType (HsTyVar ip name) = HsTyVar ip <$> located renameName name
-renameType (HsAppTy lf la) = HsAppTy <$> renameLType lf <*> renameLType la
-renameType (HsFunTy la lr) = HsFunTy <$> renameLType la <*> renameLType lr
-renameType (HsListTy lt) = HsListTy <$> renameLType lt
-renameType (HsPArrTy lt) = HsPArrTy <$> renameLType lt
-renameType (HsTupleTy srt lt) = HsTupleTy srt <$> mapM renameLType lt
-renameType (HsSumTy lt) = HsSumTy <$> mapM renameLType lt
-renameType (HsOpTy la lop lb) =
- HsOpTy <$> renameLType la <*> located renameName lop <*> renameLType lb
-renameType (HsParTy lt) = HsParTy <$> renameLType lt
-renameType (HsIParamTy ip lt) = HsIParamTy ip <$> renameLType lt
-renameType (HsEqTy la lb) = HsEqTy <$> renameLType la <*> renameLType lb
-renameType (HsKindSig lt lk) = HsKindSig <$> renameLType lt <*> pure lk
+renameType (HsTyVar x ip name) = HsTyVar x ip <$> located renameName name
+renameType (HsAppTy x lf la) = HsAppTy x <$> renameLType lf <*> renameLType la
+renameType (HsFunTy x la lr) = HsFunTy x <$> renameLType la <*> renameLType lr
+renameType (HsListTy x lt) = HsListTy x <$> renameLType lt
+renameType (HsPArrTy x lt) = HsPArrTy 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
+renameType (HsParTy x lt) = HsParTy x <$> renameLType lt
+renameType (HsIParamTy x ip lt) = HsIParamTy x ip <$> renameLType lt
+renameType (HsEqTy x la lb) = HsEqTy x <$> renameLType la <*> renameLType lb
+renameType (HsKindSig x lt lk) = HsKindSig x <$> renameLType lt <*> pure lk
renameType t@(HsSpliceTy _ _) = pure t
-renameType (HsDocTy lt doc) = HsDocTy <$> renameLType lt <*> pure doc
-renameType (HsBangTy bang lt) = HsBangTy bang <$> renameLType lt
-renameType t@(HsRecTy _) = pure t
-renameType t@(HsCoreTy _) = pure t
-renameType (HsExplicitListTy ip ph ltys) =
- HsExplicitListTy ip ph <$> renameLTypes ltys
-renameType (HsExplicitTupleTy phs ltys) =
- HsExplicitTupleTy phs <$> renameLTypes ltys
-renameType t@(HsTyLit _) = pure t
+renameType (HsDocTy x lt doc) = HsDocTy x <$> renameLType lt <*> pure doc
+renameType (HsBangTy x bang lt) = HsBangTy x bang <$> renameLType lt
+renameType t@(HsRecTy _ _) = pure t
+renameType t@(XHsType (NHsCoreTy _)) = pure t
+renameType (HsExplicitListTy x ip ltys) =
+ HsExplicitListTy x ip <$> renameLTypes ltys
+renameType (HsExplicitTupleTy x ltys) =
+ HsExplicitTupleTy x <$> renameLTypes ltys
+renameType t@(HsTyLit _ _) = pure t
renameType (HsWildCardTy wc) = pure (HsWildCardTy wc)
-renameType (HsAppsTy _) = error "HsAppsTy: Only used before renaming"
+renameType (HsAppsTy _ _) = error "HsAppsTy: Only used before renaming"
-renameLType :: (Eq (IdP name), SetName (IdP name))
- => LHsType name -> Rename (IdP name) (LHsType name)
+renameLType :: LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn)
renameLType = located renameType
-renameLTypes :: (Eq (IdP name), SetName (IdP name))
- => [LHsType name] -> Rename (IdP name) [LHsType name]
+renameLTypes :: [LHsType GhcRn] -> Rename (IdP GhcRn) [LHsType GhcRn]
renameLTypes = mapM renameLType
-renameContext :: (Eq (IdP name), SetName (IdP name))
- => HsContext name -> Rename (IdP name) (HsContext name)
+renameContext :: HsContext GhcRn -> Rename (IdP GhcRn) (HsContext GhcRn)
renameContext = renameLTypes
-renameBinder :: (Eq (IdP name), SetName (IdP name))
- => HsTyVarBndr name -> Rename (IdP name) (HsTyVarBndr name)
-renameBinder (UserTyVar lname) = UserTyVar <$> located renameName lname
-renameBinder (KindedTyVar lname lkind) =
- KindedTyVar <$> located renameName lname <*> located renameType lkind
-
+renameBinder :: HsTyVarBndr GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr GhcRn)
+renameBinder (UserTyVar x lname) = UserTyVar x <$> located renameName lname
+renameBinder (KindedTyVar x lname lkind) =
+ KindedTyVar x <$> located renameName lname <*> located renameType lkind
+renameBinder (XTyVarBndr _) = error "haddock:renameBinder"
-- | Core renaming logic.
renameName :: (Eq name, SetName name) => name -> Rename name name
@@ -363,5 +350,6 @@ located f (L loc e) = L loc <$> f e
tyVarName :: HsTyVarBndr name -> IdP name
-tyVarName (UserTyVar name) = unLoc name
-tyVarName (KindedTyVar (L _ name) _) = name
+tyVarName (UserTyVar _ name) = unLoc name
+tyVarName (KindedTyVar _ (L _ name) _) = name
+tyVarName (XTyVarBndr _ ) = error "haddock:tyVarName"
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index af8904d3..b4b16d62 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -372,7 +372,7 @@ data PseudoFamilyDecl name = PseudoFamilyDecl
}
-mkPseudoFamilyDecl :: FamilyDecl name -> PseudoFamilyDecl name
+mkPseudoFamilyDecl :: FamilyDecl (GhcPass p) -> PseudoFamilyDecl (GhcPass p)
mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl
{ pfdInfo = fdInfo
, pfdLName = fdLName
@@ -380,11 +380,12 @@ mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl
, pfdKindSig = fdResultSig
}
where
- mkType (KindedTyVar (L loc name) lkind) =
- HsKindSig tvar lkind
+ mkType (KindedTyVar _ (L loc name) lkind) =
+ HsKindSig PlaceHolder tvar lkind
where
- tvar = L loc (HsTyVar NotPromoted (L loc name))
- mkType (UserTyVar name) = HsTyVar NotPromoted name
+ tvar = L loc (HsTyVar PlaceHolder NotPromoted (L loc name))
+ mkType (UserTyVar _ name) = HsTyVar PlaceHolder NotPromoted name
+ mkType (XTyVarBndr _ ) = panic "haddock:mkPseudoFamilyDecl"
-- | An instance head that may have documentation and a source location.
@@ -662,3 +663,36 @@ type instance PostRn DocNameI DocName = DocName
type instance PostTc DocNameI Kind = PlaceHolder
type instance PostTc DocNameI Type = PlaceHolder
type instance PostTc DocNameI Coercion = PlaceHolder
+
+
+type instance XForAllTy DocNameI = PlaceHolder
+type instance XQualTy DocNameI = PlaceHolder
+type instance XTyVar DocNameI = PlaceHolder
+type instance XAppsTy DocNameI = PlaceHolder
+type instance XAppTy DocNameI = PlaceHolder
+type instance XFunTy DocNameI = PlaceHolder
+type instance XListTy DocNameI = PlaceHolder
+type instance XPArrTy DocNameI = PlaceHolder
+type instance XTupleTy DocNameI = PlaceHolder
+type instance XSumTy DocNameI = PlaceHolder
+type instance XOpTy DocNameI = PlaceHolder
+type instance XParTy DocNameI = PlaceHolder
+type instance XIParamTy DocNameI = PlaceHolder
+type instance XEqTy DocNameI = PlaceHolder
+type instance XKindSig DocNameI = PlaceHolder
+type instance XSpliceTy DocNameI = PlaceHolder
+type instance XDocTy DocNameI = PlaceHolder
+type instance XBangTy DocNameI = PlaceHolder
+type instance XRecTy DocNameI = PlaceHolder
+type instance XExplicitListTy DocNameI = PlaceHolder
+type instance XExplicitTupleTy DocNameI = PlaceHolder
+type instance XTyLit DocNameI = PlaceHolder
+type instance XWildCardTy DocNameI = HsWildCardInfo DocNameI
+type instance XXType DocNameI = NewHsTypeX
+
+type instance XUserTyVar DocNameI = PlaceHolder
+type instance XKindedTyVar DocNameI = PlaceHolder
+type instance XXTyVarBndr DocNameI = PlaceHolder
+
+type instance XFieldOcc DocNameI = DocName
+type instance XXFieldOcc DocNameI = PlaceHolder
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 1993fb5d..5de539c0 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -63,7 +63,7 @@ import Haddock.GhcUtils
import GHC
import Name
import NameSet ( emptyNameSet )
-import HsTypes (selectorFieldOcc)
+import HsTypes (extFieldOcc)
import Control.Monad ( liftM )
import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr )
@@ -136,11 +136,14 @@ addClassContext cls tvs0 (L pos (ClassOpSig _ lname ltype))
-- The mkEmptySigWcType is suspicious
where
go (L loc (HsForAllTy { hst_bndrs = tvs, hst_body = ty }))
- = L loc (HsForAllTy { hst_bndrs = tvs, hst_body = go ty })
+ = L loc (HsForAllTy { hst_xforall = PlaceHolder
+ , hst_bndrs = tvs, hst_body = go ty })
go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty }))
- = L loc (HsQualTy { hst_ctxt = add_ctxt ctxt, hst_body = ty })
+ = L loc (HsQualTy { hst_xqual = PlaceHolder
+ , hst_ctxt = add_ctxt ctxt, hst_body = ty })
go (L loc ty)
- = L loc (HsQualTy { hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty })
+ = L loc (HsQualTy { hst_xqual = PlaceHolder
+ , hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty })
extra_pred = nlHsTyConApp cls (lHsQTyVarsToTypes tvs0)
add_ctxt (L loc preds) = L loc (extra_pred : preds)
@@ -149,7 +152,7 @@ addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine
lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn]
lHsQTyVarsToTypes tvs
- = [ noLoc (HsTyVar NotPromoted (noLoc (hsLTyVarName tv)))
+ = [ noLoc (HsTyVar PlaceHolder NotPromoted (noLoc (hsLTyVarName tv)))
| tv <- hsQTvExplicit tvs ]
--------------------------------------------------------------------------------
@@ -193,7 +196,7 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
where
field_avail :: LConDeclField GhcRn -> Bool
field_avail (L _ (ConDeclField fs _ _))
- = all (\f -> selectorFieldOcc (unLoc f) `elem` names) fs
+ = all (\f -> extFieldOcc (unLoc f) `elem` names) fs
field_types flds = [ t | ConDeclField _ t _ <- flds ]
keep _ = Nothing
--
cgit v1.2.3
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/src/Haddock/GhcUtils.hs')
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
From 271a9cb0c7a070deef8df2d4fb54ebe47a0bf560 Mon Sep 17 00:00:00 2001
From: Alan Zimmerman <alan.zimm@gmail.com>
Date: Thu, 19 Apr 2018 14:04:04 +0200
Subject: Match changes in GHC for TTG
---
haddock-api/src/Haddock/Backends/Hoogle.hs | 21 +--
.../src/Haddock/Backends/Hyperlinker/Ast.hs | 18 +--
haddock-api/src/Haddock/Backends/LaTeX.hs | 43 +++---
haddock-api/src/Haddock/Backends/Xhtml.hs | 2 +-
haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 49 ++++---
haddock-api/src/Haddock/Convert.hs | 77 +++++-----
haddock-api/src/Haddock/GhcUtils.hs | 44 +++---
.../src/Haddock/Interface/AttachInstances.hs | 2 +-
haddock-api/src/Haddock/Interface/Create.hs | 118 ++++++++--------
haddock-api/src/Haddock/Interface/Rename.hs | 155 ++++++++++++---------
haddock-api/src/Haddock/Interface/Specialize.hs | 6 +-
haddock-api/src/Haddock/Types.hs | 124 ++++++++++-------
haddock-api/src/Haddock/Utils.hs | 26 ++--
13 files changed, 386 insertions(+), 299 deletions(-)
(limited to 'haddock-api/src/Haddock/GhcUtils.hs')
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 09f62a19..2c7be079 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -126,12 +126,12 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl
, expItemFixities = fixities
} = ppDocumentation dflags dc ++ f decl
where
- f (TyClD d@DataDecl{}) = ppData dflags d subdocs
- f (TyClD d@SynDecl{}) = ppSynonym dflags d
- f (TyClD d@ClassDecl{}) = ppClass dflags d subdocs
- f (ForD (ForeignImport name typ _ _)) = [pp_sig dflags [name] (hsSigType typ)]
- f (ForD (ForeignExport name typ _ _)) = [pp_sig dflags [name] (hsSigType typ)]
- f (SigD sig) = ppSig dflags sig ++ ppFixities
+ f (TyClD _ d@DataDecl{}) = ppData dflags d subdocs
+ f (TyClD _ d@SynDecl{}) = ppSynonym dflags d
+ f (TyClD _ d@ClassDecl{}) = ppClass dflags d subdocs
+ f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags [name] (hsSigType typ)]
+ f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags [name] (hsSigType typ)]
+ f (SigD _ sig) = ppSig dflags sig ++ ppFixities
f _ = []
ppFixities = concatMap (ppFixity dflags) fixities
@@ -189,7 +189,7 @@ ppClass dflags decl subdocs =
, tcdTyVars = feqn_pats tfe
, tcdFixity = feqn_fixity tfe
, tcdRhs = feqn_rhs tfe
- , tcdFVs = emptyNameSet
+ , tcdSExt = emptyNameSet
}
@@ -241,8 +241,8 @@ ppCtor dflags dat subdocs con@ConDeclH98 {}
[out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]
| r <- map unLoc recs]
- funs = foldr1 (\x y -> reL $ HsFunTy PlaceHolder x y)
- apps = foldl1 (\x y -> reL $ HsAppTy PlaceHolder x y)
+ funs = foldr1 (\x y -> reL $ HsFunTy NoExt x y)
+ apps = foldl1 (\x y -> reL $ HsAppTy NoExt x y)
typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds)
@@ -250,7 +250,7 @@ ppCtor dflags dat subdocs con@ConDeclH98 {}
-- docs for con_names on why it is a list to begin with.
name = commaSeparate dflags . map unL $ getConNames con
- resType = apps $ map (reL . HsTyVar PlaceHolder NotPromoted . reL) $
+ resType = apps $ map (reL . HsTyVar NoExt NotPromoted . reL) $
(tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _ _) <- hsQTvExplicit $ tyClDeclTyVars dat]
ppCtor dflags _dat subdocs con@(ConDeclGADT { })
@@ -260,6 +260,7 @@ ppCtor dflags _dat subdocs con@(ConDeclGADT { })
typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty)
name = out dflags $ map unL $ getConNames con
+ppCtor _ _ _ XConDecl {} = panic "haddock:ppCtor"
ppFixity :: DynFlags -> (Name, Fixity) -> [String]
ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExt [noLoc name] fixity) :: FixitySig GhcRn)]
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 19d638d9..56137f51 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -12,6 +12,7 @@ import qualified Haddock.Syb as Syb
import Haddock.Backends.Hyperlinker.Types
import qualified GHC
+import qualified Outputable as GHC
import Control.Applicative
import Control.Monad (guard)
@@ -146,9 +147,10 @@ decls (group, _, _, _) = concatMap ($ group)
where
typ (GHC.L _ t) = case t of
GHC.DataDecl { tcdLName = name } -> pure . decl $ name
- GHC.SynDecl name _ _ _ _ -> pure . decl $ name
- GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam
+ GHC.SynDecl _ name _ _ _ -> pure . decl $ name
+ GHC.FamDecl _ fam -> pure . decl $ GHC.fdLName fam
GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs
+ GHC.XTyClDecl {} -> GHC.panic "haddock:decls"
fun term = case cast term of
(Just (GHC.FunBind _ (GHC.L sspan name) _ _ _ :: GHC.HsBind GHC.GhcRn))
| GHC.isExternalName name -> pure (sspan, RtkDecl name)
@@ -159,10 +161,10 @@ decls (group, _, _, _) = concatMap ($ group)
++ everythingInRenamedSource fld cdcl
Nothing -> empty
ins term = case cast term of
- (Just ((GHC.DataFamInstD (GHC.DataFamInstDecl eqn))
+ (Just ((GHC.DataFamInstD _ (GHC.DataFamInstDecl eqn))
:: GHC.InstDecl GHC.GhcRn))
-> pure . tyref $ GHC.feqn_tycon $ GHC.hsib_body eqn
- (Just (GHC.TyFamInstD (GHC.TyFamInstDecl eqn))) ->
+ (Just (GHC.TyFamInstD _ (GHC.TyFamInstDecl eqn))) ->
pure . tyref $ GHC.feqn_tycon $ GHC.hsib_body eqn
_ -> empty
fld term = case cast term of
@@ -183,10 +185,10 @@ imports src@(_, imps, _, _) =
everythingInRenamedSource ie src ++ mapMaybe (imp . GHC.unLoc) imps
where
ie term = case cast term of
- (Just ((GHC.IEVar v) :: GHC.IE GHC.GhcRn)) -> pure $ var $ GHC.ieLWrappedName v
- (Just (GHC.IEThingAbs t)) -> pure $ typ $ GHC.ieLWrappedName t
- (Just (GHC.IEThingAll t)) -> pure $ typ $ GHC.ieLWrappedName t
- (Just (GHC.IEThingWith t _ vs _fls)) ->
+ (Just ((GHC.IEVar _ v) :: GHC.IE GHC.GhcRn)) -> pure $ var $ GHC.ieLWrappedName v
+ (Just (GHC.IEThingAbs _ t)) -> pure $ typ $ GHC.ieLWrappedName t
+ (Just (GHC.IEThingAll _ t)) -> pure $ typ $ GHC.ieLWrappedName t
+ (Just (GHC.IEThingWith _ t _ vs _fls)) ->
[typ $ GHC.ieLWrappedName t] ++ map (var . GHC.ieLWrappedName) vs
_ -> empty
typ (GHC.L sspan name) = (sspan, RtkType name)
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 4535979e..1b2515fa 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -216,7 +216,7 @@ processExports (e : es) =
isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsType DocNameI)
-isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig _ lnames t))
+isSimpleSig ExportDecl { expItemDecl = L _ (SigD _ (TypeSig _ lnames t))
, expItemMbDoc = (Documentation Nothing Nothing, argDocs) }
| Map.null argDocs = Just (map unLoc lnames, unLoc (hsSigWcType t))
isSimpleSig _ = Nothing
@@ -256,11 +256,11 @@ declNames :: LHsDecl DocNameI
, [DocName] -- ^ names being declared
)
declNames (L _ decl) = case decl of
- TyClD d -> (empty, [tcdName d])
- SigD (TypeSig _ lnames _ ) -> (empty, map unLoc lnames)
- SigD (PatSynSig _ lnames _) -> (text "pattern", map unLoc lnames)
- ForD (ForeignImport (L _ n) _ _ _) -> (empty, [n])
- ForD (ForeignExport (L _ n) _ _ _) -> (empty, [n])
+ TyClD _ d -> (empty, [tcdName d])
+ SigD _ (TypeSig _ lnames _ ) -> (empty, map unLoc lnames)
+ SigD _ (PatSynSig _ lnames _) -> (text "pattern", map unLoc lnames)
+ ForD _ (ForeignImport _ (L _ n) _ _) -> (empty, [n])
+ ForD _ (ForeignExport _ (L _ n) _ _) -> (empty, [n])
_ -> error "declaration not supported by declNames"
@@ -293,20 +293,20 @@ ppDecl :: LHsDecl DocNameI -- ^ decl to print
-> LaTeX
ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of
- TyClD d@FamDecl {} -> ppTyFam False doc d unicode
- TyClD d@DataDecl {} -> ppDataDecl pats instances subdocs (Just doc) d unicode
- TyClD d@SynDecl {} -> ppTySyn (doc, fnArgsDoc) d unicode
+ TyClD _ d@FamDecl {} -> ppTyFam False doc d unicode
+ TyClD _ d@DataDecl {} -> ppDataDecl pats instances subdocs (Just doc) d unicode
+ TyClD _ d@SynDecl {} -> ppTySyn (doc, fnArgsDoc) d unicode
-- Family instances happen via FamInst now
--- TyClD d@TySynonym{}
+-- TyClD _ d@TySynonym{}
-- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode
-- Family instances happen via FamInst now
- TyClD d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode
- SigD (TypeSig _ lnames ty) -> ppFunSig (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode
- SigD (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode
- ForD d -> ppFor (doc, fnArgsDoc) d unicode
- InstD _ -> empty
- DerivD _ -> empty
- _ -> error "declaration not supported by ppDecl"
+ TyClD _ d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode
+ SigD _ (TypeSig _ lnames ty) -> ppFunSig (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode
+ SigD _ (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode
+ ForD _ d -> ppFor (doc, fnArgsDoc) d unicode
+ InstD _ _ -> empty
+ DerivD _ _ -> empty
+ _ -> error "declaration not supported by ppDecl"
where
unicode = False
@@ -318,7 +318,7 @@ ppTyFam _ _ _ _ =
ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX
-ppFor doc (ForeignImport (L _ name) typ _ _) unicode =
+ppFor doc (ForeignImport _ (L _ name) typ _) unicode =
ppFunSig doc [name] (hsSigType typ) unicode
ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX"
-- error "foreign declarations are currently not supported by --latex"
@@ -647,7 +647,7 @@ ppDataDecl pats instances subdocs doc dataDecl unicode =
text "\\enspace" <+> emph (text "Bundled Patterns") <> text "\\par" $$
text "\\haddockbeginconstrs" $$
vcat [ empty <-> ppSideBySidePat lnames typ d unicode
- | (SigD (PatSynSig _ lnames typ), d) <- pats
+ | (SigD _ (PatSynSig _ lnames typ), d) <- pats
] $$
text "\\end{tabulary}\\par"
@@ -726,6 +726,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
-- ++AZ++ make this prepend "{..}" when it is a record style GADT
, ppLType unicode (getGADTConType con)
]
+ XConDecl{} -> panic "haddock:ppSideBySideConstr"
fieldPart = case (con, getConArgs con) of
-- Record style GADTs
@@ -759,6 +760,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
[ l <+> text "\\enspace" <+> r
| (l,r) <- ppSubSigLike unicode (unLoc (getGADTConType con)) argDocs subdocs (dcolon unicode)
]
+ XConDecl{} -> panic "haddock:doConstrArgsWithDocs"
-- don't use "con_doc con", in case it's reconstructed from a .hi file,
@@ -771,13 +773,14 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
-- | Pretty-print a record field
ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocNameI -> LaTeX
-ppSideBySideField subdocs unicode (ConDeclField names ltype _) =
+ppSideBySideField subdocs unicode (ConDeclField _ names ltype _) =
decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names))
<+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc
where
-- don't use cd_fld_doc for same reason we don't use con_doc above
-- Where there is more than one name, they all have the same documentation
mbDoc = lookup (extFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst
+ppSideBySideField _ _ (XConDeclField _) = panic "haddock:ppSideBySideField"
-- | Pretty-print a bundled pattern synonym
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 00937245..464c166b 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -663,7 +663,7 @@ numberSectionHeadings = go 1
processExport :: Bool -> LinksInfo -> Bool -> Qualification
-> ExportItem DocNameI -> Maybe Html
-processExport _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances
+processExport _ _ _ _ ExportDecl { expItemDecl = L _ (InstD {}) } = Nothing -- Hide empty instances
processExport summary _ _ qual (ExportGroup lev id0 doc)
= nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) qual (mkMeta doc)
processExport summary links unicode qual (ExportDecl decl pats doc subdocs insts fixities splice)
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 5f253cbd..8ac3d91b 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -39,6 +39,7 @@ import GHC.Exts
import Name
import BooleanFormula
import RdrName ( rdrNameOcc )
+import Outputable ( panic )
-- | Pretty print a declaration
ppDecl :: Bool -- ^ print summary info only
@@ -54,18 +55,18 @@ ppDecl :: Bool -- ^ print summary info only
-> Qualification
-> Html
ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of
- TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual
- TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode qual
- TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual
- TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual
- SigD (TypeSig _ lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames
+ TyClD _ (FamDecl _ d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual
+ TyClD _ d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode qual
+ TyClD _ d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual
+ TyClD _ d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual
+ SigD _ (TypeSig _ lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames
(hsSigWcType lty) fixities splice unicode qual
- SigD (PatSynSig _ lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames
+ SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames
(hsSigType lty) fixities splice unicode qual
- ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual
- InstD _ -> noHtml
- DerivD _ -> noHtml
- _ -> error "declaration not supported by ppDecl"
+ ForD _ d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual
+ InstD _ _ -> noHtml
+ DerivD _ _ -> noHtml
+ _ -> error "declaration not supported by ppDecl"
ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
@@ -225,7 +226,7 @@ tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit
ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
-> ForeignDecl DocNameI -> [(DocName, Fixity)]
-> Splice -> Unicode -> Qualification -> Html
-ppFor summary links loc doc (ForeignImport (L _ name) typ _ _) fixities
+ppFor summary links loc doc (ForeignImport _ (L _ name) typ _) fixities
splice unicode qual
= ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode qual
ppFor _ _ _ _ _ _ _ _ _ = error "ppFor"
@@ -318,12 +319,14 @@ ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info
ClosedTypeFamily _ -> keyword "where ..."
_ -> mempty
)
+ppTyFamHeader _ _ (XFamilyDecl _) _ _ = panic "haddock;ppTyFamHeader"
ppResultSig :: FamilyResultSig DocNameI -> Unicode -> Qualification -> Html
ppResultSig result unicode qual = case result of
- NoSig -> noHtml
- KindSig kind -> dcolon unicode <+> ppLKind unicode qual kind
- TyVarSig (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr
+ NoSig _ -> noHtml
+ KindSig _ kind -> dcolon unicode <+> ppLKind unicode qual kind
+ TyVarSig _ (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr
+ XFamilyResultSig _ -> panic "haddock:ppResultSig"
ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocNameI
-> Html
@@ -367,6 +370,8 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode
= ( ppAppNameTypes (unLoc n) (map unLoc ts) unicode qual
<+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs)
, Nothing, [] )
+ ppTyFamEqn (XHsImplicitBndrs _) = panic "haddock:ppTyFam"
+ ppTyFamEqn (HsIB { hsib_body = XFamEqn _}) = panic "haddock:ppTyFam"
@@ -399,6 +404,7 @@ ppAssocType summ links doc (L loc decl) fixities splice unicode qual =
ppFamDeclBinderWithVars :: Bool -> Unicode -> Qualification -> FamilyDecl DocNameI -> Html
ppFamDeclBinderWithVars summ unicode qual (FamilyDecl { fdLName = lname, fdTyVars = tvs }) =
ppAppDocNameTyVarBndrs summ unicode qual (unLoc lname) (hsq_explicit tvs)
+ppFamDeclBinderWithVars _ _ _ (XFamilyDecl _) = panic "haddock:ppFamDeclBinderWithVars"
-- | Print a newtype / data binder and its variables
ppDataBinderWithVars :: Bool -> Unicode -> Qualification -> TyClDecl DocNameI -> Html
@@ -740,13 +746,14 @@ ppShortDataDecl summary dataInst dataDecl pats unicode qual
isH98 = case unLoc (head cons) of
ConDeclH98 {} -> True
ConDeclGADT{} -> False
+ XConDecl{} -> False
pats1 = [ hsep [ keyword "pattern"
, hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames
, dcolon unicode
, ppPatSigType unicode qual (hsSigType typ)
]
- | (SigD (PatSynSig _ lnames typ),_) <- pats
+ | (SigD _ (PatSynSig _ lnames typ),_) <- pats
]
@@ -772,6 +779,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats
isH98 = case unLoc (head cons) of
ConDeclH98 {} -> True
ConDeclGADT{} -> False
+ XConDecl{} -> False
header_ = topDeclElem links loc splice [docname] $
ppDataHeader summary dataDecl unicode qual <+> whereBit <+> fix
@@ -793,7 +801,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats
patternBit = subPatterns qual
[ ppSideBySidePat subfixs unicode qual lnames typ d
- | (SigD (PatSynSig _ lnames typ), d) <- pats
+ | (SigD _ (PatSynSig _ lnames typ), d) <- pats
, let subfixs = filter (\(n,_) -> any (\cn -> cn == n)
(map unLoc lnames)) fixities
]
@@ -854,6 +862,7 @@ ppShortConstrParts summary dataInst con unicode qual
, noHtml
, noHtml
)
+ XConDecl {} -> panic "haddock:ppShortConstrParts"
where
occ = map (nameOccName . getName . unLoc) $ getConNames con
@@ -923,6 +932,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con)
, ppLType unicode qual HideEmptyContexts (getGADTConType con)
, fixity
]
+ XConDecl{} -> panic "haddock:ppSideBySideConstr"
fieldPart = case (con, getConArgs con) of
-- Record style GADTs
@@ -951,6 +961,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con)
ConDeclGADT{} ->
ppSubSigLike unicode qual (unLoc (getGADTConType con))
argDocs subdocs (dcolon unicode) HideEmptyContexts
+ XConDecl{} -> panic "haddock:doConstrArgsWithDocs"
-- don't use "con_doc con", in case it's reconstructed from a .hi file,
-- or also because we want Haddock to do the doc-parsing, not GHC.
@@ -980,7 +991,7 @@ ppConstrHdr forall_ tvs ctxt unicode qual = ppForall +++ ppCtxt
-- | Pretty-print a record field
ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification
-> ConDeclField DocNameI -> SubDecl
-ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) =
+ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype _) =
( hsep (punctuate comma [ ppBinder False (rdrNameOcc field)
| L _ name <- names
, let field = (unLoc . rdrNameFieldOcc) name
@@ -994,12 +1005,14 @@ ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) =
-- don't use cd_fld_doc for same reason we don't use con_doc above
-- Where there is more than one name, they all have the same documentation
mbDoc = lookup (extFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst
+ppSideBySideField _ _ _ (XConDeclField _) = panic "haddock:ppSideBySideField"
ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> Html
-ppShortField summary unicode qual (ConDeclField names ltype _)
+ppShortField summary unicode qual (ConDeclField _ names ltype _)
= hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names))
<+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype
+ppShortField _ _ _ (XConDeclField _) = panic "haddock:ppShortField"
-- | Pretty print an expanded pattern (for bundled patterns)
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index fd9f0089..b4804758 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -1,5 +1,5 @@
-{-# LANGUAGE CPP, PatternGuards #-}
+{-# LANGUAGE CPP, PatternGuards, TypeFamilies #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Convert
@@ -62,14 +62,14 @@ tyThingToLHsDecl t = case t of
-- in a future code version we could turn idVarDetails = foreign-call
-- into a ForD instead of a SigD if we wanted. Haddock doesn't
-- need to care.
- AnId i -> allOK $ SigD (synifyIdSig ImplicitizeForAll i)
+ AnId i -> allOK $ SigD noExt (synifyIdSig ImplicitizeForAll i)
-- type-constructors (e.g. Maybe) are complicated, put the definition
-- later in the file (also it's used for class associated-types too.)
ATyCon tc
| Just cl <- tyConClass_maybe tc -- classes are just a little tedious
-> let extractFamilyDecl :: TyClDecl a -> Either ErrMsg (LFamilyDecl a)
- extractFamilyDecl (FamDecl d) = return $ noLoc d
+ extractFamilyDecl (FamDecl _ d) = return $ noLoc d
extractFamilyDecl _ =
Left "tyThingToLHsDecl: impossible associated tycon"
@@ -77,7 +77,7 @@ tyThingToLHsDecl t = case t of
atFamDecls = map extractFamilyDecl (rights atTyClDecls)
tyClErrors = lefts atTyClDecls
famDeclErrors = lefts atFamDecls
- in withErrs (tyClErrors ++ famDeclErrors) . TyClD $ ClassDecl
+ in withErrs (tyClErrors ++ famDeclErrors) . TyClD noExt $ ClassDecl
{ tcdCtxt = synifyCtx (classSCTheta cl)
, tcdLName = synifyName cl
, tcdTyVars = synifyTyVars (tyConVisibleTyVars (classTyCon cl))
@@ -93,20 +93,20 @@ tyThingToLHsDecl t = case t of
, tcdATs = rights atFamDecls
, tcdATDefs = [] --ignore associated type defaults
, tcdDocs = [] --we don't have any docs at this point
- , tcdFVs = placeHolderNamesTc }
+ , tcdCExt = placeHolderNamesTc }
| otherwise
- -> synifyTyCon Nothing tc >>= allOK . TyClD
+ -> synifyTyCon Nothing tc >>= allOK . TyClD noExt
-- type-constructors (e.g. Maybe) are complicated, put the definition
-- later in the file (also it's used for class associated-types too.)
ACoAxiom ax -> synifyAxiom ax >>= allOK
-- a data-constructor alone just gets rendered as a function:
- AConLike (RealDataCon dc) -> allOK $ SigD (TypeSig noExt [synifyName dc]
+ AConLike (RealDataCon dc) -> allOK $ SigD noExt (TypeSig noExt [synifyName dc]
(synifySigWcType ImplicitizeForAll (dataConUserType dc)))
AConLike (PatSynCon ps) ->
- allOK . SigD $ PatSynSig noExt [synifyName ps] (synifyPatSynSigType ps)
+ allOK . SigD noExt $ PatSynSig noExt [synifyName ps] (synifyPatSynSigType ps)
where
withErrs e x = return (e, x)
allOK x = return (mempty, x)
@@ -119,9 +119,10 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
annot_typats = zipWith3 annotHsType (mkIsPolyTvs fam_tvs)
args_types_only typats
hs_rhs = synifyType WithinType rhs
- in HsIB { hsib_vars = map tyVarName tkvs
- , hsib_closed = True
- , hsib_body = FamEqn { feqn_tycon = name
+ in HsIB { hsib_ext = HsIBRn { hsib_vars = map tyVarName tkvs
+ , hsib_closed = True }
+ , hsib_body = FamEqn { feqn_ext = noExt
+ , feqn_tycon = name
, feqn_pats = annot_typats
, feqn_fixity = Prefix
, feqn_rhs = hs_rhs } }
@@ -132,13 +133,13 @@ synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl GhcRn)
synifyAxiom ax@(CoAxiom { co_ax_tc = tc })
| isOpenTypeFamilyTyCon tc
, Just branch <- coAxiomSingleBranch_maybe ax
- = return $ InstD
- $ TyFamInstD
+ = return $ InstD noExt
+ $ TyFamInstD noExt
$ TyFamInstDecl { tfid_eqn = synifyAxBranch tc branch }
| Just ax' <- isClosedSynFamilyTyConWithAxiom_maybe tc
, getUnique ax' == getUnique ax -- without the getUniques, type error
- = synifyTyCon (Just ax) tc >>= return . TyClD
+ = synifyTyCon (Just ax) tc >>= return . TyClD noExt
| otherwise
= Left "synifyAxiom: closed/open family confusion"
@@ -153,14 +154,17 @@ synifyTyCon _coax tc
let mk_hs_tv realKind fakeTyVar
= noLoc $ KindedTyVar noExt (noLoc (getName fakeTyVar))
(synifyKindSig realKind)
- in HsQTvs { hsq_implicit = [] -- No kind polymorphism
+ in HsQTvs { hsq_ext =
+ HsQTvsRn { hsq_implicit = [] -- No kind polymorphism
+ , hsq_dependent = emptyNameSet }
, hsq_explicit = zipWith mk_hs_tv (fst (splitFunTys (tyConKind tc)))
alphaTyVars --a, b, c... which are unfortunately all kind *
- , hsq_dependent = emptyNameSet }
+ }
, tcdFixity = Prefix
- , tcdDataDefn = HsDataDefn { dd_ND = DataType -- arbitrary lie, they are neither
+ , tcdDataDefn = HsDataDefn { dd_ext = noExt
+ , dd_ND = DataType -- arbitrary lie, they are neither
-- algebraic data nor newtype:
, dd_ctxt = noLoc []
, dd_cType = Nothing
@@ -168,8 +172,7 @@ synifyTyCon _coax tc
-- we have their kind accurately:
, dd_cons = [] -- No constructors
, dd_derivs = noLoc [] }
- , tcdDataCusk = False
- , tcdFVs = placeHolderNamesTc }
+ , tcdDExt = DataDeclRn False placeHolderNamesTc }
synifyTyCon _coax tc
| Just flav <- famTyConFlav_maybe tc
@@ -190,8 +193,9 @@ synifyTyCon _coax tc
-> mkFamDecl DataFamily
where
resultVar = famTcResVar tc
- mkFamDecl i = return $ FamDecl $
- FamilyDecl { fdInfo = i
+ mkFamDecl i = return $ FamDecl noExt $
+ FamilyDecl { fdExt = noExt
+ , fdInfo = i
, fdLName = synifyName tc
, fdTyVars = synifyTyVars (tyConVisibleTyVars tc)
, fdFixity = Prefix
@@ -204,11 +208,11 @@ synifyTyCon _coax tc
synifyTyCon coax tc
| Just ty <- synTyConRhs_maybe tc
- = return $ SynDecl { tcdLName = synifyName tc
+ = return $ SynDecl { tcdSExt = emptyNameSet
+ , tcdLName = synifyName tc
, tcdTyVars = synifyTyVars (tyConVisibleTyVars tc)
, tcdFixity = Prefix
- , tcdRhs = synifyType WithinType ty
- , tcdFVs = placeHolderNamesTc }
+ , tcdRhs = synifyType WithinType ty }
| otherwise =
-- (closed) newtype and data
let
@@ -241,7 +245,8 @@ synifyTyCon coax tc
cons = rights consRaw
-- "deriving" doesn't affect the signature, no need to specify any.
alg_deriv = noLoc []
- defn = HsDataDefn { dd_ND = alg_nd
+ defn = HsDataDefn { dd_ext = noExt
+ , dd_ND = alg_nd
, dd_ctxt = alg_ctx
, dd_cType = Nothing
, dd_kindSig = fmap synifyKindSig kindSig
@@ -251,7 +256,7 @@ synifyTyCon coax tc
[] -> return $
DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdFixity = Prefix
, tcdDataDefn = defn
- , tcdDataCusk = False, tcdFVs = placeHolderNamesTc }
+ , tcdDExt = DataDeclRn False placeHolderNamesTc }
dataConErrs -> Left $ unlines dataConErrs
synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity
@@ -264,9 +269,9 @@ synifyInjectivityAnn (Just lhs) tvs (Injective inj) =
synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig GhcRn
synifyFamilyResultSig Nothing kind =
- noLoc $ KindSig (synifyKindSig kind)
+ noLoc $ KindSig noExt (synifyKindSig kind)
synifyFamilyResultSig (Just name) kind =
- noLoc $ TyVarSig (noLoc $ KindedTyVar noExt (noLoc name) (synifyKindSig kind))
+ noLoc $ TyVarSig noExt (noLoc $ KindedTyVar noExt (noLoc name) (synifyKindSig kind))
-- User beware: it is your responsibility to pass True (use_gadt_syntax)
-- for any constructor that would be misrepresented by omitting its
@@ -297,7 +302,7 @@ synifyDataCon use_gadt_syntax dc =
field_tys = zipWith con_decl_field (dataConFieldLabels dc) linear_tys
con_decl_field fl synTy = noLoc $
- ConDeclField [noLoc $ FieldOcc (flSelector fl) (noLoc $ mkVarUnqual $ flLabel fl)] synTy
+ ConDeclField noExt [noLoc $ FieldOcc (flSelector fl) (noLoc $ mkVarUnqual $ flLabel fl)] synTy
Nothing
hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of
(True,True) -> Left "synifyDataCon: contradiction!"
@@ -311,7 +316,8 @@ synifyDataCon use_gadt_syntax dc =
\hat ->
if use_gadt_syntax
then return $ noLoc $
- ConDeclGADT { con_names = [name]
+ ConDeclGADT { con_g_ext = noExt
+ , con_names = [name]
, con_forall = True
, con_qvars = synifyTyVars (univ_tvs ++ ex_tvs)
, con_mb_cxt = Just ctx
@@ -319,7 +325,8 @@ synifyDataCon use_gadt_syntax dc =
, con_res_ty = synifyType WithinType res_ty
, con_doc = Nothing }
else return $ noLoc $
- ConDeclH98 { con_name = name
+ ConDeclH98 { con_ext = noExt
+ , con_name = name
, con_forall = True
, con_ex_tvs = map synifyTyVar ex_tvs
, con_mb_cxt = Just ctx
@@ -341,9 +348,9 @@ synifyCtx = noLoc . map (synifyType WithinType)
synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn
-synifyTyVars ktvs = HsQTvs { hsq_implicit = []
- , hsq_explicit = map synifyTyVar ktvs
- , hsq_dependent = emptyNameSet }
+synifyTyVars ktvs = HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = []
+ , hsq_dependent = emptyNameSet }
+ , hsq_explicit = map synifyTyVar ktvs }
synifyTyVar :: TyVar -> LHsTyVarBndr GhcRn
synifyTyVar tv
@@ -546,7 +553,7 @@ synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead
, clsiTyVars = synifyTyVars (tyConVisibleTyVars cls_tycon)
, clsiSigs = map synifyClsIdSig $ classMethods cls
, clsiAssocTys = do
- (Right (FamDecl fam)) <- map (synifyTyCon Nothing) $ classATs cls
+ (Right (FamDecl _ fam)) <- map (synifyTyCon Nothing) $ classATs cls
pure $ mkPseudoFamilyDecl fam
}
}
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 14111a6a..2d254414 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -47,28 +47,36 @@ isConSym = isLexConSym . occNameFS
getMainDeclBinder :: HsDecl name -> [IdP name]
-getMainDeclBinder (TyClD d) = [tcdName d]
-getMainDeclBinder (ValD d) =
+getMainDeclBinder (TyClD _ d) = [tcdName d]
+getMainDeclBinder (ValD _ d) =
case collectHsBindBinders d of
[] -> []
(name:_) -> [name]
-getMainDeclBinder (SigD d) = sigNameNoLoc d
-getMainDeclBinder (ForD (ForeignImport name _ _ _)) = [unLoc name]
-getMainDeclBinder (ForD (ForeignExport _ _ _ _)) = []
+getMainDeclBinder (SigD _ d) = sigNameNoLoc d
+getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name]
+getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = []
getMainDeclBinder _ = []
-- Extract the source location where an instance is defined. This is used
-- to correlate InstDecls with their Instance/CoAxiom Names, via the
-- instanceMap.
getInstLoc :: InstDecl name -> SrcSpan
-getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty)
-getInstLoc (DataFamInstD (DataFamInstDecl
+getInstLoc (ClsInstD _ (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty)
+getInstLoc (DataFamInstD _ (DataFamInstDecl
{ dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}})) = l
-getInstLoc (TyFamInstD (TyFamInstDecl
+getInstLoc (TyFamInstD _ (TyFamInstDecl
-- Since CoAxioms' Names refer to the whole line for type family instances
-- in particular, we need to dig a bit deeper to pull out the entire
-- equation. This does not happen for data family instances, for some reason.
{ tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = L l _ }}})) = l
+getInstLoc (ClsInstD _ (XClsInstDecl _)) = panic "getInstLoc"
+getInstLoc (DataFamInstD _ (DataFamInstDecl (HsIB _ (XFamEqn _)))) = panic "getInstLoc"
+getInstLoc (TyFamInstD _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = panic "getInstLoc"
+getInstLoc (XInstDecl _) = panic "getInstLoc"
+getInstLoc (DataFamInstD _ (DataFamInstDecl (XHsImplicitBndrs _))) = panic "getInstLoc"
+getInstLoc (TyFamInstD _ (TyFamInstDecl (XHsImplicitBndrs _))) = panic "getInstLoc"
+
+
-- Useful when there is a signature with multiple names, e.g.
-- foo, bar :: Types..
@@ -124,16 +132,16 @@ isUserLSig _ = False
isClassD :: HsDecl a -> Bool
-isClassD (TyClD d) = isClassDecl d
+isClassD (TyClD _ d) = isClassDecl d
isClassD _ = False
isValD :: HsDecl a -> Bool
-isValD (ValD _) = True
+isValD (ValD _ _) = True
isValD _ = False
declATs :: HsDecl a -> [IdP a]
-declATs (TyClD d) | isClassDecl d = map (unL . fdLName . unL) $ tcdATs d
+declATs (TyClD _ d) | isClassDecl d = map (unL . fdLName . unL) $ tcdATs d
declATs _ = []
@@ -165,13 +173,13 @@ getGADTConType (ConDeclGADT { con_forall = has_forall
, con_qvars = qtvs
, con_mb_cxt = mcxt, con_args = args
, con_res_ty = res_ty })
- | has_forall = noLoc (HsForAllTy { hst_xforall = PlaceHolder
+ | has_forall = noLoc (HsForAllTy { hst_xforall = NoExt
, hst_bndrs = hsQTvExplicit qtvs
, hst_body = theta_ty })
| otherwise = theta_ty
where
theta_ty | Just theta <- mcxt
- = noLoc (HsQualTy { hst_xqual = PlaceHolder, hst_ctxt = theta, hst_body = tau_ty })
+ = noLoc (HsQualTy { hst_xqual = NoExt, hst_ctxt = theta, hst_body = tau_ty })
| otherwise
= tau_ty
@@ -184,6 +192,7 @@ getGADTConType (ConDeclGADT { con_forall = has_forall
getGADTConType (ConDeclH98 {}) = panic "getGADTConType"
-- Should only be called on ConDeclGADT
+getGADTConType (XConDecl {}) = panic "getGADTConType"
-- -------------------------------------
@@ -196,13 +205,13 @@ getGADTConTypeG (ConDeclGADT { con_forall = has_forall
, con_qvars = qtvs
, con_mb_cxt = mcxt, con_args = args
, con_res_ty = res_ty })
- | has_forall = noLoc (HsForAllTy { hst_xforall = PlaceHolder
+ | has_forall = noLoc (HsForAllTy { hst_xforall = NoExt
, hst_bndrs = hsQTvExplicit qtvs
, hst_body = theta_ty })
| otherwise = theta_ty
where
theta_ty | Just theta <- mcxt
- = noLoc (HsQualTy { hst_xqual = PlaceHolder, hst_ctxt = theta, hst_body = tau_ty })
+ = noLoc (HsQualTy { hst_xqual = NoExt, hst_ctxt = theta, hst_body = tau_ty })
| otherwise
= tau_ty
@@ -213,8 +222,9 @@ getGADTConTypeG (ConDeclGADT { con_forall = has_forall
mkFunTy a b = noLoc (HsFunTy noExt a b)
-getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConType"
+getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConTypeG"
-- Should only be called on ConDeclGADT
+getGADTConTypeG (XConDecl {}) = panic "getGADTConTypeG"
-------------------------------------------------------------------------------
-- * Located
@@ -286,7 +296,7 @@ parentMap d = [ (c, p) | (p, cs) <- families d, c <- cs ]
-- | The parents of a subordinate in a declaration
parents :: Name -> HsDecl GhcRn -> [Name]
-parents n (TyClD d) = [ p | (c, p) <- parentMap d, c == n ]
+parents n (TyClD _ d) = [ p | (c, p) <- parentMap d, c == n ]
parents _ _ = []
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index 4fd9d264..286907e5 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -87,7 +87,7 @@ attachToExportItem
-> Ghc (ExportItem GhcRn)
attachToExportItem index expInfo iface ifaceMap instIfaceMap export =
case attachFixities export of
- e@ExportDecl { expItemDecl = L eSpan (TyClD d) } -> do
+ e@ExportDecl { expItemDecl = L eSpan (TyClD _ d) } -> do
insts <-
let mb_instances = lookupNameEnv index (tcdName d)
cls_instances = maybeToList mb_instances >>= fst
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index c119f3c3..bc93449f 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -125,7 +125,7 @@ createInterface tm flags modMap instIfaceMap = do
$ map getName instances
++ map getName fam_instances
-- Locations of all TH splices
- splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ]
+ splices = [ l | L l (SpliceD _ _) <- hsmodDecls hsm ]
warningMap <- liftErrMsg (mkWarningMap dflags warnings gre exportedNames)
@@ -406,9 +406,9 @@ mkMaps dflags gre instances decls = do
instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ]
names :: SrcSpan -> HsDecl GhcRn -> [Name]
- names l (InstD d) = maybeToList (M.lookup loc instanceMap) -- See note [2].
+ names l (InstD _ d) = maybeToList (M.lookup loc instanceMap) -- See note [2].
where loc = case d of
- TyFamInstD _ -> l -- The CoAx's loc is the whole line, but only for TFs
+ TyFamInstD _ _ -> l -- The CoAx's loc is the whole line, but only for TFs
_ -> getInstLoc d
names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See note [2].
names _ decl = getMainDeclBinder decl
@@ -433,16 +433,16 @@ subordinates :: InstMap
-> HsDecl GhcRn
-> [(Name, [HsDocString], Map Int HsDocString)]
subordinates instMap decl = case decl of
- InstD (ClsInstD d) -> do
+ InstD _ (ClsInstD _ d) -> do
DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
FamEqn { feqn_tycon = L l _
, feqn_rhs = defn }}} <- unLoc <$> cid_datafam_insts d
[ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn
- InstD (DataFamInstD (DataFamInstDecl (HsIB { hsib_body = d })))
+ InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = d })))
-> dataSubs (feqn_rhs d)
- TyClD d | isClassDecl d -> classSubs d
- | isDataDecl d -> dataSubs (tcdDataDefn d)
+ TyClD _ d | isClassDecl d -> classSubs d
+ | isDataDecl d -> dataSubs (tcdDataDefn d)
_ -> []
where
classSubs dd = [ (name, doc, declTypeDocs d) | (L _ d, doc) <- classDecls dd
@@ -456,7 +456,7 @@ subordinates instMap decl = case decl of
| c <- cons, cname <- getConNames c ]
fields = [ (extFieldOcc n, maybeToList $ fmap unL doc, M.empty)
| RecCon flds <- map getConArgs cons
- , L _ (ConDeclField ns _ doc) <- (unLoc flds)
+ , L _ (ConDeclField _ ns _ doc) <- (unLoc flds)
, L _ n <- ns ]
derivs = [ (instName, [unL doc], M.empty)
| HsIB { hsib_body = L l (HsDocTy _ _ doc) }
@@ -481,11 +481,11 @@ conArgDocs con = case getConArgs con of
-- | Extract function argument docs from inside top-level decls.
declTypeDocs :: HsDecl GhcRn -> Map Int HsDocString
-declTypeDocs (SigD (TypeSig _ _ ty)) = typeDocs (unLoc (hsSigWcType ty))
-declTypeDocs (SigD (ClassOpSig _ _ _ ty)) = typeDocs (unLoc (hsSigType ty))
-declTypeDocs (SigD (PatSynSig _ _ ty)) = typeDocs (unLoc (hsSigType ty))
-declTypeDocs (ForD (ForeignImport _ ty _ _)) = typeDocs (unLoc (hsSigType ty))
-declTypeDocs (TyClD (SynDecl { tcdRhs = ty })) = typeDocs (unLoc ty)
+declTypeDocs (SigD _ (TypeSig _ _ ty)) = typeDocs (unLoc (hsSigWcType ty))
+declTypeDocs (SigD _ (ClassOpSig _ _ _ ty)) = typeDocs (unLoc (hsSigType ty))
+declTypeDocs (SigD _ (PatSynSig _ _ ty)) = typeDocs (unLoc (hsSigType ty))
+declTypeDocs (ForD _ (ForeignImport _ _ ty _)) = typeDocs (unLoc (hsSigType ty))
+declTypeDocs (TyClD _ (SynDecl { tcdRhs = ty })) = typeDocs (unLoc ty)
declTypeDocs _ = M.empty
-- | Extract function argument docs from inside types.
@@ -505,10 +505,10 @@ classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls
where
decls = docs ++ defs ++ sigs ++ ats
- docs = mkDecls tcdDocs DocD class_
- defs = mkDecls (bagToList . tcdMeths) ValD class_
- sigs = mkDecls tcdSigs SigD class_
- ats = mkDecls tcdATs (TyClD . FamDecl) class_
+ docs = mkDecls tcdDocs (DocD noExt) class_
+ defs = mkDecls (bagToList . tcdMeths) (ValD noExt) class_
+ sigs = mkDecls tcdSigs (SigD noExt) class_
+ ats = mkDecls tcdATs (TyClD noExt . FamDecl noExt) class_
-- | The top-level declarations of a module that we care about,
@@ -526,14 +526,14 @@ mkFixMap group_ = M.fromList [ (n,f)
-- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.
ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn]
ungroup group_ =
- mkDecls (tyClGroupTyClDecls . hs_tyclds) TyClD group_ ++
- mkDecls hs_derivds DerivD group_ ++
- mkDecls hs_defds DefD group_ ++
- mkDecls hs_fords ForD group_ ++
- mkDecls hs_docs DocD group_ ++
- mkDecls (tyClGroupInstDecls . hs_tyclds) InstD group_ ++
- mkDecls (typesigs . hs_valds) SigD group_ ++
- mkDecls (valbinds . hs_valds) ValD group_
+ mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExt) group_ ++
+ mkDecls hs_derivds (DerivD noExt) group_ ++
+ mkDecls hs_defds (DefD noExt) group_ ++
+ mkDecls hs_fords (ForD noExt) group_ ++
+ mkDecls hs_docs (DocD noExt) group_ ++
+ mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExt) group_ ++
+ mkDecls (typesigs . hs_valds) (SigD noExt) group_ ++
+ mkDecls (valbinds . hs_valds) (ValD noExt) group_
where
typesigs (XValBindsLR (NValBinds _ sigs)) = filter isUserLSig sigs
typesigs _ = error "expected ValBindsOut"
@@ -564,14 +564,14 @@ sortByLoc = sortBy (comparing getLoc)
filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
filterDecls = filter (isHandled . unL . fst)
where
- isHandled (ForD (ForeignImport {})) = True
+ isHandled (ForD _ (ForeignImport {})) = True
isHandled (TyClD {}) = True
isHandled (InstD {}) = True
isHandled (DerivD {}) = True
- isHandled (SigD d) = isUserLSig (reL d)
- isHandled (ValD _) = True
+ isHandled (SigD _ d) = isUserLSig (reL d)
+ isHandled (ValD {}) = True
-- we keep doc declarations to be able to get at named docs
- isHandled (DocD _) = True
+ isHandled (DocD {}) = True
isHandled _ = False
@@ -580,8 +580,8 @@ filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x
| x@(L loc d, doc) <- decls ]
where
- filterClass (TyClD c) =
- TyClD $ c { tcdSigs = filter (liftA2 (||) isUserLSig isMinimalLSig) $ tcdSigs c }
+ filterClass (TyClD x c) =
+ TyClD x $ c { tcdSigs = filter (liftA2 (||) isUserLSig isMinimalLSig) $ tcdSigs c }
filterClass _ = error "expected TyClD"
@@ -600,10 +600,10 @@ collectDocs = go Nothing []
where
go Nothing _ [] = []
go (Just prev) docs [] = finished prev docs []
- go prev docs (L _ (DocD (DocCommentNext str)) : ds)
+ go prev docs (L _ (DocD _ (DocCommentNext str)) : ds)
| Nothing <- prev = go Nothing (str:docs) ds
| Just decl <- prev = finished decl docs (go Nothing [str] ds)
- go prev docs (L _ (DocD (DocCommentPrev str)) : ds) = go prev (str:docs) ds
+ go prev docs (L _ (DocD _ (DocCommentPrev str)) : ds) = go prev (str:docs) ds
go Nothing docs (d:ds) = go (Just d) docs ds
go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds)
@@ -644,22 +644,22 @@ mkExportItems
decls maps fixMap splices instIfaceMap dflags allExports
Just exports -> liftM concat $ mapM lookupExport exports
where
- lookupExport (IEGroup lev docStr, _) = liftErrMsg $ do
+ lookupExport (IEGroup _ lev docStr, _) = liftErrMsg $ do
doc <- processDocString dflags gre docStr
return [ExportGroup lev "" doc]
- lookupExport (IEDoc docStr, _) = liftErrMsg $ do
+ lookupExport (IEDoc _ docStr, _) = liftErrMsg $ do
doc <- processDocStringParas dflags gre docStr
return [ExportDoc doc]
- lookupExport (IEDocNamed str, _) = liftErrMsg $
+ lookupExport (IEDocNamed _ str, _) = liftErrMsg $
findNamedDoc str [ unL d | d <- decls ] >>= \case
Nothing -> return []
Just docStr -> do
doc <- processDocStringParas dflags gre docStr
return [ExportDoc doc]
- lookupExport (IEModuleContents (L _ mod_name), _)
+ lookupExport (IEModuleContents _ (L _ mod_name), _)
-- only consider exporting a module if we are sure we
-- are really exporting the whole module and not some
-- subset. We also look through module aliases here.
@@ -696,7 +696,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
let t = availName avail
r <- findDecl avail
case r of
- ([L l (ValD _)], (doc, _)) -> do
+ ([L l (ValD _ _)], (doc, _)) -> do
-- Top-level binding without type signature
export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap
return [export]
@@ -721,17 +721,17 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
-- A single signature might refer to many names, but we
-- create an export item for a single name only. So we
-- modify the signature to contain only that single name.
- L loc (SigD sig) ->
+ L loc (SigD _ sig) ->
-- fromJust is safe since we already checked in guards
-- that 't' is a name declared in this declaration.
- let newDecl = L loc . SigD . fromJust $ filterSigNames (== t) sig
+ let newDecl = L loc . SigD noExt . fromJust $ filterSigNames (== t) sig
in availExportDecl avail newDecl docs_
- L loc (TyClD cl@ClassDecl{}) -> do
+ L loc (TyClD _ cl@ClassDecl{}) -> do
mdef <- liftGhcToErrMsgGhc $ minimalDef t
let sig = maybeToList $ fmap (noLoc . MinimalSig noExt NoSourceText . noLoc . fmap noLoc) mdef
availExportDecl avail
- (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_
+ (L loc $ TyClD noExt cl { tcdSigs = sig ++ tcdSigs cl }) docs_
_ -> availExportDecl avail decl docs_
@@ -994,7 +994,7 @@ fullModuleContents is_sig modMap thisMod semMod warnings exportedNames
for (getMainDeclBinder (unLoc decl)) $ \nm -> do
case lookupNameEnv availEnv nm of
Just avail
- | L _ (ValD valDecl) <- decl
+ | L _ (ValD _ valDecl) <- decl
, (name:_) <- collectHsBindBinders valDecl
, Just (L _ SigD{}:_) <- filter isSigD <$> M.lookup name declMap
-> pure []
@@ -1017,7 +1017,7 @@ extractDecl declMap name decl
| name `elem` getMainDeclBinder (unLoc decl) = decl
| otherwise =
case unLoc decl of
- TyClD d@ClassDecl {} ->
+ TyClD _ d@ClassDecl {} ->
let
matchesMethod =
[ lsig
@@ -1037,8 +1037,8 @@ extractDecl declMap name decl
in case (matchesMethod, matchesAssociatedType) of
([s0], _) -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d)
L pos sig = addClassContext n tyvar_names s0
- in L pos (SigD sig)
- (_, [L pos fam_decl]) -> L pos (TyClD (FamDecl fam_decl))
+ in L pos (SigD noExt sig)
+ (_, [L pos fam_decl]) -> L pos (TyClD noExt (FamDecl noExt fam_decl))
([], [])
| Just (famInstDecl:_) <- M.lookup name declMap
@@ -1047,21 +1047,21 @@ extractDecl declMap name decl
O.$$ O.nest 4 (O.ppr d)
O.$$ O.text "Matches:"
O.$$ O.nest 4 (O.ppr matchesMethod O.<+> O.ppr matchesAssociatedType))
- TyClD d@DataDecl {} ->
+ TyClD _ d@DataDecl {} ->
let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d))
in if isDataConName name
- then SigD <$> extractPatternSyn name n tyvar_tys (dd_cons (tcdDataDefn d))
- else SigD <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d))
- TyClD FamDecl {}
+ then SigD noExt <$> extractPatternSyn name n tyvar_tys (dd_cons (tcdDataDefn d))
+ else SigD noExt <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d))
+ TyClD _ FamDecl {}
| isValName name
, Just (famInst:_) <- M.lookup name declMap
-> extractDecl declMap name famInst
- InstD (DataFamInstD (DataFamInstDecl (HsIB { hsib_body =
+ InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body =
FamEqn { feqn_tycon = L _ n
, feqn_pats = tys
, feqn_rhs = defn }}))) ->
- SigD <$> extractRecSel name n tys (dd_cons defn)
- InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) ->
+ SigD noExt <$> extractRecSel name n tys (dd_cons defn)
+ InstD _ (ClsInstD _ ClsInstDecl { cid_datafam_insts = insts }) ->
let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d }))
<- insts
-- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (feqn_rhs d)
@@ -1071,7 +1071,7 @@ extractDecl declMap name decl
, extFieldOcc n == name
]
in case matches of
- [d0] -> extractDecl declMap name (noLoc . InstD $ DataFamInstD d0)
+ [d0] -> extractDecl declMap name (noLoc . InstD noExt $ DataFamInstD noExt d0)
_ -> error "internal: extractDecl (ClsInstD)"
_ -> error "internal: extractDecl"
@@ -1112,12 +1112,12 @@ extractRecSel _ _ _ [] = error "extractRecSel: selector not found"
extractRecSel nm t tvs (L _ con : rest) =
case getConArgs con of
- RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields ->
+ RecCon (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields ->
L l (TypeSig noExt [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExt data_ty (getBangType ty)))))
_ -> extractRecSel nm t tvs rest
where
matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)]
- matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds
+ matching_fields flds = [ (l,f) | f@(L _ (ConDeclField _ ns _ _)) <- flds
, L l n <- ns, extFieldOcc n == nm ]
data_ty
-- ResTyGADT _ ty <- con_res con = ty
@@ -1142,8 +1142,8 @@ mkVisibleNames (_, _, _, instMap) exports opts
where subs = map fst (expItemSubDocs e)
patsyns = concatMap (getMainDeclBinder . fst) (expItemPats e)
name = case unLoc $ expItemDecl e of
- InstD d -> maybeToList $ M.lookup (getInstLoc d) instMap
- decl -> getMainDeclBinder decl
+ InstD _ d -> maybeToList $ M.lookup (getInstLoc d) instMap
+ decl -> getMainDeclBinder decl
exportName ExportNoDecl {} = [] -- we don't count these as visible, since
-- we don't want links to go to them.
exportName _ = []
@@ -1184,7 +1184,7 @@ findNamedDoc name = search
search [] = do
tell ["Cannot find documentation for: $" ++ name]
return Nothing
- search (DocD (DocCommentNamed name' doc) : rest)
+ search (DocD _ (DocCommentNamed name' doc) : rest)
| name == name' = return (Just doc)
| otherwise = search rest
search (_other_decl : rest) = search rest
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 0652ae47..5b588964 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -21,6 +21,7 @@ import Haddock.Types
import Bag (emptyBag)
import GHC hiding (NoLink)
import Name
+import Outputable ( panic )
import Control.Applicative
import Control.Monad hiding (mapM)
@@ -188,14 +189,15 @@ renameMaybeLKind :: Maybe (LHsKind GhcRn) -> RnM (Maybe (LHsKind DocNameI))
renameMaybeLKind = traverse renameLKind
renameFamilyResultSig :: LFamilyResultSig GhcRn -> RnM (LFamilyResultSig DocNameI)
-renameFamilyResultSig (L loc NoSig)
- = return (L loc NoSig)
-renameFamilyResultSig (L loc (KindSig ki))
+renameFamilyResultSig (L loc (NoSig _))
+ = return (L loc (NoSig noExt))
+renameFamilyResultSig (L loc (KindSig _ ki))
= do { ki' <- renameLKind ki
- ; return (L loc (KindSig ki')) }
-renameFamilyResultSig (L loc (TyVarSig bndr))
+ ; return (L loc (KindSig noExt ki')) }
+renameFamilyResultSig (L loc (TyVarSig _ bndr))
= do { bndr' <- renameLTyVarBndr bndr
- ; return (L loc (TyVarSig bndr')) }
+ ; return (L loc (TyVarSig noExt bndr')) }
+renameFamilyResultSig (L _ (XFamilyResultSig _)) = panic "haddock:renameFamilyResultSig"
renameInjectivityAnn :: LInjectivityAnn GhcRn -> RnM (LInjectivityAnn DocNameI)
renameInjectivityAnn (L loc (InjectivityAnn lhs rhs))
@@ -212,55 +214,55 @@ renameType t = case t of
HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do
tyvars' <- mapM renameLTyVarBndr tyvars
ltype' <- renameLType ltype
- return (HsForAllTy { hst_xforall = PlaceHolder, hst_bndrs = tyvars', hst_body = ltype' })
+ return (HsForAllTy { hst_xforall = NoExt, hst_bndrs = tyvars', hst_body = ltype' })
HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do
lcontext' <- renameLContext lcontext
ltype' <- renameLType ltype
- return (HsQualTy { hst_xqual = PlaceHolder, hst_ctxt = lcontext', hst_body = ltype' })
+ return (HsQualTy { hst_xqual = NoExt, hst_ctxt = lcontext', hst_body = ltype' })
- HsTyVar _ ip (L l n) -> return . HsTyVar PlaceHolder ip . L l =<< rename n
- HsBangTy _ b ltype -> return . HsBangTy PlaceHolder b =<< renameLType ltype
+ HsTyVar _ ip (L l n) -> return . HsTyVar NoExt ip . L l =<< rename n
+ HsBangTy _ b ltype -> return . HsBangTy NoExt b =<< renameLType ltype
HsAppTy _ a b -> do
a' <- renameLType a
b' <- renameLType b
- return (HsAppTy PlaceHolder a' b')
+ return (HsAppTy NoExt a' b')
HsFunTy _ a b -> do
a' <- renameLType a
b' <- renameLType b
- return (HsFunTy PlaceHolder a' b')
+ return (HsFunTy NoExt a' b')
- HsListTy _ ty -> return . (HsListTy PlaceHolder) =<< renameLType ty
- HsPArrTy _ ty -> return . (HsPArrTy PlaceHolder) =<< renameLType ty
- HsIParamTy _ n ty -> liftM (HsIParamTy PlaceHolder n) (renameLType ty)
- HsEqTy _ ty1 ty2 -> liftM2 (HsEqTy PlaceHolder) (renameLType ty1) (renameLType ty2)
+ HsListTy _ ty -> return . (HsListTy NoExt) =<< renameLType ty
+ HsPArrTy _ ty -> return . (HsPArrTy NoExt) =<< renameLType ty
+ HsIParamTy _ n ty -> liftM (HsIParamTy NoExt n) (renameLType ty)
+ HsEqTy _ ty1 ty2 -> liftM2 (HsEqTy NoExt) (renameLType ty1) (renameLType ty2)
- HsTupleTy _ b ts -> return . HsTupleTy PlaceHolder b =<< mapM renameLType ts
- HsSumTy _ ts -> HsSumTy PlaceHolder <$> mapM renameLType ts
+ HsTupleTy _ b ts -> return . HsTupleTy NoExt b =<< mapM renameLType ts
+ HsSumTy _ ts -> HsSumTy NoExt <$> mapM renameLType ts
HsOpTy _ a (L loc op) b -> do
op' <- rename op
a' <- renameLType a
b' <- renameLType b
- return (HsOpTy PlaceHolder a' (L loc op') b')
+ return (HsOpTy NoExt a' (L loc op') b')
- HsParTy _ ty -> return . (HsParTy PlaceHolder) =<< renameLType ty
+ HsParTy _ ty -> return . (HsParTy NoExt) =<< renameLType ty
HsKindSig _ ty k -> do
ty' <- renameLType ty
k' <- renameLKind k
- return (HsKindSig PlaceHolder ty' k')
+ return (HsKindSig NoExt ty' k')
HsDocTy _ ty doc -> do
ty' <- renameLType ty
doc' <- renameLDocHsSyn doc
- return (HsDocTy PlaceHolder ty' doc')
+ return (HsDocTy NoExt ty' doc')
- HsTyLit _ x -> return (HsTyLit PlaceHolder x)
+ HsTyLit _ x -> return (HsTyLit NoExt x)
- HsRecTy _ a -> HsRecTy PlaceHolder <$> mapM renameConDeclFieldField a
+ HsRecTy _ a -> HsRecTy NoExt <$> mapM renameConDeclFieldField a
(XHsType (NHsCoreTy a)) -> pure (XHsType (NHsCoreTy a))
HsExplicitListTy x i b -> HsExplicitListTy x i <$> mapM renameLType b
HsExplicitTupleTy x b -> HsExplicitTupleTy x <$> mapM renameLType b
@@ -269,10 +271,11 @@ renameType t = case t of
HsAppsTy _ _ -> error "renameType: HsAppsTy"
renameLHsQTyVars :: LHsQTyVars GhcRn -> RnM (LHsQTyVars DocNameI)
-renameLHsQTyVars (HsQTvs { hsq_implicit = _, hsq_explicit = tvs })
+renameLHsQTyVars (HsQTvs { hsq_explicit = tvs })
= do { tvs' <- mapM renameLTyVarBndr tvs
- ; return (HsQTvs { hsq_implicit = error "haddock:renameLHsQTyVars", hsq_explicit = tvs', hsq_dependent = error "haddock:renameLHsQTyVars" }) }
- -- This is rather bogus, but I'm not sure what else to do
+ ; return (HsQTvs { hsq_ext = noExt
+ , hsq_explicit = tvs' }) }
+renameLHsQTyVars (XLHsQTyVars _) = panic "haddock:renameLHsQTyVars"
renameLTyVarBndr :: LHsTyVarBndr GhcRn -> RnM (LHsTyVarBndr DocNameI)
renameLTyVarBndr (L loc (UserTyVar x (L l n)))
@@ -289,8 +292,8 @@ renameLContext (L loc context) = do
context' <- mapM renameLType context
return (L loc context')
-renameWildCardInfo :: HsWildCardInfo GhcRn -> RnM (HsWildCardInfo DocNameI)
-renameWildCardInfo (AnonWildCard (L l name)) = AnonWildCard . L l <$> rename name
+renameWildCardInfo :: HsWildCardInfo -> RnM HsWildCardInfo
+renameWildCardInfo (AnonWildCard (L l name)) = return (AnonWildCard (L l name))
renameInstHead :: InstHead GhcRn -> RnM (InstHead DocNameI)
renameInstHead InstHead {..} = do
@@ -321,21 +324,21 @@ renamePats = mapM
renameDecl :: HsDecl GhcRn -> RnM (HsDecl DocNameI)
renameDecl decl = case decl of
- TyClD d -> do
+ TyClD _ d -> do
d' <- renameTyClD d
- return (TyClD d')
- SigD s -> do
+ return (TyClD noExt d')
+ SigD _ s -> do
s' <- renameSig s
- return (SigD s')
- ForD d -> do
+ return (SigD noExt s')
+ ForD _ d -> do
d' <- renameForD d
- return (ForD d')
- InstD d -> do
+ return (ForD noExt d')
+ InstD _ d -> do
d' <- renameInstD d
- return (InstD d')
- DerivD d -> do
+ return (InstD noExt d')
+ DerivD _ d -> do
d' <- renameDerivD d
- return (DerivD d')
+ return (DerivD noExt d')
_ -> error "renameDecl"
renameLThing :: (a GhcRn -> RnM (a DocNameI)) -> Located (a GhcRn) -> RnM (Located (a DocNameI))
@@ -346,19 +349,21 @@ renameTyClD d = case d of
-- TyFamily flav lname ltyvars kind tckind -> do
FamDecl { tcdFam = decl } -> do
decl' <- renameFamilyDecl decl
- return (FamDecl { tcdFam = decl' })
+ return (FamDecl { tcdFExt = noExt, tcdFam = decl' })
- SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdRhs = rhs, tcdFVs = _fvs } -> do
+ SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdRhs = rhs } -> do
lname' <- renameL lname
tyvars' <- renameLHsQTyVars tyvars
rhs' <- renameLType rhs
- return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdFixity = fixity, tcdRhs = rhs', tcdFVs = placeHolderNames })
+ return (SynDecl { tcdSExt = noExt, tcdLName = lname', tcdTyVars = tyvars'
+ , tcdFixity = fixity, tcdRhs = rhs' })
- DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn, tcdFVs = _fvs } -> do
+ DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn } -> do
lname' <- renameL lname
tyvars' <- renameLHsQTyVars tyvars
defn' <- renameDataDefn defn
- return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdFixity = fixity, tcdDataDefn = defn', tcdDataCusk = PlaceHolder, tcdFVs = placeHolderNames })
+ return (DataDecl { tcdDExt = noExt, tcdLName = lname', tcdTyVars = tyvars'
+ , tcdFixity = fixity, tcdDataDefn = defn' })
ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars, tcdFixity = fixity
, tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do
@@ -373,7 +378,8 @@ renameTyClD d = case d of
return (ClassDecl { tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars'
, tcdFixity = fixity
, tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag
- , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdFVs = placeHolderNames })
+ , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdCExt = NoExt })
+ XTyClDecl _ -> panic "haddock:renameTyClD"
where
renameLFunDep (L loc (xs, ys)) = do
@@ -394,11 +400,12 @@ renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname
ltyvars' <- renameLHsQTyVars ltyvars
result' <- renameFamilyResultSig result
injectivity' <- renameMaybeInjectivityAnn injectivity
- return (FamilyDecl { fdInfo = info', fdLName = lname'
+ return (FamilyDecl { fdExt = noExt, fdInfo = info', fdLName = lname'
, fdTyVars = ltyvars'
, fdFixity = fixity
, fdResultSig = result'
, fdInjectivityAnn = injectivity' })
+renameFamilyDecl (XFamilyDecl _) = panic "renameFamilyDecl"
renamePseudoFamilyDecl :: PseudoFamilyDecl GhcRn
@@ -424,9 +431,11 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType
k' <- renameMaybeLKind k
cons' <- mapM (mapM renameCon) cons
-- I don't think we need the derivings, so we return Nothing
- return (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType
+ return (HsDataDefn { dd_ext = noExt
+ , dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType
, dd_kindSig = k', dd_cons = cons'
, dd_derivs = noLoc [] })
+renameDataDefn (XHsDataDefn _) = panic "haddock:renameDataDefn"
renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI)
renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars
@@ -437,7 +446,7 @@ renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars
lcontext' <- traverse renameLContext lcontext
details' <- renameDetails details
mbldoc' <- mapM renameLDocHsSyn mbldoc
- return (decl { con_name = lname', con_ex_tvs = ltyvars'
+ return (decl { con_ext = noExt, con_name = lname', con_ex_tvs = ltyvars'
, con_mb_cxt = lcontext'
, con_args = details', con_doc = mbldoc' })
@@ -451,9 +460,10 @@ renameCon decl@(ConDeclGADT { con_names = lnames, con_qvars = ltyvars
details' <- renameDetails details
res_ty' <- renameLType res_ty
mbldoc' <- mapM renameLDocHsSyn mbldoc
- return (decl { con_names = lnames', con_qvars = ltyvars'
+ return (decl { con_g_ext = noExt, con_names = lnames', con_qvars = ltyvars'
, con_mb_cxt = lcontext', con_args = details'
, con_res_ty = res_ty', con_doc = mbldoc' })
+renameCon (XConDecl _) = panic "haddock:renameCon"
renameDetails :: HsConDeclDetails GhcRn -> RnM (HsConDeclDetails DocNameI)
renameDetails (RecCon (L l fields)) = do
@@ -466,11 +476,12 @@ renameDetails (InfixCon a b) = do
return (InfixCon a' b')
renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI)
-renameConDeclFieldField (L l (ConDeclField names t doc)) = do
+renameConDeclFieldField (L l (ConDeclField _ names t doc)) = do
names' <- mapM renameLFieldOcc names
t' <- renameLType t
doc' <- mapM renameLDocHsSyn doc
- return $ L l (ConDeclField names' t' doc')
+ return $ L l (ConDeclField noExt names' t' doc')
+renameConDeclFieldField (L _ (XConDeclField _)) = panic "haddock:renameConDeclFieldField"
renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI)
renameLFieldOcc (L l (FieldOcc sel lbl)) = do
@@ -503,35 +514,39 @@ renameSig sig = case sig of
renameForD :: ForeignDecl GhcRn -> RnM (ForeignDecl DocNameI)
-renameForD (ForeignImport lname ltype co x) = do
+renameForD (ForeignImport _ lname ltype x) = do
lname' <- renameL lname
ltype' <- renameLSigType ltype
- return (ForeignImport lname' ltype' co x)
-renameForD (ForeignExport lname ltype co x) = do
+ return (ForeignImport noExt lname' ltype' x)
+renameForD (ForeignExport _ lname ltype x) = do
lname' <- renameL lname
ltype' <- renameLSigType ltype
- return (ForeignExport lname' ltype' co x)
+ return (ForeignExport noExt lname' ltype' x)
+renameForD (XForeignDecl _) = panic "haddock:renameForD"
renameInstD :: InstDecl GhcRn -> RnM (InstDecl DocNameI)
renameInstD (ClsInstD { cid_inst = d }) = do
d' <- renameClsInstD d
- return (ClsInstD { cid_inst = d' })
+ return (ClsInstD { cid_d_ext = noExt, cid_inst = d' })
renameInstD (TyFamInstD { tfid_inst = d }) = do
d' <- renameTyFamInstD d
- return (TyFamInstD { tfid_inst = d' })
+ return (TyFamInstD { tfid_ext = noExt, tfid_inst = d' })
renameInstD (DataFamInstD { dfid_inst = d }) = do
d' <- renameDataFamInstD d
- return (DataFamInstD { dfid_inst = d' })
+ return (DataFamInstD { dfid_ext = noExt, dfid_inst = d' })
+renameInstD (XInstDecl _) = panic "haddock:renameInstD"
renameDerivD :: DerivDecl GhcRn -> RnM (DerivDecl DocNameI)
renameDerivD (DerivDecl { deriv_type = ty
, deriv_strategy = strat
, deriv_overlap_mode = omode }) = do
ty' <- renameLSigWcType ty
- return (DerivDecl { deriv_type = ty'
+ return (DerivDecl { deriv_ext = noExt
+ , deriv_type = ty'
, deriv_strategy = strat
, deriv_overlap_mode = omode })
+renameDerivD (XDerivDecl _) = panic "haddock:renameDerivD"
renameClsInstD :: ClsInstDecl GhcRn -> RnM (ClsInstDecl DocNameI)
renameClsInstD (ClsInstDecl { cid_overlap_mode = omode
@@ -540,10 +555,11 @@ renameClsInstD (ClsInstDecl { cid_overlap_mode = omode
ltype' <- renameLSigType ltype
lATs' <- mapM (mapM renameTyFamInstD) lATs
lADTs' <- mapM (mapM renameDataFamInstD) lADTs
- return (ClsInstDecl { cid_overlap_mode = omode
+ return (ClsInstDecl { cid_ext = noExt, cid_overlap_mode = omode
, cid_poly_ty = ltype', cid_binds = emptyBag
, cid_sigs = []
, cid_tyfam_insts = lATs', cid_datafam_insts = lADTs' })
+renameClsInstD (XClsInstDecl _) = panic "haddock:renameClsInstD"
renameTyFamInstD :: TyFamInstDecl GhcRn -> RnM (TyFamInstDecl DocNameI)
@@ -563,10 +579,12 @@ renameTyFamInstEqn eqn
= do { tc' <- renameL tc
; pats' <- mapM renameLType pats
; rhs' <- renameLType rhs
- ; return (FamEqn { feqn_tycon = tc'
+ ; return (FamEqn { feqn_ext = noExt
+ , feqn_tycon = tc'
, feqn_pats = pats'
, feqn_fixity = fixity
, feqn_rhs = rhs' }) }
+ rename_ty_fam_eqn (XFamEqn _) = panic "haddock:renameTyFamInstEqn"
renameLTyFamDefltEqn :: LTyFamDefltEqn GhcRn -> RnM (LTyFamDefltEqn DocNameI)
renameLTyFamDefltEqn (L loc (FamEqn { feqn_tycon = tc, feqn_pats = tvs
@@ -574,10 +592,12 @@ renameLTyFamDefltEqn (L loc (FamEqn { feqn_tycon = tc, feqn_pats = tvs
= do { tc' <- renameL tc
; tvs' <- renameLHsQTyVars tvs
; rhs' <- renameLType rhs
- ; return (L loc (FamEqn { feqn_tycon = tc'
+ ; return (L loc (FamEqn { feqn_ext = noExt
+ , feqn_tycon = tc'
, feqn_pats = tvs'
, feqn_fixity = fixity
, feqn_rhs = rhs' })) }
+renameLTyFamDefltEqn (L _ (XFamEqn _)) = panic "haddock:renameLTyFamDefltEqn"
renameDataFamInstD :: DataFamInstDecl GhcRn -> RnM (DataFamInstDecl DocNameI)
renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn })
@@ -592,10 +612,12 @@ renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn })
= do { tc' <- renameL tc
; pats' <- mapM renameLType pats
; defn' <- renameDataDefn defn
- ; return (FamEqn { feqn_tycon = tc'
+ ; return (FamEqn { feqn_ext = noExt
+ , feqn_tycon = tc'
, feqn_pats = pats'
, feqn_fixity = fixity
, feqn_rhs = defn' }) }
+ rename_data_fam_eqn (XFamEqn _) = panic "haddock:renameDataFamInstD"
renameImplicit :: (in_thing -> RnM out_thing)
-> HsImplicitBndrs GhcRn in_thing
@@ -603,8 +625,8 @@ renameImplicit :: (in_thing -> RnM out_thing)
renameImplicit rn_thing (HsIB { hsib_body = thing })
= do { thing' <- rn_thing thing
; return (HsIB { hsib_body = thing'
- , hsib_vars = PlaceHolder
- , hsib_closed = PlaceHolder }) }
+ , hsib_ext = noExt }) }
+renameImplicit _ (XHsImplicitBndrs _) = panic "haddock:renameImplicit"
renameWc :: (in_thing -> RnM out_thing)
-> HsWildCardBndrs GhcRn in_thing
@@ -612,7 +634,8 @@ renameWc :: (in_thing -> RnM out_thing)
renameWc rn_thing (HsWC { hswc_body = thing })
= do { thing' <- rn_thing thing
; return (HsWC { hswc_body = thing'
- , hswc_wcs = PlaceHolder }) }
+ , hswc_ext = noExt }) }
+renameWc _ (XHsWildCardBndrs _) = panic "haddock:renameWc"
renameDocInstance :: DocInstance GhcRn -> RnM (DocInstance DocNameI)
renameDocInstance (inst, idoc, L l n) = do
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index b84a676f..c49663db 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -110,7 +110,7 @@ sugar = sugarOperators . sugarTuples . sugarLists
sugarLists :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p)
sugarLists (HsAppTy _ (L _ (HsTyVar _ _ (L _ name))) ltyp)
- | isBuiltInSyntax name' && strName == "[]" = HsListTy PlaceHolder ltyp
+ | isBuiltInSyntax name' && strName == "[]" = HsListTy NoExt ltyp
where
name' = getName name
strName = occNameString . nameOccName $ name'
@@ -124,7 +124,7 @@ sugarTuples typ =
aux apps (HsAppTy _ (L _ ftyp) atyp) = aux (atyp:apps) ftyp
aux apps (HsParTy _ (L _ typ')) = aux apps typ'
aux apps (HsTyVar _ _ (L _ name))
- | isBuiltInSyntax name' && suitable = HsTupleTy PlaceHolder HsBoxedTuple apps
+ | isBuiltInSyntax name' && suitable = HsTupleTy NoExt HsBoxedTuple apps
where
name' = getName name
strName = occNameString . nameOccName $ name'
@@ -137,7 +137,7 @@ sugarTuples typ =
sugarOperators :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p)
sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb)
| isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb
- | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy PlaceHolder la lb
+ | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy NoExt la lb
where
name' = getName name
sugarOperators typ = typ
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 2234894c..99fccf2a 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -381,11 +381,12 @@ mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl
}
where
mkType (KindedTyVar _ (L loc name) lkind) =
- HsKindSig PlaceHolder tvar lkind
+ HsKindSig NoExt tvar lkind
where
- tvar = L loc (HsTyVar PlaceHolder NotPromoted (L loc name))
- mkType (UserTyVar _ name) = HsTyVar PlaceHolder NotPromoted name
+ tvar = L loc (HsTyVar NoExt NotPromoted (L loc name))
+ mkType (UserTyVar _ name) = HsTyVar NoExt NotPromoted name
mkType (XTyVarBndr _ ) = panic "haddock:mkPseudoFamilyDecl"
+mkPseudoFamilyDecl (XFamilyDecl {}) = panic "haddock:mkPseudoFamilyDecl"
-- | An instance head that may have documentation and a source location.
@@ -652,54 +653,77 @@ instance Monad ErrMsgGhc where
-- * Pass sensitive types
-----------------------------------------------------------------------------
-type instance PostRn DocNameI NameSet = PlaceHolder
-type instance PostRn DocNameI Fixity = PlaceHolder
-type instance PostRn DocNameI Bool = PlaceHolder
-type instance PostRn DocNameI Name = DocName
-type instance PostRn DocNameI (Located Name) = Located DocName
-type instance PostRn DocNameI [Name] = PlaceHolder
-type instance PostRn DocNameI DocName = DocName
-
-type instance PostTc DocNameI Kind = PlaceHolder
-type instance PostTc DocNameI Type = PlaceHolder
-type instance PostTc DocNameI Coercion = PlaceHolder
-
-
-type instance XForAllTy DocNameI = PlaceHolder
-type instance XQualTy DocNameI = PlaceHolder
-type instance XTyVar DocNameI = PlaceHolder
-type instance XAppsTy DocNameI = PlaceHolder
-type instance XAppTy DocNameI = PlaceHolder
-type instance XFunTy DocNameI = PlaceHolder
-type instance XListTy DocNameI = PlaceHolder
-type instance XPArrTy DocNameI = PlaceHolder
-type instance XTupleTy DocNameI = PlaceHolder
-type instance XSumTy DocNameI = PlaceHolder
-type instance XOpTy DocNameI = PlaceHolder
-type instance XParTy DocNameI = PlaceHolder
-type instance XIParamTy DocNameI = PlaceHolder
-type instance XEqTy DocNameI = PlaceHolder
-type instance XKindSig DocNameI = PlaceHolder
-type instance XSpliceTy DocNameI = PlaceHolder
-type instance XDocTy DocNameI = PlaceHolder
-type instance XBangTy DocNameI = PlaceHolder
-type instance XRecTy DocNameI = PlaceHolder
-type instance XExplicitListTy DocNameI = PlaceHolder
-type instance XExplicitTupleTy DocNameI = PlaceHolder
-type instance XTyLit DocNameI = PlaceHolder
-type instance XWildCardTy DocNameI = HsWildCardInfo DocNameI
+type instance XForAllTy DocNameI = NoExt
+type instance XQualTy DocNameI = NoExt
+type instance XTyVar DocNameI = NoExt
+type instance XAppsTy DocNameI = NoExt
+type instance XAppTy DocNameI = NoExt
+type instance XFunTy DocNameI = NoExt
+type instance XListTy DocNameI = NoExt
+type instance XPArrTy DocNameI = NoExt
+type instance XTupleTy DocNameI = NoExt
+type instance XSumTy DocNameI = NoExt
+type instance XOpTy DocNameI = NoExt
+type instance XParTy DocNameI = NoExt
+type instance XIParamTy DocNameI = NoExt
+type instance XEqTy DocNameI = NoExt
+type instance XKindSig DocNameI = NoExt
+type instance XSpliceTy DocNameI = NoExt
+type instance XDocTy DocNameI = NoExt
+type instance XBangTy DocNameI = NoExt
+type instance XRecTy DocNameI = NoExt
+type instance XExplicitListTy DocNameI = NoExt
+type instance XExplicitTupleTy DocNameI = NoExt
+type instance XTyLit DocNameI = NoExt
+type instance XWildCardTy DocNameI = HsWildCardInfo
type instance XXType DocNameI = NewHsTypeX
-type instance XUserTyVar DocNameI = PlaceHolder
-type instance XKindedTyVar DocNameI = PlaceHolder
-type instance XXTyVarBndr DocNameI = PlaceHolder
+type instance XUserTyVar DocNameI = NoExt
+type instance XKindedTyVar DocNameI = NoExt
+type instance XXTyVarBndr DocNameI = NoExt
type instance XFieldOcc DocNameI = DocName
-type instance XXFieldOcc DocNameI = PlaceHolder
-
-type instance XFixitySig DocNameI = PlaceHolder
-type instance XFixSig DocNameI = PlaceHolder
-type instance XPatSynSig DocNameI = PlaceHolder
-type instance XClassOpSig DocNameI = PlaceHolder
-type instance XTypeSig DocNameI = PlaceHolder
-type instance XMinimalSig DocNameI = PlaceHolder
+type instance XXFieldOcc DocNameI = NoExt
+
+type instance XFixitySig DocNameI = NoExt
+type instance XFixSig DocNameI = NoExt
+type instance XPatSynSig DocNameI = NoExt
+type instance XClassOpSig DocNameI = NoExt
+type instance XTypeSig DocNameI = NoExt
+type instance XMinimalSig DocNameI = NoExt
+
+type instance XForeignExport DocNameI = NoExt
+type instance XForeignImport DocNameI = NoExt
+type instance XConDeclGADT DocNameI = NoExt
+type instance XConDeclH98 DocNameI = NoExt
+
+type instance XDerivD DocNameI = NoExt
+type instance XInstD DocNameI = NoExt
+type instance XForD DocNameI = NoExt
+type instance XSigD DocNameI = NoExt
+type instance XTyClD DocNameI = NoExt
+
+type instance XNoSig DocNameI = NoExt
+type instance XCKindSig DocNameI = NoExt
+type instance XTyVarSig DocNameI = NoExt
+
+type instance XCFamEqn DocNameI _ _ = NoExt
+
+type instance XCClsInstDecl DocNameI = NoExt
+type instance XCDerivDecl DocNameI = NoExt
+type instance XDataFamInstD DocNameI = NoExt
+type instance XTyFamInstD DocNameI = NoExt
+type instance XClsInstD DocNameI = NoExt
+type instance XCHsDataDefn DocNameI = NoExt
+type instance XCFamilyDecl DocNameI = NoExt
+type instance XClassDecl DocNameI = NoExt
+type instance XDataDecl DocNameI = NoExt
+type instance XSynDecl DocNameI = NoExt
+type instance XFamDecl DocNameI = NoExt
+
+type instance XHsIB DocNameI _ = NoExt
+type instance XHsWC DocNameI _ = NoExt
+
+type instance XHsQTvs DocNameI = NoExt
+type instance XConDeclField DocNameI = NoExt
+
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 1ebf7ffa..e3cc9655 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -64,6 +64,7 @@ import GHC
import Name
import NameSet ( emptyNameSet )
import HsTypes (extFieldOcc)
+import Outputable ( panic )
import Control.Monad ( liftM )
import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr )
@@ -152,7 +153,7 @@ addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine
lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn]
lHsQTyVarsToTypes tvs
- = [ noLoc (HsTyVar PlaceHolder NotPromoted (noLoc (hsLTyVarName tv)))
+ = [ noLoc (HsTyVar NoExt NotPromoted (noLoc (hsLTyVarName tv)))
| tv <- hsQTvExplicit tvs ]
--------------------------------------------------------------------------------
@@ -162,10 +163,10 @@ lHsQTyVarsToTypes tvs
restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn
restrictTo names (L loc decl) = L loc $ case decl of
- TyClD d | isDataDecl d ->
- TyClD (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) })
- TyClD d | isClassDecl d ->
- TyClD (d { tcdSigs = restrictDecls names (tcdSigs d),
+ TyClD x d | isDataDecl d ->
+ TyClD x (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) })
+ TyClD x d | isClassDecl d ->
+ TyClD x (d { tcdSigs = restrictDecls names (tcdSigs d),
tcdATs = restrictATs names (tcdATs d) })
_ -> decl
@@ -178,6 +179,7 @@ restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons })
[] -> defn { dd_ND = DataType, dd_cons = [] }
[con] -> defn { dd_cons = [con] }
_ -> error "Should not happen"
+restrictDataDefn _ (XHsDataDefn _) = error "restrictDataDefn"
restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn]
restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
@@ -195,9 +197,10 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
InfixCon _ _ -> Just d
where
field_avail :: LConDeclField GhcRn -> Bool
- field_avail (L _ (ConDeclField fs _ _))
+ field_avail (L _ (ConDeclField _ fs _ _))
= all (\f -> extFieldOcc (unLoc f) `elem` names) fs
- field_types flds = [ t | ConDeclField _ t _ <- flds ]
+ field_avail (L _ (XConDeclField _)) = panic "haddock:field_avail"
+ field_types flds = [ t | ConDeclField _ _ t _ <- flds ]
keep _ = Nothing
@@ -208,13 +211,14 @@ restrictDecls names = mapMaybe (filterLSigNames (`elem` names))
restrictATs :: [Name] -> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn]
restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ]
-emptyHsQTvs :: LHsQTyVars Name
+emptyHsQTvs :: LHsQTyVars GhcRn
-- This function is here, rather than in HsTypes, because it *renamed*, but
-- does not necessarily have all the rigt kind variables. It is used
-- in Haddock just for printing, so it doesn't matter
-emptyHsQTvs = HsQTvs { hsq_implicit = error "haddock:emptyHsQTvs"
- , hsq_explicit = []
- , hsq_dependent = error "haddock:emptyHsQTvs" }
+emptyHsQTvs = HsQTvs { hsq_ext = HsQTvsRn
+ { hsq_implicit = error "haddock:emptyHsQTvs"
+ , hsq_dependent = error "haddock:emptyHsQTvs" }
+ , hsq_explicit = [] }
--------------------------------------------------------------------------------
--
cgit v1.2.3