diff --git a/AUTHORS b/AUTHORS --- a/AUTHORS +++ b/AUTHORS @@ -2,8 +2,10 @@ Austin Seipp Bertram Felgenhauer +Brandon Chinn Bryan O'Sullivan Carl Howells +Christiaan Baaij Conrad Parker Corentin Dupont Daniel Gorin diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +### 0.9.0.5 + +* Support GHC 9.2.1 + ### 0.9.0.4 * Support GHC 9.0.1 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -22,9 +22,11 @@ {-# LANGUAGE LambdaCase, ScopedTypeVariables, TypeApplications #-} import Control.Exception (throwIO) + import Control.Monad (when) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Writer (execWriterT, tell) import Data.Foldable (for_) + import Data.List (isPrefixOf) import Data.Typeable (Typeable) import qualified Language.Haskell.Interpreter as Hint @@ -32,23 +34,23 @@ -- Interpret expressions into values: -- -- >>> eval @[Int] "[1,2] ++ [3]" - -- [1,2,3] + -- Right [1,2,3] -- -- Send values from your compiled program to your interpreted program by -- interpreting a function: -- - -- >>> f <- eval @(Int -> [Int]) "\\x -> [1..x]" + -- >>> Right f <- eval @(Int -> [Int]) "\\x -> [1..x]" -- >>> f 5 -- [1,2,3,4,5] eval :: forall t. Typeable t - => String -> IO t - eval s = runInterpreter $ do + => String -> IO (Either Hint.InterpreterError t) + eval s = Hint.runInterpreter $ do Hint.setImports ["Prelude"] Hint.interpret s (Hint.as :: t) -- | -- >>> :{ - -- do contents <- browse "Prelude" + -- do Right contents <- browse "Prelude" -- for_ contents $ \(identifier, tp) -> do -- when ("put" `isPrefixOf` identifier) $ do -- putStrLn $ identifier ++ " :: " ++ tp @@ -56,8 +58,8 @@ -- putChar :: Char -> IO () -- putStr :: String -> IO () -- putStrLn :: String -> IO () - browse :: Hint.ModuleName -> IO [(String, String)] - browse moduleName = runInterpreter $ do + browse :: Hint.ModuleName -> IO (Either Hint.InterpreterError [(String, String)]) + browse moduleName = Hint.runInterpreter $ do Hint.setImports ["Prelude", "Data.Typeable", moduleName] exports <- Hint.getModuleExports moduleName execWriterT $ do diff --git a/hint.cabal b/hint.cabal --- a/hint.cabal +++ b/hint.cabal @@ -1,5 +1,5 @@ name: hint -version: 0.9.0.4 +version: 0.9.0.5 description: This library defines an Interpreter monad. It allows to load Haskell modules, browse them, type-check and evaluate strings with Haskell @@ -60,7 +60,8 @@ library default-language: Haskell2010 build-depends: base == 4.*, - ghc >= 8.4 && < 9.2, + containers, + ghc >= 8.4 && < 9.3, ghc-paths, ghc-boot, transformers, diff --git a/src/Control/Monad/Ghc.hs b/src/Control/Monad/Ghc.hs --- a/src/Control/Monad/Ghc.hs +++ b/src/Control/Monad/Ghc.hs @@ -14,6 +14,9 @@ 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 @@ -91,6 +94,11 @@ instance (MonadIO m, MonadCatch m, MonadMask m) => GHC.ExceptionMonad (GhcT m) where gcatch = catch 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 diff --git a/src/Hint/Annotations.hs b/src/Hint/Annotations.hs --- a/src/Hint/Annotations.hs +++ b/src/Hint/Annotations.hs @@ -9,13 +9,20 @@ 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 @@ -- 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 diff --git a/src/Hint/Base.hs b/src/Hint/Base.hs --- a/src/Hint/Base.hs +++ b/src/Hint/Base.hs @@ -3,13 +3,11 @@ 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 @@ (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 @@ 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 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 @@ 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 diff --git a/src/Hint/Configuration.hs b/src/Hint/Configuration.hs --- a/src/Hint/Configuration.hs +++ b/src/Hint/Configuration.hs @@ -29,12 +29,13 @@ 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 @@ 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) diff --git a/src/Hint/Context.hs b/src/Hint/Context.hs --- a/src/Hint/Context.hs +++ b/src/Hint/Context.hs @@ -127,11 +127,11 @@ -- 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 @@ 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 @@ 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 @@ 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 @@ 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 = 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 @@ 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 @@ 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 @@ 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 = 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 ++ "( ", diff --git a/src/Hint/Conversions.hs b/src/Hint/Conversions.hs --- a/src/Hint/Conversions.hs +++ b/src/Hint/Conversions.hs @@ -14,7 +14,8 @@ -- (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 diff --git a/src/Hint/Eval.hs b/src/Hint/Eval.hs --- a/src/Hint/Eval.hs +++ b/src/Hint/Eval.hs @@ -41,7 +41,7 @@ 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 @@ -- > 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 @@ -81,7 +81,7 @@ -- put the closing parenthesis in a different line. However, now we are -- messing with the layout rules and we don't know where @s@ is going to -- be used! --- Solution: @parens s = \"(let {foo =\n\" ++ s ++ \"\\n ;} in foo)\"@ where @foo@ does not occur in @s@ +-- Solution: @parens s = \"(let {foo =\\n\" ++ s ++ \"\\n ;} in foo)\"@ where @foo@ does not occur in @s@ parens :: String -> String parens s = concat ["(let {", foo, " =\n", s, "\n", " ;} in ", foo, ")"] diff --git a/src/Hint/GHC.hs b/src/Hint/GHC.hs --- a/src/Hint/GHC.hs +++ b/src/Hint/GHC.hs @@ -1,74 +1,357 @@ module Hint.GHC ( - Message, module X -#if MIN_VERSION_ghc(9,0,0) - , dynamicGhc -#endif + -- * Shims + dynamicGhc, + Message, + Logger, + initLogger, + putLogMsg, + pushLogHook, + modifyLogger, + UnitState, + emptyUnitState, + showSDocForUser, + ParserOpts, + mkParserOpts, + initParserState, + getErrorMessages, + pprErrorMessages, + SDocContext, + defaultSDocContext, + showGhcException, + addWay, + setBackendToInterpreter, + parseDynamicFlags, + -- * Re-exports + module X, ) where -import GHC as X hiding (Phase, GhcT, runGhcT) +import GHC as X hiding (Phase, GhcT, parseDynamicFlags, runGhcT, showGhcException +#if MIN_VERSION_ghc(9,2,0) + , Logger + , modifyLogger + , pushLogHook +#endif + ) import Control.Monad.Ghc as X (GhcT, runGhcT) -#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,2,0) +import GHC.Types.SourceError as X (SourceError, srcErrorMessages) + +import GHC.Driver.Ppr as X (showSDoc) + +import GHC.Types.SourceFile as X (HscSource(HsSrcFile)) + +import GHC.Utils.Logger as X (LogAction) +import GHC.Platform.Ways as X (Way (..)) + +import GHC.Types.TyThing.Ppr as X (pprTypeForUser) +#elif MIN_VERSION_ghc(9,0,0) import GHC.Driver.Types as X (SourceError, srcErrorMessages, GhcApiError) --- import GHC.Driver.Types as X (mgModSummaries) +import GHC.Utils.Outputable as X (showSDoc) + +import GHC.Driver.Phases as X (HscSource(HsSrcFile)) + +import GHC.Driver.Session as X (LogAction, addWay') +import GHC.Driver.Ways as X (Way (..)) + +import GHC.Core.Ppr.TyThing as X (pprTypeForUser) +#else +import HscTypes as X (SourceError, srcErrorMessages, GhcApiError) + +import Outputable as X (showSDoc) + +import DriverPhases as X (HscSource(HsSrcFile)) + +import DynFlags as X (LogAction, addWay', Way(..)) + +import PprTyThing as X (pprTypeForUser) +#endif + +#if MIN_VERSION_ghc(9,0,0) import GHC.Utils.Outputable as X (PprStyle, SDoc, Outputable(ppr), - showSDoc, showSDocForUser, showSDocUnqual, withPprStyle, defaultErrStyle, vcat) -import GHC.Utils.Error as X (mkLocMessage, pprErrMsgBagWithLoc, MsgDoc, - errMsgSpan, pprErrMsgBagWithLoc) - -- we alias MsgDoc as Message below +import GHC.Utils.Error as X (mkLocMessage, errMsgSpan) -import GHC.Driver.Phases as X (Phase(Cpp), HscSource(HsSrcFile)) +import GHC.Driver.Phases as X (Phase(Cpp)) import GHC.Data.StringBuffer as X (stringToStringBuffer) -import GHC.Parser.Lexer as X (P(..), ParseResult(..), mkPState, - getErrorMessages) +import GHC.Parser.Lexer as X (P(..), ParseResult(..)) import GHC.Parser as X (parseStmt, parseType) import GHC.Data.FastString as X (fsLit) -import GHC.Driver.Session as X (xFlags, xopt, LogAction, FlagSpec(..), - WarnReason(NoReason), addWay') -import GHC.Driver.Ways as X (Way (..), hostIsDynamic) +import GHC.Driver.Session as X (xFlags, xopt, FlagSpec(..), WarnReason(NoReason)) -import GHC.Core.Ppr.TyThing as X (pprTypeForUser) import GHC.Types.SrcLoc as X (combineSrcSpans, mkRealSrcLoc) import GHC.Core.ConLike as X (ConLike(RealDataCon)) - -dynamicGhc :: Bool -dynamicGhc = hostIsDynamic #else -import HscTypes as X (SourceError, srcErrorMessages, GhcApiError) import HscTypes as X (mgModSummaries) import Outputable as X (PprStyle, SDoc, Outputable(ppr), - showSDoc, showSDocForUser, showSDocUnqual, withPprStyle, defaultErrStyle, vcat) -import ErrUtils as X (mkLocMessage, pprErrMsgBagWithLoc, MsgDoc -#if __GLASGOW_HASKELL__ >= 810 - , errMsgSpan, pprErrMsgBagWithLoc -#endif - ) -- we alias MsgDoc as Message below +import ErrUtils as X (mkLocMessage, errMsgSpan) -import DriverPhases as X (Phase(Cpp), HscSource(HsSrcFile)) +import DriverPhases as X (Phase(Cpp)) import StringBuffer as X (stringToStringBuffer) -import Lexer as X (P(..), ParseResult(..), mkPState -#if __GLASGOW_HASKELL__ >= 810 - , getErrorMessages -#endif - ) +import Lexer as X (P(..), ParseResult(..), mkPState) import Parser as X (parseStmt, parseType) import FastString as X (fsLit) -import DynFlags as X (xFlags, xopt, LogAction, FlagSpec(..), - WarnReason(NoReason), addWay', Way(..), dynamicGhc) +import DynFlags as X (xFlags, xopt, FlagSpec(..), WarnReason(NoReason)) -import PprTyThing as X (pprTypeForUser) import SrcLoc as X (combineSrcSpans, mkRealSrcLoc) import ConLike as X (ConLike(RealDataCon)) #endif -type Message = MsgDoc +{-------------------- Imports for Shims --------------------} + +import Control.Monad.IO.Class (MonadIO) + +#if MIN_VERSION_ghc(9,2,0) +-- dynamicGhc +import GHC.Platform.Ways (hostIsDynamic) + +-- Logger +import qualified GHC.Utils.Logger as GHC (Logger, initLogger, putLogMsg, pushLogHook) +import qualified GHC.Driver.Monad as GHC (modifyLogger) + +-- UnitState +import qualified GHC.Unit.State as GHC (UnitState, emptyUnitState) + +-- showSDocForUser +import qualified GHC.Driver.Ppr as GHC (showSDocForUser) + +-- PState +import qualified GHC.Parser.Lexer as GHC (PState, ParserOpts, mkParserOpts, initParserState) +import GHC.Data.StringBuffer (StringBuffer) +import qualified GHC.Driver.Session as DynFlags (warningFlags, extensionFlags, safeImportsOn) + +-- ErrorMessages +import qualified GHC.Parser.Errors.Ppr as GHC (pprError) +import qualified GHC.Parser.Lexer as GHC (getErrorMessages) +import qualified GHC.Types.Error as GHC (ErrorMessages, errMsgDiagnostic, unDecorated) +import GHC.Data.Bag (bagToList) + +-- showGhcException +import qualified GHC (showGhcException) +import qualified GHC.Utils.Outputable as GHC (SDocContext, defaultSDocContext) + +-- addWay +import qualified GHC.Driver.Session as DynFlags (targetWays_) +import qualified Data.Set as Set + +-- parseDynamicFlags +import qualified GHC (parseDynamicFlags) +import GHC.Driver.CmdLine (Warn) +#elif MIN_VERSION_ghc(9,0,0) +-- dynamicGhc +import GHC.Driver.Ways (hostIsDynamic) + +-- Message +import qualified GHC.Utils.Error as GHC (MsgDoc) + +-- Logger +import qualified GHC.Driver.Session as GHC (defaultLogAction) +import qualified GHC.Driver.Session as DynFlags (log_action) + +-- showSDocForUser +import qualified GHC.Utils.Outputable as GHC (showSDocForUser) + +-- PState +import qualified GHC.Parser.Lexer as GHC (PState, ParserFlags, mkParserFlags, mkPStatePure) +import GHC.Data.StringBuffer (StringBuffer) + +-- ErrorMessages +import qualified GHC.Utils.Error as GHC (ErrorMessages, pprErrMsgBagWithLoc) +import qualified GHC.Parser.Lexer as GHC (getErrorMessages) + +-- showGhcException +import qualified GHC (showGhcException) + +-- addWay +import qualified GHC.Driver.Session as GHC (addWay') + +-- parseDynamicFlags +import qualified GHC (parseDynamicFlags) +import GHC.Driver.CmdLine (Warn) +#else +-- dynamicGhc +import qualified DynFlags as GHC (dynamicGhc) + +-- Message +import qualified ErrUtils as GHC (MsgDoc) + +-- Logger +import qualified DynFlags as GHC (defaultLogAction) +import qualified DynFlags (log_action) + +-- showSDocForUser +import qualified Outputable as GHC (showSDocForUser) + +-- PState +import qualified Lexer as GHC (PState, ParserFlags, mkParserFlags, mkPStatePure) +import StringBuffer (StringBuffer) + +-- ErrorMessages +import qualified ErrUtils as GHC (ErrorMessages, pprErrMsgBagWithLoc) +#if MIN_VERSION_ghc(8,10,0) +import qualified Lexer as GHC (getErrorMessages) +#else +import Bag (emptyBag) +#endif + +-- showGhcException +import qualified GHC (showGhcException) + +-- addWay +import qualified DynFlags as GHC (addWay') + +-- parseDynamicFlags +import qualified GHC (parseDynamicFlags) +import CmdLineParser (Warn) +#endif + +{-------------------- Shims --------------------} + +-- dynamicGhc +dynamicGhc :: Bool +#if MIN_VERSION_ghc(9,0,0) +dynamicGhc = hostIsDynamic +#else +dynamicGhc = GHC.dynamicGhc +#endif + +-- Message +#if MIN_VERSION_ghc(9,2,0) +type Message = SDoc +#else +type Message = GHC.MsgDoc +#endif + +-- Logger +initLogger :: IO Logger +putLogMsg :: Logger -> LogAction +pushLogHook :: (LogAction -> LogAction) -> Logger -> Logger +modifyLogger :: GhcMonad m => (Logger -> Logger) -> m () +#if MIN_VERSION_ghc(9,2,0) +type Logger = GHC.Logger +initLogger = GHC.initLogger +putLogMsg = GHC.putLogMsg +pushLogHook = GHC.pushLogHook +modifyLogger = GHC.modifyLogger +#else +type Logger = LogAction +initLogger = pure GHC.defaultLogAction +putLogMsg = id +pushLogHook = id +modifyLogger f = do + df <- getSessionDynFlags + _ <- setSessionDynFlags df{log_action = f $ DynFlags.log_action df} + return () +#endif + +-- UnitState +emptyUnitState :: UnitState +#if MIN_VERSION_ghc(9,2,0) +type UnitState = GHC.UnitState +emptyUnitState = GHC.emptyUnitState +#else +type UnitState = () +emptyUnitState = () +#endif + +-- showSDocForUser +showSDocForUser :: DynFlags -> UnitState -> PrintUnqualified -> SDoc -> String +#if MIN_VERSION_ghc(9,2,0) +showSDocForUser = GHC.showSDocForUser +#else +showSDocForUser df _ = GHC.showSDocForUser df +#endif + +-- PState +mkParserOpts :: DynFlags -> ParserOpts +initParserState :: ParserOpts -> StringBuffer -> RealSrcLoc -> GHC.PState +#if MIN_VERSION_ghc(9,2,0) +type ParserOpts = GHC.ParserOpts +mkParserOpts = + -- adapted from + -- https://hackage.haskell.org/package/ghc-8.10.2/docs/src/Lexer.html#line-2437 + GHC.mkParserOpts + <$> DynFlags.warningFlags + <*> DynFlags.extensionFlags + <*> DynFlags.safeImportsOn + <*> gopt Opt_Haddock + <*> gopt Opt_KeepRawTokenStream + <*> const True + +initParserState = GHC.initParserState +#else +type ParserOpts = GHC.ParserFlags +mkParserOpts = GHC.mkParserFlags + +initParserState = GHC.mkPStatePure +#endif + +-- ErrorMessages +getErrorMessages :: GHC.PState -> DynFlags -> GHC.ErrorMessages +pprErrorMessages :: GHC.ErrorMessages -> [SDoc] +#if MIN_VERSION_ghc(9,2,0) +getErrorMessages pstate _ = fmap GHC.pprError $ GHC.getErrorMessages pstate +pprErrorMessages = bagToList . fmap pprErrorMessage + where + pprErrorMessage = vcat . GHC.unDecorated . GHC.errMsgDiagnostic +#elif MIN_VERSION_ghc(8,10,0) +getErrorMessages = GHC.getErrorMessages +pprErrorMessages = GHC.pprErrMsgBagWithLoc +#else +getErrorMessages _ _ = emptyBag +pprErrorMessages = GHC.pprErrMsgBagWithLoc +#endif + +-- SDocContext +defaultSDocContext :: SDocContext +#if MIN_VERSION_ghc(9,2,0) +type SDocContext = GHC.SDocContext +defaultSDocContext = GHC.defaultSDocContext +#else +type SDocContext = () +defaultSDocContext = () +#endif + +-- showGhcException +showGhcException :: SDocContext -> GhcException -> ShowS +#if MIN_VERSION_ghc(9,2,0) +showGhcException = GHC.showGhcException +#else +showGhcException _ = GHC.showGhcException +#endif + +-- addWay +addWay :: Way -> DynFlags -> DynFlags +#if MIN_VERSION_ghc(9,2,0) +addWay way df = + df + { targetWays_ = Set.insert way $ DynFlags.targetWays_ df + } +#else +addWay = GHC.addWay' +#endif + +-- setBackendToInterpreter +setBackendToInterpreter :: DynFlags -> DynFlags +#if MIN_VERSION_ghc(9,2,0) +setBackendToInterpreter df = df{backend = Interpreter} +#else +setBackendToInterpreter df = df{hscTarget = HscInterpreted} +#endif + +-- parseDynamicFlags +parseDynamicFlags :: MonadIO m => Logger -> DynFlags -> [Located String] -> m (DynFlags, [Located String], [Warn]) +#if MIN_VERSION_ghc(9,2,0) +parseDynamicFlags = GHC.parseDynamicFlags +#else +parseDynamicFlags _ = GHC.parseDynamicFlags +#endif diff --git a/src/Hint/InterpreterT.hs b/src/Hint/InterpreterT.hs --- a/src/Hint/InterpreterT.hs +++ b/src/Hint/InterpreterT.hs @@ -64,11 +64,11 @@ compilationError dynFlags = WontCompile . map (GhcError . GHC.showSDoc dynFlags) - . GHC.pprErrMsgBagWithLoc + . GHC.pprErrorMessages . GHC.srcErrorMessages showGhcEx :: GHC.GhcException -> String -showGhcEx = flip GHC.showGhcException "" +showGhcEx = flip (GHC.showGhcException GHC.defaultSDocContext) "" -- ================= Executing the interpreter ================== @@ -76,12 +76,14 @@ => [String] -> InterpreterT m () initialize args = - do log_handler <- fromSession ghcErrLogger + do logger <- fromSession ghcLogger + runGhc $ GHC.modifyLogger (const logger) + -- Set a custom log handler, to intercept error messages :S df0 <- runGhc GHC.getSessionDynFlags let df1 = configureDynFlags df0 - (df2, extra) <- runGhc2 parseDynamicFlags df1 args + (df2, extra) <- runGhc $ parseDynamicFlags logger df1 args unless (null extra) $ throwM $ UnknownError (concat [ "flags: '" , unwords extra @@ -89,7 +91,7 @@ -- Observe that, setSessionDynFlags loads info on packages -- available; calling this function once is mandatory! - _ <- runGhc1 GHC.setSessionDynFlags df2{GHC.log_action = log_handler} + _ <- runGhc $ GHC.setSessionDynFlags df2 let extMap = [ (GHC.flagSpecName flagSpec, GHC.flagSpecFlag flagSpec) | flagSpec <- GHC.xFlags @@ -175,35 +177,30 @@ newSessionData a = do initial_state <- liftIO $ newIORef initialState ghc_err_list_ref <- liftIO $ newIORef [] + logger <- liftIO $ GHC.initLogger return SessionData { internalState = initial_state, versionSpecific = a, ghcErrListRef = ghc_err_list_ref, - ghcErrLogger = mkLogHandler ghc_err_list_ref + ghcLogger = GHC.pushLogHook (const $ mkLogAction ghc_err_list_ref) logger } -#if MIN_VERSION_ghc(9,0,0) -mkLogHandler :: IORef [GhcError] -> GhcErrLogger -mkLogHandler r df _ _ src msg = - let renderErrMsg = GHC.showSDoc df +mkLogAction :: IORef [GhcError] -> GHC.LogAction +mkLogAction r = mkLogAction' $ \df _ _ src withStyle msg -> + let renderErrMsg = GHC.showSDoc df . withStyle errorEntry = mkGhcError renderErrMsg src msg in modifyIORef r (errorEntry :) + where + mkLogAction' f = +#if MIN_VERSION_ghc(9,0,0) + \df wr sev src msg -> f df wr sev src id msg +#else + \df wr sev src style msg -> f df wr sev src (GHC.withPprStyle style) msg +#endif mkGhcError :: (GHC.SDoc -> String) -> GHC.SrcSpan -> GHC.Message -> GhcError mkGhcError render src_span msg = GhcError{errMsg = niceErrMsg} where niceErrMsg = render $ GHC.mkLocMessage GHC.SevError src_span msg -#else -mkLogHandler :: IORef [GhcError] -> GhcErrLogger -mkLogHandler r df _ _ src style msg = - let renderErrMsg = GHC.showSDoc df - errorEntry = mkGhcError renderErrMsg src style msg - in modifyIORef r (errorEntry :) - -mkGhcError :: (GHC.SDoc -> String) -> GHC.SrcSpan -> GHC.PprStyle -> GHC.Message -> GhcError -mkGhcError render src_span style msg = GhcError{errMsg = niceErrMsg} - where niceErrMsg = render . GHC.withPprStyle style $ - GHC.mkLocMessage GHC.SevError src_span msg -#endif -- The MonadInterpreter instance diff --git a/src/Hint/Parsers.hs b/src/Hint/Parsers.hs --- a/src/Hint/Parsers.hs +++ b/src/Hint/Parsers.hs @@ -24,19 +24,19 @@ -- -- ghc >= 7 panics if noSrcLoc is given let srcLoc = GHC.mkRealSrcLoc (GHC.fsLit "") 1 1 - let parse_res = GHC.unP parser (GHC.mkPState dyn_fl buf srcLoc) + let parserOpts = GHC.mkParserOpts dyn_fl + let parse_res = GHC.unP parser (GHC.initParserState parserOpts buf srcLoc) -- case parse_res of GHC.POk{} -> return ParseOk -- -#if __GLASGOW_HASKELL__ >= 810 +#if MIN_VERSION_ghc(8,10,0) GHC.PFailed pst -> let errMsgs = GHC.getErrorMessages pst dyn_fl span = foldr (GHC.combineSrcSpans . GHC.errMsgSpan) GHC.noSrcSpan errMsgs - err = GHC.vcat $ GHC.pprErrMsgBagWithLoc errMsgs + err = GHC.vcat $ GHC.pprErrorMessages errMsgs in pure (ParseError span err) #else - GHC.PFailed _ span err - -> return (ParseError span err) + GHC.PFailed _ span err -> return (ParseError span err) #endif failOnParseError :: MonadInterpreter m @@ -51,9 +51,9 @@ ParseError span err -> do -- parsing failed, so we report it just as all -- other errors get reported.... - logger <- fromSession ghcErrLogger + logger <- fromSession ghcLogger dflags <- runGhc GHC.getSessionDynFlags - let logger' = logger dflags + let logger' = GHC.putLogMsg logger dflags #if !MIN_VERSION_ghc(9,0,0) errStyle = GHC.defaultErrStyle dflags #endif diff --git a/src/Hint/Reflection.hs b/src/Hint/Reflection.hs --- a/src/Hint/Reflection.hs +++ b/src/Hint/Reflection.hs @@ -30,8 +30,8 @@ getModuleExports :: MonadInterpreter m => ModuleName -> m [ModuleElem] getModuleExports mn = do module_ <- findModule mn - mod_info <- mayFail $ runGhc1 GHC.getModuleInfo module_ - exports <- mapM (runGhc1 GHC.lookupName) (GHC.modInfoExports mod_info) + mod_info <- mayFail $ runGhc $ GHC.getModuleInfo module_ + exports <- mapM (\n -> runGhc $ GHC.lookupName n) (GHC.modInfoExports mod_info) dflags <- runGhc GHC.getSessionDynFlags -- return $ asModElemList dflags (catMaybes exports) @@ -52,4 +52,4 @@ alsoIn es = (`elem` map name es) getUnqualName :: GHC.NamedThing a => GHC.DynFlags -> a -> String -getUnqualName dfs = GHC.showSDocUnqual dfs . GHC.pprParenSymName +getUnqualName dfs = GHC.showSDoc dfs . GHC.pprParenSymName diff --git a/src/Hint/Typecheck.hs b/src/Hint/Typecheck.hs --- a/src/Hint/Typecheck.hs +++ b/src/Hint/Typecheck.hs @@ -18,7 +18,7 @@ -- kind of errors failOnParseError parseExpr expr -- - type_ <- mayFail (runGhc1 exprType expr) + type_ <- mayFail (runGhc $ exprType expr) typeToString type_ -- | Tests if the expression type checks. @@ -45,7 +45,7 @@ -- kind of errors failOnParseError parseType type_expr -- - (_, kind) <- mayFail $ runGhc1 typeKind type_expr + (_, kind) <- mayFail $ runGhc $ typeKind type_expr -- kindToString kind @@ -58,7 +58,7 @@ -- kind of errors failOnParseError parseType type_expr -- - (ty, _) <- mayFail $ runGhc1 typeKind type_expr + (ty, _) <- mayFail $ runGhc $ typeKind type_expr -- typeToString ty diff --git a/unit-tests/run-unit-tests.hs b/unit-tests/run-unit-tests.hs --- a/unit-tests/run-unit-tests.hs +++ b/unit-tests/run-unit-tests.hs @@ -55,10 +55,13 @@ test_lang_exts :: TestCase test_lang_exts = TestCase "lang_exts" [mod_file] $ do - liftIO $ writeFile mod_file "data T where T :: T" + liftIO $ writeFile mod_file $ unlines + [ "data Foo = Foo { a :: Int }" + , "f Foo{..} = a * 10" + ] fails do_load @@? "first time, it shouldn't load" -- - set [languageExtensions := [GADTs]] + set [languageExtensions := [RecordWildCards]] succeeds do_load @@? "now, it should load" -- set [languageExtensions := []] @@ -230,7 +233,7 @@ -- is run on an older ghc version. Otherwise this test is not testing what it's -- meant to. test_multiple_instances :: TestCase -test_multiple_instances = TestCase "multiple_instances" ["mod_file"] $ liftIO $ do +test_multiple_instances = TestCase "multiple_instances" [mod_file] $ liftIO $ do writeFile mod_file "f = id" -- ensure the two threads interleave in a deterministic way