Merge pull request #139 from brandon-leapyear/ghc-9.2

GHC 9.2 support

.github/workflows/ci.yml

@@ -26,6 +26,7 @@ jobs:
           - stack-8.8.4.yaml
           - stack-8.10.4.yaml
           - stack-9.0.1.yaml
+          - stack-9.2.1.yaml
         os:
           - ubuntu-latest
 

hint.cabal

@@ -60,7 +60,8 @@ test-suite unit-tests
 library
   default-language: Haskell2010
   build-depends: base == 4.*,
-                 ghc >= 8.4 && < 9.2,
+                 containers,
+                 ghc >= 8.4 && < 9.3,
                  ghc-paths,
                  ghc-boot,
                  transformers,

src/Control/Monad/Ghc.hs

@@ -14,6 +14,9 @@ import Control.Monad.Catch
 import Data.IORef
 
 import qualified GHC
+#if MIN_VERSION_ghc(9,2,0)
+import qualified GHC.Utils.Logger as GHC
+#endif
 #if MIN_VERSION_ghc(9,0,0)
 import qualified GHC.Utils.Monad as GHC
 import qualified GHC.Utils.Exception as GHC
@@ -93,6 +96,11 @@ instance (MonadIO m, MonadCatch m, MonadMask m) => GHC.ExceptionMonad (GhcT m) w
     gmask  = mask
 #endif
 
+#if MIN_VERSION_ghc(9,2,0)
+instance MonadIO m => GHC.HasLogger (GhcT m) where
+    getLogger = GhcT GHC.getLogger
+#endif
+
 instance (Functor m, MonadIO m, MonadCatch m, MonadMask m) => GHC.GhcMonad (GhcT m) where
     getSession = GhcT GHC.getSession
     setSession = GhcT . GHC.setSession

src/Hint/Annotations.hs

@@ -9,13 +9,20 @@ import GHC.Serialized
 import Hint.Base
 import qualified Hint.GHC as GHC
 
-#if MIN_VERSION_ghc(9,0,0)
+#if MIN_VERSION_ghc(9,2,0)
+import GHC (ms_mod)
+import GHC.Driver.Env (hsc_mod_graph)
+#elif MIN_VERSION_ghc(9,0,0)
 import GHC.Driver.Types (hsc_mod_graph, ms_mod)
+#else
+import HscTypes (hsc_mod_graph, ms_mod)
+#endif
+
+#if MIN_VERSION_ghc(9,0,0)
 import GHC.Types.Annotations
 import GHC.Utils.Monad (concatMapM)
 #else
 import Annotations
-import HscTypes (hsc_mod_graph, ms_mod)
 import MonadUtils (concatMapM)
 #endif
 
@@ -29,8 +36,8 @@ getModuleAnnotations _ x = do
 -- Get the annotations associated with a particular function.
 getValAnnotations :: (Data a, MonadInterpreter m) => a -> String -> m [a]
 getValAnnotations _ s = do
-    names <- runGhc1 GHC.parseName s
+    names <- runGhc $ GHC.parseName s
     concatMapM (anns . NamedTarget) names
 
 anns :: (MonadInterpreter m, Data a) => AnnTarget GHC.Name -> m [a]
-anns = runGhc1 (GHC.findGlobalAnns deserializeWithData)
+anns target = runGhc $ GHC.findGlobalAnns deserializeWithData target

src/Hint/Base.hs

@@ -3,13 +3,11 @@ module Hint.Base (
 
     GhcError(..), InterpreterError(..), mayFail, catchIE,
 
-    InterpreterSession, SessionData(..), GhcErrLogger,
+    InterpreterSession, SessionData(..),
     InterpreterState(..), fromState, onState,
     InterpreterConfiguration(..),
     ImportList(..), ModuleQualification(..), ModuleImport(..),
 
-    runGhc1, runGhc2,
-
     ModuleName, PhantomModule(..),
     findModule, moduleIsLoaded,
     withDynFlags,
@@ -99,19 +97,11 @@ type RunGhc  m a =
     (forall n.(MonadIO n, MonadMask n) => GHC.GhcT n a)
  -> m a
 
-type RunGhc1 m a b =
-    (forall n.(MonadIO n, MonadMask n) => a -> GHC.GhcT n b)
- -> (a -> m b)
-
-type RunGhc2 m a b c =
-    (forall n.(MonadIO n, MonadMask n) => a -> b -> GHC.GhcT n c)
- -> (a -> b -> m c)
-
 data SessionData a = SessionData {
                        internalState   :: IORef InterpreterState,
                        versionSpecific :: a,
                        ghcErrListRef   :: IORef [GhcError],
-                       ghcErrLogger    :: GhcErrLogger
+                       ghcLogger       :: GHC.Logger
                      }
 
 -- When intercepting errors reported by GHC, we only get a ErrUtils.Message
@@ -135,17 +125,9 @@ mapGhcExceptions buildEx action =
 catchIE :: MonadInterpreter m => m a -> (InterpreterError -> m a) -> m a
 catchIE = MC.catch
 
-type GhcErrLogger = GHC.LogAction
-
 -- | Module names are _not_ filepaths.
 type ModuleName = String
 
-runGhc1 :: MonadInterpreter m => RunGhc1 m a b
-runGhc1 f a = runGhc (f a)
-
-runGhc2 :: MonadInterpreter m => RunGhc2 m a b c
-runGhc2 f a = runGhc1 (f a)
-
 -- ================ Handling the interpreter state =================
 
 fromState :: MonadInterpreter m => (InterpreterState -> a) -> m a
@@ -179,7 +161,8 @@ showGHC :: (MonadInterpreter m, GHC.Outputable a) => a -> m String
 showGHC a
  = do unqual <- runGhc GHC.getPrintUnqual
       withDynFlags $ \df ->
-        return $ GHC.showSDocForUser df unqual (GHC.ppr a)
+        -- TODO: get unit state from somewhere?
+        return $ GHC.showSDocForUser df GHC.emptyUnitState unqual (GHC.ppr a)
 
 -- ================ Misc ===================================
 
@@ -189,7 +172,7 @@ data PhantomModule = PhantomModule{pmName :: ModuleName, pmFile :: FilePath}
 
 findModule :: MonadInterpreter m => ModuleName -> m GHC.Module
 findModule mn = mapGhcExceptions NotAllowed $
-                    runGhc2 GHC.findModule mod_name Nothing
+                    runGhc $ GHC.findModule mod_name Nothing
     where mod_name = GHC.mkModuleName mn
 
 moduleIsLoaded :: MonadInterpreter m => ModuleName -> m Bool

src/Hint/Configuration.hs

@@ -29,12 +29,13 @@ import Hint.Extension
 setGhcOptions :: MonadInterpreter m => [String] -> m ()
 setGhcOptions opts =
     do old_flags <- runGhc GHC.getSessionDynFlags
-       (new_flags,not_parsed) <- runGhc2 parseDynamicFlags old_flags opts
+       logger <- fromSession ghcLogger
+       (new_flags,not_parsed) <- runGhc $ parseDynamicFlags logger old_flags opts
        unless (null not_parsed) $
             throwM $ UnknownError
                             $ concat ["flags: ", unwords $ map quote not_parsed,
                                                "not recognized"]
-       _ <- runGhc1 GHC.setSessionDynFlags new_flags
+       _ <- runGhc $ GHC.setSessionDynFlags new_flags
        return ()
 
 setGhcOption :: MonadInterpreter m => String -> m ()
@@ -137,13 +138,14 @@ onConf f = onState $ \st -> st{configuration = f (configuration st)}
 
 configureDynFlags :: GHC.DynFlags -> GHC.DynFlags
 configureDynFlags dflags =
-    (if GHC.dynamicGhc then GHC.addWay' GHC.WayDyn else id)
+    (if GHC.dynamicGhc then GHC.addWay GHC.WayDyn else id)
+    . GHC.setBackendToInterpreter
+    $
                            dflags{GHC.ghcMode    = GHC.CompManager,
-                                  GHC.hscTarget  = GHC.HscInterpreted,
                                   GHC.ghcLink    = GHC.LinkInMemory,
                                   GHC.verbosity  = 0}
 
 parseDynamicFlags :: GHC.GhcMonad m
-                  => GHC.DynFlags -> [String] -> m (GHC.DynFlags, [String])
-parseDynamicFlags d = fmap firstTwo . GHC.parseDynamicFlags d . map GHC.noLoc
+                  => GHC.Logger -> GHC.DynFlags -> [String] -> m (GHC.DynFlags, [String])
+parseDynamicFlags l d = fmap firstTwo . GHC.parseDynamicFlags l d . map GHC.noLoc
     where firstTwo (a,b,_) = (a, map GHC.unLoc b)

src/Hint/Context.hs

@@ -127,11 +127,11 @@ addPhantomModule mod_text =
                    -- we save the context...
                    (old_top, old_imps) <- runGhc getContext
                    --
-                   runGhc1 GHC.addTarget t
-                   res <- runGhc1 GHC.load (GHC.LoadUpTo m)
+                   runGhc $ GHC.addTarget t
+                   res <- runGhc $ GHC.load (GHC.LoadUpTo m)
                    --
                    if isSucceeded res
-                     then do runGhc2 setContext old_top old_imps
+                     then do runGhc $ setContext old_top old_imps
                              return $ Just ()
                      else return Nothing)
         `catchIE` (\err -> case err of
@@ -158,7 +158,7 @@ removePhantomModule pm =
                      mod <- findModule (pmName pm)
                      (mods, imps) <- runGhc getContext
                      let mods' = filter (mod /=) mods
-                     runGhc2 setContext mods' imps
+                     runGhc $ setContext mods' imps
                      --
                      let isNotPhantom :: GHC.Module -> m Bool
                          isNotPhantom mod' = do
@@ -167,12 +167,12 @@ removePhantomModule pm =
              else return True
        --
        let file_name = pmFile pm
-       runGhc1 GHC.removeTarget (GHC.targetId $ fileTarget file_name)
+       runGhc $ GHC.removeTarget (GHC.targetId $ fileTarget file_name)
        --
        onState (\s -> s{activePhantoms = filter (pm /=) $ activePhantoms s})
        --
        if safeToRemove
-         then mayFail $ do res <- runGhc1 GHC.load GHC.LoadAllTargets
+         then mayFail $ do res <- runGhc $ GHC.load GHC.LoadAllTargets
                            return $ guard (isSucceeded res) >> Just ()
               `finally` do liftIO $ removeFile (pmFile pm)
          else onState (\s -> s{zombiePhantoms = pm:zombiePhantoms s})
@@ -218,10 +218,10 @@ loadModules fs = do -- first, unload everything, and do some clean-up
 
 doLoad :: MonadInterpreter m => [String] -> m ()
 doLoad fs = mayFail $ do
-                   targets <- mapM (\f->runGhc2 GHC.guessTarget f Nothing) fs
+                   targets <- mapM (\f->runGhc $ GHC.guessTarget f Nothing) fs
                    --
-                   runGhc1 GHC.setTargets targets
-                   res <- runGhc1 GHC.load GHC.LoadAllTargets
+                   runGhc $ GHC.setTargets targets
+                   res <- runGhc $ GHC.load GHC.LoadAllTargets
                    -- loading the targets removes the support module
                    reinstallSupportModule
                    return $ guard (isSucceeded res) >> Just ()
@@ -230,7 +230,7 @@ doLoad fs = mayFail $ do
 isModuleInterpreted :: MonadInterpreter m => ModuleName -> m Bool
 isModuleInterpreted moduleName = do
   mod <- findModule moduleName
-  runGhc1 GHC.moduleIsInterpreted mod
+  runGhc $ GHC.moduleIsInterpreted mod
 
 -- | Returns the list of modules loaded with 'loadModules'.
 getLoadedModules :: MonadInterpreter m => m [ModuleName]
@@ -245,7 +245,7 @@ getLoadedModSummaries :: MonadInterpreter m => m [GHC.ModSummary]
 getLoadedModSummaries = do
     modGraph <- runGhc GHC.getModuleGraph
     let modSummaries = GHC.mgModSummaries modGraph
-    filterM (runGhc1 GHC.isLoaded . GHC.ms_mod_name) modSummaries
+    filterM (\modl -> runGhc $ GHC.isLoaded $ GHC.ms_mod_name modl) modSummaries
 
 -- | Sets the modules whose context is used during evaluation. All bindings
 --   of these modules are in scope, not only those exported.
@@ -263,14 +263,14 @@ setTopLevelModules ms =
        active_pms <- fromState activePhantoms
        ms_mods <- mapM findModule (nub $ ms ++ map pmName active_pms)
        --
-       let mod_is_interpr = runGhc1 GHC.moduleIsInterpreted
+       let mod_is_interpr modl = runGhc $ GHC.moduleIsInterpreted modl
        not_interpreted <- filterM (fmap not . mod_is_interpr) ms_mods
        unless (null not_interpreted) $
          throwM $ NotAllowed ("These modules are not interpreted:\n" ++
                               unlines (map moduleToString not_interpreted))
        --
        (_, old_imports) <- runGhc getContext
-       runGhc2 setContext ms_mods old_imports
+       runGhc $ setContext ms_mods old_imports
 
 -- | Sets the modules whose exports must be in context.
 --
@@ -323,7 +323,7 @@ setImportsF moduleImports = do
            pure [phantom_mod]
        (old_top_level, _) <- runGhc getContext
        let new_top_level = phantom_mods ++ old_top_level
-       runGhc2 setContextModules new_top_level regularMods
+       runGhc $ setContextModules new_top_level regularMods
        --
        onState (\s ->s{qualImports = phantomImports})
   where
@@ -351,11 +351,11 @@ setImportsF moduleImports = do
 cleanPhantomModules :: MonadInterpreter m => m ()
 cleanPhantomModules =
     do -- Remove all modules from context
-       runGhc2 setContext [] []
+       runGhc $ setContext [] []
        --
        -- Unload all previously loaded modules
-       runGhc1 GHC.setTargets []
-       _ <- runGhc1 GHC.load GHC.LoadAllTargets
+       runGhc $ GHC.setTargets []
+       _ <- runGhc $ GHC.load GHC.LoadAllTargets
        --
        -- At this point, GHCi would call rts_revertCAFs and
        -- reset the buffering of stdin, stdout and stderr.
@@ -392,7 +392,7 @@ installSupportModule :: MonadInterpreter m => m ()
 installSupportModule = do mod <- addPhantomModule support_module
                           onState (\st -> st{hintSupportModule = mod})
                           mod' <- findModule (pmName mod)
-                          runGhc2 setContext [mod'] []
+                          runGhc $ setContext [mod'] []
     --
     where support_module m = unlines [
                                "module " ++ m ++ "( ",

src/Hint/Conversions.hs

@@ -14,7 +14,8 @@ typeToString t
       -- (i.e., do not expose internals)
       unqual <- runGhc GHC.getPrintUnqual
       withDynFlags $ \df ->
-        return $ GHC.showSDocForUser df unqual (GHC.pprTypeForUser t)
+        -- TODO: get unit state from somewhere?
+        return $ GHC.showSDocForUser df GHC.emptyUnitState unqual (GHC.pprTypeForUser t)
 
 kindToString :: MonadInterpreter m => GHC.Kind -> m String
 kindToString k

src/Hint/Eval.hs

@@ -41,7 +41,7 @@ unsafeInterpret expr type_str =
        failOnParseError parseExpr expr
        --
        let expr_typesig = concat [parens expr, " :: ", type_str]
-       expr_val <- mayFail $ runGhc1 compileExpr expr_typesig
+       expr_val <- mayFail $ runGhc $ compileExpr expr_typesig
        --
        return (GHC.Exts.unsafeCoerce# expr_val :: a)
 
@@ -65,7 +65,7 @@ eval expr = do in_scope_show   <- supportShow
 -- > runStmt "x <- return 42"
 -- > runStmt "print x"
 runStmt :: (MonadInterpreter m) => String -> m ()
-runStmt = mayFail . runGhc1 go
+runStmt s = mayFail $ runGhc $ go s
     where
     go statements = do
         result <- GHC.execStmt statements GHC.execOptions