From ba6d3b3408b1ab23822d831d86ff8a8ff488631e Mon Sep 17 00:00:00 2001 From: fendor Date: Tue, 13 Sep 2022 09:59:49 +0200 Subject: [PATCH] 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 --- .github/workflows/haskell.yml | 4 +-- cabal.project | 3 +++ hie-bios.cabal | 2 +- src/HIE/Bios.hs | 2 +- src/HIE/Bios/Environment.hs | 2 +- src/HIE/Bios/Ghc/Api.hs | 2 +- src/HIE/Bios/Ghc/Check.hs | 1 + src/HIE/Bios/Ghc/Gap.hs | 49 ++++++++++++++++++++++++++++++----- src/HIE/Bios/Ghc/Load.hs | 15 ++++++++--- src/HIE/Bios/Ghc/Logger.hs | 29 +++++++++++++++++++-- tests/BiosTests.hs | 10 ++++--- 11 files changed, 96 insertions(+), 23 deletions(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index ae2b611d4..45d0cd11b 100644 --- a/.github/workflows/haskell.yml +++ b/.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 diff --git a/cabal.project b/cabal.project index e6fdbadb4..faf1b0deb 100644 --- a/cabal.project +++ b/cabal.project @@ -1 +1,4 @@ packages: . + +allow-newer: + co-log-core:base diff --git a/hie-bios.cabal b/hie-bios.cabal index 539767026..163a3cca8 100644 --- a/hie-bios.cabal +++ b/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, diff --git a/src/HIE/Bios.hs b/src/HIE/Bios.hs index 27136f7b7..3069296b9 100644 --- a/src/HIE/Bios.hs +++ b/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 \ No newline at end of file +import HIE.Bios.Ghc.Load diff --git a/src/HIE/Bios/Environment.hs b/src/HIE/Bios/Environment.hs index e106c8e80..72a7866ea 100644 --- a/src/HIE/Bios/Environment.hs +++ b/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. diff --git a/src/HIE/Bios/Ghc/Api.hs b/src/HIE/Bios/Ghc/Api.hs index 53e08a3a2..ce357a477 100644 --- a/src/HIE/Bios/Ghc/Api.hs +++ b/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) ---------------------------------------------------------------- diff --git a/src/HIE/Bios/Ghc/Check.hs b/src/HIE/Bios/Ghc/Check.hs index 29635daa4..9018e27f9 100644 --- a/src/HIE/Bios/Ghc/Check.hs +++ b/src/HIE/Bios/Ghc/Check.hs @@ -93,3 +93,4 @@ allWarningFlags libDir = unsafePerformIO $ df <- G.getSessionDynFlags (df', _) <- addCmdOpts ["-Wall"] df return $ G.warningFlags df' + diff --git a/src/HIE/Bios/Ghc/Gap.hs b/src/HIE/Bios/Ghc/Gap.hs index d5cca8ec4..141155368 100644 --- a/src/HIE/Bios/Ghc/Gap.hs +++ b/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 diff --git a/src/HIE/Bios/Ghc/Load.hs b/src/HIE/Bios/Ghc/Load.hs index 426d6400b..0cb7bf6e4 100644 --- a/src/HIE/Bios/Ghc/Load.hs +++ b/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 diff --git a/src/HIE/Bios/Ghc/Logger.hs b/src/HIE/Bios/Ghc/Logger.hs index 35fcdf7a6..6bc895045 100644 --- a/src/HIE/Bios/Ghc/Logger.hs +++ b/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 diff --git a/tests/BiosTests.hs b/tests/BiosTests.hs index 8269d701b..8164b4719 100644 --- a/tests/BiosTests.hs +++ b/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