Add GHC 9.4 support (#366)

* 9.4 support

* test 9.4.1

* Dont run stack tests for GHC >= 9.4

* Export 'getDynFlags' correctly for GHC < 9

* use cabal-install 3.8

Co-authored-by: Zubin Duggal <[email protected]>

.github/workflows/haskell.yml

@@ -15,7 +15,7 @@ jobs:
     strategy:
       fail-fast: false
       matrix:
-        ghc: ['9.2.4', '9.2.1', '9.0.2', '8.10.7', '8.8.4', '8.6.5']
+        ghc: ['9.4.2', '9.4.1', '9.2.4', '9.2.1', '9.0.2', '8.10.7', '8.8.4', '8.6.5']
         os: [ubuntu-latest, macOS-latest, windows-latest]
 
     steps:
@@ -28,7 +28,7 @@ jobs:
     - uses: haskell/actions/setup@v2
       with:
         ghc-version: ${{ matrix.ghc }}
-        cabal-version: '3.6'
+        cabal-version: '3.8.1.0'
         enable-stack: true
 
     - name: Print extra ghc version

cabal.project

@@ -1 +1,4 @@
 packages: .
+
+allow-newer:
+  co-log-core:base

hie-bios.cabal

@@ -164,7 +164,7 @@ Library
                         extra                >= 1.6.14 && < 1.8,
                         prettyprinter        ^>= 1.7.0,
                         process              >= 1.6.1 && < 1.7,
-                        ghc                  >= 8.6.1 && < 9.3,
+                        ghc                  >= 8.6.1 && < 9.5,
                         transformers         >= 0.5.2 && < 0.7,
                         temporary            >= 1.2 && < 1.4,
                         text                 >= 1.2.3 && < 2.1,

src/HIE/Bios.hs

@@ -30,4 +30,4 @@ import HIE.Bios.Cradle
 import HIE.Bios.Types
 import HIE.Bios.Flags
 import HIE.Bios.Environment
-import HIE.Bios.Ghc.Load
+import HIE.Bios.Ghc.Load

src/HIE/Bios/Environment.hs

@@ -150,7 +150,7 @@ addCmdOpts cmdOpts df1 = do
   let leftovers = map G.unLoc leftovers' ++ additionalTargets
 
   let (df3, srcs, _objs) = Gap.parseTargetFiles df2 leftovers
-  ts <- mapM (uncurry Gap.guessTarget) srcs
+  ts <- mapM (uncurry (\f phase -> Gap.guessTarget f (Just $ Gap.homeUnitId_ df3) phase) ) srcs
   return (df3, ts)
 
 -- | Make filepaths in the given 'DynFlags' absolute.

src/HIE/Bios/Ghc/Api.hs

@@ -64,7 +64,7 @@ initSessionWithMessage msg compOpts = (do
     G.setTargets targets
     -- Get the module graph using the function `getModuleGraph`
     mod_graph <- G.depanal [] True
-    G.load' LoadAllTargets msg mod_graph, compOpts)
+    Gap.load' Nothing LoadAllTargets msg mod_graph, compOpts)
 
 ----------------------------------------------------------------
 

src/HIE/Bios/Ghc/Check.hs

@@ -93,3 +93,4 @@ allWarningFlags libDir = unsafePerformIO $
         df <- G.getSessionDynFlags
         (df', _) <- addCmdOpts ["-Wall"] df
         return $ G.warningFlags df'
+

src/HIE/Bios/Ghc/Gap.hs

@@ -57,6 +57,9 @@ module HIE.Bios.Ghc.Gap (
   , mapMG
   , mgModSummaries
   , unsetLogAction
+  , load'
+  , homeUnitId_
+  , getDynFlags
   ) where
 
 import Control.Monad.IO.Class
@@ -69,7 +72,7 @@ import qualified GHC as G
 import Data.List
 import System.FilePath
 
-import DynFlags (LogAction, WarningFlag, updOptLevel, Way(WayDyn), updateWays, addWay')
+import DynFlags (LogAction, WarningFlag, updOptLevel, Way(WayDyn), updateWays, addWay', getDynFlags)
 import qualified DynFlags as G
 import qualified Exception as G
 
@@ -143,10 +146,37 @@ import qualified GHC.Tc.Types as Tc
 import GHC.Utils.Outputable
 import qualified GHC.Utils.Ppr as Ppr
 #endif
+#if __GLASGOW_HASKELL__ >= 900
+import GHC.Unit.Types (UnitId)
+#endif
+
+#if __GLASGOW_HASKELL__ >= 900
+import qualified GHC.Driver.Main as G
+import qualified GHC.Driver.Make as G
+#else
+import qualified HscMain as G
+import qualified GhcMake as G
+#endif
 
 ghcVersion :: String
 ghcVersion = VERSION_ghc
 
+#if __GLASGOW_HASKELL__ <= 810
+homeUnitId_ :: a -> ()
+homeUnitId_ = const ()
+#elif __GLASGOW_HASKELL__ <= 901
+homeUnitId_ :: DynFlags -> UnitId
+homeUnitId_ = homeUnitId
+#endif
+
+#if __GLASGOW_HASKELL__ >= 904
+load' :: GhcMonad m => Maybe G.ModIfaceCache -> LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
+load' = G.load'
+#else
+load' :: GhcMonad m => a -> LoadHowMuch -> Maybe G.Messager -> ModuleGraph -> m SuccessFlag
+load' _ a b c = G.load' a b c
+#endif
+
 #if __GLASGOW_HASKELL__ >= 900
 bracket :: E.MonadMask m => m a -> (a -> m c) -> (a -> m b) -> m b
 bracket =
@@ -211,11 +241,12 @@ overPkgDbRef _f db = db
 
 ----------------------------------------------------------------
 
-guessTarget :: GhcMonad m => String -> Maybe G.Phase -> m G.Target
-#if __GLASGOW_HASKELL__ >= 901
-guessTarget a b = G.guessTarget a b
+#if __GLASGOW_HASKELL__ >= 903
+guessTarget :: GhcMonad m => String -> Maybe UnitId -> Maybe G.Phase -> m G.Target
+guessTarget a b c = G.guessTarget a b c
 #else
-guessTarget a b = G.guessTarget a b
+guessTarget :: GhcMonad m => String -> a -> Maybe G.Phase -> m G.Target
+guessTarget a _ b = G.guessTarget a b
 #endif
 
 ----------------------------------------------------------------
@@ -309,7 +340,9 @@ unsetLogAction = do
 #endif
 
 noopLogger :: LogAction
-#if __GLASGOW_HASKELL__ >= 900
+#if __GLASGOW_HASKELL__ >= 903
+noopLogger = (\_wr _s _ss _m -> return ())
+#elif __GLASGOW_HASKELL__ >= 900
 noopLogger = (\_df _wr _s _ss _m -> return ())
 #else
 noopLogger = (\_df _wr _s _ss _pp _m -> return ())
@@ -335,7 +368,9 @@ oneLineMode = Ppr.OneLineMode
 -- --------------------------------------------------------
 
 numLoadedPlugins :: HscEnv -> Int
-#if __GLASGOW_HASKELL__ >= 902
+#if __GLASGOW_HASKELL__ >= 903
+numLoadedPlugins = length . Plugins.pluginsWithArgs . hsc_plugins
+#elif __GLASGOW_HASKELL__ >= 902
 numLoadedPlugins = length . Plugins.plugins
 #elif __GLASGOW_HASKELL__ >= 808
 numLoadedPlugins = length . Plugins.plugins . hsc_dflags

src/HIE/Bios/Ghc/Load.hs

@@ -2,7 +2,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE CPP #-}
 -- | Convenience functions for loading a file into a GHC API session
-module HIE.Bios.Ghc.Load ( loadFileWithMessage, loadFile, setTargetFiles, setTargetFilesWithMessage, Log (..)) where
+module HIE.Bios.Ghc.Load  where
 
 
 import Colog.Core (LogAction (..), WithSeverity (..), Severity (..), (<&))
@@ -26,6 +26,7 @@ import qualified HscMain as G
 #endif
 
 import qualified HIE.Bios.Ghc.Gap as Gap
+import GHC.Fingerprint
 
 data Log =
   LogLoaded FilePath FilePath
@@ -120,7 +121,12 @@ updateTime :: MonadIO m => [Target] -> ModuleGraph -> m ModuleGraph
 updateTime ts graph = liftIO $ do
   cur_time <- getCurrentTime
   let go ms
-        | any (msTargetIs ms) ts = ms {ms_hs_date = cur_time}
+        | any (msTargetIs ms) ts =
+#if __GLASGOW_HASKELL__ >= 903
+            ms {ms_hs_hash = fingerprint0}
+#else
+            ms {ms_hs_date = cur_time}
+#endif
         | otherwise = ms
   pure $ Gap.mapMG go graph
 
@@ -138,7 +144,7 @@ setTargetFilesWithMessage logger msg files = do
     G.setTargets targets
     mod_graph <- updateTime targets =<< depanal [] False
     liftIO $ logger <& LogModGraph mod_graph `WithSeverity` Debug
-    void $ G.load' LoadAllTargets msg mod_graph
+    void $ Gap.load' Nothing LoadAllTargets msg mod_graph
 
 -- | Add a hook to record the contents of any 'TypecheckedModule's which are produced
 -- during compilation.
@@ -194,7 +200,8 @@ ghcInHsc gm = do
 -- target file to be a temporary file.
 guessTargetMapped :: (GhcMonad m) => (FilePath, FilePath) -> m Target
 guessTargetMapped (orig_file_name, mapped_file_name) = do
-  t <- Gap.guessTarget orig_file_name Nothing
+  df <- Gap.getDynFlags
+  t <- Gap.guessTarget orig_file_name (Just $ Gap.homeUnitId_ df) Nothing
   return (setTargetFilename mapped_file_name t)
 
 setTargetFilename :: FilePath -> Target -> Target

src/HIE/Bios/Ghc/Logger.hs

@@ -40,6 +40,11 @@ import HIE.Bios.Ghc.Doc (showPage, getStyle)
 import HIE.Bios.Ghc.Api (withDynFlags)
 import qualified HIE.Bios.Ghc.Gap as Gap
 
+#if __GLASGOW_HASKELL__ >= 903
+import GHC.Types.Error
+import GHC.Driver.Errors.Types
+#endif
+
 ----------------------------------------------------------------
 
 type Builder = [String] -> [String]
@@ -56,7 +61,12 @@ readAndClearLogRef (LogRef ref) = do
     return $! unlines (b [])
 
 appendLogRef :: DynFlags -> Gap.PprStyle -> LogRef -> LogAction
-appendLogRef df style (LogRef ref) _ _ sev src
+appendLogRef df style (LogRef ref)
+#if __GLASGOW_HASKELL__ < 903
+    _ _ sev src
+#else
+    _ (MCDiagnostic sev _) src
+#endif
 #if __GLASGOW_HASKELL__ < 900
   _style
 #endif
@@ -101,10 +111,25 @@ sourceError ::
 sourceError err = do
     dflag <- getSessionDynFlags
     style <- getStyle dflag
+#if __GLASGOW_HASKELL__ >= 903
+    let ret = unlines . errBagToStrList dflag style . getMessages . srcErrorMessages $ err
+#else
     let ret = unlines . errBagToStrList dflag style . srcErrorMessages $ err
+#endif
     return (Left ret)
 
-#if __GLASGOW_HASKELL__ >= 902
+#if __GLASGOW_HASKELL__ >= 903
+errBagToStrList :: DynFlags -> Gap.PprStyle -> Bag (MsgEnvelope GhcMessage) -> [String]
+errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList
+
+
+ppErrMsg :: DynFlags -> Gap.PprStyle -> MsgEnvelope GhcMessage -> String
+ppErrMsg dflag style err = ppMsg spn SevError dflag style msg -- ++ ext
+   where
+     spn = errMsgSpan err
+     msg = pprLocMsgEnvelope err
+     -- fixme
+#elif __GLASGOW_HASKELL__ >= 902
 errBagToStrList :: DynFlags -> Gap.PprStyle -> Bag (MsgEnvelope DecoratedSDoc) -> [String]
 errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList
 

tests/BiosTests.hs

@@ -64,7 +64,7 @@ main = do
         [ testGroup "bios" biosTestCases
         , testGroup "direct" directTestCases
         , testGroupWithDependency cabalDep (cabalTestCases extraGhcDep)
-        , ignoreOnGhc921 $ testGroupWithDependency stackDep stackTestCases
+        , ignoreOnUnsupportedGhc $ testGroupWithDependency stackDep stackTestCases
         ]
       ]
 
@@ -380,9 +380,11 @@ ignoreToolTests = Tasty.TestManager [Tasty.Option (Proxy :: Proxy IgnoreToolDeps
 -- Ignore test group if built with GHC 9.2.1 until GHC 9.2.4
 -- ------------------------------------------------------------------
 
-ignoreOnGhc921 :: TestTree -> TestTree
-ignoreOnGhc921 tt =
-#if (defined(MIN_VERSION_GLASGOW_HASKELL) && MIN_VERSION_GLASGOW_HASKELL(9,2,1,0) && !MIN_VERSION_GLASGOW_HASKELL(9,2,4,0))
+ignoreOnUnsupportedGhc :: TestTree -> TestTree
+ignoreOnUnsupportedGhc tt =
+#if (defined(MIN_VERSION_GLASGOW_HASKELL) && MIN_VERSION_GLASGOW_HASKELL(9,4,0,0))
+  ignoreTestBecause "Not supported on GHC >= 9.4"
+#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && MIN_VERSION_GLASGOW_HASKELL(9,2,1,0) && !MIN_VERSION_GLASGOW_HASKELL(9,2,4,0))
   ignoreTestBecause "Not supported on GHC >= 9.2.1 && < 9.2.4"
 #endif
   tt