From 8ebab9884beff3788f4829d63ede0fadd0714f34 Mon Sep 17 00:00:00 2001 From: Vaibhav Sagar Date: Sun, 10 Oct 2021 18:15:20 +1100 Subject: [PATCH] ihaskell: support GHC 9.2 --- ihaskell.cabal | 6 +- src/IHaskell/Eval/Completion.hs | 16 +++- src/IHaskell/Eval/Evaluate.hs | 112 ++++++++++++++++++++++---- src/IHaskell/Eval/Info.hs | 5 +- src/IHaskell/Eval/Util.hs | 47 ++++++++++- src/tests/IHaskell/Test/Completion.hs | 9 +++ src/tests/IHaskell/Test/Eval.hs | 5 +- src/tests/IHaskell/Test/Parser.hs | 4 +- 8 files changed, 178 insertions(+), 26 deletions(-) diff --git a/ihaskell.cabal b/ihaskell.cabal index 7cbd518a..a5cb5769 100644 --- a/ihaskell.cabal +++ b/ihaskell.cabal @@ -95,7 +95,7 @@ library utf8-string -any, vector -any, ipython-kernel >=0.10.2.0, - ghc-boot >=8.0 && <9.1 + ghc-boot >=8.0 && <9.3 exposed-modules: IHaskell.Display IHaskell.Convert @@ -149,10 +149,10 @@ executable ihaskell default-language: Haskell2010 build-depends: ihaskell -any, - base >=4.9 && < 4.16, + base >=4.9 && < 4.17, text >=0.11, transformers -any, - ghc >=8.0 && < 9.1, + ghc >=8.0 && < 9.3, process >=1.1, aeson >=0.7, bytestring >=0.10, diff --git a/src/IHaskell/Eval/Completion.hs b/src/IHaskell/Eval/Completion.hs index ef50ded4..cfe4c712 100644 --- a/src/IHaskell/Eval/Completion.hs +++ b/src/IHaskell/Eval/Completion.hs @@ -22,7 +22,13 @@ import qualified Data.List.Split.Internals as Split import System.Environment (getEnv) import GHC -#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,2,0) +import GHC.Unit.Database +import GHC.Unit.State +import GHC.Driver.Ppr +import GHC.Driver.Session +import GHC.Driver.Monad as GhcMonad +#elif MIN_VERSION_ghc(9,0,0) import GHC.Unit.Database import GHC.Unit.State import GHC.Driver.Session @@ -81,8 +87,12 @@ complete code posOffset = do let isQualified = ('.' `elem`) unqualNames = nub $ filter (not . isQualified) rdrNames qualNames = nub $ scopeNames ++ filter isQualified rdrNames - -#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,2,0) + logger <- getLogger + (db, _, _, _) <- liftIO $ initUnits logger flags Nothing + let getNames = map (moduleNameString . exposedName) . unitExposedModules + moduleNames = nub $ concatMap getNames $ concatMap unitDatabaseUnits db +#elif MIN_VERSION_ghc(9,0,0) let Just db = unitDatabases flags getNames = map (moduleNameString . exposedName) . unitExposedModules moduleNames = nub $ concatMap getNames $ concatMap unitDatabaseUnits db diff --git a/src/IHaskell/Eval/Evaluate.hs b/src/IHaskell/Eval/Evaluate.hs index 69a76a19..1ccdf31a 100644 --- a/src/IHaskell/Eval/Evaluate.hs +++ b/src/IHaskell/Eval/Evaluate.hs @@ -37,7 +37,21 @@ import System.Exit import Data.Maybe (mapMaybe) import System.Environment (getEnv) -#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,2,0) +import qualified GHC.Runtime.Debugger as Debugger +import GHC.Runtime.Eval +import GHC.Driver.Session +import GHC.Unit.State +import Control.Monad.Catch as MC +import GHC.Utils.Outputable hiding ((<>)) +import GHC.Data.Bag +import GHC.Driver.Backend +import GHC.Driver.Ppr +import GHC.Runtime.Context +import GHC.Types.SourceError +import GHC.Unit.Types (UnitId) +import qualified GHC.Utils.Error as ErrUtils +#elif MIN_VERSION_ghc(9,0,0) import qualified GHC.Runtime.Debugger as Debugger import GHC.Runtime.Eval import GHC.Driver.Session @@ -87,6 +101,11 @@ import Paths_ihaskell (version) import Data.Version (versionBranch) #endif +#if MIN_VERSION_ghc(9,2,0) +showSDocUnqual :: DynFlags -> SDoc -> String +showSDocUnqual = showSDoc +#endif + #if MIN_VERSION_ghc(9,0,0) gcatch :: Ghc a -> (SomeException -> Ghc a) -> Ghc a gcatch = MC.catch @@ -192,29 +211,43 @@ interpret libdir allowedStdin needsSupportLibraries action = runGhc (Just libdir -- Run the rest of the interpreter action hasSupportLibraries -#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,2,0) +packageIdString' :: Logger -> DynFlags -> UnitInfo -> IO String +packageIdString' logger dflags pkg_cfg = do + (_, unitState, _, _) <- initUnits logger dflags Nothing + case (lookupUnit unitState $ mkUnit pkg_cfg) of + Nothing -> pure "(unknown)" + Just cfg -> let + PackageName name = unitPackageName cfg + in pure $ unpackFS name +#elif MIN_VERSION_ghc(9,0,0) packageIdString' :: DynFlags -> UnitInfo -> String -#else -packageIdString' :: DynFlags -> PackageConfig -> String -#endif packageIdString' dflags pkg_cfg = -#if MIN_VERSION_ghc(9,0,0) case (lookupUnit (unitState dflags) $ mkUnit pkg_cfg) of Nothing -> "(unknown)" Just cfg -> let PackageName name = unitPackageName cfg in unpackFS name #elif MIN_VERSION_ghc(8,2,0) +packageIdString' :: DynFlags -> PackageConfig -> String +packageIdString' dflags pkg_cfg = case (lookupPackage dflags $ packageConfigId pkg_cfg) of Nothing -> "(unknown)" Just cfg -> let PackageName name = packageName cfg in unpackFS name #else +packageIdString' :: DynFlags -> PackageConfig -> String +packageIdString' dflags pkg_cfg = fromMaybe "(unknown)" (unitIdPackageIdString dflags $ packageConfigId pkg_cfg) #endif -#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,2,0) +getPackageConfigs :: Logger -> DynFlags -> IO [GenUnitInfo UnitId] +getPackageConfigs logger dflags = do + (pkgDb, _, _, _) <- initUnits logger dflags Nothing + pure $ foldMap unitDatabaseUnits pkgDb +#elif MIN_VERSION_ghc(9,0,0) getPackageConfigs :: DynFlags -> [GenUnitInfo UnitId] getPackageConfigs dflags = foldMap unitDatabaseUnits pkgDb @@ -236,16 +269,28 @@ initializeImports importSupportLibraries = do -- version of the ihaskell library. Also verify that the packages we load are not broken. dflags <- getSessionDynFlags broken <- liftIO getBrokenPackages -#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,2,0) + let dflgs = dflags +#elif MIN_VERSION_ghc(9,0,0) dflgs <- liftIO $ initUnits dflags #else (dflgs, _) <- liftIO $ initPackages dflags #endif + +#if MIN_VERSION_ghc(9,2,0) + logger <- getLogger + db <- liftIO $ getPackageConfigs logger dflgs + packageNames <- liftIO $ mapM (packageIdString' logger dflgs) db + let hiddenPackages = Set.intersection hiddenPackageNames (Set.fromList packageNames) + hiddenFlags = fmap HidePackage $ Set.toList hiddenPackages + initStr = "ihaskell-" +#else let db = getPackageConfigs dflgs packageNames = map (packageIdString' dflgs) db hiddenPackages = Set.intersection hiddenPackageNames (Set.fromList packageNames) hiddenFlags = fmap HidePackage $ Set.toList hiddenPackages initStr = "ihaskell-" +#endif #if MIN_VERSION_ghc(8,2,0) -- Name of the ihaskell package, i.e. "ihaskell" @@ -464,9 +509,13 @@ flushWidgetMessages state evalmsgs widgetHandler = do let commMessages = evalmsgs ++ messages widgetHandler state commMessages - +#if MIN_VERSION_ghc(9,2,0) +getErrMsgDoc :: ErrUtils.WarnMsg -> SDoc +getErrMsgDoc = ErrUtils.pprLocMsgEnvelope +#else getErrMsgDoc :: ErrUtils.ErrMsg -> SDoc getErrMsgDoc = ErrUtils.pprLocErrMsg +#endif safely :: KernelState -> Interpreter EvalOut -> Interpreter EvalOut safely state = ghandle handler . ghandle sourceErrorHandler @@ -862,9 +911,16 @@ evalCommand _ (Directive SPrint binding) state = wrapExecution state $ do #else let action = \_dflags _sev _srcspan _ppr _style msg -> modifyIORef' contents (showSDoc flags msg :) #endif +#if MIN_VERSION_ghc(9,2,0) + pushLogHookM (const action) +#else let flags' = flags { log_action = action } _ <- setSessionDynFlags flags' +#endif Debugger.pprintClosureCommand False False binding +#if MIN_VERSION_ghc(9,2,0) + popLogHookM +#endif _ <- setSessionDynFlags flags sprint <- liftIO $ readIORef contents return $ formatType (unlines sprint) @@ -1100,13 +1156,21 @@ doLoadModule name modName = do -- Compile loaded modules. flags <- getSessionDynFlags errRef <- liftIO $ newIORef [] +#if MIN_VERSION_ghc(9,0,0) + let logAction = \_dflags _warn _sev _srcspan msg -> modifyIORef' errRef (showSDoc flags msg :) +#else + let logAction = \_dflags _sev _srcspan _ppr _style msg -> modifyIORef' errRef (showSDoc flags msg :) +#endif +#if MIN_VERSION_ghc(9,2,0) + pushLogHookM (const logAction) +#endif _ <- setSessionDynFlags $ flip gopt_set Opt_BuildDynamicToo flags - { hscTarget = objTarget flags -#if MIN_VERSION_ghc(9,0,0) - , log_action = \_dflags _warn _sev _srcspan msg -> modifyIORef' errRef (showSDoc flags msg :) +#if MIN_VERSION_ghc(9,2,0) + { backend = objTarget flags #else - , log_action = \_dflags _sev _srcspan _ppr _style msg -> modifyIORef' errRef (showSDoc flags msg :) + { hscTarget = objTarget flags + , log_action = logAction #endif } @@ -1134,6 +1198,9 @@ doLoadModule name modName = do -- Switch back to interpreted mode. _ <- setSessionDynFlags flags +#if MIN_VERSION_ghc(9,2,0) + popLogHookM +#endif case result of Succeeded -> return mempty @@ -1151,7 +1218,11 @@ doLoadModule name modName = do -- Switch to interpreted mode! flags <- getSessionDynFlags +#if MIN_VERSION_ghc(9,2,0) + _ <- setSessionDynFlags flags { backend = Interpreter } +#else _ <- setSessionDynFlags flags { hscTarget = HscInterpreted } +#endif -- Return to old context, make sure we have `it`. setContext imported @@ -1170,10 +1241,13 @@ doReload = do errRef <- liftIO $ newIORef [] _ <- setSessionDynFlags $ flip gopt_set Opt_BuildDynamicToo flags +#if MIN_VERSION_ghc(9,2,0) + { backend = objTarget flags +#elif MIN_VERSION_ghc(9,0,0) { hscTarget = objTarget flags -#if MIN_VERSION_ghc(9,0,0) , log_action = \_dflags _warn _sev _srcspan msg -> modifyIORef' errRef (showSDoc flags msg :) #else + { hscTarget = objTarget flags , log_action = \_dflags _sev _srcspan _ppr _style msg -> modifyIORef' errRef (showSDoc flags msg :) #endif } @@ -1212,7 +1286,11 @@ doReload = do -- Switch to interpreted mode! flags <- getSessionDynFlags +#if MIN_VERSION_ghc(9,2,0) + _ <- setSessionDynFlags flags { backend = Interpreter } +#else _ <- setSessionDynFlags flags { hscTarget = HscInterpreted } +#endif -- Return to old context, make sure we have `it`. setContext imported @@ -1220,10 +1298,14 @@ doReload = do return $ displayError $ "Failed to reload." +#if MIN_VERSION_ghc(9,2,0) +objTarget :: DynFlags -> Backend +objTarget = platformDefaultBackend . targetPlatform +#elif MIN_VERSION_ghc(8,10,0) objTarget :: DynFlags -> HscTarget -#if MIN_VERSION_ghc(8,10,0) objTarget = defaultObjectTarget #else +objTarget :: DynFlags -> HscTarget objTarget flags = defaultObjectTarget $ targetPlatform flags #endif diff --git a/src/IHaskell/Eval/Info.hs b/src/IHaskell/Eval/Info.hs index 888ea1cd..b5502457 100644 --- a/src/IHaskell/Eval/Info.hs +++ b/src/IHaskell/Eval/Info.hs @@ -8,7 +8,10 @@ import IHaskellPrelude import IHaskell.Eval.Evaluate (typeCleaner, Interpreter) import GHC -#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,2,0) +import GHC.Driver.Ppr +import Control.Monad.Catch (handle) +#elif MIN_VERSION_ghc(9,0,0) import GHC.Utils.Outputable import Control.Monad.Catch (handle) #else diff --git a/src/IHaskell/Eval/Util.hs b/src/IHaskell/Eval/Util.hs index f622fcd0..ce3200d3 100644 --- a/src/IHaskell/Eval/Util.hs +++ b/src/IHaskell/Eval/Util.hs @@ -33,7 +33,23 @@ import qualified Data.ByteString.Char8 as CBS #endif -- GHC imports. -#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,2,0) +import GHC.Core.InstEnv (is_cls, is_tys) +import GHC.Core.Unify +import GHC.Types.TyThing.Ppr +import GHC.Driver.CmdLine +import GHC.Driver.Monad (modifySession) +import GHC.Driver.Ppr +import GHC.Driver.Session +import GHC.Driver.Env.Types +import GHC.Runtime.Context +import GHC.Types.Name (pprInfixName) +import GHC.Types.Name.Set +import GHC.Types.TyThing +import qualified GHC.Driver.Session as DynFlags +import qualified GHC.Utils.Outputable as O +import qualified GHC.Utils.Ppr as Pretty +#elif MIN_VERSION_ghc(9,0,0) import GHC.Core.InstEnv (is_cls, is_tys) import GHC.Core.Unify import GHC.Core.Ppr.TyThing @@ -218,7 +234,12 @@ setFlags :: GhcMonad m => [String] -> m [String] setFlags ext = do -- Try to parse flags. flags <- getSessionDynFlags +#if MIN_VERSION_ghc(9,2,0) + logger <- getLogger + (flags', unrecognized, warnings) <- parseDynamicFlags logger flags (map noLoc ext) +#else (flags', unrecognized, warnings) <- parseDynamicFlags flags (map noLoc ext) +#endif -- First, try to check if this flag matches any extension name. let restoredPkgs = flags' { packageFlags = packageFlags flags } @@ -252,8 +273,13 @@ doc sdoc = do let style = O.mkUserStyle unqual O.AllTheWay #endif let cols = pprCols flags +#if MIN_VERSION_ghc(9,2,0) + d = O.runSDoc sdoc (initSDocContext flags style) + return $ Pretty.fullRender (Pretty.PageMode False) cols 1.5 string_txt "" d +#else d = O.runSDoc sdoc (O.initSDocContext flags style) return $ Pretty.fullRender Pretty.PageMode cols 1.5 string_txt "" d +#endif where string_txt :: Pretty.TextDetails -> String -> String @@ -279,7 +305,12 @@ doc sdoc = do initGhci :: GhcMonad m => Maybe String -> m () initGhci sandboxPackages = do -- Initialize dyn flags. Start with -XExtendedDefaultRules and -XNoMonomorphismRestriction. -#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,2,0) + -- We start handling GHC environment files + originalFlagsNoPackageEnv <- getSessionDynFlags + logger <- getLogger + originalFlags <- liftIO $ interpretPackageEnv logger originalFlagsNoPackageEnv +#elif MIN_VERSION_ghc(9,0,0) -- We start handling GHC environment files originalFlagsNoPackageEnv <- getSessionDynFlags originalFlags <- liftIO $ interpretPackageEnv originalFlagsNoPackageEnv @@ -302,7 +333,11 @@ initGhci sandboxPackages = do in packageDBFlags originalFlags ++ [pkg] void $ setSessionDynFlags $ dflags +#if MIN_VERSION_ghc(9,2,0) + { backend = Interpreter +#else { hscTarget = HscInterpreted +#endif , ghcLink = LinkInMemory , pprCols = 300 , packageDBFlags = pkgFlags @@ -394,7 +429,11 @@ evalDeclarations decl = do names <- runDecls decl cleanUpDuplicateInstances flags <- getSessionDynFlags +#if MIN_VERSION_ghc(9,2,0) + return $ map (replace ":Interactive." "" . showPpr flags) names +#else return $ map (replace ":Interactive." "" . O.showPpr flags) names +#endif cleanUpDuplicateInstances :: GhcMonad m => m () cleanUpDuplicateInstances = modifySession $ \hscEnv -> @@ -421,7 +460,11 @@ getType expr = do result <- exprType expr #endif flags <- getSessionDynFlags +#if MIN_VERSION_ghc(9,2,0) + let typeStr = showSDoc flags $ O.ppr result +#else let typeStr = O.showSDocUnqual flags $ O.ppr result +#endif return typeStr -- | This is unfoldM from monad-loops. It repeatedly runs an IO action until it return Nothing, and diff --git a/src/tests/IHaskell/Test/Completion.hs b/src/tests/IHaskell/Test/Completion.hs index 61c0cfc1..e70629e7 100644 --- a/src/tests/IHaskell/Test/Completion.hs +++ b/src/tests/IHaskell/Test/Completion.hs @@ -14,8 +14,13 @@ import Control.Monad.IO.Class (liftIO) import System.Environment (setEnv) import System.Directory (setCurrentDirectory, getCurrentDirectory) +#if MIN_VERSION_ghc(9,2,0) +import GHC (getSessionDynFlags, setSessionDynFlags, DynFlags(..), GhcLink(..), setContext, + parseImportDecl, Backend(..), InteractiveImport(..)) +#else import GHC (getSessionDynFlags, setSessionDynFlags, DynFlags(..), GhcLink(..), setContext, parseImportDecl, HscTarget(..), InteractiveImport(..)) +#endif import Test.Hspec @@ -61,7 +66,11 @@ completionHas string expected = do initCompleter :: Interpreter () initCompleter = do flags <- getSessionDynFlags +#if MIN_VERSION_ghc(9,2,0) + _ <- setSessionDynFlags $ flags { backend = Interpreter, ghcLink = LinkInMemory } +#else _ <- setSessionDynFlags $ flags { hscTarget = HscInterpreted, ghcLink = LinkInMemory } +#endif -- Import modules. imports <- mapM parseImportDecl diff --git a/src/tests/IHaskell/Test/Eval.hs b/src/tests/IHaskell/Test/Eval.hs index 650c2332..8ec13108 100644 --- a/src/tests/IHaskell/Test/Eval.hs +++ b/src/tests/IHaskell/Test/Eval.hs @@ -161,7 +161,10 @@ testEval = ":! printf \"hello\\nworld\"" `becomes` ["hello\nworld"] it "evaluates directives" $ do -#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,2,0) + -- It's `a` instead of `p` + ":typ 3" `becomes` ["3 :: forall {a}. Num a => a"] +#elif MIN_VERSION_ghc(9,0,0) -- brackets around the type variable ":typ 3" `becomes` ["3 :: forall {p}. Num p => p"] #elif MIN_VERSION_ghc(8,2,0) diff --git a/src/tests/IHaskell/Test/Parser.hs b/src/tests/IHaskell/Test/Parser.hs index 71ce0d61..7d3cdef7 100644 --- a/src/tests/IHaskell/Test/Parser.hs +++ b/src/tests/IHaskell/Test/Parser.hs @@ -232,7 +232,9 @@ testParseString = describe "Parser" $ do #else dataKindsError = ParseError (Loc 1 10) msg #endif -#if MIN_VERSION_ghc(8,8,0) +#if MIN_VERSION_ghc(9,2,0) + msg = "Cannot parse data constructor in a data/newtype declaration: 3" +#elif MIN_VERSION_ghc(8,8,0) msg = "Cannot parse data constructor in a data/newtype declaration:\n 3" #else msg = "Cannot parse data constructor in a data/newtype declaration: 3"