From 89afef9daeb6da6624d42d32813d86c1f9b9f0c3 Mon Sep 17 00:00:00 2001 From: romes Date: Mon, 25 Apr 2022 19:52:22 +0200 Subject: TTG: Match new GHC AST --- haddock-api/src/Haddock.hs | 1 - haddock-api/src/Haddock/Backends/Hyperlinker.hs | 2 -- haddock-api/src/Haddock/Backends/LaTeX.hs | 3 +-- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 3 +-- haddock-api/src/Haddock/Interface.hs | 9 +-------- haddock-api/src/Haddock/Interface/Create.hs | 2 +- haddock-api/src/Haddock/Interface/LexParseRn.hs | 1 - haddock-api/src/Haddock/Interface/Rename.hs | 14 ++------------ haddock-api/src/Haddock/Interface/Specialize.hs | 1 - haddock-api/src/Haddock/Types.hs | 5 ++++- 10 files changed, 10 insertions(+), 31 deletions(-) (limited to 'haddock-api') diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 4a655f64..e1775cc8 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -79,7 +79,6 @@ import GHC.Utils.Error import GHC.Utils.Logger import GHC.Types.Name.Cache import GHC.Unit -import GHC.Unit.State (lookupUnit) import GHC.Utils.Panic (handleGhcException) import GHC.Data.FastString diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 89828e30..9316da6d 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -26,8 +26,6 @@ import GHC.Types.SrcLoc ( realSrcLocSpan, mkRealSrcLoc, srcSpanFile ) import Data.Map as M import GHC.Data.FastString ( mkFastString ) import GHC.Unit.Module ( Module, moduleName ) -import GHC.Types.Name.Cache ( initNameCache ) -import GHC.Types.Unique.Supply ( mkSplitUniqSupply ) -- | Generate hyperlinked source for given interfaces. diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 349c6e8e..420bd3f0 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -40,7 +40,6 @@ import Data.Char import Control.Monad import Data.Maybe import Data.List ( sort ) -import Data.Void ( absurd ) import Prelude hiding ((<>)) import Haddock.Doc (combineDocumentation) @@ -1120,7 +1119,7 @@ ppr_mono_ty (HsSumTy _ tys) u = sumParens (map (ppLType u) tys) ppr_mono_ty (HsKindSig _ ty kind) u = parens (ppr_mono_lty ty u <+> dcolon u <+> ppLKind u kind) ppr_mono_ty (HsListTy _ ty) u = brackets (ppr_mono_lty ty u) ppr_mono_ty (HsIParamTy _ (L _ n) ty) u = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u -ppr_mono_ty (HsSpliceTy v _) _ = absurd v +ppr_mono_ty (HsSpliceTy v _) _ = dataConCantHappen v ppr_mono_ty (HsRecTy {}) _ = text "{..}" ppr_mono_ty (XHsType {}) _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty (HsExplicitListTy _ IsPromoted tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index a54bb0aa..d385b42a 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -32,7 +32,6 @@ import Haddock.Doc (combineDocumentation) import Data.List ( intersperse, sort ) import qualified Data.Map as Map import Data.Maybe -import Data.Void ( absurd ) import Text.XHtml hiding ( name, title, p, quote ) import GHC.Core.Type ( Specificity(..) ) @@ -1263,7 +1262,7 @@ ppr_mono_ty (HsKindSig _ ty kind) u q e = ppr_mono_ty (HsListTy _ ty) u q _ = brackets (ppr_mono_lty ty u q HideEmptyContexts) ppr_mono_ty (HsIParamTy _ (L _ n) ty) u q _ = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u q HideEmptyContexts -ppr_mono_ty (HsSpliceTy v _) _ _ _ = absurd v +ppr_mono_ty (HsSpliceTy v _) _ _ _ = dataConCantHappen v 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 diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index 19113107..92b727ac 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -46,7 +46,7 @@ import Haddock.Types (DocOption (..), Documentation (..), ExportItem (..), Iface import Haddock.Utils (Verbosity (..), normal, out, verbose) import Control.Monad (unless, when) -import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.IO.Class (MonadIO) import Data.IORef (atomicModifyIORef', newIORef, readIORef) import Data.List (foldl', isPrefixOf, nub) import Text.Printf (printf) @@ -54,7 +54,6 @@ import qualified Data.Map as Map import qualified Data.Set as Set import GHC hiding (verbosity) -import GHC.Data.FastString (unpackFS) import GHC.Data.Graph.Directed import GHC.Driver.Env import GHC.Driver.Monad (modifySession, withTimingM) @@ -64,13 +63,7 @@ import GHC.Plugins import GHC.Tc.Types (TcGblEnv (..), TcM) import GHC.Tc.Utils.Env (tcLookupGlobal) import GHC.Tc.Utils.Monad (getTopEnv, setGblEnv) -import GHC.Types.Name (nameIsFromExternalPackage, nameOccName) -import GHC.Types.Name.Occurrence (isTcOcc) -import GHC.Types.Name.Reader (globalRdrEnvElts, greMangledName, unQualOK) -import GHC.Unit.Module.Env (ModuleSet, emptyModuleSet, mkModuleSet, unionModuleSet) import GHC.Unit.Module.Graph -import GHC.Unit.Module.ModSummary (isBootSummary) -import GHC.Unit.Types (IsBootInterface (..)) import GHC.Utils.Error (withTiming) #if defined(mingw32_HOST_OS) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index dbd4a9b2..c5f81520 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -55,7 +55,7 @@ import Data.Traversable (for) import GHC hiding (lookupName) import GHC.Core.Class (ClassMinimalDef, classMinimalDef) import GHC.Core.ConLike (ConLike (..)) -import GHC.Data.FastString (bytesFS, unpackFS) +import GHC.Data.FastString (unpackFS) import GHC.Driver.Ppr (showSDoc) import GHC.HsToCore.Docs hiding (mkMaps, unionArgMaps) import GHC.IORef (readIORef) diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index f3b57792..199365b0 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -39,7 +39,6 @@ import GHC.Parser.PostProcess import GHC.Driver.Ppr ( showPpr, showSDoc ) import GHC.Types.Name.Reader import GHC.Data.EnumSet as EnumSet -import GHC.Utils.Trace processDocStrings :: DynFlags -> Maybe Package -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (MDoc Name)) diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index cbc7e58f..d2f11733 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -314,7 +314,8 @@ renameType t = case t of XHsType a -> pure (XHsType a) HsExplicitListTy _ a b -> HsExplicitListTy noAnn a <$> mapM renameLType b HsExplicitTupleTy _ b -> HsExplicitTupleTy noAnn <$> mapM renameLType b - HsSpliceTy _ s -> renameHsSpliceTy s + HsSpliceTy (HsUntypedSpliceTop _ st) _ -> renameType st + HsSpliceTy (HsUntypedSpliceNested _) _ -> error "renameType: not an top level type splice" HsWildCardTy _ -> pure (HsWildCardTy noAnn) @@ -324,17 +325,6 @@ renameSigType (HsSig { sig_bndrs = bndrs, sig_body = body }) = do body' <- renameLType body pure $ HsSig { sig_ext = noExtField, sig_bndrs = bndrs', sig_body = body' } --- | Rename splices, but _only_ those that turn out to be for types. --- I think this is actually safe for our possible inputs: --- --- * the input is from after GHC's renamer, so should have an 'HsSpliced' --- * the input is typechecked, and only 'HsSplicedTy' should get through that --- -renameHsSpliceTy :: HsSplice GhcRn -> RnM (HsType DocNameI) -renameHsSpliceTy (HsSpliced _ _ (HsSplicedTy t)) = renameType t -renameHsSpliceTy (HsSpliced _ _ _) = error "renameHsSpliceTy: not an HsSplicedTy" -renameHsSpliceTy _ = error "renameHsSpliceTy: not an HsSpliced" - renameLHsQTyVars :: LHsQTyVars GhcRn -> RnM (LHsQTyVars DocNameI) renameLHsQTyVars (HsQTvs { hsq_explicit = tvs }) = do { tvs' <- mapM renameLTyVarBndr tvs diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index d1164858..ca6b9e74 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -16,7 +16,6 @@ import Haddock.Syb import Haddock.Types import GHC -import GHC.Types.Basic ( PromotionFlag(..) ) import GHC.Types.Name import GHC.Data.FastString import GHC.Builtin.Types ( listTyConName, unrestrictedFunTyConName ) diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 7d00c5ec..dc15dfe0 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -322,6 +322,7 @@ type instance IdP DocNameI = DocName instance CollectPass DocNameI where collectXXPat _ ext = dataConCantHappen ext collectXXHsBindsLR ext = dataConCantHappen ext + collectXSplicePat _ ext = dataConCantHappen ext instance NamedThing DocName where getName (Documented name _) = name @@ -750,7 +751,7 @@ type instance XOpTy DocNameI = EpAnn [AddEpAnn] type instance XParTy DocNameI = EpAnn AnnParen type instance XIParamTy DocNameI = EpAnn [AddEpAnn] type instance XKindSig DocNameI = EpAnn [AddEpAnn] -type instance XSpliceTy DocNameI = Void -- see `renameHsSpliceTy` +type instance XSpliceTy DocNameI = DataConCantHappen type instance XDocTy DocNameI = EpAnn [AddEpAnn] type instance XBangTy DocNameI = EpAnn [AddEpAnn] type instance XRecTy DocNameI = EpAnn [AddEpAnn] @@ -832,6 +833,8 @@ type instance XXConDeclField DocNameI = DataConCantHappen type instance XXPat DocNameI = DataConCantHappen type instance XXHsBindsLR DocNameI a = DataConCantHappen +type instance XSplicePat DocNameI = DataConCantHappen + type instance XCInjectivityAnn DocNameI = NoExtField type instance XCFunDep DocNameI = NoExtField -- cgit v1.2.3