Add compatbility for GHC 9.0 and 9.2 (haskell#300)

* Make hie-bios compile with GHC-HEAD

* Adapt hie-bios to compile with GHC HEAD

* Add allow-newer to get a build plan

* Bump up ghc upper bound

* Update ghc head to 9.0

* Use ghc-api-compat head

* Adjust some defs to 9.0.1

* Add ghc-api-compat to exe component

* Remove updated libraries

* Fix some definitions

* Add compatibility for GHC 9.2

Co-authored-by: jneira <atreyu.bbb@gmail.com>
(cherry picked from commit 3703788)

.github/workflows/haskell.yml

@@ -8,7 +8,7 @@ jobs:
     strategy:
       fail-fast: false
       matrix:
-        ghc: ['8.10.1', '8.8.3', '8.6.5', '8.4.4']
+        ghc: ['9.0.1', '8.10.4', '8.8.4', '8.6.5', '8.4.4']
         os: [ubuntu-latest, macOS-latest, windows-latest]
         exclude:
           - os: windows-latest

exe/Main.hs

@@ -2,8 +2,6 @@
 
 module Main where
 
-import Config (cProjectVersion)
-
 import Control.Monad ( forM )
 import Data.Version (showVersion)
 import Options.Applicative
@@ -13,13 +11,14 @@ import System.FilePath( (</>) )
 
 import HIE.Bios
 import HIE.Bios.Ghc.Check
+import HIE.Bios.Ghc.Gap as Gap
 import HIE.Bios.Internal.Debug
 import Paths_hie_bios
 
 ----------------------------------------------------------------
 
 progVersion :: String
-progVersion = "hie-bios version " ++ showVersion version ++ " compiled by GHC " ++ cProjectVersion ++ "\n"
+progVersion = "hie-bios version " ++ showVersion version ++ " compiled by GHC " ++ Gap.ghcVersion ++ "\n"
 
 data Command
   = Check { checkTargetFiles :: [FilePath] }

hie-bios.cabal

@@ -150,14 +150,16 @@ Library
                         base16-bytestring    >= 0.1.1 && < 1.1,
                         bytestring           >= 0.10.8 && < 0.12,
                         deepseq              >= 1.4.3 && < 1.5,
+                        exceptions           ^>= 0.10,
                         containers           >= 0.5.10 && < 0.7,
                         cryptohash-sha1      >= 0.11.100 && < 0.12,
                         directory            >= 1.3.0 && < 1.4,
                         filepath             >= 1.4.1 && < 1.5,
                         time                 >= 1.8.0 && < 1.12,
                         extra                >= 1.6.14 && < 1.8,
+                        exceptions,
                         process              >= 1.6.1 && < 1.7,
-                        ghc                  >= 8.4.1 && < 8.11,
+                        ghc                  >= 8.4.1 && < 9.3,
                         transformers         >= 0.5.2 && < 0.6,
                         temporary            >= 1.2 && < 1.4,
                         text                 >= 1.2.3 && < 1.3,

hie.yaml.back

@@ -0,0 +1,10 @@
+cradle:
+  cabal:
+    - path: "./src"
+      component: "lib:hie-bios"
+    - path: "./tests/BiosTests.hs"
+      component: "test:bios-tests"
+    - path: "./tests/ParserTests.hs"
+      component: "test:parser-tests"
+    - path: "./exe"
+      component: "exe:hie-bios"

src/HIE/Bios/Cradle.hs

@@ -34,6 +34,7 @@ import HIE.Bios.Types hiding (ActionName(..))
 import qualified HIE.Bios.Types as Types
 import HIE.Bios.Config
 import HIE.Bios.Environment (getCacheDir)
+import qualified HIE.Bios.Ghc.Gap as Gap
 import System.Directory hiding (findFile)
 import Control.Monad.Trans.Cont
 import Control.Monad.Trans.Maybe
@@ -61,7 +62,6 @@ import qualified Data.Text as T
 import qualified Data.HashMap.Strict as Map
 import           Data.Maybe (fromMaybe, maybeToList)
 import           GHC.Fingerprint (fingerprintString)
-import DynFlags (dynamicGhc)
 
 hie_bios_output :: String
 hie_bios_output = "HIE_BIOS_OUTPUT"
@@ -196,7 +196,7 @@ configFileName = "hie.yaml"
 -- because unlike the case of using build tools, which means '-dynamic' can be set via
 -- '.cabal' or 'package.yaml', users have to create an explicit hie.yaml to pass this flag.
 argDynamic :: [String]
-argDynamic = ["-dynamic" | dynamicGhc]
+argDynamic = ["-dynamic" | Gap.hostIsDynamic ]
 
 ---------------------------------------------------------------
 

src/HIE/Bios/Environment.hs

@@ -1,15 +1,12 @@
 {-# LANGUAGE RecordWildCards, CPP #-}
 module HIE.Bios.Environment (initSession, getRuntimeGhcLibDir, getRuntimeGhcVersion, makeDynFlagsAbsolute, makeTargetsAbsolute, getCacheDir, addCmdOpts) where
 
-import CoreMonad (liftIO)
 import GHC (GhcMonad)
 import qualified GHC as G
-import qualified DriverPhases as G
-import qualified Util as G
-import DynFlags
 
 import Control.Applicative
 import Control.Monad (void)
+import Control.Monad.IO.Class
 
 import System.Directory
 import System.FilePath
@@ -21,8 +18,9 @@ import Data.ByteString.Base16
 import Data.List
 import Data.Char (isSpace)
 import Text.ParserCombinators.ReadP hiding (optional)
+
 import HIE.Bios.Types
-import HIE.Bios.Ghc.Gap
+import qualified HIE.Bios.Ghc.Gap as Gap
 
 -- | Start a GHC session and set some sensible options for tooling to use.
 -- Creates a folder in the cache directory to cache interface files to make
@@ -44,13 +42,13 @@ initSession  ComponentOptions {..} = do
         $ setIgnoreInterfacePragmas            -- Ignore any non-essential information in interface files such as unfoldings changing.
         $ writeInterfaceFiles (Just cache_dir) -- Write interface files to the cache
         $ setVerbosity 0                       -- Set verbosity to zero just in case the user specified `-vx` in the options.
-        $ (if dynamicGhc then updateWays . addWay' WayDyn else id) -- Add dynamic way if GHC is built with dynamic linking
-        $ setLinkerOptions df''                 -- Set `-fno-code` to avoid generating object files, unless we have to.
+        $ Gap.setWayDynamicIfHostIsDynamic     -- Add dynamic way if GHC is built with dynamic linking
+        $ setLinkerOptions df''                -- Set `-fno-code` to avoid generating object files, unless we have to.
         )
 
     let targets' = makeTargetsAbsolute componentRoot targets
     -- Unset the default log action to avoid output going to stdout.
-    unsetLogAction
+    Gap.unsetLogAction
     return targets'
 
 ----------------------------------------------------------------
@@ -116,139 +114,62 @@ getCacheDir fp = do
 -- we don't want to generate object code so we compile to bytecode
 -- (HscInterpreted) which implies LinkInMemory
 -- HscInterpreted
-setLinkerOptions :: DynFlags -> DynFlags
-setLinkerOptions df = df {
-    ghcLink   = LinkInMemory
-  , hscTarget = HscNothing
-  , ghcMode = CompManager
+setLinkerOptions :: G.DynFlags -> G.DynFlags
+setLinkerOptions df = Gap.setNoCode $ df {
+    G.ghcLink = G.LinkInMemory
+  , G.ghcMode = G.CompManager
   }
 
-setIgnoreInterfacePragmas :: DynFlags -> DynFlags
-setIgnoreInterfacePragmas df = gopt_set df Opt_IgnoreInterfacePragmas
+setIgnoreInterfacePragmas :: G.DynFlags -> G.DynFlags
+setIgnoreInterfacePragmas df = Gap.gopt_set df G.Opt_IgnoreInterfacePragmas
 
-setVerbosity :: Int -> DynFlags -> DynFlags
-setVerbosity n df = df { verbosity = n }
+setVerbosity :: Int -> G.DynFlags -> G.DynFlags
+setVerbosity n df = df { G.verbosity = n }
 
-writeInterfaceFiles :: Maybe FilePath -> DynFlags -> DynFlags
+writeInterfaceFiles :: Maybe FilePath -> G.DynFlags -> G.DynFlags
 writeInterfaceFiles Nothing df = df
-writeInterfaceFiles (Just hi_dir) df = setHiDir hi_dir (gopt_set df Opt_WriteInterface)
+writeInterfaceFiles (Just hi_dir) df = setHiDir hi_dir (Gap.gopt_set df G.Opt_WriteInterface)
 
-setHiDir :: FilePath -> DynFlags -> DynFlags
-setHiDir f d = d { hiDir      = Just f}
+setHiDir :: FilePath -> G.DynFlags -> G.DynFlags
+setHiDir f d = d { G.hiDir      = Just f}
 
 
 -- | Interpret and set the specific command line options.
 -- A lot of this code is just copied from ghc/Main.hs
 -- It would be good to move this code into a library module so we can just use it
 -- rather than copy it.
 addCmdOpts :: (GhcMonad m)
-           => [String] -> DynFlags -> m (DynFlags, [G.Target])
+           => [String] -> G.DynFlags -> m (G.DynFlags, [G.Target])
 addCmdOpts cmdOpts df1 = do
-  (df2, leftovers', _warns) <- G.parseDynamicFlags df1 (map G.noLoc cmdOpts)
+  logger <- Gap.getLogger <$> G.getSession
+  (df2, leftovers', _warns) <- Gap.parseDynamicFlags logger df1 (map G.noLoc cmdOpts)
   -- parse targets from ghci-scripts. Only extract targets that have been ":add"'ed.
-  additionalTargets <- concat <$> mapM (liftIO . getTargetsFromGhciScript) (ghciScripts df2)
+  additionalTargets <- concat <$> mapM (liftIO . getTargetsFromGhciScript) (G.ghciScripts df2)
 
   -- leftovers contains all Targets from the command line
-  let leftovers = leftovers' ++ map G.noLoc additionalTargets
-
-  let
-     -- To simplify the handling of filepaths, we normalise all filepaths right
-     -- away. Note the asymmetry of FilePath.normalise:
-     --    Linux:   p/q -> p/q; p\q -> p\q
-     --    Windows: p/q -> p\q; p\q -> p\q
-     -- #12674: Filenames starting with a hypen get normalised from ./-foo.hs
-     -- to -foo.hs. We have to re-prepend the current directory.
-    normalise_hyp fp
-        | strt_dot_sl && "-" `isPrefixOf` nfp = cur_dir ++ nfp
-        | otherwise                           = nfp
-        where
-#if defined(mingw32_HOST_OS)
-          strt_dot_sl = "./" `isPrefixOf` fp || ".\\" `isPrefixOf` fp
-#else
-          strt_dot_sl = "./" `isPrefixOf` fp
-#endif
-          cur_dir = '.' : [pathSeparator]
-          nfp = normalise fp
-    normal_fileish_paths = map (normalise_hyp . G.unLoc) leftovers
-  let
-   (srcs, objs) = partition_args normal_fileish_paths [] []
-   df3 = df2 { ldInputs = map (FileOption "") objs ++ ldInputs df2 }
-  ts <- mapM (uncurry G.guessTarget) srcs
+  let leftovers = map G.unLoc leftovers' ++ additionalTargets
+
+  let (df3, srcs, _objs) = Gap.parseTargetFiles df2 leftovers
+  ts <- mapM (uncurry Gap.guessTarget) srcs
   return (df3, ts)
-    -- TODO: Need to handle these as well
-    -- Ideally it requires refactoring to work in GHCi monad rather than
-    -- Ghc monad and then can just use newDynFlags.
-    {-
-    liftIO $ G.handleFlagWarnings idflags1 warns
-    when (not $ null leftovers)
-        (throwGhcException . CmdLineError
-         $ "Some flags have not been recognized: "
-         ++ (concat . intersperse ", " $ map unLoc leftovers))
-    when (interactive_only && packageFlagsChanged idflags1 idflags0) $ do
-       liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set"
-    -}
 
 -- | Make filepaths in the given 'DynFlags' absolute.
 -- This makes the 'DynFlags' independent of the current working directory.
-makeDynFlagsAbsolute :: FilePath -> DynFlags -> DynFlags
+makeDynFlagsAbsolute :: FilePath -> G.DynFlags -> G.DynFlags
 makeDynFlagsAbsolute work_dir df =
-  mapOverIncludePaths (work_dir </>)
+  Gap.mapOverIncludePaths makeAbs
   $ df
-    { importPaths = map (work_dir </>) (importPaths df)
-    , packageDBFlags =
-        let makePackageDbAbsolute (PackageDB pkgConfRef) = PackageDB
-              $ case pkgConfRef of
-                PkgConfFile fp -> PkgConfFile (work_dir </> fp)
-                conf -> conf
-            makePackageDbAbsolute db = db
-        in map makePackageDbAbsolute (packageDBFlags df)
+    { G.importPaths = map makeAbs (G.importPaths df)
+    , G.packageDBFlags =
+        map (Gap.overPkgDbRef makeAbs) (G.packageDBFlags df)
     }
-
--- partition_args, along with some of the other code in this file,
--- was copied from ghc/Main.hs
--- -----------------------------------------------------------------------------
--- Splitting arguments into source files and object files.  This is where we
--- interpret the -x <suffix> option, and attach a (Maybe Phase) to each source
--- file indicating the phase specified by the -x option in force, if any.
-partition_args :: [String] -> [(String, Maybe G.Phase)] -> [String]
-               -> ([(String, Maybe G.Phase)], [String])
-partition_args [] srcs objs = (reverse srcs, reverse objs)
-partition_args ("-x":suff:args) srcs objs
-  | "none" <- suff      = partition_args args srcs objs
-  | G.StopLn <- phase     = partition_args args srcs (slurp ++ objs)
-  | otherwise           = partition_args rest (these_srcs ++ srcs) objs
-        where phase = G.startPhase suff
-              (slurp,rest) = break (== "-x") args
-              these_srcs = zip slurp (repeat (Just phase))
-partition_args (arg:args) srcs objs
-  | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs
-  | otherwise               = partition_args args srcs (arg:objs)
-
-    {-
-      We split out the object files (.o, .dll) and add them
-      to ldInputs for use by the linker.
-      The following things should be considered compilation manager inputs:
-       - haskell source files (strings ending in .hs, .lhs or other
-         haskellish extension),
-       - module names (not forgetting hierarchical module names),
-       - things beginning with '-' are flags that were not recognised by
-         the flag parser, and we want them to generate errors later in
-         checkOptions, so we class them as source files (#5921)
-       - and finally we consider everything without an extension to be
-         a comp manager input, as shorthand for a .hs or .lhs filename.
-      Everything else is considered to be a linker object, and passed
-      straight through to the linker.
-    -}
-looks_like_an_input :: String -> Bool
-looks_like_an_input m =  G.isSourceFilename m
-                      || G.looksLikeModuleName m
-                      || "-" `isPrefixOf` m
-                      || not (hasExtension m)
+  where
+    makeAbs = (work_dir </>)
 
 -- --------------------------------------------------------
 
-disableOptimisation :: DynFlags -> DynFlags
-disableOptimisation df = updOptLevel 0 df
+disableOptimisation :: G.DynFlags -> G.DynFlags
+disableOptimisation df = Gap.updOptLevel 0 df
 
 -- --------------------------------------------------------
 

src/HIE/Bios/Ghc/Api.hs

@@ -7,15 +7,20 @@ module HIE.Bios.Ghc.Api (
   , withDynFlags
   ) where
 
-import CoreMonad (liftIO)
-import GHC (LoadHowMuch(..), GhcMonad)
-import DynFlags
-
+import GHC (LoadHowMuch(..), DynFlags, GhcMonad)
 import qualified GHC as G
+
+#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
 
+import qualified HIE.Bios.Ghc.Gap as Gap
 import Control.Monad (void)
+import Control.Monad.IO.Class
 import HIE.Bios.Types
 import HIE.Bios.Environment
 import HIE.Bios.Flags
@@ -28,7 +33,7 @@ initializeFlagsWithCradle ::
     => FilePath -- ^ The file we are loading the 'Cradle' because of
     -> Cradle a   -- ^ The cradle we want to load
     -> m (CradleLoadResult (m G.SuccessFlag, ComponentOptions))
-initializeFlagsWithCradle = initializeFlagsWithCradleWithMessage (Just G.batchMsg)
+initializeFlagsWithCradle = initializeFlagsWithCradleWithMessage (Just Gap.batchMsg)
 
 -- | The same as 'initializeFlagsWithCradle' but with an additional argument to control
 -- how the loading progress messages are displayed to the user. In @haskell-ide-engine@
@@ -61,7 +66,7 @@ initSessionWithMessage msg compOpts = (do
 withDynFlags ::
   (GhcMonad m)
   => (DynFlags -> DynFlags) -> m a -> m a
-withDynFlags setFlag body = G.gbracket setup teardown (\_ -> body)
+withDynFlags setFlag body = Gap.bracket setup teardown (\_ -> body)
   where
     setup = do
         dflag <- G.getSessionDynFlags

src/HIE/Bios/Ghc/Check.hs

@@ -1,10 +1,19 @@
+{-# LANGUAGE CPP #-}
 module HIE.Bios.Ghc.Check (
     checkSyntax
   , check
   ) where
 
 import GHC (DynFlags(..), GhcMonad)
-import Exception
+import qualified GHC as G
+
+#if __GLASGOW_HASKELL__ >= 900
+import qualified GHC.Driver.Session as G
+#else
+import qualified DynFlags as G
+#endif
+
+import Control.Exception
 
 import HIE.Bios.Environment
 import HIE.Bios.Ghc.Api
@@ -17,8 +26,6 @@ import Control.Monad.IO.Class
 import System.IO.Unsafe (unsafePerformIO)
 import qualified HIE.Bios.Ghc.Gap as Gap
 
-import qualified DynFlags as G
-import qualified GHC as G
 
 ----------------------------------------------------------------
 
@@ -40,7 +47,7 @@ checkSyntax cradle files = do
           either id id <$> check files
   where
     handleRes (CradleSuccess x) f = f x
-    handleRes (CradleFail ce) _f = liftIO $ throwIO ce 
+    handleRes (CradleFail ce) _f = liftIO $ throwIO ce
     handleRes CradleNone _f = return "None cradle"
 
 ----------------------------------------------------------------