From 7bd04379ada2d9ff1c406d258629f8abdf617b30 Mon Sep 17 00:00:00 2001
From: romes <rodrigo.m.mesquita@gmail.com>
Date: Tue, 14 Jun 2022 20:09:01 +0200
Subject: [PATCH] TTG: AST Updates for !8308
---
haddock-api/src/Haddock/Backends/Hoogle.hs | 3 +--
haddock-api/src/Haddock/Backends/LaTeX.hs | 3 +--
.../src/Haddock/Backends/Xhtml/Decl.hs | 5 ++---
haddock-api/src/Haddock/Convert.hs | 6 ++---
haddock-api/src/Haddock/GhcUtils.hs | 3 +--
haddock-api/src/Haddock/Interface/Create.hs | 3 +--
haddock-api/src/Haddock/Interface/Rename.hs | 22 ++++++++++++++-----
haddock-api/src/Haddock/Types.hs | 14 ++++++++++--
8 files changed, 38 insertions(+), 21 deletions(-)
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 221580cc1e..d508cc6ded 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -18,8 +18,7 @@ module Haddock.Backends.Hoogle (
ppHoogle
) where
-import GHC.Types.Basic ( OverlapFlag(..), OverlapMode(..),
- PromotionFlag(..), TopLevelFlag(..) )
+import GHC.Types.Basic ( OverlapFlag(..), OverlapMode(..), TopLevelFlag(..) )
import GHC.Types.SourceText
import GHC.Core.InstEnv (ClsInst(..))
import Documentation.Haddock.Markup
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 420bd3f02a..38efeba8a6 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -24,7 +24,6 @@ import Haddock.GhcUtils
import GHC.Utils.Ppr hiding (Doc, quote)
import qualified GHC.Utils.Ppr as Pretty
-import GHC.Types.Basic ( PromotionFlag(..), isPromoted )
import GHC hiding (fromMaybeContext )
import GHC.Types.Name.Occurrence
import GHC.Types.Name ( nameOccName )
@@ -1155,7 +1154,7 @@ ppr_mono_ty (HsTyLit _ t) u = ppr_tylit t u
ppr_mono_ty (HsStarTy _ isUni) unicode = starSymbol (isUni || unicode)
-ppr_tylit :: HsTyLit -> Bool -> LaTeX
+ppr_tylit :: HsTyLit DocNameI -> Bool -> LaTeX
ppr_tylit (HsNumTy _ n) _ = integer n
ppr_tylit (HsStrTy _ s) _ = text (show s)
ppr_tylit (HsCharTy _ c) _ = text (show c)
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index d385b42a7b..8cf6e7af8d 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -35,7 +35,6 @@ import Data.Maybe
import Text.XHtml hiding ( name, title, p, quote )
import GHC.Core.Type ( Specificity(..) )
-import GHC.Types.Basic (PromotionFlag(..), isPromoted)
import GHC hiding (LexicalFixity(..), fromMaybeContext)
import GHC.Exts
import GHC.Types.Name
@@ -609,7 +608,7 @@ ppClassDecl summary links instances fixities loc d subdocs
]
-- Minimal complete definition
- 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 | ClassOpSig _ _ ns _ <- sigs, L _ n <- ns]
@@ -1300,7 +1299,7 @@ ppr_mono_ty (HsDocTy _ ty _) unicode qual emptyCtxts
ppr_mono_ty (HsWildCardTy _) _ _ _ = char '_'
ppr_mono_ty (HsTyLit _ n) _ _ _ = ppr_tylit n
-ppr_tylit :: HsTyLit -> Html
+ppr_tylit :: HsTyLit DocNameI -> Html
ppr_tylit (HsNumTy _ n) = toHtml (show n)
ppr_tylit (HsStrTy _ s) = toHtml (show s)
ppr_tylit (HsCharTy _ c) = toHtml (show c)
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index ceefedf344..f8b4185130 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -20,7 +20,7 @@ module Haddock.Convert (
) where
import GHC.Data.Bag ( emptyBag )
-import GHC.Types.Basic ( TupleSort(..), PromotionFlag(..), DefMethSpec(..), TopLevelFlag(..) )
+import GHC.Types.Basic ( TupleSort(..), DefMethSpec(..), TopLevelFlag(..) )
import GHC.Types.SourceText (SourceText(..))
import GHC.Types.Fixity (LexicalFixity(..))
import GHC.Core.Class
@@ -131,7 +131,7 @@ tyThingToLHsDecl prr t = case t of
, tcdFDs = map (\ (l,r) -> noLocA
(FunDep noAnn (map (noLocA . getName) l) (map (noLocA . getName) r)) ) $
snd $ classTvsFds cl
- , tcdSigs = noLocA (MinimalSig noAnn NoSourceText . noLocA . fmap noLocA $ classMinimalDef cl) :
+ , tcdSigs = noLocA (MinimalSig (noAnn, NoSourceText) . noLocA . fmap noLocA $ classMinimalDef cl) :
[ noLocA tcdSig
| clsOp <- classOpItems cl
, tcdSig <- synifyTcIdSig vs clsOp ]
@@ -823,7 +823,7 @@ synifyPatSynType ps =
(\vs -> implicitForAll ts vs [] prov_theta (synifyType WithinType))
(mkVisFunTys arg_tys res_ty)
-synifyTyLit :: TyLit -> HsTyLit
+synifyTyLit :: TyLit -> HsTyLit GhcRn
synifyTyLit (NumTyLit n) = HsNumTy NoSourceText n
synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s
synifyTyLit (CharTyLit c) = HsCharTy NoSourceText c
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 7c1dc73b55..893bf010ca 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -37,7 +37,6 @@ import GHC.Types.Name
import GHC.Unit.Module
import GHC
import GHC.Driver.Session
-import GHC.Types.Basic
import GHC.Types.SrcLoc ( advanceSrcLoc )
import GHC.Types.Var ( Specificity, VarBndr(..), TyVarBinder
, tyVarKind, updateTyVarKind, isInvisibleArgFlag )
@@ -76,7 +75,7 @@ filterSigNames p (FixSig _ (FixitySig _ ns ty)) =
case filter (p . unLoc) ns of
[] -> Nothing
filtered -> Just (FixSig noAnn (FixitySig noExtField filtered ty))
-filterSigNames _ orig@(MinimalSig _ _ _) = Just orig
+filterSigNames _ orig@(MinimalSig _ _) = Just orig
filterSigNames p (TypeSig _ ns ty) =
case filter (p . unLoc) ns of
[] -> Nothing
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 09eb2ad5ab..ee93324ecd 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -64,7 +64,6 @@ import GHC.Tc.Types hiding (IfM)
import GHC.Tc.Utils.Monad (finalSafeMode)
import GHC.Types.Avail hiding (avail)
import qualified GHC.Types.Avail as Avail
-import GHC.Types.Basic (PromotionFlag (..))
import GHC.Types.Name (getOccString, getSrcSpan, isDataConName, isValName, nameIsLocalOrFrom, nameOccName, emptyOccEnv)
import GHC.Types.Name.Env (lookupNameEnv)
import GHC.Types.Name.Reader (GlobalRdrEnv, greMangledName, lookupGlobalRdrEnv)
@@ -755,7 +754,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
L loc (TyClD _ ClassDecl {..}) -> do
mdef <- minimalDef t
- let sig = maybeToList $ fmap (noLocA . MinimalSig noAnn NoSourceText . noLocA . fmap noLocA) mdef
+ let sig = maybeToList $ fmap (noLocA . MinimalSig (noAnn, NoSourceText) . noLocA . fmap noLocA) mdef
availExportDecl avail
(L loc $ TyClD noExtField ClassDecl { tcdSigs = sig ++ tcdSigs, .. }) docs_
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index d2f117331f..b3d31940a6 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -308,7 +308,7 @@ renameType t = case t of
doc' <- renameLDocHsSyn doc
return (HsDocTy noAnn ty' doc')
- HsTyLit _ x -> return (HsTyLit noAnn x)
+ HsTyLit _ x -> return (HsTyLit noAnn (renameTyLit x))
HsRecTy _ a -> HsRecTy noAnn <$> mapM renameConDeclFieldField a
XHsType a -> pure (XHsType a)
@@ -318,6 +318,12 @@ renameType t = case t of
HsSpliceTy (HsUntypedSpliceNested _) _ -> error "renameType: not an top level type splice"
HsWildCardTy _ -> pure (HsWildCardTy noAnn)
+renameTyLit :: HsTyLit GhcRn -> HsTyLit DocNameI
+renameTyLit t = case t of
+ HsNumTy _ v -> HsNumTy noExtField v
+ HsStrTy _ v -> HsStrTy noExtField v
+ HsCharTy _ v -> HsCharTy noExtField v
+
renameSigType :: HsSigType GhcRn -> RnM (HsSigType DocNameI)
renameSigType (HsSig { sig_bndrs = bndrs, sig_body = body }) = do
@@ -576,9 +582,9 @@ renameSig sig = case sig of
FixSig _ (FixitySig _ lnames fixity) -> do
lnames' <- mapM renameL lnames
return $ FixSig noExtField (FixitySig noExtField lnames' fixity)
- MinimalSig _ src (L l s) -> do
+ MinimalSig _ (L l s) -> do
s' <- traverse (traverse lookupRnNoWarn) s
- return $ MinimalSig noExtField src (L l s')
+ return $ MinimalSig noExtField (L l s')
-- we have filtered out all other kinds of signatures in Interface.Create
_ -> error "expected TypeSig"
@@ -587,11 +593,17 @@ renameForD :: ForeignDecl GhcRn -> RnM (ForeignDecl DocNameI)
renameForD (ForeignImport _ lname ltype x) = do
lname' <- renameL lname
ltype' <- renameLSigType ltype
- return (ForeignImport noExtField lname' ltype' x)
+ return (ForeignImport noExtField lname' ltype' (renameForI x))
renameForD (ForeignExport _ lname ltype x) = do
lname' <- renameL lname
ltype' <- renameLSigType ltype
- return (ForeignExport noExtField lname' ltype' x)
+ return (ForeignExport noExtField lname' ltype' (renameForE x))
+
+renameForI :: ForeignImport GhcRn -> ForeignImport DocNameI
+renameForI (CImport _ cconv safety mHeader spec) = CImport noExtField cconv safety mHeader spec
+
+renameForE :: ForeignExport GhcRn -> ForeignExport DocNameI
+renameForE (CExport _ spec) = CExport noExtField spec
renameInstD :: InstDecl GhcRn -> RnM (InstDecl DocNameI)
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index dc15dfe015..35f2e200b8 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -44,9 +44,7 @@ import Control.Monad.Writer.Strict (Writer, WriterT, MonadWriter(..), lift, runW
import Data.Typeable (Typeable)
import Data.Map (Map)
import Data.Data (Data)
-import Data.Void (Void)
import Documentation.Haddock.Types
-import GHC.Types.Basic (PromotionFlag(..))
import GHC.Types.Fixity (Fixity(..))
import GHC.Types.Var (Specificity)
@@ -761,6 +759,11 @@ type instance XTyLit DocNameI = EpAnn [AddEpAnn]
type instance XWildCardTy DocNameI = EpAnn [AddEpAnn]
type instance XXType DocNameI = HsCoreTy
+type instance XNumTy DocNameI = NoExtField
+type instance XStrTy DocNameI = NoExtField
+type instance XCharTy DocNameI = NoExtField
+type instance XXTyLit DocNameI = DataConCantHappen
+
type instance XHsForAllVis DocNameI = NoExtField
type instance XHsForAllInvis DocNameI = NoExtField
type instance XXHsForAllTelescope DocNameI = DataConCantHappen
@@ -781,6 +784,13 @@ type instance XMinimalSig DocNameI = NoExtField
type instance XForeignExport DocNameI = NoExtField
type instance XForeignImport DocNameI = NoExtField
+
+type instance XCImport DocNameI = NoExtField
+type instance XCExport DocNameI = NoExtField
+
+type instance XXForeignImport DocNameI = DataConCantHappen
+type instance XXForeignExport DocNameI = DataConCantHappen
+
type instance XConDeclGADT DocNameI = NoExtField
type instance XConDeclH98 DocNameI = NoExtField
type instance XXConDecl DocNameI = DataConCantHappen
--
GitLab