diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +### 0.9.0.7 + +* Support GHC 9.4 +* Support GHC 9.6 +* Improved documentation + ### 0.9.0.6 * Fixes the 0.9.0.5 regression diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -9,15 +9,6 @@ expressions, you can browse the contents of those modules, and you can ask for the type of the identifiers you're browsing. -It is, essentially, a huge subset of the GHC API wrapped in a simpler API. - -## Limitations - -It is possible to run the interpreter inside a thread, but on GHC 8.8 and -below, you can't run two instances of the interpreter simultaneously. - -GHC must be installed on the system on which the compiled executable is running. - ## Example {-# LANGUAGE LambdaCase, ScopedTypeVariables, TypeApplications #-} @@ -35,7 +26,7 @@ -- -- >>> eval @[Int] "[1,2] ++ [3]" -- Right [1,2,3] - -- + -- -- Send values from your compiled program to your interpreted program by -- interpreting a function: -- @@ -71,3 +62,46 @@ Check [example.hs](examples/example.hs) for a longer example (it must be run from hint's base directory). + +## Limitations + +Importing a module from the current package is not supported. It might look +like it works on one day and then segfault the next day. You have been warned. + +To work around this limitation, move those modules to a separate package. Now +the part of your code which calls hint and the code interpreted by hint can +both import that module. + +It is not possible to exchange a value [whose type involves an implicit kind +parameter](https://github.com/haskell-hint/hint/issues/159#issuecomment-1575629607). +This includes type-level lists. To work around this limitation, [define a +newtype wrapper which wraps the type you +want](https://github.com/haskell-hint/hint/issues/159#issuecomment-1575640606). + +It is possible to run the interpreter inside a thread, but on GHC 8.8 and +below, you can't run two instances of the interpreter simultaneously. + +GHC must be installed on the system on which the compiled executable is +running. There is a workaround for this but [it's not trivial](https://github.com/haskell-hint/hint/issues/80#issuecomment-963109968). + +The packages used by the interpreted code must be installed in a package +database, and hint needs to be told about that package database at runtime. + +The most common use case for package databases is for the interpreted code to +have access to the same packages as the compiled code (but not compiled code +itself). The easiest way to accomplish this is via a +[GHC environment file](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/packages.html#package-environments), +and the easiest way to generate a GHC environment file is +[via cabal](https://cabal.readthedocs.io/en/3.4/cabal-project.html#cfg-field-write-ghc-environment-files). +Compile your code using `cabal build --write-ghc-environment-files=always`; +this will create a file named `.ghc.environment.` in the current +directory. At runtime, hint will look for that file in the current directory. + +For more advanced use cases, you can use +[`unsafeRunInterpreterWithArgs`](https://hackage.haskell.org/package/hint/docs/Language-Haskell-Interpreter-Unsafe.html#v:unsafeRunInterpreterWithArgs) +to pass arguments to the underlying ghc library, such as +[`-package-db`](https://downloads.haskell.org/~ghc/latest/docs/users_guide/packages.html?highlight=package%20db#ghc-flag--package-db%20%E2%9F%A8file%E2%9F%A9) +to specify a path to a package database, or +[`-package-env`](https://downloads.haskell.org/~ghc/latest/docs/users_guide/packages.html?highlight=package%20db#ghc-flag--package-env%20%E2%9F%A8file%E2%9F%A9%7C%E2%9F%A8name%E2%9F%A9) +to specify a path to a GHC environment file. + diff --git a/hint.cabal b/hint.cabal --- a/hint.cabal +++ b/hint.cabal @@ -1,5 +1,5 @@ name: hint -version: 0.9.0.6 +version: 0.9.0.7 description: This library defines an Interpreter monad. It allows to load Haskell modules, browse them, type-check and evaluate strings with Haskell @@ -16,6 +16,13 @@ author: The Hint Authors maintainer: "Samuel Gélineau" homepage: https://github.com/haskell-hint/hint +tested-with: ghc == 8.10.7 + , ghc == 8.6.5 + , ghc == 8.8.4 + , ghc == 9.0.2 + , ghc == 9.2.7 + , ghc == 9.4.5 + , ghc == 9.6.1 cabal-version: >= 1.10 build-type: Simple @@ -64,7 +71,7 @@ default-language: Haskell2010 build-depends: base == 4.*, containers, - ghc >= 8.4 && < 9.3, + ghc >= 8.4 && < 9.7, ghc-paths, ghc-boot, transformers, diff --git a/src/Hint/Context.hs b/src/Hint/Context.hs --- a/src/Hint/Context.hs +++ b/src/Hint/Context.hs @@ -108,27 +108,24 @@ setContextModules :: GHC.GhcMonad m => [GHC.Module] -> [GHC.Module] -> m () setContextModules as = setContext as . map (GHC.simpleImportDecl . GHC.moduleName) -fileTarget :: FilePath -> GHC.Target -fileTarget f = GHC.Target (GHC.TargetFile f $ Just next_phase) True Nothing - where next_phase = GHC.Cpp GHC.HsSrcFile - addPhantomModule :: MonadInterpreter m => (ModuleName -> ModuleText) -> m PhantomModule addPhantomModule mod_text = do pm <- newPhantomModule - let t = fileTarget (pmFile pm) + df <- runGhc GHC.getSessionDynFlags + let t = GHC.fileTarget df (pmFile pm) m = GHC.mkModuleName (pmName pm) -- liftIO $ writeFile (pmFile pm) (mod_text $ pmName pm) -- onState (\s -> s{activePhantoms = pm:activePhantoms s}) - mayFail (do -- GHC.load will remove all the modules from scope, so first - -- we save the context... + mayFail (do -- GHC.load will remove all the modules from + -- scope, so first we save the context... (old_top, old_imps) <- runGhc getContext -- runGhc $ GHC.addTarget t - res <- runGhc $ GHC.load (GHC.LoadUpTo m) + res <- runGhc $ GHC.load GHC.LoadAllTargets -- if isSucceeded res then do runGhc $ setContext old_top old_imps @@ -167,7 +164,8 @@ else return True -- let file_name = pmFile pm - runGhc $ GHC.removeTarget (GHC.targetId $ fileTarget file_name) + runGhc $ do df <- GHC.getSessionDynFlags + GHC.removeTarget (GHC.targetId $ GHC.fileTarget df file_name) -- onState (\s -> s{activePhantoms = filter (pm /=) $ activePhantoms s}) -- @@ -189,7 +187,10 @@ -- | Tries to load all the requested modules from their source file. -- Modules my be indicated by their ModuleName (e.g. \"My.Module\") or --- by the full path to its source file. +-- by the full path to its source file. Note that in order to use code from +-- that module, you also need to call 'setImports' (to use the exported types +-- and definitions) or 'setTopLevelModules' (to also use the private types +-- and definitions). -- -- The interpreter is 'reset' both before loading the modules and in the event -- of an error. @@ -217,14 +218,9 @@ doLoad fs `catchIE` (\e -> reset >> throwM e) doLoad :: MonadInterpreter m => [String] -> m () -doLoad fs = mayFail $ do - targets <- mapM (\f->runGhc $ GHC.guessTarget f Nothing) fs - -- - runGhc $ GHC.setTargets targets - res <- runGhc $ GHC.load GHC.LoadAllTargets - -- loading the targets removes the support module - reinstallSupportModule - return $ guard (isSucceeded res) >> Just () +doLoad fs = do targets <- mapM (\f->runGhc $ GHC.guessTarget f Nothing) fs + -- + reinstallSupportModule targets -- | Returns True if the module was interpreted. isModuleInterpreted :: MonadInterpreter m => ModuleName -> m Bool @@ -272,7 +268,11 @@ (_, old_imports) <- runGhc getContext runGhc $ setContext ms_mods old_imports --- | Sets the modules whose exports must be in context. +-- | Sets the modules whose exports must be in context. These can be modules +-- previously loaded with 'loadModules', or modules from packages which hint is +-- aware of. This includes package databases specified to +-- 'unsafeRunInterpreterWithArgs' by the @-package-db=...@ parameter, and +-- packages specified by a ghc environment file created by @cabal build --write-ghc-environment-files=always@. -- -- Warning: 'setImports', 'setImportsQ', and 'setImportsF' are mutually exclusive. -- If you have a list of modules to be used qualified and another list @@ -282,8 +282,7 @@ setImports :: MonadInterpreter m => [ModuleName] -> m () setImports ms = setImportsF $ map (\m -> ModuleImport m NotQualified NoImportList) ms --- | Sets the modules whose exports must be in context; some --- of them may be qualified. E.g.: +-- | A variant of 'setImports' where modules them may be qualified. e.g.: -- -- @setImportsQ [("Prelude", Nothing), ("Data.Map", Just "M")]@. -- @@ -291,8 +290,7 @@ setImportsQ :: MonadInterpreter m => [(ModuleName, Maybe String)] -> m () setImportsQ ms = setImportsF $ map (\(m,q) -> ModuleImport m (maybe NotQualified (QualifiedAs . Just) q) NoImportList) ms --- | Sets the modules whose exports must be in context; some --- may be qualified or have imports lists. E.g.: +-- | A variant of 'setImportsQ' where modules may have an explicit import list. e.g.: -- -- @setImportsF [ModuleImport "Prelude" NotQualified NoImportList, ModuleImport "Data.Text" (QualifiedAs $ Just "Text") (HidingList ["pack"])]@ @@ -385,14 +383,15 @@ cleanPhantomModules -- -- Now, install a support module - installSupportModule + installSupportModule [] -- Load a phantom module with all the symbols from the prelude we need -installSupportModule :: MonadInterpreter m => m () -installSupportModule = do mod <- addPhantomModule support_module - onState (\st -> st{hintSupportModule = mod}) - mod' <- findModule (pmName mod) - runGhc $ setContext [mod'] [] +installSupportModule :: MonadInterpreter m => [GHC.Target] -> m () +installSupportModule ts = do runGhc $ GHC.setTargets ts + mod <- addPhantomModule support_module + onState (\st -> st{hintSupportModule = mod}) + mod' <- findModule (pmName mod) + runGhc $ setContext [mod'] [] -- where support_module m = unlines [ "module " ++ m ++ "( ", @@ -413,10 +412,10 @@ -- Call it when the support module is an active phantom module but has been -- unloaded as a side effect by GHC (e.g. by calling GHC.loadTargets) -reinstallSupportModule :: MonadInterpreter m => m () -reinstallSupportModule = do pm <- fromState hintSupportModule - removePhantomModule pm - installSupportModule +reinstallSupportModule :: [GHC.Target] -> MonadInterpreter m => m () +reinstallSupportModule ts = do pm <- fromState hintSupportModule + removePhantomModule pm + installSupportModule ts altStringName :: ModuleName -> String altStringName mod_name = "String_" ++ mod_name diff --git a/src/Hint/GHC.hs b/src/Hint/GHC.hs --- a/src/Hint/GHC.hs +++ b/src/Hint/GHC.hs @@ -1,12 +1,15 @@ +{-# LANGUAGE TypeApplications #-} module Hint.GHC ( -- * Shims dynamicGhc, Message, Logger, + WarnReason(NoReason), initLogger, putLogMsg, pushLogHook, modifyLogger, + mkLogAction, UnitState, emptyUnitState, showSDocForUser, @@ -21,11 +24,21 @@ addWay, setBackendToInterpreter, parseDynamicFlags, + pprTypeForUser, + errMsgSpan, + fileTarget, + guessTarget, +#if MIN_VERSION_ghc(9,6,0) + getPrintUnqual, +#endif -- * Re-exports module X, ) where +import Data.IORef (IORef, modifyIORef) + import GHC as X hiding (Phase, GhcT, parseDynamicFlags, runGhcT, showGhcException + , guessTarget #if MIN_VERSION_ghc(9,2,0) , Logger , modifyLogger @@ -34,17 +47,22 @@ ) import Control.Monad.Ghc as X (GhcT, runGhcT) -#if MIN_VERSION_ghc(9,2,0) +#if MIN_VERSION_ghc(9,4,0) import GHC.Types.SourceError as X (SourceError, srcErrorMessages) -import GHC.Driver.Ppr as X (showSDoc) +import GHC.Driver.Ppr as X (showSDoc, showSDocUnsafe) import GHC.Types.SourceFile as X (HscSource(HsSrcFile)) -import GHC.Utils.Logger as X (LogAction) import GHC.Platform.Ways as X (Way (..)) +#elif MIN_VERSION_ghc(9,2,0) +import GHC.Types.SourceError as X (SourceError, srcErrorMessages) -import GHC.Types.TyThing.Ppr as X (pprTypeForUser) +import GHC.Driver.Ppr as X (showSDoc) + +import GHC.Types.SourceFile as X (HscSource(HsSrcFile)) + +import GHC.Platform.Ways as X (Way (..)) #elif MIN_VERSION_ghc(9,0,0) import GHC.Driver.Types as X (SourceError, srcErrorMessages, GhcApiError) @@ -52,10 +70,8 @@ import GHC.Driver.Phases as X (HscSource(HsSrcFile)) -import GHC.Driver.Session as X (LogAction, addWay') +import GHC.Driver.Session as X (addWay') import GHC.Driver.Ways as X (Way (..)) - -import GHC.Core.Ppr.TyThing as X (pprTypeForUser) #else import HscTypes as X (SourceError, srcErrorMessages, GhcApiError) @@ -63,35 +79,45 @@ import DriverPhases as X (HscSource(HsSrcFile)) -import DynFlags as X (LogAction, addWay', Way(..)) - -import PprTyThing as X (pprTypeForUser) +import DynFlags as X (addWay', Way(..)) #endif -#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,4,0) import GHC.Utils.Outputable as X (PprStyle, SDoc, Outputable(ppr), - withPprStyle, defaultErrStyle, vcat) + withPprStyle, vcat) +import GHC.Driver.Phases as X (Phase(Cpp)) +import GHC.Data.StringBuffer as X (stringToStringBuffer) +import GHC.Parser.Lexer as X (P(..), ParseResult(..)) +import GHC.Parser as X (parseStmt, parseType) +import GHC.Data.FastString as X (fsLit) -import GHC.Utils.Error as X (mkLocMessage, errMsgSpan) +import GHC.Driver.Session as X (xFlags, xopt, FlagSpec(..)) +import GHC.Types.Error as X (diagnosticMessage, getMessages) +import GHC.Types.SrcLoc as X (mkRealSrcLoc) + +import GHC.Core.ConLike as X (ConLike(RealDataCon)) +#elif MIN_VERSION_ghc(9,0,0) +import GHC.Utils.Outputable as X (PprStyle, SDoc, Outputable(ppr), + withPprStyle, vcat) + import GHC.Driver.Phases as X (Phase(Cpp)) import GHC.Data.StringBuffer as X (stringToStringBuffer) 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, FlagSpec(..), WarnReason(NoReason)) +import GHC.Driver.Session as X (xFlags, xopt, FlagSpec(..)) +import GHC.Driver.Session (WarnReason(NoReason)) -import GHC.Types.SrcLoc as X (combineSrcSpans, mkRealSrcLoc) +import GHC.Types.SrcLoc as X (mkRealSrcLoc) import GHC.Core.ConLike as X (ConLike(RealDataCon)) #else import HscTypes as X (mgModSummaries) import Outputable as X (PprStyle, SDoc, Outputable(ppr), - withPprStyle, defaultErrStyle, vcat) - -import ErrUtils as X (mkLocMessage, errMsgSpan) + withPprStyle, vcat) import DriverPhases as X (Phase(Cpp)) import StringBuffer as X (stringToStringBuffer) @@ -99,9 +125,9 @@ import Parser as X (parseStmt, parseType) import FastString as X (fsLit) -import DynFlags as X (xFlags, xopt, FlagSpec(..), WarnReason(NoReason)) +import DynFlags as X (xFlags, xopt, FlagSpec(..)) -import SrcLoc as X (combineSrcSpans, mkRealSrcLoc) +import SrcLoc as X (mkRealSrcLoc) import ConLike as X (ConLike(RealDataCon)) #endif @@ -109,14 +135,23 @@ {-------------------- Imports for Shims --------------------} import Control.Monad.IO.Class (MonadIO) +-- guessTarget +import qualified GHC (guessTarget) -#if MIN_VERSION_ghc(9,2,0) +#if MIN_VERSION_ghc(9,6,0) -- dynamicGhc import GHC.Platform.Ways (hostIsDynamic) +-- Message +import qualified GHC.Utils.Error as GHC (mkLocMessage) + -- Logger -import qualified GHC.Utils.Logger as GHC (Logger, initLogger, putLogMsg, pushLogHook) +import qualified GHC.Utils.Logger as GHC + (LogAction, Logger, initLogger, logFlags, log_default_user_context, putLogMsg, pushLogHook) import qualified GHC.Driver.Monad as GHC (modifyLogger) +import qualified GHC.Types.Error as GHC + (DiagnosticReason(ErrorWithoutFlag), MessageClass(MCDiagnostic)) +import qualified GHC.Utils.Outputable as GHC (renderWithContext) -- UnitState import qualified GHC.Unit.State as GHC (UnitState, emptyUnitState) @@ -125,6 +160,122 @@ import qualified GHC.Driver.Ppr as GHC (showSDocForUser) -- PState +import qualified GHC.Parser.Lexer as GHC (PState, ParserOpts, initParserState) +import GHC.Data.StringBuffer (StringBuffer) +import qualified GHC.Driver.Config.Parser as GHC (initParserOpts) + +-- ErrorMessages +import qualified GHC.Driver.Errors.Types as GHC (GhcMessage(GhcPsMessage), ErrorMessages) +import qualified GHC.Parser.Lexer as GHC (getPsErrorMessages) +import qualified GHC.Types.Error as GHC + (diagnosticMessage, errMsgDiagnostic, getMessages, unDecorated) +import qualified GHC.Types.Error as GHC (defaultDiagnosticOpts) +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) + +-- pprTypeForUser +import qualified GHC.Core.TyCo.Ppr as GHC (pprSigmaType) + +-- errMsgSpan +import qualified GHC.Types.Error as GHC (Messages, errMsgSpan) +import qualified GHC.Types.SrcLoc as GHC (combineSrcSpans) + +-- fileTarget +import qualified GHC.Driver.Phases as GHC (Phase(Cpp)) +import qualified GHC.Driver.Session as GHC (homeUnitId_) +import qualified GHC.Types.SourceFile as GHC (HscSource(HsSrcFile)) +import qualified GHC.Types.Target as GHC (Target(Target), TargetId(TargetFile)) + +-- getPrintUnqual +import qualified GHC (getNamePprCtx) +#elif MIN_VERSION_ghc(9,4,0) +-- dynamicGhc +import GHC.Platform.Ways (hostIsDynamic) + +-- Message +import qualified GHC.Utils.Error as GHC (mkLocMessage) + +-- Logger +import qualified GHC.Utils.Logger as GHC + (LogAction, Logger, initLogger, logFlags, log_default_user_context, putLogMsg, pushLogHook) +import qualified GHC.Driver.Monad as GHC (modifyLogger) +import qualified GHC.Types.Error as GHC + (DiagnosticReason(ErrorWithoutFlag), MessageClass(MCDiagnostic)) +import qualified GHC.Utils.Outputable as GHC (renderWithContext) + +-- 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, initParserState) +import GHC.Data.StringBuffer (StringBuffer) +import qualified GHC.Driver.Config.Parser as GHC (initParserOpts) + +-- ErrorMessages +import qualified GHC.Driver.Errors.Types as GHC (GhcMessage(GhcPsMessage), ErrorMessages) +import qualified GHC.Parser.Lexer as GHC (getPsErrorMessages) +import qualified GHC.Types.Error as GHC + (diagnosticMessage, errMsgDiagnostic, getMessages, 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) + +-- pprTypeForUser +import qualified GHC.Core.TyCo.Ppr as GHC (pprSigmaType) + +-- errMsgSpan +import qualified GHC.Types.Error as GHC (Messages, errMsgSpan) +import qualified GHC.Types.SrcLoc as GHC (combineSrcSpans) + +-- fileTarget +import qualified GHC.Driver.Phases as GHC (Phase(Cpp)) +import qualified GHC.Driver.Session as GHC (homeUnitId_) +import qualified GHC.Types.SourceFile as GHC (HscSource(HsSrcFile)) +import qualified GHC.Types.Target as GHC (Target(Target), TargetId(TargetFile)) + +#elif MIN_VERSION_ghc(9,2,0) +-- dynamicGhc +import GHC.Platform.Ways (hostIsDynamic) + +-- Message +import qualified GHC.Utils.Error as GHC (mkLocMessage) + +-- Logger +import qualified GHC.Utils.Logger as GHC (LogAction, Logger, initLogger, putLogMsg, pushLogHook) +import qualified GHC.Driver.Monad as GHC (modifyLogger) +import qualified GHC.Driver.Ppr as GHC (showSDoc) + +-- 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) @@ -146,16 +297,31 @@ -- parseDynamicFlags import qualified GHC (parseDynamicFlags) import GHC.Driver.CmdLine (Warn) + +-- pprTypeForUser +import qualified GHC.Types.TyThing.Ppr as GHC (pprTypeForUser) + +-- errMsgSpan +import qualified GHC.Data.Bag as GHC (Bag) +import qualified GHC.Types.Error as GHC (MsgEnvelope, errMsgSpan) +import qualified GHC.Types.SrcLoc as GHC (combineSrcSpans) + +-- fileTarget +import qualified GHC.Driver.Phases as GHC (Phase(Cpp)) +import qualified GHC.Types.SourceFile as GHC (HscSource(HsSrcFile)) +import qualified GHC.Types.Target as GHC (Target(Target), TargetId(TargetFile)) + #elif MIN_VERSION_ghc(9,0,0) -- dynamicGhc import GHC.Driver.Ways (hostIsDynamic) -- Message -import qualified GHC.Utils.Error as GHC (MsgDoc) +import qualified GHC.Utils.Error as GHC (MsgDoc, mkLocMessage) -- Logger -import qualified GHC.Driver.Session as GHC (defaultLogAction) +import qualified GHC.Driver.Session as GHC (LogAction, defaultLogAction) import qualified GHC.Driver.Session as DynFlags (log_action) +import qualified GHC.Utils.Outputable as GHC (showSDoc) -- showSDocForUser import qualified GHC.Utils.Outputable as GHC (showSDocForUser) @@ -177,16 +343,30 @@ -- parseDynamicFlags import qualified GHC (parseDynamicFlags) import GHC.Driver.CmdLine (Warn) + +-- pprTypeForUser +import qualified GHC.Core.Ppr.TyThing as GHC (pprTypeForUser) + +-- errMsgSpan +import qualified GHC.Types.SrcLoc as GHC (combineSrcSpans) +import qualified GHC.Utils.Error as GHC (errMsgSpan) + +-- fileTarget +import qualified GHC.Driver.Phases as GHC (HscSource(HsSrcFile), Phase(Cpp)) +import qualified GHC.Driver.Types as GHC (Target(Target), TargetId(TargetFile)) + #else -- dynamicGhc import qualified DynFlags as GHC (dynamicGhc) -- Message -import qualified ErrUtils as GHC (MsgDoc) +import qualified ErrUtils as GHC (MsgDoc, mkLocMessage) -- Logger -import qualified DynFlags as GHC (defaultLogAction) +import qualified DynFlags as GHC (LogAction, defaultLogAction) import qualified DynFlags (log_action) +import DynFlags (WarnReason(NoReason)) +import qualified Outputable as GHC (defaultErrStyle, renderWithStyle) -- showSDocForUser import qualified Outputable as GHC (showSDocForUser) @@ -212,6 +392,18 @@ -- parseDynamicFlags import qualified GHC (parseDynamicFlags) import CmdLineParser (Warn) + +-- pprTypeForUser +import qualified PprTyThing as GHC (pprTypeForUser) + +-- errMsgSpan +import qualified SrcLoc as GHC (combineSrcSpans) +import qualified ErrUtils as GHC (errMsgSpan) + +-- fileTarget +import qualified DriverPhases as GHC (HscSource(HsSrcFile), Phase(Cpp)) +import qualified HscTypes as GHC (Target(Target), TargetId(TargetFile)) + #endif {-------------------- Shims --------------------} @@ -233,17 +425,44 @@ -- Logger initLogger :: IO Logger -putLogMsg :: Logger -> LogAction -pushLogHook :: (LogAction -> LogAction) -> Logger -> Logger +putLogMsg :: Logger -> DynFlags -> WarnReason -> Severity -> SrcSpan -> SDoc -> IO () +pushLogHook :: (GHC.LogAction -> GHC.LogAction) -> Logger -> Logger modifyLogger :: GhcMonad m => (Logger -> Logger) -> m () -#if MIN_VERSION_ghc(9,2,0) +mkLogAction :: (String -> a) -> IORef [a] -> GHC.LogAction +#if MIN_VERSION_ghc(9,6,0) +data WarnReason = NoReason type Logger = GHC.Logger initLogger = GHC.initLogger +putLogMsg logger _df _wn sev = GHC.putLogMsg logger (GHC.logFlags logger) (GHC.MCDiagnostic sev GHC.ErrorWithoutFlag Nothing) +pushLogHook = GHC.pushLogHook +modifyLogger = GHC.modifyLogger +mkLogAction f r = \lf mc src msg -> + let renderErrMsg = GHC.renderWithContext (GHC.log_default_user_context lf) + errorEntry = f (renderErrMsg (GHC.mkLocMessage mc src msg)) + in modifyIORef r (errorEntry :) +#elif MIN_VERSION_ghc(9,4,0) +data WarnReason = NoReason +type Logger = GHC.Logger +initLogger = GHC.initLogger +putLogMsg logger _df _wn sev = GHC.putLogMsg logger (GHC.logFlags logger) (GHC.MCDiagnostic sev GHC.ErrorWithoutFlag) +pushLogHook = GHC.pushLogHook +modifyLogger = GHC.modifyLogger +mkLogAction f r = \lf mc src msg -> + let renderErrMsg = GHC.renderWithContext (GHC.log_default_user_context lf) + errorEntry = f (renderErrMsg (GHC.mkLocMessage mc src msg)) + in modifyIORef r (errorEntry :) +#elif 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 +mkLogAction f r = \df _ sev src msg -> + let renderErrMsg = GHC.showSDoc df + errorEntry = f (renderErrMsg (GHC.mkLocMessage sev src msg)) + in modifyIORef r (errorEntry :) +#elif MIN_VERSION_ghc(9,0,0) +type Logger = GHC.LogAction initLogger = pure GHC.defaultLogAction putLogMsg = id pushLogHook = id @@ -251,6 +470,23 @@ df <- getSessionDynFlags _ <- setSessionDynFlags df{log_action = f $ DynFlags.log_action df} return () +mkLogAction f r = \df _ sev src msg -> + let renderErrMsg = GHC.showSDoc df + errorEntry = f (renderErrMsg (GHC.mkLocMessage sev src msg)) + in modifyIORef r (errorEntry :) +#else +type Logger = GHC.LogAction +initLogger = pure GHC.defaultLogAction +putLogMsg l = \df wr sev src msg -> l df wr sev src (GHC.defaultErrStyle df) msg +pushLogHook = id +modifyLogger f = do + df <- getSessionDynFlags + _ <- setSessionDynFlags df{log_action = f $ DynFlags.log_action df} + return () +mkLogAction f r = \df _ sev src style msg -> + let renderErrMsg s = GHC.renderWithStyle df s style + errorEntry = f (renderErrMsg (GHC.mkLocMessage sev src msg)) + in modifyIORef r (errorEntry :) #endif -- UnitState @@ -264,6 +500,10 @@ #endif -- showSDocForUser +#if MIN_VERSION_ghc(9,6,0) +type PrintUnqualified = NamePprCtx +#endif + showSDocForUser :: DynFlags -> UnitState -> PrintUnqualified -> SDoc -> String #if MIN_VERSION_ghc(9,2,0) showSDocForUser = GHC.showSDocForUser @@ -274,8 +514,13 @@ -- PState mkParserOpts :: DynFlags -> ParserOpts initParserState :: ParserOpts -> StringBuffer -> RealSrcLoc -> GHC.PState -#if MIN_VERSION_ghc(9,2,0) +#if MIN_VERSION_ghc(9,4,0) type ParserOpts = GHC.ParserOpts +mkParserOpts = GHC.initParserOpts + +initParserState = GHC.initParserState +#elif 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 @@ -298,7 +543,17 @@ -- ErrorMessages getErrorMessages :: GHC.PState -> DynFlags -> GHC.ErrorMessages pprErrorMessages :: GHC.ErrorMessages -> [SDoc] -#if MIN_VERSION_ghc(9,2,0) +#if MIN_VERSION_ghc(9,6,0) +getErrorMessages pstate _ = fmap GHC.GhcPsMessage $ GHC.getPsErrorMessages pstate +pprErrorMessages = bagToList . fmap pprErrorMessage . GHC.getMessages + where + pprErrorMessage = vcat . GHC.unDecorated . GHC.diagnosticMessage (GHC.defaultDiagnosticOpts @GHC.GhcMessage) . GHC.errMsgDiagnostic +#elif MIN_VERSION_ghc(9,4,0) +getErrorMessages pstate _ = fmap GHC.GhcPsMessage $ GHC.getPsErrorMessages pstate +pprErrorMessages = bagToList . fmap pprErrorMessage . GHC.getMessages + where + pprErrorMessage = vcat . GHC.unDecorated . GHC.diagnosticMessage . GHC.errMsgDiagnostic +#elif MIN_VERSION_ghc(9,2,0) getErrorMessages pstate _ = fmap GHC.pprError $ GHC.getErrorMessages pstate pprErrorMessages = bagToList . fmap pprErrorMessage where @@ -342,7 +597,9 @@ -- setBackendToInterpreter setBackendToInterpreter :: DynFlags -> DynFlags -#if MIN_VERSION_ghc(9,2,0) +#if MIN_VERSION_ghc(9,6,0) +setBackendToInterpreter df = df{backend = interpreterBackend} +#elif MIN_VERSION_ghc(9,2,0) setBackendToInterpreter df = df{backend = Interpreter} #else setBackendToInterpreter df = df{hscTarget = HscInterpreted} @@ -354,4 +611,45 @@ parseDynamicFlags = GHC.parseDynamicFlags #else parseDynamicFlags _ = GHC.parseDynamicFlags +#endif + +pprTypeForUser :: Type -> SDoc +#if MIN_VERSION_ghc(9,4,0) +pprTypeForUser = GHC.pprSigmaType +#else +pprTypeForUser = GHC.pprTypeForUser +#endif + +#if MIN_VERSION_ghc(9,4,0) +errMsgSpan :: GHC.Messages e -> SrcSpan +errMsgSpan msgs = foldr (GHC.combineSrcSpans . GHC.errMsgSpan) X.noSrcSpan (GHC.getMessages msgs) +#elif MIN_VERSION_ghc(9,2,0) +errMsgSpan :: GHC.Bag (GHC.MsgEnvelope e) -> SrcSpan +errMsgSpan = foldr (GHC.combineSrcSpans . GHC.errMsgSpan) X.noSrcSpan +#else +errMsgSpan :: GHC.ErrorMessages -> SrcSpan +errMsgSpan = foldr (GHC.combineSrcSpans . GHC.errMsgSpan) X.noSrcSpan +#endif + +fileTarget :: DynFlags -> FilePath -> GHC.Target +#if MIN_VERSION_ghc(9,4,0) +fileTarget dflags f = GHC.Target (GHC.TargetFile f $ Just next_phase) True uid Nothing + where next_phase = GHC.Cpp GHC.HsSrcFile + uid = GHC.homeUnitId_ dflags +#else +fileTarget _ f = GHC.Target (GHC.TargetFile f $ Just next_phase) True Nothing + where next_phase = GHC.Cpp GHC.HsSrcFile +#endif + +guessTarget :: GhcMonad m => String -> Maybe GHC.Phase -> m GHC.Target +#if MIN_VERSION_ghc(9,4,0) +guessTarget t pM = GHC.guessTarget t Nothing pM +#else +guessTarget = GHC.guessTarget +#endif + +-- getPrintUnqual +#if MIN_VERSION_ghc(9,6,0) +getPrintUnqual :: GhcMonad m => m PrintUnqualified +getPrintUnqual = GHC.getNamePprCtx #endif diff --git a/src/Hint/InterpreterT.hs b/src/Hint/InterpreterT.hs --- a/src/Hint/InterpreterT.hs +++ b/src/Hint/InterpreterT.hs @@ -181,25 +181,8 @@ internalState = initial_state, versionSpecific = a, ghcErrListRef = ghc_err_list_ref, - ghcLogger = GHC.pushLogHook (const $ mkLogAction ghc_err_list_ref) logger + ghcLogger = GHC.pushLogHook (const $ GHC.mkLogAction GhcError ghc_err_list_ref) logger } - -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 -- 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 @@ -32,7 +32,7 @@ -- #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 + span = GHC.errMsgSpan errMsgs err = GHC.vcat $ GHC.pprErrorMessages errMsgs in pure (ParseError span err) #else @@ -54,16 +54,11 @@ logger <- fromSession ghcLogger dflags <- runGhc GHC.getSessionDynFlags let logger' = GHC.putLogMsg logger dflags -#if !MIN_VERSION_ghc(9,0,0) - errStyle = GHC.defaultErrStyle dflags -#endif + liftIO $ logger' GHC.NoReason GHC.SevError span -#if !MIN_VERSION_ghc(9,0,0) - errStyle -#endif err -- -- behave like the rest of the GHC API functions 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 @@ -209,12 +209,63 @@ test_catch :: TestCase test_catch = TestCase "catch" [] $ do setImports ["Prelude"] - succeeds (action `catch` handler) @@? "catch failed" - where handler DivideByZero = return "catched" - handler e = throwM e - action = do s <- eval "1 `div` 0 :: Int" - return $! s + -- make sure we catch exceptions in return, and that the interpreter is + -- still in a good state afterwards + explosiveThunk <- eval "1 `div` 0 :: Int" + (detonate explosiveThunk `catch` handleDivideByZero) @@?= "caught" + eval "2 + 2 :: Int" @@?= "4" + + -- make sure we catch exceptions in eval, and that the interpreter is + -- still in a good state afterwards + (eval "2 +" `catch` handleWontCompile) @@?= "caught" + eval "2 + 2 :: Int" @@?= "4" + + -- make sure we catch exceptions in setImports, and that the interpreter + -- is still in a good state afterwards + (importNonsense `catch` handleWontCompile) @@?= "caught" + eval "2 + 2 :: Int" @@?= "4" + + -- make sure we catch exceptions in loadModules + (loadNonsense `catch` handleWontCompile) @@?= "caught" + + -- loadModules resets the interpreter state, so we do _not_ expect that + -- the Prelude is still in scope after loadNonsense + fails (eval "2 + 2 :: Int") @@? "Prelude should not be in path" + + -- but we do expect the interpreter state to be in a good enough state + -- to evaluate builtins + (eval "[1..4]" @@?= "[1,2,3,4]") + + -- bring the prelude back into scope for the rest of the tests + setImports ["Prelude"] + + -- make sure we catch exceptions in setTopLevelModules, and that the + -- interpreter is still in a good state afterwards + (setTopLevelNonsense1 `catch` handleNotAllowed) @@?= "caught" + eval "2 + 2 :: Int" @@?= "4" + (setTopLevelNonsense2 `catch` handleNotAllowed) @@?= "caught" + eval "2 + 2 :: Int" @@?= "4" + where detonate explosiveThunk = return $! explosiveThunk + importNonsense = do + setImports ["NonExistentModule"] + return "imported a non-existent module" + loadNonsense = do + loadModules ["NonExistentFile.hs"] + return "loaded a non-existent file" + setTopLevelNonsense1 = do + setTopLevelModules ["Prelude"] + return "looking inside the Prelude's internals" + setTopLevelNonsense2 = do + setTopLevelModules ["NonLoadedModule"] + return "looking inside a module which wasn't loaded" + handleDivideByZero DivideByZero = return "caught" + handleDivideByZero e = throwM e + handleWontCompile (WontCompile _) = return "caught" + handleWontCompile e = throwM e + handleNotAllowed (NotAllowed _) = return "caught" + handleNotAllowed e = throwM e + #ifndef THREAD_SAFE_LINKER -- Prior to ghc-8.10, the linker wasn't thread-safe, and so running multiple -- instances of hint in different threads can lead to mysterious errors of the @@ -318,7 +369,7 @@ & last -- "8.8.4" let pkgdb = dir "dist-newstyle" "packagedb" ("ghc-" ++ ghcVersion) - ghc_args = ["-package-db=" ++ pkgdb] + ghc_args = ["-package-db=" ++ pkgdb,"-package-env","-"] -- stack sets GHC_ENVIRONMENT to a file which pins down the versions of -- all the packages we can load, and since it does not list my-package, @@ -326,8 +377,7 @@ unsetEnv "GHC_ENVIRONMENT" wrapInterp (unsafeRunInterpreterWithArgs ghc_args) $ do - --succeeds (setImports [mod]) @@? "module from package-db must be visible" - setImports [mod] + succeeds (setImports [mod]) @@? "module from package-db must be visible" -- where pkg = "my-package" dir = pkg @@ -355,6 +405,55 @@ setEnv (filter ((/= "GHC_PACKAGE_PATH") . fst) env) $ proc "cabal" ["build"] +test_ghc_environment_file :: IOTestCase +test_ghc_environment_file = IOTestCase "ghc_environment_file" [dir] $ \wrapInterp -> do + setup + + -- stack sets GHC_ENVIRONMENT to a file which pins down the versions of + -- all the packages we can load, and since it does not list my-package, + -- we cannot load it. + unsetEnv "GHC_ENVIRONMENT" + + wrapInterp runInterpreter $ do + fails (setImports ["Acme.Dont"]) @@? "acme-dont should not be in path" + + -- in dir, there is a file .ghc.environment. which lists the + -- acme-dont package because it is a dependency of my-package. hint + -- should detect that file and make containers available to the + -- interpreted code. + withCurrentDirectory dir $ do + wrapInterp runInterpreter $ do + succeeds (setImports ["Acme.Dont"]) @@? "acme-dont should be in path" + -- + where pkg = "my-package" + dir = pkg + mod_file = dir mod <.> "hs" + mod = "MyModule" + cabal_file = dir pkg <.> "cabal" + setup = do createDirectory dir + writeFile cabal_file $ unlines + [ "cabal-version: 2.4" + , "name: " ++ pkg + , "version: 0.1.0.0" + , "" + , "library" + , " exposed-modules: " ++ mod + , " build-depends: acme-dont" + ] + writeFile mod_file $ unlines + [ "{-# LANGUAGE NoImplicitPrelude #-}" + , "module " ++ mod ++ " where" + ] + env <- getEnvironment + runProcess_ + $ proc "cabal" ["update"] + runProcess_ + $ setWorkingDir dir + $ -- stack sets GHC_PACKAGE_PATH, but cabal complains + -- that it cannot run if that variable is set. + setEnv (filter ((/= "GHC_PACKAGE_PATH") . fst) env) + $ proc "cabal" ["build", "--write-ghc-environment-files=always"] + -- earlier versions of hint were accidentally overwriting the signal handlers -- for ^C and others. -- @@ -422,6 +521,7 @@ ioTests :: [IOTestCase] ioTests = [test_signal_handlers ,test_package_db + ,test_ghc_environment_file ] main :: IO ()