ghcide: Add basic support for GHC-9.0.1

I tried to limit the use of CPP to the Compat module as much as possible
by re-exporting the new functions under the old names,
but there is still plenty of pragmas all over the code.

I'm using ghc-api-compat so the imports doesn't need to be changed as much.

Author: anka-213

ghcide/ghcide.cabal

@@ -96,6 +96,7 @@ library
         ghc >= 8.6,
         ghc-check >=0.5.0.1,
         ghc-paths,
+        ghc-api-compat,
         cryptohash-sha1 >=0.11.100 && <0.12,
         hie-bios >= 0.7.1 && < 0.8.0,
         implicit-hie-cradle >= 0.3.0.2 && < 0.4,

ghcide/session-loader/Development/IDE/Session.hs

@@ -79,7 +79,6 @@ import           HscTypes                             (hsc_IC, hsc_NC,
 import           Linker
 import           Module
 import           NameCache
-import           Packages
 
 import           Control.Concurrent.STM               (atomically)
 import           Control.Concurrent.STM.TQueue
@@ -107,7 +106,7 @@ data SessionLoadingOptions = SessionLoadingOptions
   , getCacheDirs        :: String -> [String] -> IO CacheDirs
   -- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags'
   , getInitialGhcLibDir :: IO (Maybe LibDir)
-  , fakeUid             :: InstalledUnitId
+  , fakeUid             :: GHC.InstalledUnitId
     -- ^ unit id used to tag the internal component built by ghcide
     --   To reuse external interface files the unit ids must match,
     --   thus make sure to build them with `--this-unit-id` set to the
@@ -120,7 +119,7 @@ instance Default SessionLoadingOptions where
         ,loadCradle = HieBios.loadCradle
         ,getCacheDirs = getCacheDirsDefault
         ,getInitialGhcLibDir = getInitialGhcLibDirDefault
-        ,fakeUid = toInstalledUnitId (stringToUnitId "main")
+        ,fakeUid = GHC.toInstalledUnitId (GHC.stringToUnit "main")
         }
 
 getInitialGhcLibDirDefault :: IO (Maybe LibDir)
@@ -730,12 +729,12 @@ removeInplacePackages
     -> [InstalledUnitId]
     -> DynFlags
     -> (DynFlags, [InstalledUnitId])
-removeInplacePackages fake_uid us df = (df { packageFlags = ps
-                                  , thisInstalledUnitId = fake_uid }, uids)
+removeInplacePackages fake_uid us df = (setThisInstalledUnitId fake_uid $
+                                       df { packageFlags = ps }, uids)
   where
     (uids, ps) = partitionEithers (map go (packageFlags df))
-    go p@(ExposePackage _ (UnitIdArg u) _) = if toInstalledUnitId u `elem` us
-                                                  then Left (toInstalledUnitId u)
+    go p@(ExposePackage _ (UnitIdArg u) _) = if GHC.toInstalledUnitId u `elem` us
+                                                  then Left (GHC.toInstalledUnitId u)
                                                   else Right p
     go p = Right p
 
@@ -776,7 +775,7 @@ setOptions (ComponentOptions theOpts compRoot _) dflags = do
     -- initPackages parses the -package flags and
     -- sets up the visibility for each component.
     -- Throws if a -package flag cannot be satisfied.
-    (final_df, _) <- liftIO $ wrapPackageSetupException $ initPackages dflags''
+    final_df <- liftIO $ wrapPackageSetupException $ initUnits dflags''
     return (final_df, targets)
 
 

ghcide/src/Development/IDE/Core/Compile.hs

@@ -81,7 +81,15 @@ import           MkIface
 import           StringBuffer                      as SB
 import           TcIface                           (typecheckIface)
 import           TcRnMonad                         hiding (newUnique)
+#if MIN_GHC_API_VERSION(9,0,1)
+import           GHC.Builtin.Names
+import           GHC.Iface.Recomp
+import           GHC.Tc.Gen.Splice
+import           GHC.Tc.Types.Evidence             (EvBind)
+#else
+import           PrelNames
 import           TcSplice
+#endif
 import           TidyPgm
 
 import           Bag
@@ -104,7 +112,6 @@ import qualified GHC.LanguageExtensions            as LangExt
 import           HeaderInfo
 import           Linker                            (unload)
 import           Maybes                            (orElse)
-import           PrelNames
 import           System.Directory
 import           System.FilePath
 import           System.IO.Extra                   (fixIO, newTempFileWithin)
@@ -144,10 +151,10 @@ computePackageDeps
     -> IO (Either [FileDiagnostic] [InstalledUnitId])
 computePackageDeps env pkg = do
     let dflags = hsc_dflags env
-    case lookupInstalledPackage dflags pkg of
+    case oldLookupInstalledPackage dflags pkg of
         Nothing -> return $ Left [ideErrorText (toNormalizedFilePath' noFilePath) $
             T.pack $ "unknown package: " ++ show pkg]
-        Just pkgInfo -> return $ Right $ depends pkgInfo
+        Just pkgInfo -> return $ Right $ unitDepends pkgInfo
 
 typecheckModule :: IdeDefer
                 -> HscEnv
@@ -268,7 +275,10 @@ mkHiFileResultCompile session' tcm simplified_guts ltype = catchErrs $ do
         (guts, details) <- tidyProgram session simplified_guts
         (diags, linkable) <- genLinkable session ms guts
         pure (linkable, details, diags)
-#if MIN_GHC_API_VERSION(8,10,0)
+#if MIN_GHC_API_VERSION(9,0,1)
+  let !partial_iface = force (mkPartialIface session details simplified_guts)
+  final_iface <- mkFullIface session partial_iface Nothing
+#elif MIN_GHC_API_VERSION(8,10,0)
   let !partial_iface = force (mkPartialIface session details simplified_guts)
   final_iface <- mkFullIface session partial_iface
 #else
@@ -336,7 +346,11 @@ generateObjectCode session summary guts = do
                           target = defaultObjectTarget $ targetPlatform $ hsc_dflags session
 #endif
                           session' = session { hsc_dflags = updOptLevel 0 $ (ms_hspp_opts summary') { outputFile = Just dot_o , hscTarget = target}}
+#if MIN_GHC_API_VERSION(9,0,1)
+                      (outputFilename, _mStub, _foreign_files, _cinfos) <- hscGenHardCode session' guts
+#else
                       (outputFilename, _mStub, _foreign_files) <- hscGenHardCode session' guts
+#endif
 #if MIN_GHC_API_VERSION(8,10,0)
                                 (ms_location summary')
 #else
@@ -464,7 +478,15 @@ generateHieAsts hscEnv tcm =
     -- don't export an interface which allows for additional information to be added to hie files.
     let fake_splice_binds = listToBag (map (mkVarBind unitDataConId) (spliceExpresions $ tmrTopLevelSplices tcm))
         real_binds = tcg_binds $ tmrTypechecked tcm
+#if MIN_GHC_API_VERSION(9,0,1)
+        -- TODO: Use some proper values here!
+        evBinds = emptyBag @EvBind :: Bag EvBind
+        clsInsts = [] :: [ClsInst]
+        tyCons = []   :: [TyCon]
+    Just <$> GHC.enrichHie (fake_splice_binds `unionBags` real_binds) (tmrRenamed tcm) evBinds clsInsts tyCons
+#else
     Just <$> GHC.enrichHie (fake_splice_binds `unionBags` real_binds) (tmrRenamed tcm)
+#endif
   where
     dflags = hsc_dflags hscEnv
 
@@ -638,7 +660,7 @@ setupFinderCache mss session = do
 
     -- Make modules available for others that import them,
     -- by putting them in the finder cache.
-    let ims  = map (InstalledModule (thisInstalledUnitId $ hsc_dflags session) . moduleName . ms_mod) mss
+    let ims  = map (installedModule (thisInstalledUnitId $ hsc_dflags session) . moduleName . ms_mod) mss
         ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) mss ims
     -- set the target and module graph in the session
         graph = mkModuleGraph mss
@@ -696,7 +718,7 @@ getModSummaryFromImports env fp modTime contents = do
 
         mod = fmap unLoc mb_mod `orElse` mAIN_NAME
 
-        (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps
+        (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource.unLoc) imps
 
         -- GHC.Prim doesn't exist physically, so don't go looking for it.
         ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc
@@ -765,7 +787,11 @@ parseHeader
        => DynFlags -- ^ flags to use
        -> FilePath  -- ^ the filename (for source locations)
        -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
+#if MIN_GHC_API_VERSION(9,0,1)
+       -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule))
+#else
        -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule GhcPs))
+#endif
 parseHeader dflags filename contents = do
    let loc  = mkRealSrcLoc (mkFastString filename) 1 1
    case unP Parser.parseHeader (mkPState dflags contents loc) of
@@ -814,10 +840,21 @@ parseFileContents env customPreprocessor filename ms = do
       throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr
 #endif
      POk pst rdr_module ->
-         let hpm_annotations =
+         let hpm_annotations :: ApiAnns
+             hpm_annotations =
+#if MIN_GHC_API_VERSION(9,0,1)
+               -- Copied from GHC.Driver.Main
+               ApiAnns {
+                      apiAnnItems = Map.fromListWith (++) $ annotations pst,
+                      apiAnnEofPos = eof_pos pst,
+                      apiAnnComments = Map.fromList (annotations_comments pst),
+                      apiAnnRogueComments = comment_q pst
+                   }
+#else
                (Map.fromListWith (++) $ annotations pst,
                  Map.fromList ((noSrcSpan,comment_q pst)
                                   :annotations_comments pst))
+#endif
              (warns, errs) = getMessages pst dflags
          in
            do
@@ -840,7 +877,7 @@ parseFileContents env customPreprocessor filename ms = do
                   throwE $ diagFromStrings "parser" DsError errs
 
                let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns
-               parsed' <- liftIO $ applyPluginsParsedResultAction env dflags ms hpm_annotations parsed
+               parsed' <- liftIO $ applyPluginsParsedResultAction env dflags ms (hpm_annotations) parsed
 
                -- To get the list of extra source files, we take the list
                -- that the parser gave us,

ghcide/src/Development/IDE/Core/Preprocessor.hs

@@ -1,5 +1,6 @@
 -- Copyright (c) 2019 The DAML Authors. All rights reserved.
 -- SPDX-License-Identifier: Apache-2.0
+{-# LANGUAGE CPP #-}
 
 module Development.IDE.Core.Preprocessor
   ( preprocessor
@@ -79,7 +80,11 @@ preprocessor env filename mbContents = do
         return (contents, opts, dflags)
   where
     logAction :: IORef [CPPLog] -> LogAction
+#if __GLASGOW_HASKELL__ >= 900
+    logAction cppLogs dflags _reason severity srcSpan msg = do
+#else
     logAction cppLogs dflags _reason severity srcSpan _style msg = do
+#endif
       let log = CPPLog severity srcSpan $ T.pack $ showSDoc dflags msg
       modifyIORef cppLogs (log :)
 
@@ -107,7 +112,7 @@ diagsFromCPPLogs filename logs =
     -- informational log messages and attaches them to the initial log message.
     go :: [CPPDiag] -> [CPPLog] -> [CPPDiag]
     go acc [] = reverse $ map (\d -> d {cdMessage = reverse $ cdMessage d}) acc
-    go acc (CPPLog sev (RealSrcSpan span) msg : logs) =
+    go acc (CPPLog sev (OldRealSrcSpan span) msg : logs) =
       let diag = CPPDiag (realSrcSpanToRange span) (toDSeverity sev) [msg]
        in go (diag : acc) logs
     go (diag : diags) (CPPLog _sev (UnhelpfulSpan _) msg : logs) =

ghcide/src/Development/IDE/Core/Rules.hs

@@ -261,7 +261,7 @@ lookupMod
   :: HieDbWriter -- ^ access the database
   -> FilePath -- ^ The `.hie` file we got from the database
   -> ModuleName
-  -> UnitId
+  -> Unit
   -> Bool -- ^ Is this file a boot file?
   -> MaybeT IdeAction Uri
 lookupMod _dbchan _hie_f _mod _uid _boot = MaybeT $ pure Nothing

ghcide/src/Development/IDE/Core/Shake.hs

@@ -709,6 +709,8 @@ newSession extras@ShakeExtras{..} shakeDb acts = do
                 logPriority logger (actionPriority d) msg
                 notifyTestingLogMessage extras msg
 
+        -- The inferred type signature doesn't work in ghc >= 9.0.1
+        workRun :: (forall b. IO b -> IO b) -> IO (IO ())
         workRun restore = withSpan "Shake session" $ \otSpan -> do
           let acts' = pumpActionThread otSpan : map (run otSpan) (reenqueued ++ acts)
           res <- try @SomeException (restore $ shakeRunDatabase shakeDb acts')

ghcide/src/Development/IDE/GHC/CPP.hs

@@ -25,9 +25,8 @@
 module Development.IDE.GHC.CPP(doCpp, addOptP)
 where
 
-import           Development.IDE.GHC.Compat
+import           Development.IDE.GHC.Compat as Compat
 import           FileCleanup
-import           Module
 import           Packages
 import           Panic
 import           SysTools
@@ -188,7 +187,7 @@ addOptP opt = onSettings (onOptP (opt:))
 -- ---------------------------------------------------------------------------
 -- Macros (cribbed from Cabal)
 
-generatePackageVersionMacros :: [PackageConfig] -> String
+generatePackageVersionMacros :: [Compat.PackageConfig] -> String
 generatePackageVersionMacros pkgs = concat
   -- Do not add any C-style comments. See #3389.
   [ generateMacros "" pkgname version
@@ -221,7 +220,7 @@ getGhcVersionPathName dflags = do
   candidates <- case ghcVersionFile dflags of
     Just path -> return [path]
     Nothing -> (map (</> "ghcversion.h")) <$>
-               (getPackageIncludePath dflags [toInstalledUnitId rtsUnitId])
+               (getPackageIncludePath dflags [Compat.toInstalledUnitId Compat.rtsUnit])
 
   found <- filterM doesFileExist candidates
   case found of