hint 0.6.0 → 0.9.0.9
raw patch · 23 files changed
Files
- AUTHORS +3/−0
- CHANGELOG.md +71/−1
- README.md +104/−12
- examples/example.hs +13/−2
- hint.cabal +60/−23
- src/Control/Monad/Ghc.hs +75/−22
- src/Hint/Annotations.hs +24/−12
- src/Hint/Base.hs +35/−53
- src/Hint/Compat.hs +0/−34
- src/Hint/Configuration.hs +28/−6
- src/Hint/Context.hs +145/−94
- src/Hint/Conversions.hs +5/−5
- src/Hint/Eval.hs +25/−6
- src/Hint/Extension.hs +13/−4
- src/Hint/GHC.hs +675/−15
- src/Hint/Internal.hs +33/−0
- src/Hint/InterpreterT.hs +41/−75
- src/Hint/Parsers.hs +17/−19
- src/Hint/Reflection.hs +13/−33
- src/Hint/Typecheck.hs +32/−11
- src/Language/Haskell/Interpreter.hs +9/−16
- src/Language/Haskell/Interpreter/Unsafe.hs +6/−12
- unit-tests/run-unit-tests.hs +364/−27
AUTHORS view
@@ -2,8 +2,10 @@ Austin Seipp Bertram Felgenhauer+Brandon Chinn Bryan O'Sullivan Carl Howells+Christiaan Baaij Conrad Parker Corentin Dupont Daniel Gorin <jcpetruzza@gmail.com>@@ -12,6 +14,7 @@ Evan Laforge Fernando Benavides Gwern Branwen+Heinrich Apfelmus Jean Philippe Bernardy Jens Petersen Mark Wright
CHANGELOG.md view
@@ -1,3 +1,73 @@+### 0.9.0.9++* Support GHC 9.10, GHC 9.12, and GHC 9.14+* Remove noncanonical monad instance definitions for future GHC compatibility++### 0.9.0.8++* Support GHC 9.8++### 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+* Small fix in documentation (thanks to Ed Behn)++### 0.9.0.5 (deprecated)++* Support GHC 9.2.1+* Deprecated because it breaks the common pattern of using+ 'unsafeRunInterpreterWithArgs' to load a custom package database.++### 0.9.0.4++* Support GHC 9.0.1++### 0.9.0.3++* Support GHC 8.10+* Drop support for GHC 8.4+* Hint can now be used concurrently from multiple threads on GHC 8.10+++### 0.9.0.2++* Support GHC 8.8+* Drop support for GHC 8.2++### 0.9.0.1++* Make tests pass with stack 2.1.1++### 0.9.0++* Support GHC 8.6+* Drop support for GHC 8.0++### 0.8.0++* Support GHC 8.4+* Drop support for GHC 7.8 and 7.10+* Add `runStmt` to execute statements in the IO monad and bind new names+* Internal changes of temporary files for phantom modules+ - The files are now called `M<nnn>.hs` instead of `<nnn>`+ - Improved cleanup of phantom module source files+ - ghc 8.4 only: phantom modules are put into a temporary directory+* Add `typeChecksWithDetails` to obtain type-checking errors+* Stop GHC from overwriting the Ctrl-C signal handler+* Add `SetImportsF` to allow finer imports control++### 0.7.0++* Support for GHC 8.2+* Support use in a dynamically-linked executable+* Add `normalizeType`, like ghci's :kind!+* Drop support for GHC 7.6+ ### 0.6.0 * Support for GHC 8.0@@ -121,7 +191,7 @@ * Exports functions parens and isInterpretedModule * Experimental support for module annotations * Uses extensible-exceptions in order to provide a uniform interface- accross different ghc versions+ across different ghc versions * Provides an Applicative instance for IntepreterT * Adds an option to configurate the searchPath
README.md view
@@ -1,17 +1,109 @@-# hint+# hint [](https://hackage.haskell.org/package/hint) [](https://github.com/haskell-hint/hint/actions) -[](https://travis-ci.org/mvdan/hint)-[](https://hackage.haskell.org/package/hint)+This library defines an Interpreter monad within which you can interpret+strings like `"[1,2] ++ [3]"` into values like `[1,2,3]`. You can easily+exchange data between your compiled program and your interpreted program, as+long as the data has a `Typeable` instance. -This library defines an Interpreter monad. It allows to load Haskell-modules, browse them, type-check and evaluate strings with Haskell-expressions and even coerce them into values. The library is thread-safe-and type-safe (even the coercion of expressions to values).+You can choose which modules should be in scope while evaluating these+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.+## Example -### Example+```haskell+{-# 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 -Check [example.hs](examples/example.hs) to see a simple but-comprehensive example (it must be run from the `examples` directory).+-- |+-- Interpret expressions into values:+--+-- >>> eval @[Int] "[1,2] ++ [3]"+-- Right [1,2,3]+--+-- Send values from your compiled program to your interpreted program by+-- interpreting a function:+--+-- >>> Right f <- eval @(Int -> [Int]) "\\x -> [1..x]"+-- >>> f 5+-- [1,2,3,4,5]+eval :: forall t. Typeable t+ => String -> IO (Either Hint.InterpreterError t)+eval s = Hint.runInterpreter $ do+ Hint.setImports ["Prelude"]+ Hint.interpret s (Hint.as :: t)++-- |+-- >>> :{+-- do Right contents <- browse "Prelude"+-- for_ contents $ \(identifier, tp) -> do+-- when ("put" `isPrefixOf` identifier) $ do+-- putStrLn $ identifier ++ " :: " ++ tp+-- :}+-- putChar :: Char -> IO ()+-- putStr :: String -> IO ()+-- putStrLn :: String -> IO ()+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+ for_ exports $ \case+ Hint.Fun identifier -> do+ tp <- lift $ Hint.typeOf identifier+ tell [(identifier, tp)]+ _ -> pure () -- skip datatypes and typeclasses+```++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.+
examples/example.hs view
@@ -2,9 +2,11 @@ import Control.Monad import Language.Haskell.Interpreter+import System.Directory main :: IO ()-main = do r <- runInterpreter testHint+main = do setCurrentDirectory "examples"+ r <- runInterpreter testHint case r of Left err -> putStrLn $ errorString err Right () -> return ()@@ -66,5 +68,14 @@ say $ show $ not bool_val emptyLine say "Here we evaluate an expression of type string, that when evaluated (again) leads to a string"- res <- interpret "head $ map show [\"Worked!\", \"Didn't work\"]" infer >>= flip interpret infer+ res <- do+ s <- interpret "head $ map show [\"Worked!\", \"Didn't work\"]" infer+ interpret s infer say res+ emptyLine+ say "We can also execute statements in the IO monad and bind new names, e.g."+ let stmts = ["x <- return 42", "print x"]+ forM_ stmts $ \s -> do+ say $ " " ++ s+ runStmt s+ emptyLine
hint.cabal view
@@ -1,5 +1,5 @@ name: hint-version: 0.6.0+version: 0.9.0.9 description: This library defines an Interpreter monad. It allows to load Haskell modules, browse them, type-check and evaluate strings with Haskell@@ -9,15 +9,26 @@ It is, essentially, a huge subset of the GHC API wrapped in a simpler API. -synopsis: Runtime Haskell interpreter (GHC API wrapper)+synopsis: A Haskell interpreter built on top of the GHC API category: Language, Compilers/Interpreters license: BSD3 license-file: LICENSE author: The Hint Authors-maintainer: mvdan@mvdan.cc-homepage: https://github.com/mvdan/hint+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.8+ , ghc == 9.4.8+ , ghc == 9.6.6+ , ghc == 9.8.4+ , ghc == 9.10.3+ , ghc == 9.12.3+ , ghc == 9.14.1 -cabal-version: >= 1.9.2+cabal-version: >= 1.10 build-type: Simple extra-source-files: README.md@@ -28,31 +39,56 @@ source-repository head type: git- location: https://github.com/mvdan/hint+ location: https://github.com/haskell-hint/hint -Test-Suite unit-tests+test-suite unit-tests type: exitcode-stdio-1.0 hs-source-dirs: unit-tests main-is: run-unit-tests.hs+ default-language: Haskell2010 build-depends: base == 4.*,+ bytestring, hint, HUnit, directory, filepath,- extensible-exceptions,- exceptions+ exceptions >= 0.10.0,+ stm,+ text,+ typed-process, -Library+ -- packages used by setImports calls+ containers++ if impl(ghc >= 8.10) {+ cpp-options: -DTHREAD_SAFE_LINKER+ }++ if !os(windows) {+ build-depends: unix >= 2.2.0.0+ }++ default-extensions: CPP++library+ default-language: Haskell2010 build-depends: base == 4.*,- ghc >= 7.6 && < 8.2,+ containers,+ ghc >= 8.4 && < 9.15, ghc-paths,- mtl,+ ghc-boot,+ transformers, filepath,- exceptions,+ exceptions == 0.10.*, random,- directory+ directory,+ temporary + if impl(ghc >= 8.10) {+ cpp-options: -DTHREAD_SAFE_LINKER+ }+ if !os(windows) { build-depends: unix >= 2.2.0.0 }@@ -60,10 +96,10 @@ exposed-modules: Language.Haskell.Interpreter Language.Haskell.Interpreter.Extension Language.Haskell.Interpreter.Unsafe+ Hint.Internal other-modules: Hint.GHC Hint.Base Hint.InterpreterT- Hint.Compat Hint.CompatPlatform Hint.Configuration Hint.Extension@@ -80,11 +116,12 @@ hs-source-dirs: src ghc-options: -Wall- extensions: CPP- GeneralizedNewtypeDeriving- DeriveDataTypeable- MagicHash- FunctionalDependencies- Rank2Types- ScopedTypeVariables- ExistentialQuantification+ default-extensions: CPP+ GeneralizedNewtypeDeriving+ DeriveDataTypeable+ MagicHash+ FunctionalDependencies+ Rank2Types+ ScopedTypeVariables+ ExistentialQuantification+ LambdaCase
src/Control/Monad/Ghc.hs view
@@ -6,49 +6,66 @@ import Prelude import Control.Monad-import Control.Monad.Trans-import qualified Control.Monad.Trans as MTL+import Control.Monad.IO.Class+import Control.Monad.Trans.Class import Control.Monad.Catch -import qualified GHC (runGhcT)+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+import qualified GHC.Driver.Monad as GHC++import qualified GHC.Driver.Session as GHC+#else import qualified MonadUtils as GHC import qualified Exception as GHC import qualified GhcMonad as GHC import qualified DynFlags as GHC+#endif newtype GhcT m a = GhcT { unGhcT :: GHC.GhcT (MTLAdapter m) a } deriving (Functor, Monad, GHC.HasDynFlags) instance (Functor m, Monad m) => Applicative (GhcT m) where- pure = return+ pure = GhcT . pure (<*>) = ap -#if __GLASGOW_HASKELL__ >= 800+-- adapted from https://github.com/ghc/ghc/blob/ghc-8.2/compiler/main/GHC.hs#L450-L459+-- modified to _not_ catch ^C+rawRunGhcT :: (MonadIO m, MonadMask m) => Maybe FilePath -> GHC.GhcT (MTLAdapter m) a -> MTLAdapter m a+rawRunGhcT mb_top_dir ghct = do+ ref <- liftIO $ newIORef (error "empty session")+ let session = GHC.Session ref+ flip GHC.unGhcT session $ {-GHC.withSignalHandlers $-} do -- do _not_ catch ^C+ GHC.initGhcMonad mb_top_dir+ GHC.withCleanupSession ghct+ runGhcT :: (MonadIO m, MonadMask m) => Maybe FilePath -> GhcT m a -> m a-#else-runGhcT :: (Functor m, MonadIO m, MonadCatch m, MonadMask m) => Maybe FilePath -> GhcT m a -> m a-#endif-runGhcT f = unMTLA . GHC.runGhcT f . unGhcT+runGhcT f = unMTLA . rawRunGhcT f . unGhcT -instance MTL.MonadTrans GhcT where+instance MonadTrans GhcT where lift = GhcT . GHC.liftGhcT . MTLAdapter -instance MTL.MonadIO m => MTL.MonadIO (GhcT m) where+instance MonadIO m => MonadIO (GhcT m) where liftIO = GhcT . GHC.liftIO -#if __GLASGOW_HASKELL__ < 708- -- ghc started using transformers at some point-instance MTL.MonadIO m => GHC.MonadIO (GhcT m) where- liftIO = MTL.liftIO-#endif- instance MonadCatch m => MonadThrow (GhcT m) where throwM = lift . throwM instance (MonadIO m, MonadCatch m, MonadMask m) => MonadCatch (GhcT m) where+#if MIN_VERSION_ghc(9,0,0)+ m `catch` f = GhcT (unGhcT m `catch` (unGhcT . f))+#else m `catch` f = GhcT (unGhcT m `GHC.gcatch` (unGhcT . f))+#endif instance (MonadIO m, MonadMask m) => MonadMask (GhcT m) where mask f = wrap $ \s ->@@ -58,12 +75,32 @@ wrap g = GhcT $ GHC.GhcT $ \s -> MTLAdapter (g s) unwrap m = unMTLA . GHC.unGhcT (unGhcT m) - uninterruptibleMask = mask+ uninterruptibleMask f = wrap $ \s ->+ uninterruptibleMask $ \io_restore ->+ unwrap (f $ \m -> (wrap $ \s' -> io_restore (unwrap m s'))) s+ where+ wrap g = GhcT $ GHC.GhcT $ \s -> MTLAdapter (g s)+ unwrap m = unMTLA . GHC.unGhcT (unGhcT m) + generalBracket acquire release body+ = wrap $ \s -> generalBracket (unwrap acquire s)+ (\a exitCase -> unwrap (release a exitCase) s)+ (\a -> unwrap (body a) s)+ where+ wrap g = GhcT $ GHC.GhcT $ \s -> MTLAdapter (g s)+ unwrap m = unMTLA . GHC.unGhcT (unGhcT m)++#if !MIN_VERSION_ghc(9,0,0) instance (MonadIO m, MonadCatch m, MonadMask m) => GHC.ExceptionMonad (GhcT m) where- gcatch = catch- gmask f = mask (\x -> f x)+ 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 getSession = GhcT GHC.getSession setSession = GhcT . GHC.setSession@@ -72,9 +109,25 @@ -- like 'MTL'''s 'MonadIO' and 'GHC'''s 'MonadIO'. newtype MTLAdapter m a = MTLAdapter {unMTLA :: m a} deriving (Functor, Applicative, Monad) -instance MTL.MonadIO m => GHC.MonadIO (MTLAdapter m) where- liftIO = MTLAdapter . MTL.liftIO+instance MonadIO m => GHC.MonadIO (MTLAdapter m) where+ liftIO = MTLAdapter . liftIO +#if MIN_VERSION_ghc(9,0,0)+instance MonadCatch m => MonadCatch (MTLAdapter m) where+ m `catch` f = MTLAdapter $ unMTLA m `catch` (unMTLA . f)++instance MonadMask m => MonadMask (MTLAdapter m) where+ mask io = MTLAdapter $ mask (\f -> unMTLA $ io (MTLAdapter . f . unMTLA))+ uninterruptibleMask f = MTLAdapter (unMTLA (uninterruptibleMask f))+ generalBracket acquire release body+ = MTLAdapter (generalBracket (unMTLA acquire)+ (\a exitCase -> unMTLA (release a exitCase))+ (unMTLA . body))++instance MonadThrow m => MonadThrow (MTLAdapter m) where+ throwM = MTLAdapter . throwM+#else instance (MonadIO m, MonadCatch m, MonadMask m) => GHC.ExceptionMonad (MTLAdapter m) where m `gcatch` f = MTLAdapter $ unMTLA m `catch` (unMTLA . f) gmask io = MTLAdapter $ mask (\f -> unMTLA $ io (MTLAdapter . f . unMTLA))+#endif
src/Hint/Annotations.hs view
@@ -3,29 +3,41 @@ getValAnnotations ) where -import Control.Monad import Data.Data-import Annotations-import Serialized+import GHC.Serialized import Hint.Base-import HscTypes (hsc_mod_graph, ms_mod) import qualified Hint.GHC as GHC +#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 MonadUtils (concatMapM)+#endif+ -- Get the annotations associated with a particular module. getModuleAnnotations :: (Data a, MonadInterpreter m) => a -> String -> m [a] getModuleAnnotations _ x = do- mods <- liftM hsc_mod_graph $ runGhc GHC.getSession+ mods <- GHC.mgModSummaries . hsc_mod_graph <$> runGhc GHC.getSession let x' = filter ((==) x . GHC.moduleNameString . GHC.moduleName . ms_mod) mods- v <- mapM (anns . ModuleTarget . ms_mod) x'- return $ concat v+ concatMapM (anns . ModuleTarget . ms_mod) x' -- Get the annotations associated with a particular function. getValAnnotations :: (Data a, MonadInterpreter m) => a -> String -> m [a]-getValAnnotations _ x = do- x' <- runGhc1 GHC.parseName x- v <- mapM (anns . NamedTarget) x'- return $ concat v+getValAnnotations _ s = do+ names <- runGhc $ GHC.parseName s+ concatMapM (anns . NamedTarget) names anns :: (MonadInterpreter m, Data a) => AnnTarget GHC.Name -> m [a]-anns = runGhc1 (GHC.findGlobalAnns deserializeWithData)+anns target = runGhc $ GHC.findGlobalAnns deserializeWithData target
src/Hint/Base.hs view
@@ -3,11 +3,10 @@ GhcError(..), InterpreterError(..), mayFail, catchIE, - InterpreterSession, SessionData(..), GhcErrLogger,+ InterpreterSession, SessionData(..), InterpreterState(..), fromState, onState, InterpreterConfiguration(..),-- runGhc1, runGhc2,+ ImportList(..), ModuleQualification(..), ModuleImport(..), ModuleName, PhantomModule(..), findModule, moduleIsLoaded,@@ -18,25 +17,22 @@ debug, showGHC ) where -import Control.Monad.Trans+import Control.Monad.IO.Class import Control.Monad.Catch as MC import Data.IORef import Data.Dynamic+import qualified Data.List import qualified Hint.GHC as GHC -#if MIN_VERSION_base(4,8,0)-import qualified Data.List-#endif- import Hint.Extension -- | Version of the underlying ghc api. Values are: ----- * @708@ for GHC 7.8.x+-- * @804@ for GHC 8.4.x ----- * @710@ for GHC 7.10.x+-- * @806@ for GHC 8.6.x -- -- * etc... ghcVersion :: Int@@ -62,13 +58,26 @@ data InterpreterState = St { activePhantoms :: [PhantomModule], zombiePhantoms :: [PhantomModule],+ phantomDirectory :: Maybe FilePath, hintSupportModule :: PhantomModule, importQualHackMod :: Maybe PhantomModule,- qualImports :: [(ModuleName, String)],+ qualImports :: [ModuleImport], defaultExts :: [(Extension, Bool)], -- R/O configuration :: InterpreterConfiguration } +data ImportList = NoImportList | ImportList [String] | HidingList [String]+ deriving (Eq, Show)+data ModuleQualification = NotQualified | ImportAs String | QualifiedAs (Maybe String)+ deriving (Eq, Show)++-- | Represent module import statement.+-- See 'setImportsF'+data ModuleImport = ModuleImport { modName :: String+ , modQual :: ModuleQualification+ , modImp :: ImportList+ } deriving (Show)+ data InterpreterConfiguration = Conf { searchFilePath :: [FilePath], languageExts :: [Extension],@@ -78,43 +87,21 @@ type InterpreterSession = SessionData () instance Exception InterpreterError-#if MIN_VERSION_base(4,8,0) where displayException (UnknownError err) = "UnknownError: " ++ err displayException (WontCompile es) = unlines . Data.List.nub . map errMsg $ es displayException (NotAllowed err) = "NotAllowed: " ++ err displayException (GhcException err) = "GhcException: " ++ err-#endif type RunGhc m a =-#if __GLASGOW_HASKELL__ >= 800 (forall n.(MonadIO n, MonadMask n) => GHC.GhcT n a)-#else- (forall n.(MonadIO n, MonadMask n, Functor n) => GHC.GhcT n a)-#endif -> m a -type RunGhc1 m a b =-#if __GLASGOW_HASKELL__ >= 800- (forall n.(MonadIO n, MonadMask n) => a -> GHC.GhcT n b)-#else- (forall n.(MonadIO n, MonadMask n, Functor n) => a -> GHC.GhcT n b)-#endif- -> (a -> m b)--type RunGhc2 m a b c =-#if __GLASGOW_HASKELL__ >= 800- (forall n.(MonadIO n, MonadMask n) => a -> b -> GHC.GhcT n c)-#else- (forall n.(MonadIO n, MonadMask n, Functor n) => a -> b -> GHC.GhcT n c)-#endif- -> (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@@ -138,25 +125,18 @@ 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-fromState f = do ref_st <- fromSession internalState- liftIO $ f `fmap` readIORef ref_st+fromState f = do+ ref_st <- fromSession internalState+ liftIO $ f <$> readIORef ref_st onState :: MonadInterpreter m => (InterpreterState -> InterpreterState) -> m ()-onState f = modifySessionRef internalState f >> return ()+onState f = () <$ modifySessionRef internalState f -- =============== Error handling ============================== @@ -181,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 =================================== @@ -191,16 +172,17 @@ 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-moduleIsLoaded mn = (findModule mn >> return True)+moduleIsLoaded mn = (True <$ findModule mn) `catchIE` (\e -> case e of- NotAllowed{} -> return False- _ -> throwM e)+ NotAllowed{} -> return False+ WontCompile{} -> return False+ _ -> throwM e) withDynFlags :: MonadInterpreter m => (GHC.DynFlags -> m a) -> m a-withDynFlags action- = do df <- runGhc GHC.getSessionDynFlags- action df+withDynFlags action = do+ df <- runGhc GHC.getSessionDynFlags+ action df
− src/Hint/Compat.hs
@@ -1,34 +0,0 @@-module Hint.Compat where--import qualified Hint.GHC as GHC---- Kinds became a synonym for Type in GHC 6.8. We define this wrapper--- to be able to define a FromGhcRep instance for both versions-newtype Kind = Kind GHC.Kind--supportedExtensions :: [String]-supportedExtensions = map f GHC.xFlags- where-#if (__GLASGOW_HASKELL__ >= 710)- f = GHC.flagSpecName-#else- f (e,_,_) = e-#endif--configureDynFlags :: GHC.DynFlags -> GHC.DynFlags-configureDynFlags dflags = 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- where firstTwo (a,b,_) = (a, map GHC.unLoc b)--pprType :: GHC.Type -> GHC.SDoc-#if __GLASGOW_HASKELL__ < 708-pprType = GHC.pprTypeForUser False -- False means drop explicit foralls-#else-pprType = GHC.pprTypeForUser-#endif
src/Hint/Configuration.hs view
@@ -8,16 +8,19 @@ languageExtensions, availableExtensions, Extension(..), installedModulesInScope, - searchPath+ searchPath,++ configureDynFlags, parseDynamicFlags,+ ) where import Control.Monad import Control.Monad.Catch import Data.Char+import Data.Maybe (maybe) import Data.List (intercalate) import qualified Hint.GHC as GHC-import qualified Hint.Compat as Compat import Hint.Base import Hint.Util (quote) @@ -26,12 +29,13 @@ setGhcOptions :: MonadInterpreter m => [String] -> m () setGhcOptions opts = do old_flags <- runGhc GHC.getSessionDynFlags- (new_flags,not_parsed) <- runGhc2 Compat.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 ()@@ -67,7 +71,7 @@ -- | Retrieves the value of an option. get :: MonadInterpreter m => Option m a -> m a-get = _get+get = \o -> _get o -- | Language extensions in use by the interpreter. --@@ -81,7 +85,7 @@ getter = fromConf languageExts -- resetExtensions = do es <- fromState defaultExts- setGhcOptions $ map (uncurry $ flip extFlag) es+ setGhcOptions $ uncurry (flip extFlag) <$> es extFlag :: Bool -> Extension -> String extFlag = mkFlag@@ -120,6 +124,10 @@ setGhcOption "-i" -- clear the old path setGhcOption $ "-i" ++ intercalate ":" p + mfp <- fromState phantomDirectory+ maybe (return ())+ (\fp -> setGhcOption $ "-i" ++ fp) mfp+ fromConf :: MonadInterpreter m => (InterpreterConfiguration -> a) -> m a fromConf f = fromState (f . configuration) @@ -127,3 +135,17 @@ => (InterpreterConfiguration -> InterpreterConfiguration) -> m () onConf f = onState $ \st -> st{configuration = f (configuration st)}++configureDynFlags :: GHC.DynFlags -> GHC.DynFlags+configureDynFlags dflags =+ (if GHC.dynamicGhc then GHC.addWay GHC.WayDyn else id)+ . GHC.setBackendToInterpreter+ $+ dflags{GHC.ghcMode = GHC.CompManager,+ GHC.ghcLink = GHC.LinkInMemory,+ GHC.verbosity = 0}++parseDynamicFlags :: GHC.GhcMonad m+ => GHC.Logger -> GHC.DynFlags -> [String] -> m (GHC.DynFlags, [String])+parseDynamicFlags l d = fmap firstTwo . GHC.parseDynamicFlags l d . map GHC.noLoc+ where firstTwo (a,b,_) = (a, map GHC.unLoc b)
src/Hint/Context.hs view
@@ -1,7 +1,7 @@ module Hint.Context ( isModuleInterpreted, loadModules, getLoadedModules, setTopLevelModules,- setImports, setImportsQ,+ setImports, setImportsQ, setImportsF, reset, PhantomModule(..),@@ -13,17 +13,17 @@ import Prelude hiding (mod) import Data.Char+import Data.Either (partitionEithers) import Data.List import Control.Arrow ((***)) -import Control.Monad (liftM, filterM, unless, guard, foldM, (>=>))-import Control.Monad.Trans (liftIO)+import Control.Monad (filterM, unless, guard, foldM)+import Control.Monad.IO.Class (liftIO) import Control.Monad.Catch import Hint.Base import Hint.Conversions-import qualified Hint.Util as Util import qualified Hint.CompatPlatform as Compat import qualified Hint.GHC as GHC@@ -32,6 +32,9 @@ import System.FilePath import System.Directory +import Hint.Configuration (setGhcOption)+import System.IO.Temp+ type ModuleText = String -- When creating a phantom module we have a situation similar to that of@@ -50,39 +53,52 @@ let nums = concat [show (abs n::Int), show p, filter isDigit $ concat (ls ++ is)] let mod_name = 'M':nums --- tmp_dir <- liftIO getTemporaryDirectory+ tmp_dir <- getPhantomDirectory --- return PhantomModule{pmName = mod_name, pmFile = tmp_dir </> nums}+ return PhantomModule{pmName = mod_name, pmFile = tmp_dir </> mod_name <.> "hs"} +getPhantomDirectory :: MonadInterpreter m => m FilePath+getPhantomDirectory =+ -- When a module is loaded by file name, ghc-8.4.1 loses track of the+ -- file location after the first time it has been loaded, so we create+ -- a directory for the phantom modules and add it to the search path.+ do mfp <- fromState phantomDirectory+ case mfp of+ Just fp -> return fp+ Nothing -> do tmp_dir <- liftIO getTemporaryDirectory+ fp <- liftIO $ createTempDirectory tmp_dir "hint"+ onState (\s -> s{ phantomDirectory = Just fp })+ setGhcOption $ "-i" ++ fp+ return fp+ allModulesInContext :: MonadInterpreter m => m ([ModuleName], [ModuleName]) allModulesInContext = runGhc getContextNames -getContext :: GHC.GhcMonad m => m ([GHC.Module], [GHC.ImportDecl GHC.RdrName])-getContext = GHC.getContext >>= foldM f ([], [])+getContext :: GHC.GhcMonad m => m ([GHC.Module], [GHC.ImportDecl GHC.GhcPs])+getContext = do+ ctx <- GHC.getContext+ foldM f ([], []) ctx where f :: (GHC.GhcMonad m) =>- ([GHC.Module], [GHC.ImportDecl GHC.RdrName]) ->+ ([GHC.Module], [GHC.ImportDecl GHC.GhcPs]) -> GHC.InteractiveImport ->- m ([GHC.Module], [GHC.ImportDecl GHC.RdrName])+ m ([GHC.Module], [GHC.ImportDecl GHC.GhcPs]) f (ns, ds) i = case i of (GHC.IIDecl d) -> return (ns, d : ds)- m@(GHC.IIModule _) -> do n <- iiModToMod m; return (n : ns, ds)--modToIIMod :: GHC.Module -> GHC.InteractiveImport-modToIIMod = GHC.IIModule . GHC.moduleName--iiModToMod :: GHC.GhcMonad m => GHC.InteractiveImport -> m GHC.Module-iiModToMod (GHC.IIModule m) = GHC.findModule m Nothing-iiModToMod _ = error "iiModToMod!"+ _ -> do+ mMod <- GHC.interactiveImportToModule i+ case mMod of+ Just n -> return (n : ns, ds)+ Nothing -> return (ns, ds) getContextNames :: GHC.GhcMonad m => m([String], [String]) getContextNames = fmap (map name *** map decl) getContext where name = GHC.moduleNameString . GHC.moduleName decl = GHC.moduleNameString . GHC.unLoc . GHC.ideclName -setContext :: GHC.GhcMonad m => [GHC.Module] -> [GHC.ImportDecl GHC.RdrName] -> m ()+setContext :: GHC.GhcMonad m => [GHC.Module] -> [GHC.ImportDecl GHC.GhcPs] -> m () setContext ms ds =- let ms' = map modToIIMod ms+ let ms' = map GHC.moduleToInteractiveImport ms ds' = map GHC.IIDecl ds is = ms' ++ ds' in GHC.setContext is@@ -92,30 +108,26 @@ 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)- m = GHC.mkModuleName (pmName pm)+ df <- runGhc GHC.getSessionDynFlags+ let t = GHC.fileTarget df (pmFile 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 --- runGhc1 GHC.addTarget t- res <- runGhc1 GHC.load (GHC.LoadUpTo m)+ runGhc $ GHC.addTarget t+ res <- runGhc $ GHC.load GHC.LoadAllTargets -- 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@@ -125,7 +137,7 @@ -- return pm -removePhantomModule :: MonadInterpreter m => PhantomModule -> m ()+removePhantomModule :: forall m. MonadInterpreter m => PhantomModule -> m () removePhantomModule pm = do -- We don't want to actually unload this module, because that -- would mean that all the real modules might get reloaded and the@@ -142,22 +154,24 @@ mod <- findModule (pmName pm) (mods, imps) <- runGhc getContext let mods' = filter (mod /=) mods- runGhc2 setContext mods' imps+ runGhc $ setContext mods' imps --- let isNotPhantom = isPhantomModule . moduleToString >=>- return . not- null `liftM` filterM isNotPhantom mods'+ let isNotPhantom :: GHC.Module -> m Bool+ isNotPhantom mod' = do+ not <$> isPhantomModule (moduleToString mod')+ null <$> filterM isNotPhantom mods' else return True -- let file_name = pmFile pm- runGhc1 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}) -- if safeToRemove- then do mayFail $ do res <- runGhc1 GHC.load GHC.LoadAllTargets- return $ guard (isSucceeded res) >> Just ()- liftIO $ removeFile (pmFile pm)+ 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}) -- Returns a tuple with the active and zombie phantom modules respectively@@ -172,7 +186,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.@@ -200,32 +217,30 @@ doLoad fs `catchIE` (\e -> reset >> throwM e) doLoad :: MonadInterpreter m => [String] -> m ()-doLoad fs = mayFail $ do- targets <- mapM (\f->runGhc2 GHC.guessTarget f Nothing) fs- --- runGhc1 GHC.setTargets targets- res <- runGhc1 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-isModuleInterpreted m = findModule m >>= runGhc1 GHC.moduleIsInterpreted+isModuleInterpreted moduleName = do+ mod <- findModule moduleName+ runGhc $ GHC.moduleIsInterpreted mod -- | Returns the list of modules loaded with 'loadModules'. getLoadedModules :: MonadInterpreter m => m [ModuleName] getLoadedModules = do (active_pms, zombie_pms) <- getPhantomModules- ms <- map modNameFromSummary `liftM` getLoadedModSummaries+ ms <- map modNameFromSummary <$> getLoadedModSummaries return $ ms \\ map pmName (active_pms ++ zombie_pms) modNameFromSummary :: GHC.ModSummary -> ModuleName modNameFromSummary = moduleToString . GHC.ms_mod getLoadedModSummaries :: MonadInterpreter m => m [GHC.ModSummary]-getLoadedModSummaries =- do all_mod_summ <- runGhc GHC.getModuleGraph- filterM (runGhc1 GHC.isLoaded . GHC.ms_mod_name) all_mod_summ+getLoadedModSummaries = do+ modGraph <- runGhc GHC.getModuleGraph+ let modSummaries = GHC.mgModSummaries modGraph+ 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.@@ -243,58 +258,89 @@ active_pms <- fromState activePhantoms ms_mods <- mapM findModule (nub $ ms ++ map pmName active_pms) --- let mod_is_interpr = runGhc1 GHC.moduleIsInterpreted- not_interpreted <- filterM (liftM not . mod_is_interpr) ms_mods+ 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.+-- | 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' and 'setImportsQ' are mutually exclusive.+-- Warning: 'setImports', 'setImportsQ', and 'setImportsF' are mutually exclusive. -- If you have a list of modules to be used qualified and another list -- unqualified, then you need to do something like -- -- > setImportsQ ((zip unqualified $ repeat Nothing) ++ qualifieds) setImports :: MonadInterpreter m => [ModuleName] -> m ()-setImports ms = setImportsQ $ zip ms (repeat Nothing)+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")]@. -- -- Here, "map" will refer to Prelude.map and "M.map" to Data.Map.map. setImportsQ :: MonadInterpreter m => [(ModuleName, Maybe String)] -> m ()-setImportsQ ms =- do let qualOrNot (a, mb) = maybe (Right a) (Left . (,) a) mb- (quals, unquals) = Util.partitionEither $ map qualOrNot ms- --- unqual_mods <- mapM findModule unquals- mapM_ (findModule . fst) quals -- just to be sure they exist+setImportsQ ms = setImportsF $ map (\(m,q) -> ModuleImport m (maybe NotQualified (QualifiedAs . Just) q) NoImportList) ms++-- | 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"])]@++setImportsF :: MonadInterpreter m => [ModuleImport] -> m ()+setImportsF moduleImports = do+ regularMods <- mapM (findModule . modName) regularImports+ mapM_ (findModule . modName) phantomImports -- just to be sure they exist -- old_qual_hack_mod <- fromState importQualHackMod maybe (return ()) removePhantomModule old_qual_hack_mod --- new_pm <- if not $ null quals- then do- new_pm <- addPhantomModule $ \mod_name -> unlines $- ("module " ++ mod_name ++ " where ") :- ["import qualified " ++ m ++ " as " ++ n |- (m,n) <- quals]- onState (\s -> s{importQualHackMod = Just new_pm})- return $ Just new_pm- else return Nothing+ maybe_phantom_module <- do+ if null phantomImports+ then return Nothing+ else do+ let moduleContents = map newImportLine phantomImports+ new_phantom_module <- addPhantomModule $ \mod_name+ -> unlines $ ("module " ++ mod_name ++ " where ")+ : moduleContents+ onState (\s -> s{importQualHackMod = Just new_phantom_module})+ return $ Just new_phantom_module --- pm <- maybe (return []) (findModule . pmName >=> return . return) new_pm+ phantom_mods <- case maybe_phantom_module of+ Nothing -> do+ pure []+ Just phantom_module-> do+ phantom_mod <- findModule (pmName phantom_module)+ pure [phantom_mod] (old_top_level, _) <- runGhc getContext- let new_top_level = pm ++ old_top_level- runGhc2 setContextModules new_top_level unqual_mods+ let new_top_level = phantom_mods ++ old_top_level+ runGhc $ setContextModules new_top_level regularMods --- onState (\s ->s{qualImports = quals})+ onState (\s ->s{qualImports = phantomImports})+ where+ (regularImports, phantomImports) = partitionEithers+ $ map (\m -> if isQualified m || hasImportList m+ then Right m -- phantom+ else Left m)+ moduleImports+ isQualified m = modQual m /= NotQualified+ hasImportList m = modImp m /= NoImportList+ newImportLine m = concat ["import ", case modQual m of+ NotQualified -> modName m+ ImportAs q -> modName m ++ " as " ++ q+ QualifiedAs Nothing -> "qualified " ++ modName m+ QualifiedAs (Just q) -> "qualified " ++ modName m ++ " as " ++ q+ ,case modImp m of+ NoImportList -> ""+ ImportList l -> " (" ++ intercalate "," l ++ ")"+ HidingList l -> " hiding (" ++ intercalate "," l ++ ")"+ ] -- | 'cleanPhantomModules' works like 'reset', but skips the -- loading of the support module that installs '_show'. Its purpose@@ -302,11 +348,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.@@ -323,6 +369,10 @@ qualImports = []}) liftIO $ mapM_ (removeFile . pmFile) (old_active ++ old_zombie) + old_phantomdir <- fromState phantomDirectory+ onState (\s -> s{phantomDirectory = Nothing})+ liftIO $ do maybe (return ()) removeDirectory old_phantomdir+ -- | All imported modules are cleared from the context, and -- loaded modules are unloaded. It is similar to a @:load@ in -- GHCi, but observe that not even the Prelude will be in@@ -332,14 +382,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)- runGhc2 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 ++ "( ",@@ -360,10 +411,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/Conversions.hs view
@@ -5,7 +5,6 @@ import qualified Hint.GHC as GHC import Hint.Base-import qualified Hint.Compat as Compat -- --------- Types / Kinds ----------------------- @@ -15,12 +14,13 @@ -- (i.e., do not expose internals) unqual <- runGhc GHC.getPrintUnqual withDynFlags $ \df ->- return $ GHC.showSDocForUser df unqual (Compat.pprType t)+ -- TODO: get unit state from somewhere?+ return $ GHC.showSDocForUser df GHC.emptyUnitState unqual (GHC.pprTypeForUser t) -kindToString :: MonadInterpreter m => Compat.Kind -> m String-kindToString (Compat.Kind k)+kindToString :: MonadInterpreter m => GHC.Kind -> m String+kindToString k = withDynFlags $ \df ->- return $ GHC.showSDoc df (Compat.pprType k)+ return $ GHC.showSDoc df (GHC.pprTypeForUser k) -- ---------------- Modules --------------------------
src/Hint/Eval.hs view
@@ -1,14 +1,17 @@ module Hint.Eval ( interpret, as, infer, unsafeInterpret,- eval, parens+ eval, runStmt,+ parens ) where import qualified GHC.Exts (unsafeCoerce#) -import Data.Typeable hiding (typeOf)-import qualified Data.Typeable (typeOf)+import Control.Exception +import Data.Typeable (Typeable)+import qualified Data.Typeable as Typeable+ import Hint.Base import Hint.Context import Hint.Parsers@@ -28,7 +31,7 @@ -- | Evaluates an expression, given a witness for its monomorphic type. interpret :: (MonadInterpreter m, Typeable a) => String -> a -> m a-interpret expr wit = unsafeInterpret expr (show $ Data.Typeable.typeOf wit)+interpret expr wit = unsafeInterpret expr (show $ Typeable.typeOf wit) unsafeInterpret :: (MonadInterpreter m) => String -> String -> m a unsafeInterpret expr type_str =@@ -38,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) @@ -55,6 +58,22 @@ let show_expr = unwords [in_scope_show, parens expr] unsafeInterpret show_expr in_scope_String +-- | Evaluate a statement in the 'IO' monad, possibly binding new names.+--+-- Example:+--+-- > runStmt "x <- return 42"+-- > runStmt "print x"+runStmt :: (MonadInterpreter m) => String -> m ()+runStmt s = mayFail $ runGhc $ go s+ where+ go statements = do+ result <- GHC.execStmt statements GHC.execOptions+ return $ case result of+ GHC.ExecComplete { GHC.execResult = Right _ } -> Just ()+ GHC.ExecComplete { GHC.execResult = Left e } -> throw e+ _ -> Nothing+ -- | Conceptually, @parens s = \"(\" ++ s ++ \")\"@, where s is any valid haskell -- expression. In practice, it is harder than this. -- Observe that if @s@ ends with a trailing comment, then @parens s@ would@@ -62,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, ")"]
src/Hint/Extension.hs view
@@ -1,14 +1,19 @@ -- this module was automatically generated. do not edit! -- edit util/mk_extensions_mod.hs instead module Hint.Extension (- Extension(..), availableExtensions, asExtension+ Extension(..), supportedExtensions, availableExtensions, asExtension ) where -import Hint.Compat as Compat+import qualified Hint.GHC as GHC +supportedExtensions :: [String]+supportedExtensions = map f GHC.xFlags+ where+ f = GHC.flagSpecName+ -- | List of the extensions known by the interpreter. availableExtensions :: [Extension]-availableExtensions = map asExtension Compat.supportedExtensions+availableExtensions = map asExtension supportedExtensions asExtension :: String -> Extension asExtension s = if isKnown s@@ -139,6 +144,7 @@ | MonadFailDesugaring | TemplateHaskellQuotes | OverloadedLabels+ | TypeFamilyDependencies | NoOverlappingInstances | NoUndecidableInstances | NoIncoherentInstances@@ -257,6 +263,7 @@ | NoMonadFailDesugaring | NoTemplateHaskellQuotes | NoOverloadedLabels+ | NoTypeFamilyDependencies | UnknownExtension String deriving (Eq, Show, Read) @@ -379,6 +386,7 @@ MonadFailDesugaring, TemplateHaskellQuotes, OverloadedLabels,+ TypeFamilyDependencies, NoOverlappingInstances, NoUndecidableInstances, NoIncoherentInstances,@@ -496,5 +504,6 @@ NoUndecidableSuperClasses, NoMonadFailDesugaring, NoTemplateHaskellQuotes,- NoOverloadedLabels+ NoOverloadedLabels,+ NoTypeFamilyDependencies ]
src/Hint/GHC.hs view
@@ -1,35 +1,695 @@+{-# LANGUAGE TypeApplications #-} module Hint.GHC (- Message, module X+ -- * Shims+ dynamicGhc,+ Message,+ Logger,+ WarnReason(NoReason),+ initLogger,+ putLogMsg,+ pushLogHook,+ modifyLogger,+ mkLogAction,+ UnitState,+ emptyUnitState,+ showSDocForUser,+ ParserOpts,+ mkParserOpts,+ initParserState,+ getErrorMessages,+ pprErrorMessages,+ SDocContext,+ defaultSDocContext,+ showGhcException,+ addWay,+ setBackendToInterpreter,+ parseDynamicFlags,+ pprTypeForUser,+ errMsgSpan,+ fileTarget,+ guessTarget,+ moduleToInteractiveImport,+ interactiveImportToModule,+#if MIN_VERSION_ghc(9,6,0)+ getPrintUnqual,+#endif+ -- * Re-exports+ module X, ) where -import GHC as X hiding (Phase, GhcT, runGhcT)+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+ , pushLogHook+#endif+ ) import Control.Monad.Ghc as X (GhcT, runGhcT) +#if MIN_VERSION_ghc(9,8,0)+import GHC.Types.Error (ResolvedDiagnosticReason(..), Messages)+import GHC.Driver.Errors.Types (DriverMessage)+#endif++#if MIN_VERSION_ghc(9,4,0)+import GHC.Types.SourceError as X (SourceError, srcErrorMessages)++import GHC.Driver.Ppr as X (showSDoc, showSDocUnsafe)++import GHC.Types.SourceFile as X (HscSource(HsSrcFile))++import GHC.Platform.Ways as X (Way (..))+#elif 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.Platform.Ways as X (Way (..))+#elif MIN_VERSION_ghc(9,0,0)+import GHC.Driver.Types as X (SourceError, srcErrorMessages, GhcApiError)++import GHC.Utils.Outputable as X (showSDoc)++import GHC.Driver.Phases as X (HscSource(HsSrcFile))++import GHC.Driver.Session as X (addWay')+import GHC.Driver.Ways as X (Way (..))+#else import HscTypes as X (SourceError, srcErrorMessages, GhcApiError) -import Outputable as X (PprStyle, SDoc, Outputable(ppr),- showSDoc, showSDocForUser, showSDocUnqual,- withPprStyle, defaultErrStyle)+import Outputable as X (showSDoc) -import ErrUtils as X (mkLocMessage, pprErrMsgBagWithLoc, MsgDoc) -- we alias MsgDoc as Message below+import DriverPhases as X (HscSource(HsSrcFile)) -import DriverPhases as X (Phase(Cpp), HscSource(HsSrcFile))+import DynFlags as X (addWay', Way(..))+#endif++#if MIN_VERSION_ghc(9,4,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(..))++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(..))+import GHC.Driver.Session (WarnReason(NoReason))++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, vcat)++import DriverPhases as X (Phase(Cpp)) import StringBuffer as X (stringToStringBuffer) import Lexer as X (P(..), ParseResult(..), mkPState) import Parser as X (parseStmt, parseType) import FastString as X (fsLit) -#if __GLASGOW_HASKELL__ >= 710-import DynFlags as X (xFlags, xopt, LogAction, FlagSpec(..))-#else-import DynFlags as X (xFlags, xopt, LogAction)-#endif+import DynFlags as X (xFlags, xopt, FlagSpec(..)) -import PprTyThing as X (pprTypeForUser) import SrcLoc as X (mkRealSrcLoc) -#if __GLASGOW_HASKELL__ >= 708 import ConLike as X (ConLike(RealDataCon)) #endif -type Message = MsgDoc+{-------------------- Imports for Shims --------------------}++import Control.Monad.IO.Class (MonadIO)+-- guessTarget+import qualified GHC (guessTarget)++#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+ (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 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)++-- 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)++-- 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, mkLocMessage)++-- Logger+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)++-- 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)++-- 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, mkLocMessage)++-- Logger+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)++-- 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)++-- 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 --------------------}++-- 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 -> DynFlags -> WarnReason -> Severity -> SrcSpan -> SDoc -> IO ()+pushLogHook :: (GHC.LogAction -> GHC.LogAction) -> Logger -> Logger+modifyLogger :: GhcMonad m => (Logger -> Logger) -> m ()+mkLogAction :: (String -> a) -> IORef [a] -> GHC.LogAction+#if MIN_VERSION_ghc(9,8,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 (ResolvedDiagnosticReason 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,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+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+modifyLogger f = do+ 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+emptyUnitState :: UnitState+#if MIN_VERSION_ghc(9,2,0)+type UnitState = GHC.UnitState+emptyUnitState = GHC.emptyUnitState+#else+type UnitState = ()+emptyUnitState = ()+#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+#else+showSDocForUser df _ = GHC.showSDocForUser df+#endif++-- PState+mkParserOpts :: DynFlags -> ParserOpts+initParserState :: ParserOpts -> StringBuffer -> RealSrcLoc -> GHC.PState+#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+ 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,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+ 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,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}+#endif++-- parseDynamicFlags++#if MIN_VERSION_ghc(9,8,0)+parseDynamicFlags :: MonadIO m => Logger -> DynFlags -> [Located String] -> m (DynFlags, [Located String], Messages DriverMessage)+parseDynamicFlags = GHC.parseDynamicFlags+#else+#if MIN_VERSION_ghc(9,2,0)+parseDynamicFlags :: MonadIO m => Logger -> DynFlags -> [Located String] -> m (DynFlags, [Located String], [Warn])+parseDynamicFlags = GHC.parseDynamicFlags+#else+parseDynamicFlags _ = GHC.parseDynamicFlags+#endif+#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++-- moduleToInteractiveImport / interactiveImportToModule+-- In GHC 9.14+, IIModule takes a Module directly instead of ModuleName+moduleToInteractiveImport :: Module -> InteractiveImport+interactiveImportToModule :: InteractiveImport -> GhcMonad m => m (Maybe Module)+#if MIN_VERSION_ghc(9,14,0)+moduleToInteractiveImport = IIModule+interactiveImportToModule (IIModule m) = return $ Just m+interactiveImportToModule _ = return Nothing+#else+moduleToInteractiveImport = IIModule . moduleName+interactiveImportToModule (IIModule mn) = do+ m <- findModule mn Nothing+ return $ Just m+interactiveImportToModule _ = return Nothing+#endif++-- getPrintUnqual+#if MIN_VERSION_ghc(9,6,0)+getPrintUnqual :: GhcMonad m => m PrintUnqualified+getPrintUnqual = GHC.getNamePprCtx+#endif
+ src/Hint/Internal.hs view
@@ -0,0 +1,33 @@+-- | In this module we intend to export some internal functions.+--+-- __Important note__: the authors of this library imply no assurance whatsoever+-- of the stability or functionality of the API exposed here, and compatibility+-- may break even by minor version changes. Rely on these at your+-- own risk.+--+-- The reason for showing them here is to aid discoverability+-- of already written code and prevent having to reinvent the wheel from+-- scratch if said wheel is already invented.+--+-- In case you find something here especially useful, please submit+-- an issue or a pull request at https://github.com/haskell-hint/hint so+-- we can discuss making it part of the official public API.+--+-- Some further context can be found here:+-- https://github.com/haskell-hint/hint/pull/48#issuecomment-358722638++++module Hint.Internal (+ onCompilationError+) where++import Hint.Typecheck (onCompilationError)++++-- todo: Consider refactoring like the following when+-- https://github.com/haskell/haddock/issues/563 is fixed+--+-- module Hint.Internal (module ReExport) where+-- import Hint.Typecheck as ReExport (onCompilationError)
src/Hint/InterpreterT.hs view
@@ -12,7 +12,10 @@ import Hint.Configuration import Hint.Extension -import Control.Monad.Reader+import Control.Monad (ap, unless)+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader import Control.Monad.Catch as MC import Data.Typeable (Typeable)@@ -25,7 +28,6 @@ import qualified GHC.Paths import qualified Hint.GHC as GHC-import qualified Hint.Compat as Compat type Interpreter = InterpreterT IO @@ -34,11 +36,8 @@ } deriving (Functor, Monad, MonadIO, MonadThrow, MonadCatch, MonadMask) -execute :: (MonadIO m, MonadMask m-#if __GLASGOW_HASKELL__ < 800- , Functor m-#endif- ) => String+execute :: (MonadIO m, MonadMask m)+ => String -> InterpreterSession -> InterpreterT m a -> m (Either InterpreterError a)@@ -50,11 +49,8 @@ instance MonadTrans InterpreterT where lift = InterpreterT . lift . lift -runGhcImpl :: (MonadIO m, MonadMask m-#if __GLASGOW_HASKELL__ < 800- , MonadThrow m, Functor m-#endif- ) => RunGhc (InterpreterT m) a+runGhcImpl :: (MonadIO m, MonadMask m)+ => RunGhc (InterpreterT m) a runGhcImpl a = InterpreterT (lift a) `catches`@@ -68,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 ================== @@ -80,12 +76,12 @@ => [String] -> InterpreterT m () initialize args =- do log_handler <- fromSession ghcErrLogger+ do logger <- fromSession ghcLogger -- Set a custom log handler, to intercept error messages :S df0 <- runGhc GHC.getSessionDynFlags - let df1 = Compat.configureDynFlags df0- (df2, extra) <- runGhc2 Compat.parseDynamicFlags df1 args+ let df1 = configureDynFlags df0+ (df2, extra) <- runGhc $ parseDynamicFlags logger df1 args unless (null extra) $ throwM $ UnknownError (concat [ "flags: '" , unwords extra@@ -93,17 +89,16 @@ -- 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.modifyLogger (const logger)+ _ <- runGhc $ GHC.setSessionDynFlags df2 -#if __GLASGOW_HASKELL__ >= 710- let extMap = map (\fs -> (GHC.flagSpecName fs, GHC.flagSpecFlag fs)) GHC.xFlags-#else- let extMap = map (\(a,b,_) -> (a,b)) GHC.xFlags-#endif+ let extMap = [ (GHC.flagSpecName flagSpec, GHC.flagSpecFlag flagSpec)+ | flagSpec <- GHC.xFlags+ ] let toOpt e = let err = error ("init error: unknown ext:" ++ show e) in fromMaybe err (lookup e extMap) let getOptVal e = (asExtension e, GHC.xopt (toOpt e) df2)- let defExts = map getOptVal Compat.supportedExtensions+ let defExts = map getOptVal supportedExtensions onState (\s -> s{defaultExts = defExts}) @@ -111,60 +106,48 @@ -- | Executes the interpreter. Returns @Left InterpreterError@ in case of error. ----- NB. The underlying ghc will overwrite certain signal handlers--- (SIGINT, SIGHUP, SIGTERM, SIGQUIT on Posix systems, Ctrl-C handler on Windows).--- In future versions of hint, this might be controlled by the user.-runInterpreter :: (MonadIO m, MonadMask m-#if __GLASGOW_HASKELL__ < 800- , Functor m-#endif- ) => InterpreterT m a+-- NB. In hint-0.7.0 and earlier, the underlying ghc was accidentally+-- overwriting certain signal handlers (SIGINT, SIGHUP, SIGTERM, SIGQUIT on+-- Posix systems, Ctrl-C handler on Windows).+runInterpreter :: (MonadIO m, MonadMask m)+ => InterpreterT m a -> m (Either InterpreterError a) runInterpreter = runInterpreterWithArgs [] -- | Executes the interpreter, setting args passed in as though they -- were command-line args. Returns @Left InterpreterError@ in case of -- error.-runInterpreterWithArgs :: (MonadIO m, MonadMask m-#if __GLASGOW_HASKELL__ < 800- , Functor m-#endif- ) => [String]+runInterpreterWithArgs :: (MonadIO m, MonadMask m)+ => [String] -> InterpreterT m a -> m (Either InterpreterError a) runInterpreterWithArgs args = runInterpreterWithArgsLibdir args GHC.Paths.libdir -runInterpreterWithArgsLibdir :: (MonadIO m, MonadMask m-#if __GLASGOW_HASKELL__ < 800- , Functor m-#endif- ) => [String]+runInterpreterWithArgsLibdir :: (MonadIO m, MonadMask m)+ => [String] -> String -> InterpreterT m a -> m (Either InterpreterError a) runInterpreterWithArgsLibdir args libdir action =+#ifndef THREAD_SAFE_LINKER ifInterpreterNotRunning $+#endif do s <- newInterpreterSession `MC.catch` rethrowGhcException execute libdir s (initialize args >> action `finally` cleanSession) where rethrowGhcException = throwM . GhcException . showGhcEx newInterpreterSession = newSessionData ()- cleanSession =- do cleanPhantomModules-#if __GLASGOW_HASKELL__ < 800- runGhc $ do dflags <- GHC.getSessionDynFlags- GHC.defaultCleanupHandler dflags (return ())-#endif+ cleanSession = cleanPhantomModules +#ifndef THREAD_SAFE_LINKER {-# NOINLINE uniqueToken #-} uniqueToken :: MVar () uniqueToken = unsafePerformIO $ newMVar () ifInterpreterNotRunning :: (MonadIO m, MonadMask m) => m a -> m a-ifInterpreterNotRunning action =- do maybe_token <- liftIO $ tryTakeMVar uniqueToken- case maybe_token of- Nothing -> throwM MultipleInstancesNotAllowed- Just x -> action `finally` liftIO (putMVar uniqueToken x)+ifInterpreterNotRunning action = liftIO (tryTakeMVar uniqueToken) >>= \ case+ Nothing -> throwM MultipleInstancesNotAllowed+ Just x -> action `finally` liftIO (putMVar uniqueToken x)+#endif -- | The installed version of ghc is not thread-safe. This exception -- is thrown whenever you try to execute @runInterpreter@ while another@@ -181,6 +164,7 @@ initialState = St { activePhantoms = [], zombiePhantoms = [],+ phantomDirectory = Nothing, hintSupportModule = error "No support module loaded!", importQualHackMod = Nothing, qualImports = [],@@ -192,32 +176,18 @@ 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 $ GHC.mkLogAction GhcError ghc_err_list_ref) logger } -mkLogHandler :: IORef [GhcError] -> GhcErrLogger-#if __GLASGOW_HASKELL__ >= 800-mkLogHandler r df _ _ src style msg =-#else-mkLogHandler r df _ src style msg =-#endif- 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- -- The MonadInterpreter instance instance (MonadIO m, MonadMask m, Functor m) => MonadInterpreter (InterpreterT m) where- fromSession f = InterpreterT $ fmap f ask+ fromSession f = InterpreterT $ asks f -- modifySessionRef target f = do ref <- fromSession target@@ -225,10 +195,6 @@ -- runGhc = runGhcImpl -#if __GLASGOW_HASKELL__ >= 800 instance (Monad m) => Applicative (InterpreterT m) where-#else-instance (Monad m, Applicative m) => Applicative (InterpreterT m) where-#endif- pure = return+ pure = InterpreterT . pure (<*>) = ap
src/Hint/Parsers.hs view
@@ -4,14 +4,10 @@ import Hint.Base -import Control.Monad.Trans (liftIO)+import Control.Monad.IO.Class (liftIO) import qualified Hint.GHC as GHC -#if __GLASGOW_HASKELL__ >= 800-import qualified DynFlags as GHC-#endif- data ParseResult = ParseOk | ParseError GHC.SrcSpan GHC.Message parseExpr :: MonadInterpreter m => String -> m ParseResult@@ -28,39 +24,41 @@ -- -- ghc >= 7 panics if noSrcLoc is given let srcLoc = GHC.mkRealSrcLoc (GHC.fsLit "<hint>") 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 --- GHC.PFailed span err -> return (ParseError span err)+#if MIN_VERSION_ghc(8,10,0)+ GHC.PFailed pst -> let errMsgs = GHC.getErrorMessages pst dyn_fl+ span = GHC.errMsgSpan errMsgs+ err = GHC.vcat $ GHC.pprErrorMessages errMsgs+ in pure (ParseError span err)+#else+ GHC.PFailed _ span err -> return (ParseError span err)+#endif failOnParseError :: MonadInterpreter m => (String -> m ParseResult) -> String -> m () failOnParseError parser expr = mayFail go- where go = do parsed <- parser expr- --- -- If there was a parsing error,- -- do the "standard" error reporting- case parsed of+ where go = parser expr >>= \ case ParseOk -> return (Just ())- --+ -- If there was a parsing error,+ -- do the "standard" error reporting 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- errStyle = GHC.defaultErrStyle dflags+ let logger' = GHC.putLogMsg logger dflags+ liftIO $ logger'-#if __GLASGOW_HASKELL__ >= 800 GHC.NoReason-#endif GHC.SevError span- errStyle err -- -- behave like the rest of the GHC API functions
src/Hint/Reflection.hs view
@@ -30,46 +30,26 @@ 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) asModElemList :: GHC.DynFlags -> [GHC.TyThing] -> [ModuleElem] asModElemList df xs = concat [- cs',- ts',- ds \\ concatMap (map Fun . children) ts',- fs \\ concatMap (map Fun . children) cs'+ cs,+ ts,+ ds \\ concatMap (map Fun . children) ts,+ fs \\ concatMap (map Fun . children) cs ]- where (cs,ts,ds,fs) =- (- [asModElem df c | c@(GHC.ATyCon c') <- xs, GHC.isClassTyCon c'],- [asModElem df t | t@(GHC.ATyCon c') <- xs, (not . GHC.isClassTyCon) c'],-#if __GLASGOW_HASKELL__ < 708- [asModElem df d | d@GHC.ADataCon{} <- xs],-#else- [asModElem df d | d@(GHC.AConLike (GHC.RealDataCon{})) <- xs],-#endif- [asModElem df f | f@GHC.AnId{} <- xs]- )- cs' = [Class n $ filter (alsoIn fs) ms | Class n ms <- cs]- ts' = [Data t $ filter (alsoIn ds) dcs | Data t dcs <- ts]+ where cs = [Class (getUnqualName df tc) (filter (alsoIn fs) $ getUnqualName df <$> GHC.classMethods c)+ | GHC.ATyCon tc <- xs, Just c <- [GHC.tyConClass_maybe tc]]+ ts = [Data (getUnqualName df tc) (filter (alsoIn ds) $ getUnqualName df <$> GHC.tyConDataCons tc)+ | GHC.ATyCon tc <- xs, Nothing <- [GHC.tyConClass_maybe tc]]+ ds = [Fun $ getUnqualName df dc | GHC.AConLike (GHC.RealDataCon dc) <- xs]+ fs = [Fun $ getUnqualName df f | GHC.AnId f <- xs] alsoIn es = (`elem` map name es) -asModElem :: GHC.DynFlags -> GHC.TyThing -> ModuleElem-asModElem df (GHC.AnId f) = Fun $ getUnqualName df f-#if __GLASGOW_HASKELL__ < 708-asModElem df (GHC.ADataCon dc) = Fun $ getUnqualName df dc-#else-asModElem df (GHC.AConLike (GHC.RealDataCon dc)) = Fun $ getUnqualName df dc-#endif-asModElem df (GHC.ATyCon tc) =- if GHC.isClassTyCon tc- then Class (getUnqualName df tc) (map (getUnqualName df) $ (GHC.classMethods . fromJust . GHC.tyConClass_maybe) tc)- else Data (getUnqualName df tc) (map (getUnqualName df) $ GHC.tyConDataCons tc)-asModElem _ _ = error "asModElem: can't happen!"- getUnqualName :: GHC.NamedThing a => GHC.DynFlags -> a -> String-getUnqualName dfs = GHC.showSDocUnqual dfs . GHC.pprParenSymName+getUnqualName dfs = GHC.showSDoc dfs . GHC.pprParenSymName
src/Hint/Typecheck.hs view
@@ -1,5 +1,5 @@ module Hint.Typecheck (- typeOf, typeChecks, kindOf,+ typeOf, typeChecks, kindOf, normalizeType, onCompilationError, typeChecksWithDetails ) where import Control.Monad.Catch@@ -8,7 +8,6 @@ import Hint.Parsers import Hint.Conversions -import qualified Hint.Compat as Compat import qualified Hint.GHC as GHC -- | Returns a string representation of the type of the expression.@@ -19,16 +18,25 @@ -- kind of errors failOnParseError parseExpr expr --- ty <- mayFail $ runGhc1 exprType expr- --- typeToString ty+ type_ <- mayFail (runGhc $ exprType expr)+ typeToString type_ -- | Tests if the expression type checks.+--+-- NB. Be careful if @unsafeSetGhcOption "-fdefer-type-errors"@ is used.+-- Perhaps unsurprisingly, that can falsely make @typeChecks@ and @typeChecksWithDetails@+-- return @True@ and @Right _@ respectively. typeChecks :: MonadInterpreter m => String -> m Bool-typeChecks expr = (typeOf expr >> return True)+typeChecks expr = (True <$ typeOf expr) `catchIE` onCompilationError (\_ -> return False) +-- | Similar to @typeChecks@, but gives more information, e.g. the type errors.+typeChecksWithDetails :: MonadInterpreter m => String -> m (Either [GhcError] String)+typeChecksWithDetails expr = (Right <$> typeOf expr)+ `catchIE`+ onCompilationError (return . Left)+ -- | Returns a string representation of the kind of the type expression. kindOf :: MonadInterpreter m => String -> m String kindOf type_expr =@@ -37,17 +45,30 @@ -- kind of errors failOnParseError parseType type_expr --- kind <- mayFail $ runGhc1 typeKind type_expr+ (_, kind) <- mayFail $ runGhc $ typeKind type_expr --- kindToString (Compat.Kind kind)+ kindToString kind +-- | Returns a string representation of the normalized type expression.+-- This is what the @:kind!@ GHCi command prints after @=@.+normalizeType :: MonadInterpreter m => String -> m String+normalizeType type_expr =+ do -- First, make sure the expression has no syntax errors,+ -- for this is the only way we have to "intercept" this+ -- kind of errors+ failOnParseError parseType type_expr+ --+ (ty, _) <- mayFail $ runGhc $ typeKind type_expr+ --+ typeToString ty+ -- add a bogus Maybe, in order to use it with mayFail exprType :: GHC.GhcMonad m => String -> m (Maybe GHC.Type)-exprType = fmap Just . GHC.exprType+exprType = fmap Just . GHC.exprType GHC.TM_Inst -- add a bogus Maybe, in order to use it with mayFail-typeKind :: GHC.GhcMonad m => String -> m (Maybe GHC.Kind)-typeKind = fmap (Just . snd) . GHC.typeKind True+typeKind :: GHC.GhcMonad m => String -> m (Maybe (GHC.Type, GHC.Kind))+typeKind = fmap Just . GHC.typeKind True onCompilationError :: MonadInterpreter m => ([GhcError] -> m a)
src/Language/Haskell/Interpreter.hs view
@@ -1,14 +1,3 @@--------------------------------------------------------------------------------- |--- Module : Language.Haskell.Interpreter--- License : BSD-style------ Maintainer : mvdan@mvdan.cc--- Stability : experimental--- Portability : non-portable (GHC API)------ A Haskell interpreter built on top of the GHC API------------------------------------------------------------------------------ module Language.Haskell.Interpreter( -- * The interpreter monad transformer MonadInterpreter(..), InterpreterT, Interpreter,@@ -22,8 +11,9 @@ -- ** Context handling ModuleName, isModuleInterpreted,+ ModuleImport(..), ModuleQualification(..), ImportList(..), loadModules, getLoadedModules, setTopLevelModules,- setImports, setImportsQ,+ setImports, setImportsQ, setImportsF, reset, -- ** Module querying ModuleElem(..), Id, name, children,@@ -34,14 +24,16 @@ -- pragmas inline in the code since GHC scarfs them up. getModuleAnnotations, getValAnnotations, -- ** Type inference- typeOf, typeChecks, kindOf,+ typeChecksWithDetails,+ typeOf, typeChecks, kindOf, normalizeType, -- ** Evaluation- interpret, as, infer, eval,+ interpret, as, infer, eval, runStmt, -- * Error handling InterpreterError(..), GhcError(..), MultipleInstancesNotAllowed(..), -- * Miscellaneous ghcVersion, parens,- module Control.Monad.Trans+ module Control.Monad.Trans.Class,+ module Control.Monad.IO.Class, ) where import Hint.Base@@ -53,4 +45,5 @@ import Hint.Typecheck import Hint.Eval -import Control.Monad.Trans+import Control.Monad.IO.Class+import Control.Monad.Trans.Class
src/Language/Haskell/Interpreter/Unsafe.hs view
@@ -3,7 +3,7 @@ unsafeInterpret ) where -import Control.Monad.Trans+import Control.Monad.IO.Class import Control.Monad.Catch import Hint.Base@@ -24,11 +24,8 @@ -- context. -- -- Warning: Some options may interact badly with the Interpreter.-unsafeRunInterpreterWithArgs :: (MonadMask m, MonadIO m-#if __GLASGOW_HASKELL__ < 800- , Functor m-#endif- ) => [String]+unsafeRunInterpreterWithArgs :: (MonadMask m, MonadIO m)+ => [String] -> InterpreterT m a -> m (Either InterpreterError a) unsafeRunInterpreterWithArgs = runInterpreterWithArgs@@ -38,12 +35,9 @@ -- containers, etc.) can be found. This allows you to run hint on -- a machine in which GHC is not installed. ----- A typical libdir value would be "/opt/ghc/7.10.3/lib/ghc-7.10.3".-unsafeRunInterpreterWithArgsLibdir :: (MonadIO m, MonadMask m-#if __GLASGOW_HASKELL__ < 800- , Functor m-#endif- ) => [String]+-- A typical libdir value could be @/usr/lib/ghc-8.0.1/ghc-8.0.1@.+unsafeRunInterpreterWithArgsLibdir :: (MonadIO m, MonadMask m)+ => [String] -> String -> InterpreterT m a -> m (Either InterpreterError a)
unit-tests/run-unit-tests.hs view
@@ -2,23 +2,37 @@ import Prelude hiding (catch) -import Control.Exception.Extensible (ArithException(..))+import Control.Exception (ArithException(..), AsyncException(UserInterrupt)) import Control.Monad.Catch as MC -import Control.Monad (liftM, when, void, (>=>))+import Control.Monad (guard, liftM, when, void, (>=>)) -import Control.Concurrent (forkIO)+import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.MVar+import Control.Concurrent.STM +import qualified Data.ByteString.Lazy as ByteString+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Data.Function ((&))+import Data.IORef+ import System.IO import System.FilePath import System.Directory+import System.Environment (getEnvironment, unsetEnv) import System.Exit+import System.Process.Typed+#if defined(mingw32_HOST_OS) || defined(__MINGW32__)+#else+import System.Posix.Signals+#endif -import Test.HUnit ((@?=), (@?))+import Test.HUnit ((@?=), (@?), assertFailure) import qualified Test.HUnit as HUnit import Language.Haskell.Interpreter+import Language.Haskell.Interpreter.Unsafe test_reload_modified :: TestCase test_reload_modified = TestCase "reload_modified" [mod_file] $ do@@ -48,10 +62,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 := []]@@ -68,7 +85,7 @@ loadModules [mod_file] setTopLevelModules ["Main"] setImportsQ [("Prelude", Nothing),- ("Data.Maybe", Just "Mb")]+ ("Data.Maybe", Just "Mb")] -- typeOf "f $ (1 + 1 :: Int)" @@?= "Int" eval "f . Mb.fromJust $ Just [1,2]" @@?= "[1,2]"@@ -104,6 +121,14 @@ typeChecks "null []" @@? "Unqual null" typeChecks "M.null M.empty" @@? "Qual null" +test_full_import :: TestCase+test_full_import = TestCase "full_import" [] $ do+ setImportsF [ ModuleImport "Prelude" (QualifiedAs Nothing) NoImportList+ , ModuleImport "Data.List" (QualifiedAs $ Just "List") $ ImportList ["null"]+ ]+ typeChecks "Prelude.null []" @@? "Qual prelude null"+ typeChecks "List.null []" @@? "Qual list null"+ test_basic_eval :: TestCase test_basic_eval = TestCase "basic_eval" [] $ eval "()" @@?= "()" @@ -184,12 +209,70 @@ 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+-- form "Could not load '*_closure', dependency unresolved". To make that error+-- less mysterious, 'ifInterpreterNotRunning' throw a clearer error earlier, as+-- soon as it detects that the user is trying to run multiple instances of hint+-- in parallel. This test ensures that this nicer error is thrown. test_only_one_instance :: TestCase test_only_one_instance = TestCase "only_one_instance" [] $ liftIO $ do r <- newEmptyMVar@@ -199,13 +282,226 @@ return $ Right () _ <- forkIO $ Control.Monad.void concurrent readMVar r @? "concurrent instance did not fail"+#else+-- 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+-- form "Could not load '*_closure', dependency unresolved". This test ensures+-- that this error no longer occurs. The important thing about this test is+-- that it should _fail_ if 'ifInterpreterNotRunning' is deleted and this test+-- 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+ writeFile mod_file "f = id" + -- ensure the two threads interleave in a deterministic way+ tvar <- newTVarIO 1+ let step n = liftIO $ atomically $ do+ nextStep <- readTVar tvar+ guard (nextStep >= n)+ writeTVar tvar (n + 1)+ skipToStep n = liftIO $ atomically $ do+ modifyTVar tvar (max n)++ mvar1 <- newEmptyMVar+ mvar2 <- newEmptyMVar+ void $ forkIO $ do+ r1 <- try $ runInterpreter $ do+ step 1+ loadModules [mod_file]+ step 3+ setTopLevelModules ["Main"]+ step 5+ setImports ["Prelude"]+ step 7+ eval "f [1,2]" @@?= "[1,2]"+ step 9+ skipToStep 9+ putMVar mvar1 r1+ void $ forkIO $ do+ r2 <- try $ runInterpreter $ do+ step 2+ loadModules [mod_file]+ step 4+ setTopLevelModules ["Main"]+ step 6+ setImports ["Prelude"]+ step 8+ eval "f [1,2]" @@?= "[1,2]"+ step 10+ skipToStep 10+ putMVar mvar2 r2+ noInterpreterError =<< noExceptions =<< takeMVar mvar1+ noInterpreterError =<< noExceptions =<< takeMVar mvar2+ where mod_file = "TEST_MultipleInstances.hs"+#endif++test_normalize_type :: TestCase+test_normalize_type = TestCase "normalize_type" [mod_file] $ do+ liftIO $ writeFile mod_file mod_text+ loadModules [mod_file]+ setTopLevelModules ["T"]+ normalizeType "Foo Int" @@?= "()"++ where mod_text = unlines ["{-# LANGUAGE TypeFamilies #-}"+ ,"module T where"+ ,"type family Foo x"+ ,"type instance Foo x = ()"]+ mod_file = "TEST_NormalizeType.hs"++test_package_db :: IOTestCase+test_package_db = IOTestCase "package_db" [dir] $ \wrapInterp -> do+ setup+ ghcVersionOutput <- readProcessStdout_ $ proc "ghc" ["--version"]+ let ghcVersion+ :: String+ ghcVersion+ = ghcVersionOutput+ -- "The Glorious Glasgow Haskell Compilation System, version 8.8.4" :: ByteString.Lazy+ & ByteString.toStrict+ -- "The Glorious Glasgow Haskell Compilation System, version 8.8.4" :: ByteString+ & Text.decodeUtf8+ -- "The Glorious Glasgow Haskell Compilation System, version 8.8.4" :: Text+ & Text.unpack+ -- "The Glorious Glasgow Haskell Compilation System, version 8.8.4" :: String+ & words+ -- ["The","Glorious","Glasgow","Haskell","Compilation","System,","version","8.8.4"]+ & last+ -- "8.8.4"+ let pkgdb = dir </> "dist-newstyle" </> "packagedb" </> ("ghc-" ++ ghcVersion)+ 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,+ -- we cannot load it.+ unsetEnv "GHC_ENVIRONMENT"++ wrapInterp (unsafeRunInterpreterWithArgs ghc_args) $ do+ succeeds (setImports [mod]) @@? "module from package-db must be visible"+ --+ 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+ ]+ writeFile mod_file $ unlines+ [ "{-# LANGUAGE NoImplicitPrelude #-}"+ , "module " ++ mod ++ " where"+ ]+ env <- getEnvironment+ 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"]++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.+--+-- note that hint was _not_ overwriting the signal handlers when the hint interpreter+-- was itself executed inside the ghci interpreter. for this reason, this test always+-- succeeds when executed from ghci and ghcid, regardless of whether the problematic+-- behaviour has been fixed or not.+test_signal_handlers :: IOTestCase+test_signal_handlers = IOTestCase "signal_handlers" [] $ \wrapInterp -> do+#if defined(mingw32_HOST_OS) || defined(__MINGW32__)+ wrapInterp runInterpreter $ do+ pure ()+#else+ signalDetectedRef <- newIORef False+ interruptDetectedRef <- newIORef False+ let detectSignal = writeIORef signalDetectedRef True+ detectInterrupt = writeIORef interruptDetectedRef True+ acquire = installHandler sigINT (Catch detectSignal) Nothing+ release handler = installHandler sigINT handler Nothing+ r <- bracket acquire release $ \_ -> do+ wrapInterp runInterpreter $ do+ liftIO $ do+ r <- try $ do+ raiseSignal sigINT+ threadDelay 1000000 -- will be interrupted by the above signal+ case r of+ Left UserInterrupt -> do+ -- hint is _still_ accidentally overwriting the signal handler :(+ detectInterrupt+ Left e -> do+ -- some other async exception, rethrow+ throwM e+ Right () ->+ return ()+ signalDetected <- readIORef signalDetectedRef+ signalDetected @?= True+ interruptDetected <- readIORef interruptDetectedRef+ interruptDetected @?= False+ return r+#endif+ tests :: [TestCase] tests = [test_reload_modified ,test_lang_exts ,test_work_in_main ,test_comments_in_expr ,test_qual_import+ ,test_full_import ,test_basic_eval ,test_eval_layout ,test_show_in_scope@@ -214,17 +510,32 @@ ,test_search_path ,test_search_path_dot ,test_catch+#ifndef THREAD_SAFE_LINKER ,test_only_one_instance+#else+ ,test_multiple_instances+#endif+ ,test_normalize_type ] +ioTests :: [IOTestCase]+ioTests = [test_signal_handlers+ ,test_package_db+ ,test_ghc_environment_file+ ]+ main :: IO () main = do -- run the tests...- c <- runTests False tests+ c1 <- runTests False tests+ c2 <- runIOTests False ioTests -- then run again, but with sandboxing on...- c' <- runTests True tests+ c3 <- runTests True tests+ c4 <- runIOTests True ioTests --- let failures = HUnit.errors c + HUnit.failures c +- HUnit.errors c' + HUnit.failures c'+ let failures = HUnit.errors c1 + HUnit.failures c1 ++ HUnit.errors c2 + HUnit.failures c2 ++ HUnit.errors c3 + HUnit.failures c3 ++ HUnit.errors c4 + HUnit.failures c4 exit_code | failures > 0 = ExitFailure failures | otherwise = ExitSuccess@@ -250,24 +561,50 @@ catchIE = MC.catch succeeds :: (MonadCatch m, MonadIO m) => m a -> m Bool-succeeds = liftM not . fails+succeeds = fmap not . fails -data TestCase = TestCase String [FilePath] (Interpreter ())+noExceptions :: Either SomeException a -> IO a+noExceptions (Left e) = assertFailure (show e)+noExceptions (Right a) = pure a -runTests :: Bool -> [TestCase] -> IO HUnit.Counts-runTests sandboxed = HUnit.runTestTT . HUnit.TestList . map build- where build (TestCase title tmps test) = HUnit.TestLabel title $- HUnit.TestCase test_case+noInterpreterError :: Either InterpreterError a -> IO a+noInterpreterError (Left e) = assertFailure (show e)+noInterpreterError (Right a) = pure a++data IOTestCase = IOTestCase+ String -- test name+ [FilePath] -- temporary files and folders to delete after the test+ ( ( (Interpreter () -> IO (Either InterpreterError ()))+ -> (Interpreter () -> IO (Either InterpreterError ()))+ ) -- please wrap your 'runInterpreter' calls with this+ -> IO (Either InterpreterError ()) -- create temporary files and run the test+ )++runIOTests :: Bool -> [IOTestCase] -> IO HUnit.Counts+runIOTests sandboxed = HUnit.runTestTT . HUnit.TestList . map build+ where build (IOTestCase title tmps test)+ = HUnit.TestLabel title $ HUnit.TestCase test_case where test_case = go `finally` clean_up clean_up = mapM_ removeIfExists tmps- go = do r <- runInterpreter- (when sandboxed setSandbox >> test)- either (printInterpreterError >=> (fail . show))- return r+ wrapInterp runInterp body = runInterp (when sandboxed setSandbox >> body)+ go = do r <- test wrapInterp+ noInterpreterError r removeIfExists f = do existsF <- doesFileExist f if existsF then removeFile f else do existsD <- doesDirectoryExist f when existsD $- removeDirectory f+ removeDirectoryRecursive f++data TestCase = TestCase+ String -- test name+ [FilePath] -- temporary files and folders to delete after the test+ (Interpreter ()) -- create temporary files and run the test++runTests :: Bool -> [TestCase] -> IO HUnit.Counts+runTests sandboxed = runIOTests sandboxed . map toIOTestCase+ where+ toIOTestCase :: TestCase -> IOTestCase+ toIOTestCase (TestCase title tmps test) = IOTestCase title tmps $ \wrapInterp -> do+ wrapInterp runInterpreter test