hint 0.9.0.6 → 0.9.0.7
raw patch · 8 files changed
+534/−112 lines, 8 filesdep ~ghcPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: ghc
API changes (from Hackage documentation)
Files
- CHANGELOG.md +6/−0
- README.md +44/−10
- hint.cabal +9/−2
- src/Hint/Context.hs +32/−33
- src/Hint/GHC.hs +332/−34
- src/Hint/InterpreterT.hs +1/−18
- src/Hint/Parsers.hs +2/−7
- unit-tests/run-unit-tests.hs +108/−8
CHANGELOG.md view
@@ -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
README.md view
@@ -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.<something>` 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.+
hint.cabal view
@@ -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" <gelisam@gmail.com> 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,
src/Hint/Context.hs view
@@ -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
src/Hint/GHC.hs view
@@ -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
src/Hint/InterpreterT.hs view
@@ -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
src/Hint/Parsers.hs view
@@ -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
unit-tests/run-unit-tests.hs view
@@ -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.<something> 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 ()