TTG: Match new GHC AST

9 files changed, 10 insertions, 30 deletions

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