diff --git a/AUTHORS b/AUTHORS --- a/AUTHORS +++ b/AUTHORS @@ -2,8 +2,10 @@ Austin Seipp Bertram Felgenhauer +Brandon Chinn Bryan O'Sullivan Carl Howells +Christiaan Baaij Conrad Parker Corentin Dupont Daniel Gorin @@ -12,6 +14,7 @@ Evan Laforge Fernando Benavides Gwern Branwen +Heinrich Apfelmus Jean Philippe Bernardy Jens Petersen Mark Wright diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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.hs` instead of `` + - 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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,17 +1,109 @@ -# hint +# hint [![Hackage](https://img.shields.io/hackage/v/hint.svg)](https://hackage.haskell.org/package/hint) [![Build Status](https://github.com/haskell-hint/hint/workflows/CI/badge.svg)](https://github.com/haskell-hint/hint/actions) -[![Build Status](https://travis-ci.org/mvdan/hint.svg?branch=master)](https://travis-ci.org/mvdan/hint) -[![Hackage](https://img.shields.io/hackage/v/hint.svg)](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.` in the current +directory. At runtime, hint will look for that file in the current directory. + +For more advanced use cases, you can use +[`unsafeRunInterpreterWithArgs`](https://hackage.haskell.org/package/hint/docs/Language-Haskell-Interpreter-Unsafe.html#v:unsafeRunInterpreterWithArgs) +to pass arguments to the underlying ghc library, such as +[`-package-db`](https://downloads.haskell.org/~ghc/latest/docs/users_guide/packages.html?highlight=package%20db#ghc-flag--package-db%20%E2%9F%A8file%E2%9F%A9) +to specify a path to a package database, or +[`-package-env`](https://downloads.haskell.org/~ghc/latest/docs/users_guide/packages.html?highlight=package%20db#ghc-flag--package-env%20%E2%9F%A8file%E2%9F%A9%7C%E2%9F%A8name%E2%9F%A9) +to specify a path to a GHC environment file. + diff --git a/examples/example.hs b/examples/example.hs --- a/examples/example.hs +++ b/examples/example.hs @@ -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 diff --git a/hint.cabal b/hint.cabal --- a/hint.cabal +++ b/hint.cabal @@ -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" +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 diff --git a/src/Control/Monad/Ghc.hs b/src/Control/Monad/Ghc.hs --- a/src/Control/Monad/Ghc.hs +++ b/src/Control/Monad/Ghc.hs @@ -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 diff --git a/src/Hint/Annotations.hs b/src/Hint/Annotations.hs --- a/src/Hint/Annotations.hs +++ b/src/Hint/Annotations.hs @@ -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 diff --git a/src/Hint/Base.hs b/src/Hint/Base.hs --- a/src/Hint/Base.hs +++ b/src/Hint/Base.hs @@ -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 diff --git a/src/Hint/Compat.hs b/src/Hint/Compat.hs deleted file mode 100644 --- a/src/Hint/Compat.hs +++ /dev/null @@ -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 diff --git a/src/Hint/Configuration.hs b/src/Hint/Configuration.hs --- a/src/Hint/Configuration.hs +++ b/src/Hint/Configuration.hs @@ -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) diff --git a/src/Hint/Context.hs b/src/Hint/Context.hs --- a/src/Hint/Context.hs +++ b/src/Hint/Context.hs @@ -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 diff --git a/src/Hint/Conversions.hs b/src/Hint/Conversions.hs --- a/src/Hint/Conversions.hs +++ b/src/Hint/Conversions.hs @@ -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 -------------------------- diff --git a/src/Hint/Eval.hs b/src/Hint/Eval.hs --- a/src/Hint/Eval.hs +++ b/src/Hint/Eval.hs @@ -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, ")"] diff --git a/src/Hint/Extension.hs b/src/Hint/Extension.hs --- a/src/Hint/Extension.hs +++ b/src/Hint/Extension.hs @@ -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 ] diff --git a/src/Hint/GHC.hs b/src/Hint/GHC.hs --- a/src/Hint/GHC.hs +++ b/src/Hint/GHC.hs @@ -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 diff --git a/src/Hint/Internal.hs b/src/Hint/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Hint/Internal.hs @@ -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) diff --git a/src/Hint/InterpreterT.hs b/src/Hint/InterpreterT.hs --- a/src/Hint/InterpreterT.hs +++ b/src/Hint/InterpreterT.hs @@ -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 diff --git a/src/Hint/Parsers.hs b/src/Hint/Parsers.hs --- a/src/Hint/Parsers.hs +++ b/src/Hint/Parsers.hs @@ -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 "") 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 diff --git a/src/Hint/Reflection.hs b/src/Hint/Reflection.hs --- a/src/Hint/Reflection.hs +++ b/src/Hint/Reflection.hs @@ -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 diff --git a/src/Hint/Typecheck.hs b/src/Hint/Typecheck.hs --- a/src/Hint/Typecheck.hs +++ b/src/Hint/Typecheck.hs @@ -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) diff --git a/src/Language/Haskell/Interpreter.hs b/src/Language/Haskell/Interpreter.hs --- a/src/Language/Haskell/Interpreter.hs +++ b/src/Language/Haskell/Interpreter.hs @@ -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 diff --git a/src/Language/Haskell/Interpreter/Unsafe.hs b/src/Language/Haskell/Interpreter/Unsafe.hs --- a/src/Language/Haskell/Interpreter/Unsafe.hs +++ b/src/Language/Haskell/Interpreter/Unsafe.hs @@ -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) diff --git a/unit-tests/run-unit-tests.hs b/unit-tests/run-unit-tests.hs --- a/unit-tests/run-unit-tests.hs +++ b/unit-tests/run-unit-tests.hs @@ -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. 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