Merge remote-tracking branch 'upstream/ghc-9.4' into ghc-9.4

19 files changed, 367 insertions, 405 deletions

diff --git a/haddock-api/haddorg-api.cabal b/haddock-api/haddorg-api.cabal
index a0271507..caa4286f 100644
--- a/haddock-api/haddorg-api.cabal
+++ b/haddock-api/haddorg-api.cabal
@@ -42,7 +42,7 @@ library
 
   -- this package typically supports only single major versions
   build-depends: base            ^>= 4.16.0
-               , ghc             ^>= 9.2
+               , ghc             ^>= 9.3
                , ghc-paths       ^>= 0.1.0.9
                , haddock-library ^>= 1.10.0
                , xhtml           ^>= 3000.2.2
@@ -183,7 +183,7 @@ test-suite spec
     Haddock.Backends.Hyperlinker.Parser
     Haddock.Backends.Hyperlinker.Types
 
-  build-depends: ghc             ^>= 9.2
+  build-depends: ghc             ^>= 9.3
                , ghc-paths       ^>= 0.1.0.12
                , haddock-library ^>= 1.10.0
                , xhtml           ^>= 3000.2.2
diff --git a/haddock-api/src/Documentation/Haddock.hs b/haddock-api/src/Documentation/Haddock.hs
index cf244a5f..1aa666ce 100644
--- a/haddock-api/src/Documentation/Haddock.hs
+++ b/haddock-api/src/Documentation/Haddock.hs
@@ -52,9 +52,7 @@ module Documentation.Haddock (
   -- * Interface files
   InterfaceFile(..),
   readInterfaceFile,
-  nameCacheFromGhc,
   freshNameCache,
-  NameCacheAccessor,
 
   -- * Flags and options
   Flag(..),
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 65d329e2..5526a0fa 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -74,8 +74,11 @@ import Text.ParserCombinators.ReadP (readP_to_S)
 import GHC hiding (verbosity)
 import GHC.Settings.Config
 import GHC.Driver.Session hiding (projectVersion, verbosity)
+import GHC.Driver.Config.Logger (initLogFlags)
 import GHC.Driver.Env
 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)
@@ -194,9 +197,10 @@ haddockWithGhc ghc args = handleTopExceptions $ do
     unit_state <- hsc_units <$> getSession
 
     forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do
-      mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), Visible, path)] noChecks
-      forM_ mIfaceFile $ \(_,_,_, ifaceFile) -> do
-        putMsg logger dflags $ renderJson (jsonInterfaceFile ifaceFile)
+      name_cache <- freshNameCache
+      mIfaceFile <- readInterfaceFiles name_cache [(("", Nothing), path)] noChecks
+      forM_ mIfaceFile $ \(_,_, ifaceFile) -> do
+        putMsg logger $ renderJson (jsonInterfaceFile ifaceFile)
 
     if not (null files) then do
       (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files
@@ -222,7 +226,8 @@ haddockWithGhc ghc args = handleTopExceptions $ do
         throwE "No input file(s)."
 
       -- Get packages supplied with --read-interface.
-      packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) noChecks
+      name_cache <- liftIO $ freshNameCache
+      packages <- liftIO $ readInterfaceFiles name_cache (readIfaceArgs flags) noChecks
 
       -- Render even though there are no input files (usually contents/index).
       liftIO $ renderStep logger dflags unit_state flags sinceQual qual packages []
@@ -265,7 +270,8 @@ readPackagesAndProcessModules :: [Flag] -> [String]
 readPackagesAndProcessModules flags files = do
     -- Get packages supplied with --read-interface.
     let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags
-    packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags) noChecks
+    name_cache <- hsc_NC <$> getSession
+    packages <- liftIO $ readInterfaceFiles name_cache (readIfaceArgs flags) noChecks
 
     -- Create the interfaces -- this is the core part of Haddock.
     let ifaceFiles = map (\(_, _, _, ifaceFile) -> ifaceFile) packages
@@ -303,8 +309,8 @@ renderStep logger dflags unit_state flags sinceQual nameQual pkgs interfaces = d
 
 -- | Render the interfaces with whatever backend is specified in the flags.
 render :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption -> [Interface]
-       -> [(FilePath, PackageInterfaces)] -> Map Module FilePath -> IO ()
-render logger dflags unit_state flags sinceQual qual ifaces packages extSrcMap = do
+       -> [(FilePath, InstalledInterface)] -> Map Module FilePath -> IO ()
+render log' dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = do
 
   let
     packageInfo = PackageInfo { piPackageName    = fromMaybe (PackageName mempty)
@@ -327,6 +333,7 @@ render logger dflags unit_state flags sinceQual qual ifaces packages extSrcMap =
     dflags'
       | unicode          = gopt_set dflags Opt_PrintUnicodeSyntax
       | otherwise        = dflags
+    logger               = setLogFlags log' (initLogFlags dflags')
 
     visibleIfaces    = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ]
 
@@ -431,7 +438,7 @@ render logger dflags unit_state flags sinceQual qual ifaces packages extSrcMap =
                   $ flags
 
   when (Flag_GenIndex `elem` flags) $ do
-    withTiming logger dflags' "ppHtmlIndex" (const ()) $ do
+    withTiming logger "ppHtmlIndex" (const ()) $ do
       _ <- {-# SCC ppHtmlIndex #-}
            ppHtmlIndex odir title pkgStr
                   themes opt_mathjax opt_contents_url sourceUrls' opt_wiki_urls
@@ -443,7 +450,7 @@ render logger dflags unit_state flags sinceQual qual ifaces packages extSrcMap =
       copyHtmlBits odir libDir themes withQuickjump
 
   when (Flag_GenContents `elem` flags) $ do
-    withTiming logger dflags' "ppHtmlContents" (const ()) $ do
+    withTiming logger "ppHtmlContents" (const ()) $ do
       _ <- {-# SCC ppHtmlContents #-}
            ppHtmlContents unit_state odir title pkgStr
                      themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls
@@ -463,7 +470,7 @@ render logger dflags unit_state flags sinceQual qual ifaces packages extSrcMap =
                         $ packages)
 
   when (Flag_Html `elem` flags) $ do
-    withTiming logger dflags' "ppHtml" (const ()) $ do
+    withTiming logger "ppHtml" (const ()) $ do
       _ <- {-# SCC ppHtml #-}
            ppHtml unit_state title pkgStr visibleIfaces reexportedIfaces odir
                   prologue
@@ -499,7 +506,7 @@ render logger dflags unit_state flags sinceQual qual ifaces packages extSrcMap =
           ]
 
   when (Flag_LaTeX `elem` flags) $ do
-    withTiming logger dflags' "ppLatex" (const ()) $ do
+    withTiming logger "ppLatex" (const ()) $ do
       _ <- {-# SCC ppLatex #-}
            ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style
                    libDir
@@ -510,7 +517,7 @@ render logger dflags unit_state flags sinceQual qual ifaces packages extSrcMap =
       writeUtf8File (fromMaybe "haddock" (cleanPkgStr <$> pkgStr) <.> "org") org 
 
   when (Flag_HyperlinkedSource `elem` flags && not (null ifaces)) $ do
-    withTiming logger dflags' "ppHyperlinkedSource" (const ()) $ do
+    withTiming logger "ppHyperlinkedSource" (const ()) $ do
       _ <- {-# SCC ppHyperlinkedSource #-}
            ppHyperlinkedSource (verbosity flags) odir libDir opt_source_css pretty srcMap ifaces
       return ()
@@ -521,18 +528,17 @@ render logger dflags unit_state flags sinceQual qual ifaces packages extSrcMap =
 -------------------------------------------------------------------------------
 
 
-readInterfaceFiles :: MonadIO m
-                   => NameCacheAccessor m
-                   -> [(DocPaths, Visibility, FilePath)]
+readInterfaceFiles :: NameCache
+                   -> [(DocPaths, FilePath)]
                    -> Bool
-                   -> m [(DocPaths, Visibility, FilePath, InterfaceFile)]
-readInterfaceFiles name_cache_accessor pairs bypass_version_check = do
+                   -> IO [(DocPaths, FilePath, InterfaceFile)]
+readInterfaceFiles name_cache pairs bypass_version_check = do
   catMaybes `liftM` mapM ({-# SCC readInterfaceFile #-} tryReadIface) pairs
   where
     -- try to read an interface, warn if we can't
-    tryReadIface (paths, showModules, file) =
-      readInterfaceFile name_cache_accessor file bypass_version_check >>= \case
-        Left err -> liftIO $ do
+    tryReadIface (paths, file) =
+      readInterfaceFile name_cache file bypass_version_check >>= \case
+        Left err -> do
           putStrLn ("Warning: Cannot read " ++ file ++ ":")
           putStrLn ("   " ++ err)
           putStrLn "Skipping this interface."
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 9e39d98d..582c535d 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -87,7 +87,7 @@ dropHsDocTy = drop_sig_ty
         drop_ty (HsFunTy x w a b) = HsFunTy x w (drop_lty a) (drop_lty b)
         drop_ty (HsListTy x a) = HsListTy x (drop_lty a)
         drop_ty (HsTupleTy x a b) = HsTupleTy x a (map drop_lty b)
-        drop_ty (HsOpTy x a b c) = HsOpTy x (drop_lty a) b (drop_lty c)
+        drop_ty (HsOpTy x p a b c) = HsOpTy x p (drop_lty a) b (drop_lty c)
         drop_ty (HsParTy x a) = HsParTy x (drop_lty a)
         drop_ty (HsKindSig x a b) = HsKindSig x (drop_lty a) b
         drop_ty (HsDocTy _ a _) = drop_ty $ unL a
@@ -246,11 +246,11 @@ ppCtor dflags dat subdocs con@ConDeclH98 { con_args = con_args' }
         f (PrefixCon _ args) = [typeSig name $ (map hsScaledThing args) ++ [resType]]
         f (InfixCon a1 a2) = f $ PrefixCon [] [a1,a2]
         f (RecCon (L _ recs)) = f (PrefixCon [] $ map (hsLinear . cd_fld_type . unLoc) recs) ++ concat
-                          [(concatMap (lookupCon dflags subdocs . noLocA . extFieldOcc . unLoc) (cd_fld_names r)) ++
-                           [out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]
+                          [(concatMap (lookupCon dflags subdocs . noLocA . foExt . unLoc) (cd_fld_names r)) ++
+                           [out dflags (map (foExt . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]
                           | r <- map unLoc recs]
 
-        funs = foldr1 (\x y -> reL $ HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) x y)
+        funs = foldr1 (\x y -> reL $ HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) x y)
         apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y)
 
         typeSig nm flds = operator nm ++ " :: " ++
@@ -279,12 +279,12 @@ ppCtor dflags _dat subdocs (ConDeclGADT { con_names = names
         name = out dflags $ map unL names
         con_sig_ty = HsSig noExtField outer_bndrs theta_ty where
           theta_ty = case mcxt of
-            Just theta -> noLocA (HsQualTy { hst_xqual = noExtField, hst_ctxt = Just theta, hst_body = tau_ty })
+            Just theta -> noLocA (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty })
             Nothing -> tau_ty
           tau_ty = foldr mkFunTy res_ty $
             case args of PrefixConGADT pos_args -> map hsScaledThing pos_args
-                         RecConGADT (L _ flds) -> map (cd_fld_type . unL) flds
-          mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) a b)
+                         RecConGADT (L _ flds) _ -> map (cd_fld_type . unL) flds
+          mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) a b)
 
 ppFixity :: DynFlags -> (Name, Fixity) -> [String]
 ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExtField [noLocA name] fixity) :: FixitySig GhcRn)]
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
index 5bbea77b..89828e30 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -9,6 +9,7 @@ module Haddock.Backends.Hyperlinker
 
 import Haddock.Types
 import Haddock.Utils (writeUtf8File, out, verbose, Verbosity)
+import Haddock.InterfaceFile
 import Haddock.Backends.Hyperlinker.Renderer
 import Haddock.Backends.Hyperlinker.Parser
 import Haddock.Backends.Hyperlinker.Types
@@ -20,8 +21,8 @@ import System.Directory
 import System.FilePath
 
 import GHC.Iface.Ext.Types  ( pattern HiePath, HieFile(..), HieASTs(..), HieAST(..), SourcedNodeInfo(..) )
-import GHC.Iface.Ext.Binary ( readHieFile, hie_file_result, NameCacheUpdater(..))
-import GHC.Types.SrcLoc     ( realSrcLocSpan, mkRealSrcLoc )
+import GHC.Iface.Ext.Binary ( readHieFile, hie_file_result )
+import GHC.Types.SrcLoc     ( realSrcLocSpan, mkRealSrcLoc, srcSpanFile )
 import Data.Map as M
 import GHC.Data.FastString     ( mkFastString )
 import GHC.Unit.Module         ( Module, moduleName )
@@ -58,21 +59,19 @@ ppHyperlinkedModuleSource :: Verbosity -> FilePath -> Bool -> SrcMaps -> Interfa
 ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = case ifaceHieFile iface of
     Just hfp -> do
         -- Parse the GHC-produced HIE file
-        u <- mkSplitUniqSupply 'a'
-        let nc = (initNameCache u [])
-            ncu = NCU $ \f -> pure $ snd $ f nc
+        nc <- freshNameCache
         HieFile { hie_hs_file = file
                 , hie_asts = HieASTs asts
                 , hie_types = types
                 , hie_hs_src = rawSrc
                 } <- hie_file_result
-                 <$> (readHieFile ncu hfp)
+                 <$> (readHieFile nc hfp)
 
         -- Get the AST and tokens corresponding to the source file we want
         let fileFs = mkFastString file
             mast | M.size asts == 1 = snd <$> M.lookupMin asts
                  | otherwise        = M.lookup (HiePath (mkFastString file)) asts
-            tokens = parse df file rawSrc
+            tokens' = parse df file rawSrc
             ast = fromMaybe (emptyHieAst fileFs) mast
             fullAst = recoverFullIfaceTypes df types ast
 
@@ -82,6 +81,14 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = case ifaceHieFile
           else out verbosity verbose $ unwords [ "couldn't find ast for"
                                                , file, show (M.keys asts) ]
 
+        -- The C preprocessor can double the backslashes on tokens (see #19236),
+        -- which means the source spans will not be comparable and we will not
+        -- be able to associate the HieAST with the correct tokens.
+        --
+        -- We work around this by setting the source span of the tokens to the file
+        -- name from the HieAST
+        let tokens = fmap (\tk -> tk {tkSpan = (tkSpan tk){srcSpanFile = srcSpanFile $ nodeSpan fullAst}}) tokens'
+
         -- Produce and write out the hyperlinked sources
         writeUtf8File path . renderToString pretty . render' fullAst $ tokens
     Nothing -> return ()
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index d9a2e0cd..9f28d72a 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -10,14 +10,17 @@ import Data.List           ( isPrefixOf, isSuffixOf )
 
 import qualified Data.ByteString as BS
 
+import GHC.Platform
 import GHC.Types.SourceText
 import GHC.Driver.Session
+import GHC.Driver.Config.Diagnostic
 import GHC.Utils.Error     ( pprLocMsgEnvelope )
 import GHC.Data.FastString ( mkFastString )
-import GHC.Parser.Errors.Ppr ( pprError )
+import GHC.Parser.Errors.Ppr ()
+import qualified GHC.Types.Error as E
 import GHC.Parser.Lexer    as Lexer
                            ( P(..), ParseResult(..), PState(..), Token(..)
-                           , initParserState, lexer, mkParserOpts, getErrorMessages)
+                           , initParserState, lexer, mkParserOpts, getPsErrorMessages)
 import GHC.Data.Bag         ( bagToList )
 import GHC.Utils.Outputable ( text, ($$) )
 import GHC.Utils.Panic      ( panic )
@@ -40,7 +43,7 @@ parse
 parse dflags fpath bs = case unP (go False []) initState of
     POk _ toks -> reverse toks
     PFailed pst ->
-      let err:_ = bagToList (fmap pprError (getErrorMessages pst)) in
+      let err:_ = bagToList (E.getMessages $ getPsErrorMessages pst) in
       panic $ showSDoc dflags $
         text "Hyperlinker parse error:" $$ pprLocMsgEnvelope err
   where
@@ -48,8 +51,10 @@ parse dflags fpath bs = case unP (go False []) initState of
     initState = initParserState pflags buf start
     buf = stringBufferFromByteString bs
     start = mkRealSrcLoc (mkFastString fpath) 1 1
-    pflags = mkParserOpts   (warningFlags dflags)
-                            (extensionFlags dflags)
+    arch_os = platformArchOS (targetPlatform dflags)
+    pflags = mkParserOpts   (extensionFlags dflags)
+                            (initDiagOpts dflags)
+                            (supportedLanguagesAndExtensions arch_os)
                             (safeImportsOn dflags)
                             False -- lex Haddocks as comment tokens
                             True  -- produce comment tokens
@@ -233,6 +238,7 @@ classify tok =
     ITrequires             -> TkKeyword
 
     ITinline_prag       {} -> TkPragma
+    ITopaque_prag       {} -> TkPragma
     ITspec_prag         {} -> TkPragma
     ITspec_inline_prag  {} -> TkPragma
     ITsource_prag       {} -> TkPragma
@@ -263,6 +269,7 @@ classify tok =
     ITequal                -> TkGlyph
     ITlam                  -> TkGlyph
     ITlcase                -> TkGlyph
+    ITlcases               -> TkGlyph
     ITvbar                 -> TkGlyph
     ITlarrow            {} -> TkGlyph
     ITrarrow            {} -> TkGlyph
@@ -350,10 +357,7 @@ classify tok =
     ITeof                  -> TkUnknown
 
     ITlineComment       {} -> TkComment
-    ITdocCommentNext    {} -> TkComment
-    ITdocCommentPrev    {} -> TkComment
-    ITdocCommentNamed   {} -> TkComment
-    ITdocSection        {} -> TkComment
+    ITdocComment        {} -> TkComment
     ITdocOptions        {} -> TkComment
 
     -- The lexer considers top-level pragmas as comments (see `pragState` in
@@ -374,6 +378,7 @@ inPragma True _ = True
 inPragma False tok =
   case tok of
     ITinline_prag       {} -> True
+    ITopaque_prag       {} -> True
     ITspec_prag         {} -> True
     ITspec_inline_prag  {} -> True
     ITsource_prag       {} -> True
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index b045fa90..faa23d6a 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -24,7 +24,7 @@ import Haddock.GhcUtils
 import GHC.Utils.Ppr hiding (Doc, quote)
 import qualified GHC.Utils.Ppr as Pretty
 
-import GHC.Types.Basic        ( PromotionFlag(..) )
+import GHC.Types.Basic        ( PromotionFlag(..), isPromoted )
 import GHC hiding (fromMaybeContext )
 import GHC.Types.Name.Occurrence
 import GHC.Types.Name        ( nameOccName )
@@ -843,7 +843,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
     fieldPart = case con of
         ConDeclGADT{con_g_args = con_args'} -> case con_args' of
           -- GADT record declarations
-          RecConGADT _                    -> doConstrArgsWithDocs []
+          RecConGADT _ _                  -> doConstrArgsWithDocs []
           -- GADT prefix data constructors
           PrefixConGADT args | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args)
           _                               -> empty
@@ -887,12 +887,12 @@ 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 _) =
-  decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names))
+  decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . unLoc . foLabel . 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
+    mbDoc = lookup (foExt $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst
 
 
 -- | Pretty-print a bundled pattern synonym
@@ -983,11 +983,12 @@ ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts)
 -------------------------------------------------------------------------------
 
 
-ppLContext, ppLContextNoArrow :: Maybe (LHsContext DocNameI) -> Bool -> LaTeX
-ppLContext        Nothing _ = empty
-ppLContext        (Just ctxt) unicode  = ppContext        (unLoc ctxt) unicode
-ppLContextNoArrow Nothing _ = empty
-ppLContextNoArrow (Just ctxt) unicode = ppContextNoArrow (unLoc ctxt) unicode
+ppLContext :: Maybe (LHsContext DocNameI) -> Bool -> LaTeX
+ppLContext Nothing _ = empty
+ppLContext (Just ctxt) unicode  = ppContext (unLoc ctxt) unicode
+
+ppLContextNoArrow :: LHsContext DocNameI -> Bool -> LaTeX
+ppLContextNoArrow ctxt unicode = ppContextNoArrow (unLoc ctxt) unicode
 
 ppContextNoLocsMaybe :: [HsType DocNameI] -> Bool -> Maybe LaTeX
 ppContextNoLocsMaybe [] _ = Nothing
@@ -1101,15 +1102,15 @@ ppr_mono_ty (HsForAllTy _ tele ty) unicode
   = sep [ ppHsForAllTelescope tele unicode
         , ppr_mono_lty ty unicode ]
 ppr_mono_ty (HsQualTy _ ctxt ty) unicode
-  = sep [ ppLContext ctxt unicode
+  = sep [ ppLContext (Just ctxt) unicode
         , ppr_mono_lty ty unicode ]
 ppr_mono_ty (HsFunTy _ mult ty1 ty2)   u
   = sep [ ppr_mono_lty ty1 u
         , arr <+> ppr_mono_lty ty2 u ]
    where arr = case mult of
-                 HsLinearArrow _ _ -> lollipop u
+                 HsLinearArrow _ -> lollipop u
                  HsUnrestrictedArrow _ -> arrow u
-                 HsExplicitMult _ _ m -> multAnnotation <> ppr_mono_lty m u <+> arrow u
+                 HsExplicitMult _ m _ -> multAnnotation <> ppr_mono_lty m u <+> arrow u
 
 ppr_mono_ty (HsBangTy _ b ty)     u = ppBang b <> ppLParendType u ty
 ppr_mono_ty (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name
@@ -1132,9 +1133,13 @@ ppr_mono_ty (HsAppTy _ fun_ty arg_ty) unicode
 ppr_mono_ty (HsAppKindTy _ fun_ty arg_ki) unicode
   = hsep [ppr_mono_lty fun_ty unicode, atSign unicode <> ppr_mono_lty arg_ki unicode]
 
-ppr_mono_ty (HsOpTy _ ty1 op ty2) unicode
-  = ppr_mono_lty ty1 unicode <+> ppr_op <+> ppr_mono_lty ty2 unicode
+ppr_mono_ty (HsOpTy _ prom ty1 op ty2) unicode
+  = ppr_mono_lty ty1 unicode <+> ppr_op_prom <+> ppr_mono_lty ty2 unicode
   where
+    ppr_op_prom | isPromoted prom
+                = char '\'' <> ppr_op
+                | otherwise
+                = ppr_op
     ppr_op | isSymOcc (getOccName op) = ppLDocName op
            | otherwise = char '`' <> ppLDocName op <> char '`'
 
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 8de1b1b8..a54bb0aa 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -167,7 +167,7 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_sig_args 0 sep
         leader' = leader <+> ppForAllPart unicode qual tele
 
     do_args n leader (HsQualTy _ lctxt ltype)
-      | null (fromMaybeContext lctxt)
+      | null (unLoc lctxt)
       = do_largs n leader ltype
       | otherwise
       = (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, [])
@@ -436,12 +436,14 @@ ppTypeApp n ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT ts)
 -------------------------------------------------------------------------------
 
 
-ppLContext, ppLContextNoArrow :: Maybe (LHsContext DocNameI) -> Unicode
+ppLContext :: Maybe (LHsContext DocNameI) -> Unicode
                               -> Qualification -> HideEmptyContexts -> Html
 ppLContext        Nothing  u q h = ppContext        []        u q h
 ppLContext        (Just c) u q h = ppContext        (unLoc c) u q h
-ppLContextNoArrow Nothing  u q h = ppContextNoArrow []        u q h
-ppLContextNoArrow (Just c) u q h = ppContextNoArrow (unLoc c) u q h
+
+ppLContextNoArrow :: LHsContext DocNameI -> Unicode
+                              -> Qualification -> HideEmptyContexts -> Html
+ppLContextNoArrow c u q h = ppContextNoArrow (unLoc c) u q h
 
 ppContextNoArrow :: HsContext DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
 ppContextNoArrow cxt unicode qual emptyCtxts = fromMaybe noHtml $
@@ -967,7 +969,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
     fieldPart = case con of
         ConDeclGADT{con_g_args = con_args'} -> case con_args' of
           -- GADT record declarations
-          RecConGADT _                    -> [ doConstrArgsWithDocs [] ]
+          RecConGADT _ _                  -> [ doConstrArgsWithDocs [] ]
           -- GADT prefix data constructors
           PrefixConGADT args | hasArgDocs -> [ doConstrArgsWithDocs args ]
           _                               -> []
@@ -1025,7 +1027,7 @@ ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification
 ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype _) =
   ( hsep (punctuate comma [ ppBinder False (rdrNameOcc field)
                           | L _ name <- names
-                          , let field = (unLoc . rdrNameFieldOcc) name
+                          , let field = (unLoc . foLabel) name
                           ])
       <+> dcolon unicode
       <+> ppLType unicode qual HideEmptyContexts ltype
@@ -1035,12 +1037,12 @@ 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 (extFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst
+    mbDoc = lookup (foExt $ unLoc $ head names) subdocs >>= combineDocumentation . fst
 
 
 ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> Html
 ppShortField summary unicode qual (ConDeclField _ names ltype _)
-  = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names))
+  = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . foLabel . unLoc) names))
     <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype
 
 
@@ -1185,13 +1187,13 @@ patSigContext sig_typ | hasNonEmptyContext typ && isFirstContextEmpty typ =  Sho
     hasNonEmptyContext t =
       case unLoc t of
         HsForAllTy _ _ s -> hasNonEmptyContext s
-        HsQualTy _ cxt s -> if null (fromMaybeContext cxt) then hasNonEmptyContext s else True
+        HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True
         HsFunTy _ _ _ s    -> hasNonEmptyContext s
         _ -> False
     isFirstContextEmpty t =
       case unLoc t of
         HsForAllTy _ _ s -> isFirstContextEmpty s
-        HsQualTy _ cxt _ -> null (fromMaybeContext cxt)
+        HsQualTy _ cxt _ -> null (unLoc cxt)
         HsFunTy _ _ _ s    -> isFirstContextEmpty s
         _ -> False
 
@@ -1230,7 +1232,7 @@ ppr_mono_ty (HsForAllTy _ tele ty) unicode qual emptyCtxts
   = ppForAllPart unicode qual tele <+> ppr_mono_lty ty unicode qual emptyCtxts
 
 ppr_mono_ty (HsQualTy _ ctxt ty) unicode qual emptyCtxts
-  = ppLContext ctxt unicode qual emptyCtxts <+> ppr_mono_lty ty unicode qual emptyCtxts
+  = ppLContext (Just ctxt) unicode qual emptyCtxts <+> ppr_mono_lty ty unicode qual emptyCtxts
 
 -- UnicodeSyntax alternatives
 ppr_mono_ty (HsTyVar _ _ (L _ name)) True _ _
@@ -1248,9 +1250,9 @@ ppr_mono_ty (HsFunTy _ mult ty1 ty2) u q e =
        , arr <+> ppr_mono_lty ty2 u q e
        ]
    where arr = case mult of
-                 HsLinearArrow _ _ -> lollipop u
+                 HsLinearArrow _ -> lollipop u
                  HsUnrestrictedArrow _ -> arrow u
-                 HsExplicitMult _ _ m -> multAnnotation <> ppr_mono_lty m u q e <+> arrow u
+                 HsExplicitMult _ m _ -> multAnnotation <> ppr_mono_lty m u q e <+> arrow u
 
 ppr_mono_ty (HsTupleTy _ con tys) u q _ =
   tupleParens con (map (ppLType u q HideEmptyContexts) tys)
@@ -1279,15 +1281,15 @@ ppr_mono_ty (HsAppKindTy _ fun_ty arg_ki) unicode qual _
   = hsep [ppr_mono_lty fun_ty unicode qual HideEmptyContexts
          , atSign unicode <> ppr_mono_lty arg_ki unicode qual HideEmptyContexts]
 
-ppr_mono_ty (HsOpTy _ ty1 op ty2) unicode qual _
-  = ppr_mono_lty ty1 unicode qual HideEmptyContexts <+> ppr_op <+> ppr_mono_lty ty2 unicode qual HideEmptyContexts
+ppr_mono_ty (HsOpTy _ prom ty1 op ty2) unicode qual _
+  = ppr_mono_lty ty1 unicode qual HideEmptyContexts <+> ppr_op_prom <+> ppr_mono_lty ty2 unicode qual HideEmptyContexts
   where
-    -- `(:)` is valid in type signature only as constructor to promoted list
-    -- and needs to be quoted in code so we explicitly quote it here too.
-    ppr_op
-        | (getOccString . getName . unL) op == ":" = promoQuote ppr_op'
-        | otherwise = ppr_op'
-    ppr_op' = ppLDocName qual Infix op
+    ppr_op_prom
+        | isPromoted prom
+        = promoQuote ppr_op
+        | otherwise
+        = ppr_op
+    ppr_op = ppLDocName qual Infix op
 
 ppr_mono_ty (HsParTy _ ty) unicode qual emptyCtxts
   = parens (ppr_mono_lty ty unicode qual emptyCtxts)
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 10180361..fd5300d2 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -19,10 +19,6 @@ module Haddock.Convert (
   PrintRuntimeReps(..),
 ) where
 
-#ifndef __HLINT__
-#include "HsVersions.h"
-#endif
-
 import GHC.Data.Bag ( emptyBag )
 import GHC.Types.Basic ( TupleSort(..), PromotionFlag(..), DefMethSpec(..), TopLevelFlag(..) )
 import GHC.Types.SourceText (SourceText(..))
@@ -49,9 +45,9 @@ import GHC.Builtin.Types ( eqTyConName, listTyConName, liftedTypeKindTyConName
 import GHC.Builtin.Names ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey
                  , liftedDataConKey, boxedRepDataConKey )
 import GHC.Types.Unique ( getUnique )
-import GHC.Utils.Misc ( chkAppend, debugIsOn, dropList, equalLength
+import GHC.Utils.Misc ( chkAppend, dropList, equalLength
                       , filterByList, filterOut )
-import GHC.Utils.Panic ( assertPanic )
+import GHC.Utils.Panic.Plain ( assert )
 import GHC.Types.Var
 import GHC.Types.Var.Set
 import GHC.Types.SrcLoc
@@ -128,7 +124,7 @@ tyThingToLHsDecl prr t = case t of
            vs = tyConVisibleTyVars (classTyCon cl)
 
        in withErrs (lefts atTyClDecls) . TyClD noExtField $ ClassDecl
-         { tcdCtxt = synifyCtx (classSCTheta cl)
+         { tcdCtxt = Just $ synifyCtx (classSCTheta cl)
          , tcdLName = synifyNameN cl
          , tcdTyVars = synifyTyVars vs
          , tcdFixity = synifyFixity cl
@@ -306,7 +302,7 @@ synifyTyCon _prr coax tc
   alg_deriv = []
   defn = HsDataDefn { dd_ext     = noExtField
                     , dd_ND      = alg_nd
-                    , dd_ctxt    = alg_ctx
+                    , dd_ctxt    = Just alg_ctx
                     , dd_cType   = Nothing
                     , dd_kindSig = kindSig
                     , dd_cons    = cons
@@ -345,14 +341,14 @@ synifyInjectivityAnn Nothing _ _            = Nothing
 synifyInjectivityAnn _       _ NotInjective = Nothing
 synifyInjectivityAnn (Just lhs) tvs (Injective inj) =
     let rhs = map (noLocA . tyVarName) (filterByList inj tvs)
-    in Just $ noLoc $ InjectivityAnn noAnn (noLocA lhs) rhs
+    in Just $ noLocA $ InjectivityAnn noAnn (noLocA lhs) rhs
 
 synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig GhcRn
 synifyFamilyResultSig  Nothing    kind
-   | isLiftedTypeKind kind = noLoc $ NoSig noExtField
-   | otherwise = noLoc $ KindSig  noExtField (synifyKindSig kind)
+   | isLiftedTypeKind kind = noLocA $ NoSig noExtField
+   | otherwise = noLocA $ KindSig  noExtField (synifyKindSig kind)
 synifyFamilyResultSig (Just name) kind =
-   noLoc $ TyVarSig noExtField (noLocA $ KindedTyVar noAnn () (noLocA name) (synifyKindSig kind))
+   noLocA $ TyVarSig noExtField (noLocA $ KindedTyVar noAnn () (noLocA 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
@@ -379,7 +375,7 @@ synifyDataCon use_gadt_syntax dc =
 
   -- skip any EqTheta, use 'orig'inal syntax
   ctx | null theta = Nothing
-      | otherwise = synifyCtx theta
+      | otherwise = Just $ synifyCtx theta
 
   linear_tys =
     zipWith (\ty bang ->
@@ -391,7 +387,7 @@ synifyDataCon use_gadt_syntax dc =
 
   field_tys = zipWith con_decl_field (dataConFieldLabels dc) linear_tys
   con_decl_field fl synTy = noLocA $
-    ConDeclField noAnn [noLoc $ FieldOcc (flSelector fl) (noLocA $ mkVarUnqual $ flLabel fl)] synTy
+    ConDeclField noAnn [noLocA $ FieldOcc (flSelector fl) (noLocA $ mkVarUnqual $ flLabel fl)] synTy
                  Nothing
 
   mk_h98_arg_tys :: Either ErrMsg (HsConDeclH98Details GhcRn)
@@ -405,7 +401,7 @@ synifyDataCon use_gadt_syntax dc =
 
   mk_gadt_arg_tys :: HsConDeclGADTDetails GhcRn
   mk_gadt_arg_tys
-    | use_named_field_syntax = RecConGADT (noLocA field_tys)
+    | use_named_field_syntax = RecConGADT (noLocA field_tys) noHsUniTok
     | otherwise              = PrefixConGADT (map hsUnrestricted linear_tys)
 
  -- finally we get synifyDataCon's result!
@@ -466,8 +462,8 @@ synifyTcIdSig vs (i, dm) =
     mainSig t = synifySigType DeleteTopLevelQuantification vs t
     defSig t = synifySigType ImplicitizeForAll vs t
 
-synifyCtx :: [PredType] -> Maybe (LHsContext GhcRn)
-synifyCtx ts = Just (noLocA ( map (synifyType WithinType []) ts))
+synifyCtx :: [PredType] -> LHsContext GhcRn
+synifyCtx ts = noLocA ( map (synifyType WithinType []) ts)
 
 
 synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn
@@ -610,23 +606,25 @@ synifyType _ vs (TyConApp tc tys)
              tTy | L _ (HsExplicitListTy _ IsPromoted tTy') <- stripKindSig tTy
                  -> noLocA $ HsExplicitListTy noExtField IsPromoted (hTy : tTy')
                  | otherwise
-                 -> noLocA $ HsOpTy noExtField hTy (noLocA $ getName tc) tTy
+                 -> noLocA $ HsOpTy noAnn IsPromoted hTy (noLocA $ getName tc) tTy
       -- ditto for implicit parameter tycons
       | tc `hasKey` ipClassKey
       , [name, ty] <- tys
       , Just x <- isStrLitTy name
-      = noLocA $ HsIParamTy noAnn (noLoc $ HsIPName x) (synifyType WithinType vs ty)
+      = noLocA $ HsIParamTy noAnn (noLocA $ HsIPName x) (synifyType WithinType vs ty)
       -- and equalities
       | tc `hasKey` eqTyConKey
       , [ty1, ty2] <- tys
-      = noLocA $ HsOpTy noExtField
+      = noLocA $ HsOpTy noAnn
+                       NotPromoted
                        (synifyType WithinType vs ty1)
                        (noLocA eqTyConName)
                        (synifyType WithinType vs ty2)
       -- and infix type operators
       | isSymOcc (nameOccName (getName tc))
       , ty1:ty2:tys_rest <- vis_tys
-      = mk_app_tys (HsOpTy noExtField
+      = mk_app_tys (HsOpTy noAnn
+                           prom
                            (synifyType WithinType vs ty1)
                            (noLocA $ getName tc)
                            (synifyType WithinType vs ty2))
@@ -801,9 +799,9 @@ noKindTyVars _ _ = emptyVarSet
 
 synifyMult :: [TyVar] -> Mult -> HsArrow GhcRn
 synifyMult vs t = case t of
-                    One  -> HsLinearArrow NormalSyntax Nothing
-                    Many -> HsUnrestrictedArrow NormalSyntax
-                    ty -> HsExplicitMult NormalSyntax Nothing (synifyType WithinType vs ty)
+                    One  -> HsLinearArrow (HsPct1 noHsTok noHsUniTok)
+                    Many -> HsUnrestrictedArrow noHsUniTok
+                    ty -> HsExplicitMult noHsTok (synifyType WithinType vs ty) noHsUniTok
 
 
 
@@ -935,8 +933,8 @@ tcSplitForAllTysReqPreserveSynonyms :: Type -> ([ReqTVBinder], Type)
 tcSplitForAllTysReqPreserveSynonyms ty =
   let (all_bndrs, body) = tcSplitSomeForAllTysPreserveSynonyms isVisibleArgFlag ty
       req_bndrs         = mapMaybe mk_req_bndr_maybe all_bndrs in
-  ASSERT( req_bndrs `equalLength` all_bndrs )
-  (req_bndrs, body)
+  assert ( req_bndrs `equalLength` all_bndrs)
+    (req_bndrs, body)
   where
     mk_req_bndr_maybe :: TyCoVarBinder -> Maybe ReqTVBinder
     mk_req_bndr_maybe (Bndr tv argf) = case argf of
@@ -948,8 +946,8 @@ tcSplitForAllTysInvisPreserveSynonyms :: Type -> ([InvisTVBinder], Type)
 tcSplitForAllTysInvisPreserveSynonyms ty =
   let (all_bndrs, body) = tcSplitSomeForAllTysPreserveSynonyms isInvisibleArgFlag ty
       inv_bndrs         = mapMaybe mk_inv_bndr_maybe all_bndrs in
-  ASSERT( inv_bndrs `equalLength` all_bndrs )
-  (inv_bndrs, body)
+  assert ( inv_bndrs `equalLength` all_bndrs)
+    (inv_bndrs, body)
   where
     mk_inv_bndr_maybe :: TyCoVarBinder -> Maybe InvisTVBinder
     mk_inv_bndr_maybe (Bndr tv argf) = case argf of
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index ebddb397..062d70e6 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE BangPatterns, FlexibleInstances #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -95,7 +96,7 @@ ifTrueJust True  = Just
 ifTrueJust False = const Nothing
 
 sigName :: LSig GhcRn -> [IdP GhcRn]
-sigName (L _ sig) = sigNameNoLoc sig
+sigName (L _ sig) = sigNameNoLoc emptyOccEnv sig
 
 -- | Was this signature given by the user?
 isUserLSig :: forall p. UnXRec p => LSig p -> Bool
@@ -114,7 +115,7 @@ pretty = showPpr
 -- instantiated at DocNameI instead of (GhcPass _).
 
 -- | Like 'hsTyVarName' from GHC API, but not instantiated at (GhcPass _)
-hsTyVarBndrName :: forall flag n. (XXTyVarBndr n ~ NoExtCon, UnXRec n)
+hsTyVarBndrName :: forall flag n. (XXTyVarBndr n ~ DataConCantHappen, UnXRec n)
                 => HsTyVarBndr flag n -> IdP n
 hsTyVarBndrName (UserTyVar _ _ name) = unXRec @n name
 hsTyVarBndrName (KindedTyVar _ _ name _) = unXRec @n name
@@ -171,17 +172,17 @@ getGADTConType (ConDeclGADT { con_bndrs = L _ outer_bndrs
                  , sig_body  = theta_ty })
  where
    theta_ty | Just theta <- mcxt
-            = noLocA (HsQualTy { hst_xqual = noAnn, hst_ctxt = Just theta, hst_body = tau_ty })
+            = noLocA (HsQualTy { hst_xqual = noAnn, hst_ctxt = theta, hst_body = tau_ty })
             | otherwise
             = tau_ty
 
 --  tau_ty :: LHsType DocNameI
    tau_ty = case args of
-              RecConGADT flds -> mkFunTy (noLocA (HsRecTy noAnn (unLoc flds))) res_ty
+              RecConGADT flds _ -> mkFunTy (noLocA (HsRecTy noAnn (unLoc flds))) res_ty
               PrefixConGADT pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args)
 
    mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI
-   mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) a b)
+   mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) a b)
 
 getGADTConType (ConDeclH98 {}) = panic "getGADTConType"
   -- Should only be called on ConDeclGADT
@@ -192,7 +193,7 @@ getMainDeclBinderI (ValD _ d) =
   case collectHsBindBinders CollNoDictBinders d of
     []       -> []
     (name:_) -> [name]
-getMainDeclBinderI (SigD _ d) = sigNameNoLoc d
+getMainDeclBinderI (SigD _ d) = sigNameNoLoc emptyOccEnv d
 getMainDeclBinderI (ForD _ (ForeignImport _ name _ _)) = [unLoc name]
 getMainDeclBinderI (ForD _ (ForeignExport _ _ _ _)) = []
 getMainDeclBinderI _ = []
@@ -226,12 +227,11 @@ addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype))
                          , hst_ctxt = add_ctxt ctxt, hst_body = ty })
     go_ty (L loc ty)
        = L loc (HsQualTy { hst_xqual = noExtField
-                         , hst_ctxt = add_ctxt Nothing, hst_body = L loc ty })
+                         , hst_ctxt = add_ctxt (noLocA []), hst_body = L loc ty })
 
-    extra_pred = nlHsTyConApp Prefix cls (lHsQTyVarsToTypes tvs0)
+    extra_pred = nlHsTyConApp NotPromoted Prefix cls (lHsQTyVarsToTypes tvs0)
 
-    add_ctxt Nothing              = Just $ noLocA [extra_pred]
-    add_ctxt (Just (L loc preds)) = Just $ L loc (extra_pred : preds)
+    add_ctxt (L loc preds) = L loc (extra_pred : preds)
 
 addClassContext _ _ sig = sig   -- E.g. a MinimalSig is fine
 
@@ -284,14 +284,14 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
 
           ConDeclGADT { con_g_args = con_args' } -> case con_args' of
             PrefixConGADT {} -> Just d
-            RecConGADT fields
+            RecConGADT fields _
               | all field_avail (unLoc fields) -> Just d
               | otherwise -> Just (d { con_g_args = PrefixConGADT (field_types $ unLoc fields) })
               -- see above
       where
         field_avail :: LConDeclField GhcRn -> Bool
         field_avail (L _ (ConDeclField _ fs _ _))
-            = all (\f -> extFieldOcc (unLoc f) `elem` names) fs
+            = all (\f -> foExt (unLoc f) `elem` names) fs
 
         field_types flds = [ hsUnrestricted t | L _ (ConDeclField _ _ t _) <- flds ]
 
@@ -356,9 +356,7 @@ reparenTypePrec = go
   go p (HsQualTy x ctxt ty)
     = let p' [_] = PREC_CTX
           p' _   = PREC_TOP -- parens will get added anyways later...
-          ctxt' = case ctxt of
-            Nothing -> Nothing
-            Just c -> Just $ mapXRec @a (\xs -> map (goL (p' xs)) xs) c
+          ctxt' = mapXRec @a (\xs -> map (goL (p' xs)) xs) ctxt
       in paren p PREC_CTX $ HsQualTy x ctxt' (goL PREC_TOP ty)
     -- = paren p PREC_FUN $ HsQualTy x (fmap (mapXRec @a (map reparenLType)) ctxt) (reparenLType ty)
   go p (HsFunTy x w ty1 ty2)
@@ -367,8 +365,8 @@ reparenTypePrec = go
     = paren p PREC_CON $ HsAppTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ty)
   go p (HsAppKindTy x fun_ty arg_ki)
     = paren p PREC_CON $ HsAppKindTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ki)
-  go p (HsOpTy x ty1 op ty2)
-    = paren p PREC_FUN $ HsOpTy x (goL PREC_OP ty1) op (goL PREC_OP ty2)
+  go p (HsOpTy x prom ty1 op ty2)
+    = paren p PREC_FUN $ HsOpTy x prom (goL PREC_OP ty1) op (goL PREC_OP ty2)
   go p (HsParTy _ t) = unXRec @a $ goL p t -- pretend the paren doesn't exist - it will be added back if needed
   go _ t@HsTyVar{} = t
   go _ t@HsStarTy{} = t
@@ -469,7 +467,7 @@ instance Parent (ConDecl GhcRn) where
   children con =
     case getRecConArgs_maybe con of
       Nothing -> []
-      Just flds -> map (extFieldOcc . unLoc) $ concatMap (cd_fld_names . unLoc) (unLoc flds)
+      Just flds -> map (foExt . unLoc) $ concatMap (cd_fld_names . unLoc) (unLoc flds)
 
 instance Parent (TyClDecl GhcRn) where
   children d
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index 02e7ed38..19113107 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -55,12 +55,12 @@ import qualified Data.Set as Set
 
 import GHC hiding (verbosity)
 import GHC.Data.FastString (unpackFS)
-import GHC.Data.Graph.Directed (flattenSCCs)
-import GHC.Driver.Env (hsc_dflags, hsc_home_unit, hsc_logger, hsc_static_plugins, hsc_units)
+import GHC.Data.Graph.Directed
+import GHC.Driver.Env
 import GHC.Driver.Monad (modifySession, withTimingM)
 import GHC.Driver.Session hiding (verbosity)
 import GHC.HsToCore.Docs (getMainDeclBinder)
-import GHC.Plugins (Outputable, Plugin (..), PluginWithArgs (..), StaticPlugin (..), defaultPlugin, keepRenamedSource)
+import GHC.Plugins
 import GHC.Tc.Types (TcGblEnv (..), TcM)
 import GHC.Tc.Utils.Env (tcLookupGlobal)
 import GHC.Tc.Utils.Monad (getTopEnv, setGblEnv)
@@ -68,8 +68,8 @@ 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 (ModuleGraphNode (..))
-import GHC.Unit.Module.ModSummary (emsModSummary, isBootSummary)
+import GHC.Unit.Module.Graph
+import GHC.Unit.Module.ModSummary (isBootSummary)
 import GHC.Unit.Types (IsBootInterface (..))
 import GHC.Utils.Error (withTiming)
 
@@ -145,20 +145,19 @@ createIfaces verbosity modules flags instIfaceMap = do
 
   let
     installHaddockPlugin :: HscEnv -> HscEnv
-    installHaddockPlugin hsc_env = hsc_env
-      {
-        hsc_dflags =
-          gopt_set (hsc_dflags hsc_env) Opt_PluginTrustworthy
-      , hsc_static_plugins =
-          haddockPlugin : hsc_static_plugins hsc_env
-      }
+    installHaddockPlugin hsc_env =
+      let
+        old_plugins = hsc_plugins hsc_env
+        new_plugins = old_plugins { staticPlugins = haddockPlugin : staticPlugins old_plugins }
+        hsc_env'    = hsc_env { hsc_plugins = new_plugins }
+      in hscUpdateFlags (flip gopt_set Opt_PluginTrustworthy) hsc_env'
 
   -- Note that we would rather use withTempSession but as long as we
   -- have the separate attachInstances step we need to keep the session
   -- alive to be able to find all the instances.
   modifySession installHaddockPlugin
 
-  targets <- mapM (\filePath -> guessTarget filePath Nothing) modules
+  targets <- mapM (\filePath -> guessTarget filePath Nothing Nothing) modules
   setTargets targets
 
   loadOk <- withTimingM "load" (const ()) $
@@ -173,13 +172,59 @@ createIfaces verbosity modules flags instIfaceMap = do
       moduleSet <- liftIO getModules
 
       let
+        -- We topologically sort the module graph including boot files,
+        -- so it should be acylic (hopefully we failed much earlier if this is not the case)
+        -- We then filter out boot modules from the resultant topological sort
+        --
+        -- We do it this way to make 'buildHomeLinks' a bit more stable
+        -- 'buildHomeLinks' depends on the topological order of its input in order
+        -- to construct its result. In particular, modules closer to the bottom of
+        -- the dependency chain are to be prefered for link destinations.
+        --
+        -- If there are cycles in the graph, then this order is indeterminate
+        -- (the nodes in the cycle can be ordered in any way).
+        -- While 'topSortModuleGraph' does guarantee stability for equivalent
+        -- module graphs, seemingly small changes in the ModuleGraph can have
+        -- big impacts on the `LinkEnv` constructed.
+        --
+        -- For example, suppose
+        --  G1 = A.hs -> B.hs -> C.hs (where '->' denotes an import).
+        --
+        -- Then suppose C.hs is changed to have a cyclic dependency on A
+        --
+        --  G2 = A.hs -> B.hs -> C.hs -> A.hs-boot
+        --
+        -- For G1, `C.hs` is preferred for link destinations. However, for G2,
+        -- the topologically sorted order not taking into account boot files (so
+        -- C -> A) is completely indeterminate.
+        -- Using boot files to resolve cycles, we end up with the original order
+        -- [C, B, A] (in decreasing order of preference for links)
+        --
+        -- This exact case came up in testing for the 'base' package, where there
+        -- is a big module cycle involving 'Prelude' on windows, but the cycle doesn't
+        -- include 'Prelude' on non-windows platforms. This lead to drastically different
+        -- LinkEnv's (and failing haddockHtmlTests) across the platforms
+        --
+        -- In effect, for haddock users this behaviour (using boot files to eliminate cycles)
+        -- means that {-# SOURCE #-} imports no longer count towards re-ordering
+        -- the preference of modules for linking.
+        --
+        -- i.e. if module A imports B, then B is preferred over A,
+        -- but if module A {-# SOURCE #-} imports B, then we can't say the same.
+        --
+        go (AcyclicSCC (ModuleNode _ ms))
+          | NotBoot <- isBootSummary ms = [ms]
+          | otherwise = []
+        go (AcyclicSCC _) = []
+        go (CyclicSCC _) = error "haddock: module graph cyclic even with boot files"
+
         ifaces :: [Interface]
         ifaces =
           [ Map.findWithDefault
               (error "haddock:iface")
-              (ms_mod (emsModSummary ems))
+              (ms_mod ms)
               ifaceMap
-          | ModuleNode ems <- flattenSCCs $ topSortModuleGraph True modGraph Nothing
+          | ms <- concatMap go $ topSortModuleGraph False modGraph Nothing
           ]
 
       return (ifaces, moduleSet)
@@ -212,7 +257,7 @@ plugin verbosity flags instIfaceMap = liftIO $ do
       | otherwise = do
           hsc_env <- getTopEnv
           ifaces <- liftIO $ readIORef ifaceMapRef
-          (iface, modules) <- withTiming (hsc_logger hsc_env) (hsc_dflags hsc_env)
+          (iface, modules) <- withTiming (hsc_logger hsc_env)
                                 "processModule" (const ()) $
             processModule1 verbosity flags ifaces instIfaceMap hsc_env mod_summary tc_gbl_env
 
@@ -266,9 +311,8 @@ processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env
 
   (!interface, messages) <- do
     logger <- getLogger
-    dflags <- getDynFlags
     {-# SCC createInterface #-}
-     withTiming logger dflags "createInterface" (const ()) $ runIfM (fmap Just . tcLookupGlobal) $
+     withTiming logger "createInterface" (const ()) $ runIfM (fmap Just . tcLookupGlobal) $
       createInterface1 flags unit_state mod_summary tc_gbl_env
         ifaces inst_ifaces
 
@@ -318,7 +362,7 @@ processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env
       ]
         where
           formatName :: SrcSpan -> HsDecl GhcRn -> String
-          formatName loc n = p (getMainDeclBinder n) ++ case loc of
+          formatName loc n = p (getMainDeclBinder emptyOccEnv n) ++ case loc of
             RealSrcSpan rss _ -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" ++
               show (srcSpanStartLine rss) ++ ")"
             _ -> ""
@@ -356,7 +400,7 @@ processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env
 -- The interfaces are passed in in topologically sorted order, but we start
 -- by reversing the list so we can do a foldl.
 buildHomeLinks :: [Interface] -> LinkEnv
-buildHomeLinks ifaces = foldl upd Map.empty (reverse ifaces)
+buildHomeLinks ifaces = foldl' upd Map.empty (reverse ifaces)
   where
     upd old_env iface
       | OptHide    `elem` ifaceOptions iface = old_env
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index cc9569af..4527360f 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -135,12 +135,12 @@ attachToExportItem index expInfo getInstDoc getFixity export =
                                , expItemSubDocs = subDocs
                                } = e { expItemFixities =
       nubByName fst $ expItemFixities e ++
-      [ (n',f) | n <- getMainDeclBinder d
+      [ (n',f) | n <- getMainDeclBinder emptyOccEnv d
                , n' <- n : (map fst subDocs ++ patsyn_names)
                , f <- maybeToList (getFixity n')
       ] }
       where
-        patsyn_names = concatMap (getMainDeclBinder . fst) patsyns
+        patsyn_names = concatMap (getMainDeclBinder emptyOccEnv . fst) patsyns
 
     attachFixities e = e
     -- spanName: attach the location to the name that is the same file as the instance location
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index b3796906..5d3962ca 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -34,7 +34,7 @@ import Documentation.Haddock.Doc (metaDocAppend)
 import Haddock.Convert (PrintRuntimeReps (..), tyThingToLHsDecl)
 import Haddock.GhcUtils (addClassContext, filterSigNames, lHsQTyVarsToTypes, mkEmptySigType, moduleString, parents,
                          pretty, restrictTo, sigName, unL)
-import Haddock.Interface.LexParseRn (processDocString, processDocStringParas, processDocStrings, processModuleHeader)
+import Haddock.Interface.LexParseRn
 import Haddock.Options (Flag (..), modulePackageInfo)
 import Haddock.Types hiding (liftErrMsg)
 import Haddock.Utils (replace)
@@ -56,7 +56,7 @@ import GHC.Core.Class (ClassMinimalDef, classMinimalDef)
 import GHC.Core.ConLike (ConLike (..))
 import GHC.Data.FastString (bytesFS, unpackFS)
 import GHC.Driver.Ppr (showSDoc)
-import GHC.HsToCore.Docs hiding (mkMaps)
+import GHC.HsToCore.Docs hiding (mkMaps, unionArgMaps)
 import GHC.IORef (readIORef)
 import GHC.Stack (HasCallStack)
 import GHC.Tc.Types hiding (IfM)
@@ -64,12 +64,13 @@ 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)
+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)
 import GHC.Types.Name.Set (elemNameSet, mkNameSet)
 import GHC.Types.SourceFile (HscSource (..))
 import GHC.Types.SourceText (SourceText (..), sl_fs)
+import GHC.Unit.Types
 import qualified GHC.Types.SrcLoc as SrcLoc
 import qualified GHC.Unit.Module as Module
 import GHC.Unit.Module.ModSummary (msHsFilePath)
@@ -77,6 +78,7 @@ import GHC.Unit.State (PackageName (..), UnitState, lookupModuleInAllUnits)
 import qualified GHC.Utils.Outputable as O
 import GHC.Utils.Panic (pprPanic)
 import GHC.Unit.Module.Warnings
+import GHC.Types.Unique.Map
 
 newtype IfEnv m = IfEnv
   {
@@ -253,7 +255,7 @@ createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do
 
   -- Process the top-level module header documentation.
   (!info, header_doc) <- liftErrMsg $ processModuleHeader dflags pkg_name
-    tcg_rdr_env safety (thMbDocStr <|> (unLoc <$> tcg_doc_hdr))
+    tcg_rdr_env safety (fmap hsDocString thMbDocStr <|> (hsDocString . unLoc <$> tcg_doc_hdr))
 
   -- Warnings on declarations in this module
   decl_warnings <- liftErrMsg (mkWarningMap dflags tcg_warns tcg_rdr_env exported_names)
@@ -347,8 +349,7 @@ mkAliasMap state impDecls =
          -- them to the user.  We should reuse that information;
          -- or at least reuse the renamed imports, which know what
          -- they import!
-         (fmap Module.fsToUnit $
-          fmap sl_fs $ ideclPkgQual impDecl)
+         (ideclPkgQual impDecl)
          (case ideclName impDecl of SrcLoc.L _ name -> name),
        alias))
     impDecls
@@ -391,11 +392,11 @@ unrestrictedModuleImports idecls =
 -- Similar to GHC.lookupModule
 -- ezyang: Not really...
 lookupModuleDyn ::
-  UnitState -> Maybe Unit -> ModuleName -> Module
-lookupModuleDyn _ (Just pkgId) mdlName =
-  Module.mkModule pkgId mdlName
-lookupModuleDyn state Nothing mdlName =
-  case lookupModuleInAllUnits state mdlName of
+  UnitState -> PkgQual -> ModuleName -> Module
+lookupModuleDyn state pkg_qual mdlName = case pkg_qual of
+  OtherPkg uid -> Module.mkModule (RealUnit (Definite uid)) mdlName
+  ThisPkg uid  -> Module.mkModule (RealUnit (Definite uid)) mdlName
+  NoPkgQual    -> case lookupModuleInAllUnits state mdlName of
     (m,_):_ -> m
     [] -> Module.mkModule Module.mainUnit mdlName
 
@@ -404,7 +405,7 @@ lookupModuleDyn state Nothing mdlName =
 -- Warnings
 -------------------------------------------------------------------------------
 
-mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> ErrMsgM WarningMap
+mkWarningMap :: DynFlags -> Warnings a -> GlobalRdrEnv -> [Name] -> ErrMsgM WarningMap
 mkWarningMap dflags warnings gre exps = case warnings of
   NoWarnings  -> pure M.empty
   WarnAll _   -> pure M.empty
@@ -415,18 +416,18 @@ mkWarningMap dflags warnings gre exps = case warnings of
               , let n = greMangledName elt, n `elem` exps ]
     in M.fromList <$> traverse (bitraverse pure (parseWarning dflags gre)) ws'
 
-moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> ErrMsgM (Maybe (Doc Name))
+moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings a -> ErrMsgM (Maybe (Doc Name))
 moduleWarning _ _ NoWarnings = pure Nothing
 moduleWarning _ _ (WarnSome _) = pure Nothing
 moduleWarning dflags gre (WarnAll w) = Just <$> parseWarning dflags gre w
 
-parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> ErrMsgM (Doc Name)
+parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt a -> ErrMsgM (Doc Name)
 parseWarning dflags gre w = case w of
-  DeprecatedTxt _ msg -> format "Deprecated: " (foldMap (bytesFS . sl_fs . unLoc) msg)
-  WarningTxt    _ msg -> format "Warning: "    (foldMap (bytesFS . sl_fs . unLoc) msg)
+  DeprecatedTxt _ msg -> format "Deprecated: " (foldMap (unpackFS . sl_fs . hsDocString . unLoc) msg)
+  WarningTxt    _ msg -> format "Warning: "    (foldMap (unpackFS . sl_fs . hsDocString . unLoc) msg)
   where
     format x bs = DocWarning . DocParagraph . DocAppend (DocString x)
-                  <$> processDocString dflags gre (mkHsDocStringUtf8ByteString bs)
+                  <$> processDocStringFromString dflags gre bs
 
 
 -------------------------------------------------------------------------------
@@ -478,7 +479,7 @@ mkMaps :: DynFlags
        -> Maybe Package  -- this package
        -> GlobalRdrEnv
        -> [Name]
-       -> [(LHsDecl GhcRn, [HsDocString])]
+       -> [(LHsDecl GhcRn, [HsDoc GhcRn])]
        -> ExtractedTHDocs -- ^ Template Haskell putDoc docs
        -> ErrMsgM Maps
 mkMaps dflags pkgName gre instances decls thDocs = do
@@ -511,36 +512,40 @@ mkMaps dflags pkgName gre instances decls thDocs = do
     thMappings = do
       let ExtractedTHDocs
             _
-            (DeclDocMap declDocs)
-            (ArgDocMap argDocs)
-            (DeclDocMap instDocs) = thDocs
-          ds2mdoc :: HsDocString -> ErrMsgM (MDoc Name)
-          ds2mdoc = processDocStringParas dflags pkgName gre
-
-      declDocs' <- mapM ds2mdoc declDocs
-      argDocs'  <- mapM (mapM ds2mdoc) argDocs
-      instDocs' <- mapM ds2mdoc instDocs
+            declDocs
+            argDocs
+            instDocs = thDocs
+          ds2mdoc :: (HsDoc GhcRn) -> ErrMsgM (MDoc Name)
+          ds2mdoc = processDocStringParas dflags pkgName gre . hsDocString
+
+      let cvt = M.fromList . nonDetEltsUniqMap
+
+      declDocs' <- mapM ds2mdoc (cvt declDocs)
+      argDocs'  <- mapM (mapM ds2mdoc) (cvt argDocs)
+      instDocs' <- mapM ds2mdoc (cvt instDocs)
       return (declDocs' <> instDocs', argDocs')
 
 
-    mappings :: (LHsDecl GhcRn, [HsDocString])
+    mappings :: (LHsDecl GhcRn, [HsDoc GhcRn])
              -> ErrMsgM ( [(Name, MDoc Name)]
                         , [(Name, IntMap (MDoc Name))]
                         , [(Name,  [LHsDecl GhcRn])]
                         )
-    mappings (ldecl@(L (SrcSpanAnn _ (RealSrcSpan l _)) decl), docStrs) = do
-      let declDoc :: [HsDocString] -> IntMap HsDocString
+    mappings (ldecl@(L (SrcSpanAnn _ (RealSrcSpan l _)) decl), hs_docStrs) = do
+      let docStrs = map hsDocString hs_docStrs
+          declDoc :: [HsDocString] -> IntMap HsDocString
                   -> ErrMsgM (Maybe (MDoc Name), IntMap (MDoc Name))
           declDoc strs m = do
             doc' <- processDocStrings dflags pkgName gre strs
             m'   <- traverse (processDocStringParas dflags pkgName gre) m
             pure (doc', m')
 
-      (doc, args) <- declDoc docStrs (declTypeDocs decl)
+      (doc, args) <- declDoc docStrs (fmap hsDocString (declTypeDocs decl))
 
       let
           subs :: [(Name, [HsDocString], IntMap HsDocString)]
-          subs = subordinates instanceMap decl
+          subs = map (\(n, ds, im) -> (n, map hsDocString ds, fmap hsDocString im))
+                  $ subordinates emptyOccEnv instanceMap decl
 
       (subDocs, subArgs) <- unzip <$> traverse (\(_, strs, m) -> declDoc strs m) subs
 
@@ -571,7 +576,23 @@ mkMaps dflags pkgName gre instances decls thDocs = do
               TyFamInstD _ (TyFamInstDecl _ d') -> getLocA (feqn_tycon d')
               _ -> getInstLoc d
     names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See note [2].
-    names _ decl = getMainDeclBinder decl
+    names _ decl = getMainDeclBinder emptyOccEnv decl
+
+-- | Unions together two 'ArgDocMaps' (or ArgMaps in haddock-api), such that two
+-- maps with values for the same key merge the inner map as well.
+-- Left biased so @unionArgMaps a b@ prefers @a@ over @b@.
+
+unionArgMaps :: forall b . Map Name (IntMap b)
+             -> Map Name (IntMap b)
+             -> Map Name (IntMap b)
+unionArgMaps a b = M.foldrWithKey go b a
+  where
+    go :: Name -> IntMap b
+            -> Map Name (IntMap b) -> Map Name (IntMap b)
+    go n newArgMap acc
+      | Just oldArgMap <- M.lookup n acc =
+          M.insert n (newArgMap `IM.union` oldArgMap) acc
+      | otherwise = M.insert n newArgMap acc
 
 -- Note [2]:
 ------------
@@ -633,11 +654,11 @@ mkExportItems
     Just exports -> liftM concat $ mapM lookupExport exports
   where
     lookupExport (IEGroup _ lev docStr, _)  = liftErrMsg $ do
-      doc <- processDocString dflags gre docStr
+      doc <- processDocString dflags gre (hsDocString . unLoc $ docStr)
       return [ExportGroup lev "" doc]
 
     lookupExport (IEDoc _ docStr, _)        = liftErrMsg $ do
-      doc <- processDocStringParas dflags pkgName gre docStr
+      doc <- processDocStringParas dflags pkgName gre (hsDocString . unLoc $ docStr)
       return [ExportDoc doc]
 
     lookupExport (IEDocNamed _ str, _)      = liftErrMsg $
@@ -705,7 +726,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
           export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap
           return [export]
         (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds ->
-          let declNames = getMainDeclBinder (unL decl)
+          let declNames = getMainDeclBinder emptyOccEnv (unL decl)
           in case () of
             _
               -- We should not show a subordinate by itself if any of its
@@ -784,7 +805,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
 
           let
             patSynNames =
-              concatMap (getMainDeclBinder . fst) bundledPatSyns
+              concatMap (getMainDeclBinder emptyOccEnv . fst) bundledPatSyns
 
             fixities =
                 [ (n, f)
@@ -1006,17 +1027,17 @@ fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNam
   (concat . concat) `fmap` (for decls $ \decl -> do
     case decl of
       (L _ (DocD _ (DocGroup lev docStr))) -> do
-        doc <- liftErrMsg (processDocString dflags gre docStr)
+        doc <- liftErrMsg (processDocString dflags gre (hsDocString . unLoc $ docStr))
         return [[ExportGroup lev "" doc]]
       (L _ (DocD _ (DocCommentNamed _ docStr))) -> do
-        doc <- liftErrMsg (processDocStringParas dflags pkgName gre docStr)
+        doc <- liftErrMsg (processDocStringParas dflags pkgName gre (hsDocString . unLoc $ docStr))
         return [[ExportDoc doc]]
       (L _ (ValD _ valDecl))
         | name:_ <- collectHsBindBinders CollNoDictBinders valDecl
         , Just (L _ SigD{}:_) <- filter isSigD <$> M.lookup name declMap
         -> return []
       _ ->
-        for (getMainDeclBinder (unLoc decl)) $ \nm -> do
+        for (getMainDeclBinder emptyOccEnv (unLoc decl)) $ \nm -> do
           case lookupNameEnv availEnv nm of
             Just avail ->
               availExportItem is_sig modMap thisMod
@@ -1041,7 +1062,7 @@ extractDecl
   -> LHsDecl GhcRn             -- ^ parent declaration
   -> Either ErrMsg (LHsDecl GhcRn)
 extractDecl declMap name decl
-  | name `elem` getMainDeclBinder (unLoc decl) = pure decl
+  | name `elem` getMainDeclBinder emptyOccEnv (unLoc decl) = pure decl
   | otherwise  =
     case unLoc decl of
       TyClD _ d@ClassDecl { tcdLName = L _ clsNm
@@ -1109,7 +1130,7 @@ extractDecl declMap name decl
                                , Just rec <- map (getRecConArgs_maybe . unLoc) (dd_cons (feqn_rhs d))
                                , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec)
                                , L _ n <- ns
-                               , extFieldOcc n == name
+                               , foExt n == name
                           ]
             in case matches of
               [d0] -> extractDecl declMap name (noLocA . InstD noExtField $ DataFamInstD noExtField d0)
@@ -1138,17 +1159,17 @@ extractPatternSyn nm t tvs cons =
               InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2]
             ConDeclGADT { con_g_args = con_args' } -> case con_args' of
               PrefixConGADT args' -> map hsScaledThing args'
-              RecConGADT (L _ fields) -> cd_fld_type . unLoc <$> fields
+              RecConGADT (L _ fields) _ -> cd_fld_type . unLoc <$> fields
         typ = longArrow args (data_ty con)
         typ' =
           case con of
-            ConDeclH98 { con_mb_cxt = Just cxt } -> noLocA (HsQualTy noExtField (Just cxt) typ)
+            ConDeclH98 { con_mb_cxt = Just cxt } -> noLocA (HsQualTy noExtField cxt typ)
             _ -> typ
-        typ'' = noLocA (HsQualTy noExtField Nothing typ')
+        typ'' = noLocA (HsQualTy noExtField (noLocA []) typ')
     in PatSynSig noAnn [noLocA nm] (mkEmptySigType typ'')
 
   longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn
-  longArrow inputs output = foldr (\x y -> noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) x y)) output inputs
+  longArrow inputs output = foldr (\x y -> noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) x y)) output inputs
 
   data_ty con
     | ConDeclGADT{} <- con = con_res_ty con
@@ -1165,12 +1186,12 @@ extractRecSel _ _ _ [] = Left "extractRecSel: selector not found"
 extractRecSel nm t tvs (L _ con : rest) =
   case getRecConArgs_maybe con of
     Just (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields ->
-      pure (L (noAnnSrcSpan l) (TypeSig noAnn [noLocA nm] (mkEmptyWildCardBndrs $ mkEmptySigType (noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty))))))
+      pure (L (noAnnSrcSpan l) (TypeSig noAnn [noLocA nm] (mkEmptyWildCardBndrs $ mkEmptySigType (noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) 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, extFieldOcc n == nm ]
+  matching_fields flds = [ (locA l,f) | f@(L _ (ConDeclField _ ns _ _)) <- flds
+                                      , L l n <- ns, foExt n == nm ]
   data_ty
     -- ResTyGADT _ ty <- con_res con = ty
     | ConDeclGADT{} <- con = con_res_ty con
@@ -1196,10 +1217,10 @@ mkVisibleNames (_, _, _, instMap) exports opts
   where
     exportName e@ExportDecl {} = name ++ subs ++ patsyns
       where subs    = map fst (expItemSubDocs e)
-            patsyns = concatMap (getMainDeclBinder . fst) (expItemPats e)
+            patsyns = concatMap (getMainDeclBinder emptyOccEnv . fst) (expItemPats e)
             name = case unLoc $ expItemDecl e of
               InstD _ d -> maybeToList $ SrcLoc.lookupSrcSpan (getInstLoc d) instMap
-              decl      -> getMainDeclBinder decl
+              decl      -> getMainDeclBinder emptyOccEnv decl
     exportName ExportNoDecl {} = [] -- we don't count these as visible, since
                                     -- we don't want links to go to them.
     exportName _ = []
@@ -1216,6 +1237,7 @@ findNamedDoc name = search
       tell ["Cannot find documentation for: $" ++ name]
       return Nothing
     search (DocD _ (DocCommentNamed name' doc) : rest)
-      | name == name' = return (Just doc)
+      | name == name' = return (Just (hsDocString . unLoc $ doc))
+
       | otherwise = search rest
     search (_other_decl : rest) = search rest
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index d769f0cc..4e1964af 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -15,6 +15,7 @@
 -----------------------------------------------------------------------------
 module Haddock.Interface.LexParseRn
   ( processDocString
+  , processDocStringFromString
   , processDocStringParas
   , processDocStrings
   , processModuleHeader
@@ -38,6 +39,7 @@ 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))
@@ -52,11 +54,15 @@ processDocStrings dflags pkg gre strs = do
 
 processDocStringParas :: DynFlags -> Maybe Package -> GlobalRdrEnv -> HsDocString -> ErrMsgM (MDoc Name)
 processDocStringParas dflags pkg gre hds =
-  overDocF (rename dflags gre) $ parseParas dflags pkg (unpackHDS hds)
+  overDocF (rename dflags gre) $ parseParas dflags pkg (renderHsDocString hds)
 
 processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Doc Name)
 processDocString dflags gre hds =
-  rename dflags gre $ parseString dflags (unpackHDS hds)
+  processDocStringFromString dflags gre (renderHsDocString hds)
+
+processDocStringFromString :: DynFlags -> GlobalRdrEnv -> String -> ErrMsgM (Doc Name)
+processDocStringFromString dflags gre hds =
+  rename dflags gre $ parseString dflags hds
 
 processModuleHeader :: DynFlags -> Maybe Package -> GlobalRdrEnv -> SafeHaskellMode -> Maybe HsDocString
                     -> ErrMsgM (HaddockModInfo Name, Maybe (MDoc Name))
@@ -65,7 +71,7 @@ processModuleHeader dflags pkgName gre safety mayStr = do
     case mayStr of
       Nothing -> return failure
       Just hds -> do
-        let str = unpackHDS hds
+        let str = renderHsDocString hds
             (hmi, doc) = parseModuleHeader dflags pkgName str
         !descr <- case hmi_description hmi of
                     Just hmi_descr -> Just <$> rename dflags gre hmi_descr
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 2833df49..6057bf75 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -191,8 +191,8 @@ renameDocumentation (Documentation mDoc mWarning) =
   Documentation <$> mapM renameDoc mDoc <*> mapM renameDoc mWarning
 
 
-renameLDocHsSyn :: LHsDocString -> RnM LHsDocString
-renameLDocHsSyn = return
+renameLDocHsSyn :: Located (WithHsDocIdentifiers HsDocString a) -> RnM (Located (WithHsDocIdentifiers HsDocString b))
+renameLDocHsSyn (L l doc) = return (L l (WithHsDocIdentifiers (hsDocString doc) []))
 
 
 renameDoc :: Traversable t => t (Wrap Name) -> RnM (t (Wrap DocName))
@@ -245,9 +245,10 @@ renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
 renameMaybeInjectivityAnn = traverse renameInjectivityAnn
 
 renameArrow :: HsArrow GhcRn -> RnM (HsArrow DocNameI)
-renameArrow (HsUnrestrictedArrow u) = return (HsUnrestrictedArrow u)
-renameArrow (HsLinearArrow u a) = return (HsLinearArrow u a)
-renameArrow (HsExplicitMult u a p) = HsExplicitMult u a <$> renameLType p
+renameArrow (HsUnrestrictedArrow arr) = return (HsUnrestrictedArrow arr)
+renameArrow (HsLinearArrow (HsPct1 pct1 arr)) = return (HsLinearArrow (HsPct1 pct1 arr))
+renameArrow (HsLinearArrow (HsLolly arr)) = return (HsLinearArrow (HsLolly arr))
+renameArrow (HsExplicitMult pct p arr) = (\p' -> HsExplicitMult pct p' arr) <$> renameLType p
 
 renameType :: HsType GhcRn -> RnM (HsType DocNameI)
 renameType t = case t of
@@ -258,7 +259,7 @@ renameType t = case t of
                        , hst_tele = tele', hst_body = ltype' })
 
   HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do
-    lcontext' <- traverse renameLContext lcontext
+    lcontext' <- renameLContext lcontext
     ltype'    <- renameLType ltype
     return (HsQualTy { hst_xqual = noAnn, hst_ctxt = lcontext', hst_body = ltype' })
 
@@ -289,11 +290,11 @@ renameType t = case t of
   HsTupleTy _ b ts -> return . HsTupleTy noAnn b =<< mapM renameLType ts
   HsSumTy _ ts -> HsSumTy noAnn <$> mapM renameLType ts
 
-  HsOpTy _ a (L loc op) b -> do
+  HsOpTy _ prom a (L loc op) b -> do
     op' <- rename op
     a'  <- renameLType a
     b'  <- renameLType b
-    return (HsOpTy noAnn a' (L loc op') b')
+    return (HsOpTy noAnn prom a' (L loc op') b')
 
   HsParTy _ ty -> return . (HsParTy noAnn) =<< renameLType ty
 
@@ -316,6 +317,7 @@ renameType t = case t of
   HsSpliceTy _ s          -> renameHsSpliceTy s
   HsWildCardTy _          -> pure (HsWildCardTy noAnn)
 
+
 renameSigType :: HsSigType GhcRn -> RnM (HsSigType DocNameI)
 renameSigType (HsSig { sig_bndrs = bndrs, sig_body = body }) = do
   bndrs' <- renameOuterTyVarBndrs bndrs
@@ -505,15 +507,15 @@ renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI)
 renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars
                            , con_mb_cxt = lcontext, con_args = details
                            , con_doc = mbldoc
-                           , con_forall = forall }) = do
+                           , con_forall = forall_ }) = do
       lname'    <- renameL lname
       ltyvars'  <- mapM renameLTyVarBndr ltyvars
       lcontext' <- traverse renameLContext lcontext
       details'  <- renameH98Details details
-      mbldoc'   <- mapM renameLDocHsSyn mbldoc
+      mbldoc'   <- mapM (renameLDocHsSyn) mbldoc
       return (decl { con_ext = noExtField, con_name = lname', con_ex_tvs = ltyvars'
                    , con_mb_cxt = lcontext'
-                   , con_forall = forall -- Remove when #18311 is fixed
+                   , con_forall = forall_ -- Remove when #18311 is fixed
                    , con_args = details', con_doc = mbldoc' })
 
 renameCon ConDeclGADT { con_names = lnames, con_bndrs = bndrs
@@ -548,9 +550,9 @@ renameH98Details (InfixCon a b) = do
 
 renameGADTDetails :: HsConDeclGADTDetails GhcRn
                   -> RnM (HsConDeclGADTDetails DocNameI)
-renameGADTDetails (RecConGADT (L l fields)) = do
+renameGADTDetails (RecConGADT (L l fields) arr) = do
   fields' <- mapM renameConDeclFieldField fields
-  return (RecConGADT (L (locA l) fields'))
+  return (RecConGADT (L (locA l) fields') arr)
 renameGADTDetails (PrefixConGADT ps) = PrefixConGADT <$> mapM renameHsScaled ps
 
 renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI)
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 16f00fda..d1164858 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -16,6 +16,7 @@ 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 )
@@ -132,9 +133,9 @@ sugarTuples typ =
 
 
 sugarOperators :: HsType GhcRn -> HsType GhcRn
-sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb)
-    | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb
-    | unrestrictedFunTyConName == name' = HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) la lb
+sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ prom (L l name))) la)) lb)
+    | isSymOcc $ getOccName name' = mkHsOpTy prom la (L l name) lb
+    | unrestrictedFunTyConName == name' = HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) la lb
   where
     name' = getName name
 sugarOperators typ = typ
@@ -283,7 +284,7 @@ renameType (HsForAllTy x tele lt) =
         <*> renameLType lt
 renameType (HsQualTy x lctxt lt) =
     HsQualTy x
-        <$> renameMContext lctxt
+        <$> renameLContext lctxt
         <*> renameLType lt
 renameType (HsTyVar x ip name) = HsTyVar x ip <$> locatedN renameName name
 renameType t@(HsStarTy _ _) = pure t
@@ -293,8 +294,8 @@ renameType (HsFunTy x w la lr) = HsFunTy x <$> renameHsArrow w <*> renameLType l
 renameType (HsListTy x lt) = HsListTy 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 <*> locatedN renameName lop <*> renameLType lb
+renameType (HsOpTy x prom la lop lb) =
+    HsOpTy x prom <$> renameLType la <*> locatedN renameName lop <*> renameLType lb
 renameType (HsParTy x lt) = HsParTy x <$> renameLType lt
 renameType (HsIParamTy x ip lt) = HsIParamTy x ip <$> renameLType lt
 renameType (HsKindSig x lt lk) = HsKindSig x <$> renameLType lt <*> pure lk
@@ -311,7 +312,7 @@ renameType t@(HsTyLit _ _) = pure t
 renameType (HsWildCardTy wc) = pure (HsWildCardTy wc)
 
 renameHsArrow :: HsArrow GhcRn -> Rename (IdP GhcRn) (HsArrow GhcRn)
-renameHsArrow (HsExplicitMult u a p) = HsExplicitMult u a <$> renameLType p
+renameHsArrow (HsExplicitMult pct p arr) = (\p' -> HsExplicitMult pct p' arr) <$> renameLType p
 renameHsArrow mult = pure mult
 
 
@@ -324,11 +325,10 @@ renameLKind = renameLType
 renameLTypes :: [LHsType GhcRn] -> Rename (IdP GhcRn) [LHsType GhcRn]
 renameLTypes = mapM renameLType
 
-renameMContext :: Maybe (LHsContext GhcRn) -> Rename (IdP GhcRn) (Maybe (LHsContext GhcRn))
-renameMContext Nothing = return Nothing
-renameMContext (Just (L l ctxt)) = do
+renameLContext :: LHsContext GhcRn -> Rename (IdP GhcRn) (LHsContext GhcRn)
+renameLContext (L l ctxt) = do
   ctxt' <- renameContext ctxt
-  return (Just (L l ctxt'))
+  return (L l ctxt')
 
 renameContext :: HsContext GhcRn -> Rename (IdP GhcRn) (HsContext GhcRn)
 renameContext = renameLTypes
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index fa51bcbc..d83578b1 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -16,39 +16,28 @@
 -- Reading and writing the .haddock interface file
 -----------------------------------------------------------------------------
 module Haddock.InterfaceFile (
-  InterfaceFile(..), PackageInfo(..), ifUnitId, ifModule,
-  PackageInterfaces(..), mkPackageInterfaces, ppPackageInfo, readInterfaceFile,
-  nameCacheFromGhc, freshNameCache, NameCacheAccessor, writeInterfaceFile,
-  binaryInterfaceVersion, binaryInterfaceVersionCompatibility
+  InterfaceFile(..), ifUnitId, ifModule,
+  readInterfaceFile, freshNameCache,
+  writeInterfaceFile, binaryInterfaceVersion, binaryInterfaceVersionCompatibility
 ) where
 
 
 import Haddock.Types
 
-import Control.Monad
-import Control.Monad.IO.Class ( MonadIO(..) )
-import Data.Array
 import Data.IORef
-import Data.List (mapAccumR)
 import qualified Data.Map as Map
 import Data.Map (Map)
 import Data.Version
 import Data.Word
 import Text.ParserCombinators.ReadP (readP_to_S)
 
-import GHC.Iface.Binary (getSymtabName, getDictFastString)
-import GHC.Unit.State
+import GHC.Iface.Binary (getWithUserData, putSymbolTable)
 import GHC.Utils.Binary
 import GHC.Data.FastMutInt
 import GHC.Data.FastString
 import GHC hiding (NoLink)
-import GHC.Driver.Monad (withSession)
-import GHC.Driver.Env
 import GHC.Types.Name.Cache
-import GHC.Iface.Env
-import GHC.Types.Name
 import GHC.Types.Unique.FM
-import GHC.Types.Unique.Supply
 import GHC.Types.Unique
 
 import Haddock.Options (Visibility (..))
@@ -131,12 +120,11 @@ binaryInterfaceMagic = 0xD0Cface
 -- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion]
 --
 binaryInterfaceVersion :: Word16
-#if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,3,0)
-binaryInterfaceVersion = 39
+#if MIN_VERSION_ghc(9,4,0) && !MIN_VERSION_ghc(9,5,0)
+binaryInterfaceVersion = 40
 
 binaryInterfaceVersionCompatibility :: [Word16]
-binaryInterfaceVersionCompatibility = [37, 38, binaryInterfaceVersion]
-#elif defined(__HLINT__)
+binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]
 #else
 #error Unsupported GHC version
 #endif
@@ -203,103 +191,31 @@ writeInterfaceFile filename iface = do
   return ()
 
 
-type NameCacheAccessor m = (m NameCache, NameCache -> m ())
-
-
-nameCacheFromGhc :: forall m. GhcMonad m => NameCacheAccessor m
-nameCacheFromGhc = ( read_from_session , write_to_session )
-  where
-    read_from_session = do
-       ref <- withSession (return . hsc_NC)
-       liftIO $ readIORef ref
-    write_to_session nc' = do
-       ref <- withSession (return . hsc_NC)
-       liftIO $ writeIORef ref nc'
-
-
-freshNameCache :: NameCacheAccessor IO
-freshNameCache = ( create_fresh_nc , \_ -> return () )
-  where
-    create_fresh_nc = do
-       u  <- mkSplitUniqSupply 'a' -- ??
-       return (initNameCache u [])
-
+freshNameCache :: IO NameCache
+freshNameCache = initNameCache 'a' -- ??
+                               []
 
 -- | Read a Haddock (@.haddock@) interface file. Return either an
 -- 'InterfaceFile' or an error message.
 --
 -- This function can be called in two ways.  Within a GHC session it will
 -- update the use and update the session's name cache.  Outside a GHC session
--- a new empty name cache is used.  The function is therefore generic in the
--- monad being used.  The exact monad is whichever monad the first
--- argument, the getter and setter of the name cache, requires.
---
-readInterfaceFile :: forall m.
-                     MonadIO m
-                  => NameCacheAccessor m
+-- a new empty name cache is used.
+readInterfaceFile :: NameCache
                   -> FilePath
                   -> Bool  -- ^ Disable version check. Can cause runtime crash.
-                  -> m (Either String InterfaceFile)
-readInterfaceFile (get_name_cache, set_name_cache) filename bypass_checks = do
-  bh0 <- liftIO $ readBinMem filename
-
-  magic   <- liftIO $ get bh0
-  version <- liftIO $ get bh0
-
-  case () of
-    _ | magic /= binaryInterfaceMagic -> return . Left $
-      "Magic number mismatch: couldn't load interface file: " ++ filename
-      | not bypass_checks
-      , (version `notElem` binaryInterfaceVersionCompatibility) -> return . Left $
-      "Interface file is of wrong version: " ++ filename
-      | otherwise -> with_name_cache $ \update_nc -> do
-
-      dict  <- get_dictionary bh0
-
-      -- read the symbol table so we are capable of reading the actual data
-      bh1 <- do
-          let bh1 = setUserData bh0 $ newReadState (error "getSymtabName")
-                                                   (getDictFastString dict)
-          symtab <- update_nc (get_symbol_table bh1)
-          return $ setUserData bh1 $ newReadState (getSymtabName (NCU (\f -> update_nc (return . f))) dict symtab)
-                                                  (getDictFastString dict)
-
-      -- load the actual data
-      iface <- liftIO $ getInterfaceFile bh1 version
-      return (Right iface)
- where
-   with_name_cache :: forall a.
-                      ((forall n b. MonadIO n
-                                => (NameCache -> n (NameCache, b))
-                                -> n b)
-                       -> m a)
-                   -> m a
-   with_name_cache act = do
-      nc_var <-  get_name_cache >>= (liftIO . newIORef)
-      x <- act $ \f -> do
-              nc <- liftIO $ readIORef nc_var
-              (nc', x) <- f nc
-              liftIO $ writeIORef nc_var nc'
-              return x
-      liftIO (readIORef nc_var) >>= set_name_cache
-      return x
-
-   get_dictionary bin_handle = liftIO $ do
-      dict_p <- get bin_handle
-      data_p <- tellBin bin_handle
-      seekBin bin_handle dict_p
-      dict <- getDictionary bin_handle
-      seekBin bin_handle data_p
-      return dict
-
-   get_symbol_table bh1 theNC = liftIO $ do
-      symtab_p <- get bh1
-      data_p'  <- tellBin bh1
-      seekBin bh1 symtab_p
-      (nc', symtab) <- getSymbolTable bh1 theNC
-      seekBin bh1 data_p'
-      return (nc', symtab)
-
+                  -> IO (Either String InterfaceFile)
+readInterfaceFile name_cache filename bypass_checks = do
+  bh <- readBinMem filename
+
+  magic   <- get bh
+  if magic /= binaryInterfaceMagic
+    then return . Left $ "Magic number mismatch: couldn't load interface file: " ++ filename
+    else do
+      version <- get bh
+      if not bypass_checks && (version `notElem` binaryInterfaceVersionCompatibility)
+        then return . Left $ "Interface file is of wrong version: " ++ filename
+        else Right <$> getWithUserData name_cache bh
 
 -------------------------------------------------------------------------------
 -- * Symbol table
@@ -350,56 +266,6 @@ data BinDictionary = BinDictionary {
                                 -- indexed by FastString
   }
 
-
-putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int,Name) -> IO ()
-putSymbolTable bh next_off symtab = do
-  put_ bh next_off
-  let names = elems (array (0,next_off-1) (eltsUFM symtab))
-  mapM_ (\n -> serialiseName bh n symtab) names
-
-
-getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, Array Int Name)
-getSymbolTable bh namecache = do
-  sz <- get bh
-  od_names <- replicateM sz (get bh)
-  let arr = listArray (0,sz-1) names
-      (namecache', names) = mapAccumR (fromOnDiskName arr) namecache od_names
-  return (namecache', arr)
-
-
-type OnDiskName = (Unit, ModuleName, OccName)
-
-
-fromOnDiskName
-   :: Array Int Name
-   -> NameCache
-   -> OnDiskName
-   -> (NameCache, Name)
-fromOnDiskName _ nc (pid, mod_name, occ) =
-  let
-        modu  = mkModule pid mod_name
-        cache = nsNames nc
-  in
-  case lookupOrigNameCache cache modu occ of
-     Just name -> (nc, name)
-     Nothing   ->
-        let
-                us        = nsUniqs nc
-                u         = uniqFromSupply us
-                name      = mkExternalName u modu occ noSrcSpan
-                new_cache = extendNameCache cache modu occ name
-        in
-        case splitUniqSupply us of { (us',_) ->
-        ( nc{ nsUniqs = us', nsNames = new_cache }, name )
-        }
-
-
-serialiseName :: BinHandle -> Name -> UniqFM Name (Int,Name) -> IO ()
-serialiseName bh name _ = do
-  let modu = nameModule name
-  put_ bh (moduleUnit modu, moduleName modu, nameOccName name)
-
-
 -------------------------------------------------------------------------------
 -- * GhcBinary instances
 -------------------------------------------------------------------------------
diff --git a/haddock-api/src/Haddock/Parser.hs b/haddock-api/src/Haddock/Parser.hs
index a7230e25..850fdf7f 100644
--- a/haddock-api/src/Haddock/Parser.hs
+++ b/haddock-api/src/Haddock/Parser.hs
@@ -18,7 +18,7 @@ import Documentation.Haddock.Types
 import Haddock.Types
 
 import GHC.Driver.Session ( DynFlags )
-import GHC.Driver.Config
+import GHC.Driver.Config.Parser (initParserOpts)
 import GHC.Data.FastString   ( fsLit )
 import GHC.Parser.Lexer ( initParserState, unP, ParseResult(POk, PFailed) )
 import GHC.Parser       ( parseIdentifier )
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 08d74f53..e30d2ce7 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -1,4 +1,5 @@
-{-# LANGUAGE CPP, DeriveDataTypeable, DeriveTraversable, StandaloneDeriving, TypeFamilies, RecordWildCards #-}
+{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies, RecordWildCards #-}
+{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE PartialTypeSignatures #-}
@@ -319,7 +320,8 @@ type instance NoGhcTc DocNameI = DocNameI
 type instance IdP DocNameI = DocName
 
 instance CollectPass DocNameI where
-  collectXXPat _ _ ext = noExtCon ext
+  collectXXPat _ ext = dataConCantHappen ext
+  collectXXHsBindsLR ext = dataConCantHappen ext
 
 instance NamedThing DocName where
   getName (Documented name _) = name
@@ -709,8 +711,8 @@ type instance Anno (HsTyVarBndr flag DocNameI)       = SrcSpanAnnA
 type instance Anno [LocatedA (HsType DocNameI)]      = SrcSpanAnnC
 type instance Anno (HsType DocNameI)                 = SrcSpanAnnA
 type instance Anno (DataFamInstDecl DocNameI)        = SrcSpanAnnA
-type instance Anno (DerivStrategy DocNameI)          = SrcSpan
-type instance Anno (FieldOcc DocNameI)               = SrcSpan
+type instance Anno (DerivStrategy DocNameI)          = SrcAnn NoEpAnns
+type instance Anno (FieldOcc DocNameI)               = SrcAnn NoEpAnns
 type instance Anno (ConDeclField DocNameI)           = SrcSpan
 type instance Anno (Located (ConDeclField DocNameI)) = SrcSpan
 type instance Anno [Located (ConDeclField DocNameI)] = SrcSpan
@@ -720,9 +722,9 @@ type instance Anno (TyFamInstDecl DocNameI)          = SrcSpanAnnA
 type instance Anno [LocatedA (TyFamInstDecl DocNameI)] = SrcSpanAnnL
 type instance Anno (FamilyDecl DocNameI)               = SrcSpan
 type instance Anno (Sig DocNameI)                      = SrcSpan
-type instance Anno (InjectivityAnn DocNameI)           = SrcSpan
+type instance Anno (InjectivityAnn DocNameI)           = SrcAnn NoEpAnns
 type instance Anno (HsDecl DocNameI)                   = SrcSpanAnnA
-type instance Anno (FamilyResultSig DocNameI)          = SrcSpan
+type instance Anno (FamilyResultSig DocNameI)          = SrcAnn NoEpAnns
 type instance Anno (HsOuterTyVarBndrs Specificity DocNameI) = SrcSpanAnnA
 type instance Anno (HsSigType DocNameI)                     = SrcSpanAnnA
 
@@ -760,11 +762,11 @@ type instance XXType           DocNameI = HsCoreTy
 
 type instance XHsForAllVis        DocNameI = NoExtField
 type instance XHsForAllInvis      DocNameI = NoExtField
-type instance XXHsForAllTelescope DocNameI = NoExtCon
+type instance XXHsForAllTelescope DocNameI = DataConCantHappen
 
 type instance XUserTyVar    DocNameI = NoExtField
 type instance XKindedTyVar  DocNameI = NoExtField
-type instance XXTyVarBndr   DocNameI = NoExtCon
+type instance XXTyVarBndr   DocNameI = DataConCantHappen
 
 type instance XCFieldOcc   DocNameI = DocName
 type instance XXFieldOcc   DocNameI = NoExtField
@@ -780,7 +782,7 @@ type instance XForeignExport  DocNameI = NoExtField
 type instance XForeignImport  DocNameI = NoExtField
 type instance XConDeclGADT    DocNameI = NoExtField
 type instance XConDeclH98     DocNameI = NoExtField
-type instance XXConDecl       DocNameI = NoExtCon
+type instance XXConDecl       DocNameI = DataConCantHappen
 
 type instance XDerivD     DocNameI = NoExtField
 type instance XInstD      DocNameI = NoExtField
@@ -791,10 +793,10 @@ type instance XTyClD      DocNameI = NoExtField
 type instance XNoSig            DocNameI = NoExtField
 type instance XCKindSig         DocNameI = NoExtField
 type instance XTyVarSig         DocNameI = NoExtField
-type instance XXFamilyResultSig DocNameI = NoExtCon
+type instance XXFamilyResultSig DocNameI = DataConCantHappen
 
 type instance XCFamEqn       DocNameI _ = NoExtField
-type instance XXFamEqn       DocNameI _ = NoExtCon
+type instance XXFamEqn       DocNameI _ = DataConCantHappen
 
 type instance XCClsInstDecl DocNameI = NoExtField
 type instance XCDerivDecl   DocNameI = NoExtField
@@ -811,23 +813,24 @@ type instance XClassDecl    DocNameI = NoExtField
 type instance XDataDecl     DocNameI = NoExtField
 type instance XSynDecl      DocNameI = NoExtField
 type instance XFamDecl      DocNameI = NoExtField
-type instance XXFamilyDecl  DocNameI = NoExtCon
-type instance XXTyClDecl    DocNameI = NoExtCon
+type instance XXFamilyDecl  DocNameI = DataConCantHappen
+type instance XXTyClDecl    DocNameI = DataConCantHappen
 
 type instance XHsWC DocNameI _ = NoExtField
 
 type instance XHsOuterExplicit    DocNameI _ = NoExtField
 type instance XHsOuterImplicit    DocNameI   = NoExtField
-type instance XXHsOuterTyVarBndrs DocNameI   = NoExtCon
+type instance XXHsOuterTyVarBndrs DocNameI   = DataConCantHappen
 
 type instance XHsSig      DocNameI = NoExtField
-type instance XXHsSigType DocNameI = NoExtCon
+type instance XXHsSigType DocNameI = DataConCantHappen
 
 type instance XHsQTvs        DocNameI = NoExtField
 type instance XConDeclField  DocNameI = NoExtField
-type instance XXConDeclField DocNameI = NoExtCon
+type instance XXConDeclField DocNameI = DataConCantHappen
 
-type instance XXPat DocNameI = NoExtCon
+type instance XXPat DocNameI = DataConCantHappen
+type instance XXHsBindsLR DocNameI a = DataConCantHappen
 
 type instance XCInjectivityAnn DocNameI = NoExtField