hint-0.9.0.7/0000755000000000000000000000000007346545000011020 5ustar0000000000000000hint-0.9.0.7/AUTHORS0000644000000000000000000000070207346545000012067 0ustar0000000000000000# Please keep the list sorted. Austin Seipp Bertram Felgenhauer Brandon Chinn Bryan O'Sullivan Carl Howells Christiaan Baaij Conrad Parker Corentin Dupont Daniel Gorin Daniel Martí Daniel Wagner Evan Laforge Fernando Benavides Gwern Branwen Heinrich Apfelmus Jean Philippe Bernardy Jens Petersen Mark Wright Nathaniel W. Filardo Pasqualino Titto Assini Rob Zinkov Samuel Gélineau Sid Kapur hint-0.9.0.7/CHANGELOG.md0000644000000000000000000001313607346545000012635 0ustar0000000000000000### 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 * Add `displayException` to InterpreterError ### 0.5.2 * Add `runInterpreter` variant that takes a GHC libdir at runtime * Add missing negated extensions to the `Extension` type * Do not throw GHC warnings as errors ### 0.5.1 * Expose `unsafeInterpret` in `Language.Haskell.Interpreter.Unsafe` ### 0.5.0 * Drop support for GHC 7.4 * Remove deprecated functions and modules: - `glasgowExtensions` - `setUseLanguageExtensions` - `setInstalledModsAreInScopeQualified` - `Language.Haskell.Interpreter.GHC` - `Language.Haskell.Interpreter.GHC.Unsafe` * Drop dependencies on `ghc-mtl` and `extensible-exceptions` ### 0.4.3 * New maintainer and source code repo ### 0.4.2.3 * It builds against 7.4.2 (not 7.4.1), so update the constraints. ### 0.4.2.2 * Builds with GHC 7.10 * Builds again with GHC 7.4 * Drops dependency on `utf8-string` ### 0.4.2.1 * Better error reporting (thanks to Corentin Dupont) ### 0.4.2.0 * Based on exceptions-0.6 ### 0.4.1.0 * Based on exceptions-0.4 ### 0.4.0.0 * Compiles with GHC 7.8 * Fixed an issue where `P` was available as a qualified version of Prelude (thanks to Samuel Gélineau) * Uses `exceptions` package instead of `MonadCatchIO-mtl` (API breakage expected) * No longer depends on `haskell-src` * Changelog should now appear in Hackage * Integrated unit tests with cabal ### 0.3.3.7 * Fixed a race condition that would happen, for instance, when two process where run one next to the other, making them, on some platforms, to get the same random number seed (thanks to Mario Pastorelli and Samuel Gélineau) * Small fix in documentation (thanks to Daniil Frumin) ### 0.3.3.6 * Works again on GHC 7.2.x (thanks to Björn Peemöller) ### 0.3.3.5 * Works on GHC 7.4.6 * Cleans up files for phantom modules that were left behind (thanks to Beltram Felgenhauer) ### 0.3.3.4 * Works on GHC 7.4.1 ### 0.3.3.3 * Works on GHC 7.2.1 ### 0.3.3.2 * Supports GHC 7 ### 0.3.3.1 * Instance declaration for Applicative (InterpreterT m) works with mtl-2 (requires Applicative m, this shouldn't break anything...) ### 0.3.3.0 * Add unsafeRunInterpreterWithArgs * Check that only one instance of the interpreter is run at any time ### 0.3.2.3 * Can be built against MonadCatchIO-mtl-0.3.x.x ### 0.3.2.2 * Fixed a bug that would make expressions using heavy use of the layout rule to fail to be interpreted (see parens) ### 0.3.2.1 * hint.cabal includes version bounds for package ghc-mtl. This is to avoid the accidental selection of the completely unrelated ghc-mtl internal to GHC and, apparently, installed in the hackage server ### 0.3.2.0 * Exports functions parens and isInterpretedModule * Experimental support for module annotations * Uses extensible-exceptions in order to provide a uniform interface across different ghc versions * Provides an Applicative instance for IntepreterT * Adds an option to configurate the searchPath ### 0.3.1.0 * No longer uses Language.Haskell.Extension due to configuration problems with Cabal. Instead, it uses its own Language.Haskell.Interpreter.Extension module. ### 0.3.0.0 * Updated API: + InterpreterT monad transformer (Interpreter = InterpreterT IO) + No more Sessions, use runInterpreter only once + New options handling functions - but observe that there is no setOptimizations equivalent; since GHC does no optimization on interpreted code, this was actually doing nothing * Works with GHC 6.10 and 6.8 (untested with 6.6) ### 0.2.5 * setImportsQ added (modules can be imported both qualified and unqualified) ### 0.2.4.1 * BUGFIX: No longer fails on expressions ending in a -- comment ### 0.2.4 * setInstalledModsAreInScopeQualified added * Now depends on ghc-paths (no longer needs a custom cabal script) ### 0.2.2 * setOptimizations added * Module Language.Haskell.Interpreter.GHC.Unsafe added (contains unsafeSetGhcOption) * Unit tests now based on HUnit ### 0.2.1 * BUGFIX: Module reloading was broken under 6.8 * GHC.GhcExceptions are catched and turned into InterpreterErrors ### 0.2.0.1 * Adds the requirement cabal-version < 1.3 ### 0.2 * Works also with GHC 6.8 and 6.6 * Added the getModuleExports function * withSession function throws a dynamic exception instead of returning Either Error a * Requires Cabal 1.2.x hint-0.9.0.7/LICENSE0000644000000000000000000000272207346545000012030 0ustar0000000000000000Copyright (c) 2007 The Hint Authors. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. hint-0.9.0.7/README.md0000644000000000000000000001207407346545000012303 0ustar0000000000000000# 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) 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. 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. ## Example {-# 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 -- | -- 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. hint-0.9.0.7/Setup.hs0000644000000000000000000000005607346545000012455 0ustar0000000000000000import Distribution.Simple main = defaultMain hint-0.9.0.7/examples/0000755000000000000000000000000007346545000012636 5ustar0000000000000000hint-0.9.0.7/examples/SomeModule.hs0000644000000000000000000000007107346545000015241 0ustar0000000000000000module SomeModule(g, h) where f = head g = f [f] h = fhint-0.9.0.7/examples/example.hs0000644000000000000000000000540707346545000014633 0ustar0000000000000000import Data.List import Control.Monad import Language.Haskell.Interpreter import System.Directory main :: IO () main = do setCurrentDirectory "examples" r <- runInterpreter testHint case r of Left err -> putStrLn $ errorString err Right () -> return () errorString :: InterpreterError -> String errorString (WontCompile es) = intercalate "\n" (header : map unbox es) where header = "ERROR: Won't compile:" unbox (GhcError e) = e errorString e = show e say :: String -> Interpreter () say = liftIO . putStrLn emptyLine :: Interpreter () emptyLine = say "" -- observe that Interpreter () is an alias for InterpreterT IO () testHint :: Interpreter () testHint = do say "Load SomeModule.hs" loadModules ["SomeModule.hs"] emptyLine say "Put the Prelude, Data.Map and *SomeModule in scope" say "Data.Map is qualified as M!" setTopLevelModules ["SomeModule"] setImportsQ [("Prelude", Nothing), ("Data.Map", Just "M")] emptyLine say "Now we can query the type of an expression" let expr1 = "M.singleton (f, g, h, 42)" say $ "e.g. typeOf " ++ expr1 say =<< typeOf expr1 emptyLine say $ "Observe that f, g and h are defined in SomeModule.hs, " ++ "but f is not exported. Let's check it..." exports <- getModuleExports "SomeModule" say $ show exports emptyLine say "We can also evaluate an expression; the result will be a string" let expr2 = "length $ concat [[f,g],[h]]" say $ "e.g. eval " ++ show expr2 a <- eval expr2 say $ show a emptyLine say "Or we can interpret it as a proper, say, int value!" a_int <- interpret expr2 (as :: Int) say $ show a_int emptyLine say "This works for any monomorphic type, even for function types" let expr3 = "\\(Just x) -> succ x" say $ "e.g. we interpret " ++ expr3 ++ " with type Maybe Int -> Int and apply it on Just 7" fun <- interpret expr3 (as :: Maybe Int -> Int) say $ show $ fun (Just 7) emptyLine say "And sometimes we can even use the type system to infer the expected type (eg Maybe Bool -> Bool)!" bool_val <- interpret expr3 infer `ap` return (Just False) say $ show $ not bool_val emptyLine say "Here we evaluate an expression of type string, that when evaluated (again) leads to a string" res <- do s <- interpret "head $ map show [\"Worked!\", \"Didn't work\"]" infer interpret s infer say res emptyLine say "We can also execute statements in the IO monad and bind new names, e.g." let stmts = ["x <- return 42", "print x"] forM_ stmts $ \s -> do say $ " " ++ s runStmt s emptyLine hint-0.9.0.7/hint.cabal0000644000000000000000000000671207346545000012754 0ustar0000000000000000name: hint version: 0.9.0.7 description: This library defines an Interpreter monad. It allows to load Haskell modules, browse them, type-check and evaluate strings with Haskell expressions and even coerce them into values. The library is thread-safe and type-safe (even the coercion of expressions to values). It is, essentially, a huge subset of the GHC API wrapped in a simpler API. 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: "Samuel Gélineau" homepage: https://github.com/haskell-hint/hint tested-with: ghc == 8.10.7 , ghc == 8.6.5 , ghc == 8.8.4 , ghc == 9.0.2 , ghc == 9.2.7 , ghc == 9.4.5 , ghc == 9.6.1 cabal-version: >= 1.10 build-type: Simple extra-source-files: README.md AUTHORS CHANGELOG.md examples/example.hs examples/SomeModule.hs source-repository head type: git location: https://github.com/haskell-hint/hint 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, exceptions >= 0.10.0, stm, text, typed-process, -- 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.*, containers, ghc >= 8.4 && < 9.7, ghc-paths, ghc-boot, transformers, filepath, exceptions == 0.10.*, random, directory, temporary if impl(ghc >= 8.10) { cpp-options: -DTHREAD_SAFE_LINKER } if !os(windows) { build-depends: unix >= 2.2.0.0 } exposed-modules: Language.Haskell.Interpreter Language.Haskell.Interpreter.Extension Language.Haskell.Interpreter.Unsafe Hint.Internal other-modules: Hint.GHC Hint.Base Hint.InterpreterT Hint.CompatPlatform Hint.Configuration Hint.Extension Hint.Context Hint.Conversions Hint.Eval Hint.Parsers Hint.Reflection Hint.Typecheck Hint.Util Hint.Annotations Control.Monad.Ghc hs-source-dirs: src ghc-options: -Wall default-extensions: CPP GeneralizedNewtypeDeriving DeriveDataTypeable MagicHash FunctionalDependencies Rank2Types ScopedTypeVariables ExistentialQuantification LambdaCase hint-0.9.0.7/src/Control/Monad/0000755000000000000000000000000007346545000014265 5ustar0000000000000000hint-0.9.0.7/src/Control/Monad/Ghc.hs0000644000000000000000000001077107346545000015330 0ustar0000000000000000module Control.Monad.Ghc ( GhcT, runGhcT ) where import Control.Applicative import Prelude import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Catch 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 (<*>) = ap -- 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 runGhcT f = unMTLA . rawRunGhcT f . unGhcT instance MonadTrans GhcT where lift = GhcT . GHC.liftGhcT . MTLAdapter instance MonadIO m => MonadIO (GhcT m) where liftIO = GhcT . GHC.liftIO 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 -> mask $ \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) 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 = 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 -- | We use the 'MTLAdapter' to convert between similar classes -- like 'MTL'''s 'MonadIO' and 'GHC'''s 'MonadIO'. newtype MTLAdapter m a = MTLAdapter {unMTLA :: m a} deriving (Functor, Applicative, Monad) 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 hint-0.9.0.7/src/Hint/0000755000000000000000000000000007346545000012511 5ustar0000000000000000hint-0.9.0.7/src/Hint/Annotations.hs0000644000000000000000000000242407346545000015344 0ustar0000000000000000module Hint.Annotations ( getModuleAnnotations, getValAnnotations ) where import Data.Data import GHC.Serialized import Hint.Base 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 <- GHC.mgModSummaries . hsc_mod_graph <$> runGhc GHC.getSession let x' = filter ((==) x . GHC.moduleNameString . GHC.moduleName . ms_mod) mods concatMapM (anns . ModuleTarget . ms_mod) x' -- Get the annotations associated with a particular function. getValAnnotations :: (Data a, MonadInterpreter m) => a -> String -> m [a] getValAnnotations _ s = do names <- runGhc $ GHC.parseName s concatMapM (anns . NamedTarget) names anns :: (MonadInterpreter m, Data a) => AnnTarget GHC.Name -> m [a] anns target = runGhc $ GHC.findGlobalAnns deserializeWithData target hint-0.9.0.7/src/Hint/Base.hs0000644000000000000000000001514507346545000013725 0ustar0000000000000000module Hint.Base ( MonadInterpreter(..), RunGhc, GhcError(..), InterpreterError(..), mayFail, catchIE, InterpreterSession, SessionData(..), InterpreterState(..), fromState, onState, InterpreterConfiguration(..), ImportList(..), ModuleQualification(..), ModuleImport(..), ModuleName, PhantomModule(..), findModule, moduleIsLoaded, withDynFlags, ghcVersion, debug, showGHC ) where 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 import Hint.Extension -- | Version of the underlying ghc api. Values are: -- -- * @804@ for GHC 8.4.x -- -- * @806@ for GHC 8.6.x -- -- * etc... ghcVersion :: Int ghcVersion = __GLASGOW_HASKELL__ class (MonadIO m, MonadMask m) => MonadInterpreter m where fromSession :: FromSession m a modifySessionRef :: ModifySessionRef m a runGhc :: RunGhc m a -- this is for hiding the actual types in haddock type FromSession m a = (InterpreterSession -> a) -> m a type ModifySessionRef m a = (InterpreterSession -> IORef a) -> (a -> a) -> m a data InterpreterError = UnknownError String | WontCompile [GhcError] | NotAllowed String -- | GhcExceptions from the underlying GHC API are caught -- and rethrown as this. | GhcException String deriving (Show, Typeable) data InterpreterState = St { activePhantoms :: [PhantomModule], zombiePhantoms :: [PhantomModule], phantomDirectory :: Maybe FilePath, hintSupportModule :: PhantomModule, importQualHackMod :: Maybe PhantomModule, 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], allModsInScope :: Bool } type InterpreterSession = SessionData () instance Exception InterpreterError 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 type RunGhc m a = (forall n.(MonadIO n, MonadMask n) => GHC.GhcT n a) -> m a data SessionData a = SessionData { internalState :: IORef InterpreterState, versionSpecific :: a, ghcErrListRef :: IORef [GhcError], ghcLogger :: GHC.Logger } -- When intercepting errors reported by GHC, we only get a ErrUtils.Message -- and a SrcLoc.SrcSpan. The latter holds the file name and the location -- of the error. However, SrcSpan is abstract and it doesn't provide -- functions to retrieve the line and column of the error... we can only -- generate a string with this information. Maybe I can parse this string -- later.... (sigh) newtype GhcError = GhcError{errMsg :: String} deriving Show mapGhcExceptions :: MonadInterpreter m => (String -> InterpreterError) -> m a -> m a mapGhcExceptions buildEx action = action `MC.catch` (\err -> case err of GhcException s -> throwM (buildEx s) _ -> throwM err) catchIE :: MonadInterpreter m => m a -> (InterpreterError -> m a) -> m a catchIE = MC.catch -- | Module names are _not_ filepaths. type ModuleName = String -- ================ Handling the interpreter state ================= fromState :: MonadInterpreter m => (InterpreterState -> a) -> m a fromState f = do ref_st <- fromSession internalState liftIO $ f <$> readIORef ref_st onState :: MonadInterpreter m => (InterpreterState -> InterpreterState) -> m () onState f = () <$ modifySessionRef internalState f -- =============== Error handling ============================== mayFail :: MonadInterpreter m => m (Maybe a) -> m a mayFail action = do maybe_res <- action -- es <- modifySessionRef ghcErrListRef (const []) -- case (maybe_res, null es) of (Nothing, True) -> throwM $ UnknownError "Got no error message" (Nothing, False) -> throwM $ WontCompile (reverse es) (Just a, _) -> return a -- ================= Debugging stuff =============== debug :: MonadInterpreter m => String -> m () debug = liftIO . putStrLn . ("!! " ++) showGHC :: (MonadInterpreter m, GHC.Outputable a) => a -> m String showGHC a = do unqual <- runGhc GHC.getPrintUnqual withDynFlags $ \df -> -- TODO: get unit state from somewhere? return $ GHC.showSDocForUser df GHC.emptyUnitState unqual (GHC.ppr a) -- ================ Misc =================================== -- this type ought to go in Hint.Context, but ghc dislikes cyclic imports... data PhantomModule = PhantomModule{pmName :: ModuleName, pmFile :: FilePath} deriving (Eq, Show) findModule :: MonadInterpreter m => ModuleName -> m GHC.Module findModule mn = mapGhcExceptions NotAllowed $ runGhc $ GHC.findModule mod_name Nothing where mod_name = GHC.mkModuleName mn moduleIsLoaded :: MonadInterpreter m => ModuleName -> m Bool moduleIsLoaded mn = (True <$ findModule mn) `catchIE` (\e -> case e of 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 hint-0.9.0.7/src/Hint/CompatPlatform.hs0000644000000000000000000000143307346545000015776 0ustar0000000000000000#if defined(mingw32_HOST_OS) || defined(__MINGW32__) {-# LANGUAGE ForeignFunctionInterface #-} #endif module Hint.CompatPlatform ( getPID ) where import Control.Applicative import Prelude #if defined(mingw32_HOST_OS) || defined(__MINGW32__) import Data.Word #else import System.Posix.Process #endif getPID :: IO Int #if defined(mingw32_HOST_OS) || defined(__MINGW32__) -- This function is not yet in the win32 package, so we have to -- roll down our own definition. -- -- Credit goes where it is deserved: -- http://www.haskell.org/pipermail/haskell-cafe/2009-February/055097.html foreign import stdcall unsafe "winbase.h GetCurrentProcessId" c_GetCurrentProcessId :: IO Word32 getPID = fromIntegral <$> c_GetCurrentProcessId #else getPID = fromIntegral <$> getProcessID #endif hint-0.9.0.7/src/Hint/Configuration.hs0000644000000000000000000001254607346545000015664 0ustar0000000000000000module Hint.Configuration ( setGhcOption, setGhcOptions, defaultConf, get, set, Option, OptionVal(..), languageExtensions, availableExtensions, Extension(..), installedModulesInScope, 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 Hint.Base import Hint.Util (quote) import Hint.Extension setGhcOptions :: MonadInterpreter m => [String] -> m () setGhcOptions opts = do old_flags <- runGhc GHC.getSessionDynFlags 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"] _ <- runGhc $ GHC.setSessionDynFlags new_flags return () setGhcOption :: MonadInterpreter m => String -> m () setGhcOption opt = setGhcOptions [opt] defaultConf :: InterpreterConfiguration defaultConf = Conf { languageExts = [], allModsInScope = False, searchFilePath = ["."] } -- | Available options are: -- -- * 'languageExtensions' -- -- * 'installedModulesInScope' -- -- * 'searchPath' data Option m a = Option{ _set :: MonadInterpreter m => a -> m (), _get :: MonadInterpreter m => m a } data OptionVal m = forall a . (Option m a) := a -- | Use this function to set or modify the value of any option. It is -- invoked like this: -- -- @set [opt1 := val1, opt2 := val2,... optk := valk]@ set :: MonadInterpreter m => [OptionVal m] -> m () set = mapM_ $ \(opt := val) -> _set opt val -- | Retrieves the value of an option. get :: MonadInterpreter m => Option m a -> m a get = \o -> _get o -- | Language extensions in use by the interpreter. -- -- Default is: @[]@ (i.e. none, pure Haskell 98) languageExtensions :: MonadInterpreter m => Option m [Extension] languageExtensions = Option setter getter where setter es = do resetExtensions setGhcOptions $ map (extFlag True) es onConf $ \c -> c{languageExts = es} -- getter = fromConf languageExts -- resetExtensions = do es <- fromState defaultExts setGhcOptions $ uncurry (flip extFlag) <$> es extFlag :: Bool -> Extension -> String extFlag = mkFlag where mkFlag b (UnknownExtension o) = strToFlag b o mkFlag b o = strToFlag b (show o) -- strToFlag b o@('N':'o':(c:_)) | isUpper c = "-X" ++ drop (if b then 0 else 2) o strToFlag b o = "-X" ++ concat ["No"|not b] ++ o -- | When set to @True@, every module in every available package is implicitly -- imported qualified. This is very convenient for interactive -- evaluation, but can be a problem in sandboxed environments -- (e.g. 'System.Unsafe.unsafePerformIO' is in scope). -- -- Default value is @True@. -- -- Observe that due to limitations in the GHC-API, when set to @False@, the -- private symbols in interpreted modules will not be in scope. installedModulesInScope :: MonadInterpreter m => Option m Bool installedModulesInScope = Option setter getter where getter = fromConf allModsInScope setter b = do onConf $ \c -> c{allModsInScope = b} setGhcOption $ "-f" ++ concat ["no-" | not b] ++ "implicit-import-qualified" -- | The search path for source files. Observe that every time it is set, -- it overrides the previous search path. The default is @[\".\"]@. -- -- Keep in mind that by a limitation in ghc, @\".\"@ is always in scope. searchPath :: MonadInterpreter m => Option m [FilePath] searchPath = Option setter getter where getter = fromConf searchFilePath setter p = do onConf $ \c -> c{searchFilePath = p} 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) onConf :: MonadInterpreter m => (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) hint-0.9.0.7/src/Hint/Context.hs0000644000000000000000000004635707346545000014510 0ustar0000000000000000module Hint.Context ( isModuleInterpreted, loadModules, getLoadedModules, setTopLevelModules, setImports, setImportsQ, setImportsF, reset, PhantomModule(..), cleanPhantomModules, supportString, supportShow ) where import Prelude hiding (mod) import Data.Char import Data.Either (partitionEithers) import Data.List import Control.Arrow ((***)) 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.CompatPlatform as Compat import qualified Hint.GHC as GHC import System.Random import System.FilePath import System.Directory import Data.Maybe (maybe) import Hint.Configuration (setGhcOption) import System.IO.Temp type ModuleText = String -- When creating a phantom module we have a situation similar to that of -- @Hint.Util.safeBndFor@: we want to avoid picking a module name that is -- already in-scope. Additionally, since this may be used with sandboxing in -- mind we want to avoid easy-to-guess names. Thus, we do a trick similar -- to the one in safeBndFor, but including a random number instead of an -- additional digit. Finally, to avoid clashes between two processes -- that are concurrently running with the same random seed (e.g., initialized -- with the system time with not enough resolution), we also include the process id newPhantomModule :: MonadInterpreter m => m PhantomModule newPhantomModule = do n <- liftIO randomIO p <- liftIO Compat.getPID (ls,is) <- allModulesInContext let nums = concat [show (abs n::Int), show p, filter isDigit $ concat (ls ++ is)] let mod_name = 'M':nums -- tmp_dir <- getPhantomDirectory -- 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.GhcPs]) getContext = do ctx <- GHC.getContext foldM f ([], []) ctx where f :: (GHC.GhcMonad m) => ([GHC.Module], [GHC.ImportDecl GHC.GhcPs]) -> GHC.InteractiveImport -> m ([GHC.Module], [GHC.ImportDecl GHC.GhcPs]) f (ns, ds) i = case i of (GHC.IIDecl d) -> return (ns, d : ds) (GHC.IIModule m) -> do n <- GHC.findModule m Nothing; return (n : ns, ds) modToIIMod :: GHC.Module -> GHC.InteractiveImport modToIIMod = GHC.IIModule . GHC.moduleName 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.GhcPs] -> m () setContext ms ds = let ms' = map modToIIMod ms ds' = map GHC.IIDecl ds is = ms' ++ ds' in GHC.setContext is -- Explicitly-typed variants of getContext/setContext, for use where we modify -- or override the context. setContextModules :: GHC.GhcMonad m => [GHC.Module] -> [GHC.Module] -> m () setContextModules as = setContext as . map (GHC.simpleImportDecl . GHC.moduleName) addPhantomModule :: MonadInterpreter m => (ModuleName -> ModuleText) -> m PhantomModule addPhantomModule mod_text = do pm <- newPhantomModule df <- runGhc GHC.getSessionDynFlags let t = GHC.fileTarget df (pmFile pm) m = GHC.mkModuleName (pmName pm) -- liftIO $ writeFile (pmFile pm) (mod_text $ pmName pm) -- onState (\s -> s{activePhantoms = pm:activePhantoms s}) mayFail (do -- GHC.load will remove all the modules from -- scope, so first we save the context... (old_top, old_imps) <- runGhc getContext -- runGhc $ GHC.addTarget t res <- runGhc $ GHC.load GHC.LoadAllTargets -- if isSucceeded res then do runGhc $ setContext old_top old_imps return $ Just () else return Nothing) `catchIE` (\err -> case err of WontCompile _ -> do removePhantomModule pm throwM err _ -> throwM err) -- return pm 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 -- user didn't require that (they may be in a non-compiling state!). -- However, this means that we can't actually delete the file, because -- it is an active target. Therefore, we simply take it out of scope -- and mark it as "delete me when possible" (i.e., next time the -- @loadModules@ function is called). -- isLoaded <- moduleIsLoaded $ pmName pm safeToRemove <- if isLoaded then do -- take it out of scope mod <- findModule (pmName pm) (mods, imps) <- runGhc getContext let mods' = filter (mod /=) mods runGhc $ setContext mods' imps -- 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 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 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 getPhantomModules :: MonadInterpreter m => m ([PhantomModule], [PhantomModule]) getPhantomModules = do active <- fromState activePhantoms zombie <- fromState zombiePhantoms return (active, zombie) isPhantomModule :: MonadInterpreter m => ModuleName -> m Bool isPhantomModule mn = do (as,zs) <- getPhantomModules return $ mn `elem` map pmName (as ++ zs) -- | 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. 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. -- -- /IMPORTANT/: Like in a ghci session, this will also load (and interpret) -- any dependency that is not available via an installed package. Make -- sure that you are not loading any module that is also being used to -- compile your application. In particular, you need to avoid modules -- that define types that will later occur in an expression that you will -- want to interpret. -- -- The problem in doing this is that those types will have two incompatible -- representations at runtime: 1) the one in the compiled code and 2) the -- one in the interpreted code. When interpreting such an expression (bringing -- it to program-code) you will likely get a segmentation fault, since the -- latter representation will be used where the program assumes the former. -- -- The rule of thumb is: never make the interpreter run on the directory -- with the source code of your program! If you want your interpreted code to -- use some type that is defined in your program, then put the defining module -- on a library and make your program depend on that package. loadModules :: MonadInterpreter m => [String] -> m () loadModules fs = do -- first, unload everything, and do some clean-up reset doLoad fs `catchIE` (\e -> reset >> throwM e) doLoad :: MonadInterpreter m => [String] -> m () 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 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 <$> 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 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. -- -- Modules must be interpreted to use this function. setTopLevelModules :: MonadInterpreter m => [ModuleName] -> m () setTopLevelModules ms = do loaded_mods_ghc <- getLoadedModSummaries -- let not_loaded = ms \\ map modNameFromSummary loaded_mods_ghc unless (null not_loaded) $ throwM $ NotAllowed ("These modules have not been loaded:\n" ++ unlines not_loaded) -- active_pms <- fromState activePhantoms ms_mods <- mapM findModule (nub $ ms ++ map pmName active_pms) -- 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 runGhc $ setContext ms_mods old_imports -- | Sets the modules whose exports must be in context. These can be modules -- previously loaded with 'loadModules', or modules from packages which hint is -- aware of. This includes package databases specified to -- 'unsafeRunInterpreterWithArgs' by the @-package-db=...@ parameter, and -- packages specified by a ghc environment file created by @cabal build --write-ghc-environment-files=always@. -- -- Warning: 'setImports', 'setImportsQ', and 'setImportsF' are mutually exclusive. -- If you have a list of modules to be used qualified and another list -- unqualified, then you need to do something like -- -- > setImportsQ ((zip unqualified $ repeat Nothing) ++ qualifieds) setImports :: MonadInterpreter m => [ModuleName] -> m () setImports ms = setImportsF $ map (\m -> ModuleImport m NotQualified NoImportList) ms -- | 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 = 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 -- 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 -- 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 = phantom_mods ++ old_top_level runGhc $ setContextModules new_top_level regularMods -- 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 -- is to clean up all temporary files generated for phantom modules. cleanPhantomModules :: MonadInterpreter m => m () cleanPhantomModules = do -- Remove all modules from context runGhc $ setContext [] [] -- -- Unload all previously loaded modules 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. -- Should we do any of these? -- -- liftIO $ rts_revertCAFs -- -- We now remove every phantom module and forget about qual imports old_active <- fromState activePhantoms old_zombie <- fromState zombiePhantoms onState (\s -> s{activePhantoms = [], zombiePhantoms = [], importQualHackMod = Nothing, 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 -- context after a reset. reset :: MonadInterpreter m => m () reset = do -- clean up context cleanPhantomModules -- -- Now, install a support module installSupportModule [] -- Load a phantom module with all the symbols from the prelude we need 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 ++ "( ", " " ++ _String ++ ",", " " ++ _show ++ ")", "where", "", "import qualified Prelude as " ++ _P ++ " (String, Show(show))", "", "type " ++ _String ++ " = " ++ _P ++ ".String", "", _show ++ " :: " ++ _P ++ ".Show a => a -> " ++ _P ++ ".String", _show ++ " = " ++ _P ++ ".show" ] where _String = altStringName m _show = altShowName m _P = altPreludeName m -- 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 :: [GHC.Target] -> MonadInterpreter m => m () reinstallSupportModule ts = do pm <- fromState hintSupportModule removePhantomModule pm installSupportModule ts altStringName :: ModuleName -> String altStringName mod_name = "String_" ++ mod_name altShowName :: ModuleName -> String altShowName mod_name = "show_" ++ mod_name altPreludeName :: ModuleName -> String altPreludeName mod_name = "Prelude_" ++ mod_name supportString :: MonadInterpreter m => m String supportString = do mod_name <- fromState (pmName . hintSupportModule) return $ concat [mod_name, ".", altStringName mod_name] supportShow :: MonadInterpreter m => m String supportShow = do mod_name <- fromState (pmName . hintSupportModule) return $ concat [mod_name, ".", altShowName mod_name] -- SHOULD WE CALL THIS WHEN MODULES ARE LOADED / UNLOADED? -- foreign import ccall "revertCAFs" rts_revertCAFs :: IO () hint-0.9.0.7/src/Hint/Conversions.hs0000644000000000000000000000200107346545000015346 0ustar0000000000000000module Hint.Conversions ( typeToString, kindToString, moduleToString, isSucceeded ) where import qualified Hint.GHC as GHC import Hint.Base -- --------- Types / Kinds ----------------------- typeToString :: MonadInterpreter m => GHC.Type -> m String typeToString t = do -- Unqualify necessary types -- (i.e., do not expose internals) unqual <- runGhc GHC.getPrintUnqual withDynFlags $ \df -> -- TODO: get unit state from somewhere? return $ GHC.showSDocForUser df GHC.emptyUnitState unqual (GHC.pprTypeForUser t) kindToString :: MonadInterpreter m => GHC.Kind -> m String kindToString k = withDynFlags $ \df -> return $ GHC.showSDoc df (GHC.pprTypeForUser k) -- ---------------- Modules -------------------------- moduleToString :: GHC.Module -> String moduleToString = GHC.moduleNameString . GHC.moduleName -- ---------------- Misc ----------------------------- isSucceeded :: GHC.SuccessFlag -> Bool isSucceeded GHC.Succeeded = True isSucceeded GHC.Failed = False hint-0.9.0.7/src/Hint/Eval.hs0000644000000000000000000000621607346545000013741 0ustar0000000000000000module Hint.Eval ( interpret, as, infer, unsafeInterpret, eval, runStmt, parens ) where import qualified GHC.Exts (unsafeCoerce#) import Control.Exception import Data.Typeable (Typeable) import qualified Data.Typeable as Typeable import Hint.Base import Hint.Context import Hint.Parsers import Hint.Util import qualified Hint.GHC as GHC -- | Convenience functions to be used with @interpret@ to provide witnesses. -- Example: -- -- * @interpret \"head [True,False]\" (as :: Bool)@ -- -- * @interpret \"head $ map show [True,False]\" infer >>= flip interpret (as :: Bool)@ as, infer :: Typeable a => a as = undefined infer = undefined -- | 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 $ Typeable.typeOf wit) unsafeInterpret :: (MonadInterpreter m) => String -> String -> m a unsafeInterpret expr type_str = 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 parseExpr expr -- let expr_typesig = concat [parens expr, " :: ", type_str] expr_val <- mayFail $ runGhc $ compileExpr expr_typesig -- return (GHC.Exts.unsafeCoerce# expr_val :: a) -- add a bogus Maybe, in order to use it with mayFail compileExpr :: GHC.GhcMonad m => String -> m (Maybe GHC.HValue) compileExpr = fmap Just . GHC.compileExpr -- | @eval expr@ will evaluate @show expr@. -- It will succeed only if @expr@ has type t and there is a 'Show' -- instance for t. eval :: MonadInterpreter m => String -> m String eval expr = do in_scope_show <- supportShow in_scope_String <- supportString 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 -- be a malformed expression. The straightforward solution for this is to -- 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@ parens :: String -> String parens s = concat ["(let {", foo, " =\n", s, "\n", " ;} in ", foo, ")"] where foo = safeBndFor s hint-0.9.0.7/src/Hint/Extension.hs0000644000000000000000000004306307346545000015027 0ustar0000000000000000-- this module was automatically generated. do not edit! -- edit util/mk_extensions_mod.hs instead module Hint.Extension ( Extension(..), supportedExtensions, availableExtensions, asExtension ) where 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 supportedExtensions asExtension :: String -> Extension asExtension s = if isKnown s then read s else let no_s = "No" ++ s in if isKnown no_s then read no_s else UnknownExtension s where isKnown e = e `elem` map show knownExtensions -- | This represents language extensions beyond Haskell 98 -- that are supported by GHC (it was taken from -- Cabal's @Language.Haskell.Extension@) data Extension = OverlappingInstances | UndecidableInstances | IncoherentInstances | DoRec | RecursiveDo | ParallelListComp | MultiParamTypeClasses | MonomorphismRestriction | FunctionalDependencies | Rank2Types | RankNTypes | PolymorphicComponents | ExistentialQuantification | ScopedTypeVariables | PatternSignatures | ImplicitParams | FlexibleContexts | FlexibleInstances | EmptyDataDecls | CPP | KindSignatures | BangPatterns | TypeSynonymInstances | TemplateHaskell | ForeignFunctionInterface | Arrows | Generics | ImplicitPrelude | NamedFieldPuns | PatternGuards | GeneralizedNewtypeDeriving | ExtensibleRecords | RestrictedTypeSynonyms | HereDocuments | MagicHash | TypeFamilies | StandaloneDeriving | UnicodeSyntax | UnliftedFFITypes | InterruptibleFFI | CApiFFI | LiberalTypeSynonyms | TypeOperators | RecordWildCards | RecordPuns | DisambiguateRecordFields | TraditionalRecordSyntax | OverloadedStrings | GADTs | GADTSyntax | MonoPatBinds | RelaxedPolyRec | ExtendedDefaultRules | UnboxedTuples | DeriveDataTypeable | DeriveGeneric | DefaultSignatures | InstanceSigs | ConstrainedClassMethods | PackageImports | ImpredicativeTypes | NewQualifiedOperators | PostfixOperators | QuasiQuotes | TransformListComp | MonadComprehensions | ViewPatterns | XmlSyntax | RegularPatterns | TupleSections | GHCForeignImportPrim | NPlusKPatterns | DoAndIfThenElse | MultiWayIf | LambdaCase | RebindableSyntax | ExplicitForAll | DatatypeContexts | MonoLocalBinds | DeriveFunctor | DeriveTraversable | DeriveFoldable | NondecreasingIndentation | SafeImports | Safe | Trustworthy | Unsafe | ConstraintKinds | PolyKinds | DataKinds | ParallelArrays | RoleAnnotations | OverloadedLists | EmptyCase | AutoDeriveTypeable | NegativeLiterals | BinaryLiterals | NumDecimals | NullaryTypeClasses | ExplicitNamespaces | AllowAmbiguousTypes | JavaScriptFFI | PatternSynonyms | PartialTypeSignatures | NamedWildCards | DeriveAnyClass | DeriveLift | StaticPointers | StrictData | Strict | ApplicativeDo | DuplicateRecordFields | TypeApplications | TypeInType | UndecidableSuperClasses | MonadFailDesugaring | TemplateHaskellQuotes | OverloadedLabels | TypeFamilyDependencies | NoOverlappingInstances | NoUndecidableInstances | NoIncoherentInstances | NoDoRec | NoRecursiveDo | NoParallelListComp | NoMultiParamTypeClasses | NoMonomorphismRestriction | NoFunctionalDependencies | NoRank2Types | NoRankNTypes | NoPolymorphicComponents | NoExistentialQuantification | NoScopedTypeVariables | NoPatternSignatures | NoImplicitParams | NoFlexibleContexts | NoFlexibleInstances | NoEmptyDataDecls | NoCPP | NoKindSignatures | NoBangPatterns | NoTypeSynonymInstances | NoTemplateHaskell | NoForeignFunctionInterface | NoArrows | NoGenerics | NoImplicitPrelude | NoNamedFieldPuns | NoPatternGuards | NoGeneralizedNewtypeDeriving | NoExtensibleRecords | NoRestrictedTypeSynonyms | NoHereDocuments | NoMagicHash | NoTypeFamilies | NoStandaloneDeriving | NoUnicodeSyntax | NoUnliftedFFITypes | NoInterruptibleFFI | NoCApiFFI | NoLiberalTypeSynonyms | NoTypeOperators | NoRecordWildCards | NoRecordPuns | NoDisambiguateRecordFields | NoTraditionalRecordSyntax | NoOverloadedStrings | NoGADTs | NoGADTSyntax | NoMonoPatBinds | NoRelaxedPolyRec | NoExtendedDefaultRules | NoUnboxedTuples | NoDeriveDataTypeable | NoDeriveGeneric | NoDefaultSignatures | NoInstanceSigs | NoConstrainedClassMethods | NoPackageImports | NoImpredicativeTypes | NoNewQualifiedOperators | NoPostfixOperators | NoQuasiQuotes | NoTransformListComp | NoMonadComprehensions | NoViewPatterns | NoXmlSyntax | NoRegularPatterns | NoTupleSections | NoGHCForeignImportPrim | NoNPlusKPatterns | NoDoAndIfThenElse | NoMultiWayIf | NoLambdaCase | NoRebindableSyntax | NoExplicitForAll | NoDatatypeContexts | NoMonoLocalBinds | NoDeriveFunctor | NoDeriveTraversable | NoDeriveFoldable | NoNondecreasingIndentation | NoSafeImports | NoSafe | NoTrustworthy | NoUnsafe | NoConstraintKinds | NoPolyKinds | NoDataKinds | NoParallelArrays | NoRoleAnnotations | NoOverloadedLists | NoEmptyCase | NoAutoDeriveTypeable | NoNegativeLiterals | NoBinaryLiterals | NoNumDecimals | NoNullaryTypeClasses | NoExplicitNamespaces | NoAllowAmbiguousTypes | NoJavaScriptFFI | NoPatternSynonyms | NoPartialTypeSignatures | NoNamedWildCards | NoDeriveAnyClass | NoDeriveLift | NoStaticPointers | NoStrictData | NoStrict | NoApplicativeDo | NoDuplicateRecordFields | NoTypeApplications | NoTypeInType | NoUndecidableSuperClasses | NoMonadFailDesugaring | NoTemplateHaskellQuotes | NoOverloadedLabels | NoTypeFamilyDependencies | UnknownExtension String deriving (Eq, Show, Read) knownExtensions :: [Extension] knownExtensions = [OverlappingInstances, UndecidableInstances, IncoherentInstances, DoRec, RecursiveDo, ParallelListComp, MultiParamTypeClasses, MonomorphismRestriction, FunctionalDependencies, Rank2Types, RankNTypes, PolymorphicComponents, ExistentialQuantification, ScopedTypeVariables, PatternSignatures, ImplicitParams, FlexibleContexts, FlexibleInstances, EmptyDataDecls, CPP, KindSignatures, BangPatterns, TypeSynonymInstances, TemplateHaskell, ForeignFunctionInterface, Arrows, Generics, ImplicitPrelude, NamedFieldPuns, PatternGuards, GeneralizedNewtypeDeriving, ExtensibleRecords, RestrictedTypeSynonyms, HereDocuments, MagicHash, TypeFamilies, StandaloneDeriving, UnicodeSyntax, UnliftedFFITypes, InterruptibleFFI, CApiFFI, LiberalTypeSynonyms, TypeOperators, RecordWildCards, RecordPuns, DisambiguateRecordFields, TraditionalRecordSyntax, OverloadedStrings, GADTs, GADTSyntax, MonoPatBinds, RelaxedPolyRec, ExtendedDefaultRules, UnboxedTuples, DeriveDataTypeable, DeriveGeneric, DefaultSignatures, InstanceSigs, ConstrainedClassMethods, PackageImports, ImpredicativeTypes, NewQualifiedOperators, PostfixOperators, QuasiQuotes, TransformListComp, MonadComprehensions, ViewPatterns, XmlSyntax, RegularPatterns, TupleSections, GHCForeignImportPrim, NPlusKPatterns, DoAndIfThenElse, MultiWayIf, LambdaCase, RebindableSyntax, ExplicitForAll, DatatypeContexts, MonoLocalBinds, DeriveFunctor, DeriveTraversable, DeriveFoldable, NondecreasingIndentation, SafeImports, Safe, Trustworthy, Unsafe, ConstraintKinds, PolyKinds, DataKinds, ParallelArrays, RoleAnnotations, OverloadedLists, EmptyCase, AutoDeriveTypeable, NegativeLiterals, BinaryLiterals, NumDecimals, NullaryTypeClasses, ExplicitNamespaces, AllowAmbiguousTypes, JavaScriptFFI, PatternSynonyms, PartialTypeSignatures, NamedWildCards, DeriveAnyClass, DeriveLift, StaticPointers, StrictData, Strict, ApplicativeDo, DuplicateRecordFields, TypeApplications, TypeInType, UndecidableSuperClasses, MonadFailDesugaring, TemplateHaskellQuotes, OverloadedLabels, TypeFamilyDependencies, NoOverlappingInstances, NoUndecidableInstances, NoIncoherentInstances, NoDoRec, NoRecursiveDo, NoParallelListComp, NoMultiParamTypeClasses, NoMonomorphismRestriction, NoFunctionalDependencies, NoRank2Types, NoRankNTypes, NoPolymorphicComponents, NoExistentialQuantification, NoScopedTypeVariables, NoPatternSignatures, NoImplicitParams, NoFlexibleContexts, NoFlexibleInstances, NoEmptyDataDecls, NoCPP, NoKindSignatures, NoBangPatterns, NoTypeSynonymInstances, NoTemplateHaskell, NoForeignFunctionInterface, NoArrows, NoGenerics, NoImplicitPrelude, NoNamedFieldPuns, NoPatternGuards, NoGeneralizedNewtypeDeriving, NoExtensibleRecords, NoRestrictedTypeSynonyms, NoHereDocuments, NoMagicHash, NoTypeFamilies, NoStandaloneDeriving, NoUnicodeSyntax, NoUnliftedFFITypes, NoInterruptibleFFI, NoCApiFFI, NoLiberalTypeSynonyms, NoTypeOperators, NoRecordWildCards, NoRecordPuns, NoDisambiguateRecordFields, NoTraditionalRecordSyntax, NoOverloadedStrings, NoGADTs, NoGADTSyntax, NoMonoPatBinds, NoRelaxedPolyRec, NoExtendedDefaultRules, NoUnboxedTuples, NoDeriveDataTypeable, NoDeriveGeneric, NoDefaultSignatures, NoInstanceSigs, NoConstrainedClassMethods, NoPackageImports, NoImpredicativeTypes, NoNewQualifiedOperators, NoPostfixOperators, NoQuasiQuotes, NoTransformListComp, NoMonadComprehensions, NoViewPatterns, NoXmlSyntax, NoRegularPatterns, NoTupleSections, NoGHCForeignImportPrim, NoNPlusKPatterns, NoDoAndIfThenElse, NoMultiWayIf, NoLambdaCase, NoRebindableSyntax, NoExplicitForAll, NoDatatypeContexts, NoMonoLocalBinds, NoDeriveFunctor, NoDeriveTraversable, NoDeriveFoldable, NoNondecreasingIndentation, NoSafeImports, NoSafe, NoTrustworthy, NoUnsafe, NoConstraintKinds, NoPolyKinds, NoDataKinds, NoParallelArrays, NoRoleAnnotations, NoOverloadedLists, NoEmptyCase, NoAutoDeriveTypeable, NoNegativeLiterals, NoBinaryLiterals, NoNumDecimals, NoNullaryTypeClasses, NoExplicitNamespaces, NoAllowAmbiguousTypes, NoJavaScriptFFI, NoPatternSynonyms, NoPartialTypeSignatures, NoNamedWildCards, NoDeriveAnyClass, NoDeriveLift, NoStaticPointers, NoStrictData, NoStrict, NoApplicativeDo, NoDuplicateRecordFields, NoTypeApplications, NoTypeInType, NoUndecidableSuperClasses, NoMonadFailDesugaring, NoTemplateHaskellQuotes, NoOverloadedLabels, NoTypeFamilyDependencies ] hint-0.9.0.7/src/Hint/GHC.hs0000644000000000000000000004762507346545000013464 0ustar0000000000000000{-# LANGUAGE TypeApplications #-} module Hint.GHC ( -- * 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, #if MIN_VERSION_ghc(9,6,0) getPrintUnqual, #endif -- * Re-exports module X, ) where import Data.IORef (IORef, modifyIORef) import GHC as X hiding (Phase, GhcT, parseDynamicFlags, runGhcT, showGhcException , guessTarget #if MIN_VERSION_ghc(9,2,0) , Logger , modifyLogger , pushLogHook #endif ) import Control.Monad.Ghc as X (GhcT, runGhcT) #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 (showSDoc) import DriverPhases as X (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) import DynFlags as X (xFlags, xopt, FlagSpec(..)) import SrcLoc as X (mkRealSrcLoc) import ConLike as X (ConLike(RealDataCon)) #endif {-------------------- 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,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 parseDynamicFlags :: MonadIO m => Logger -> DynFlags -> [Located String] -> m (DynFlags, [Located String], [Warn]) #if MIN_VERSION_ghc(9,2,0) parseDynamicFlags = GHC.parseDynamicFlags #else parseDynamicFlags _ = GHC.parseDynamicFlags #endif pprTypeForUser :: Type -> SDoc #if MIN_VERSION_ghc(9,4,0) pprTypeForUser = GHC.pprSigmaType #else pprTypeForUser = GHC.pprTypeForUser #endif #if MIN_VERSION_ghc(9,4,0) errMsgSpan :: GHC.Messages e -> SrcSpan errMsgSpan msgs = foldr (GHC.combineSrcSpans . GHC.errMsgSpan) X.noSrcSpan (GHC.getMessages msgs) #elif MIN_VERSION_ghc(9,2,0) errMsgSpan :: GHC.Bag (GHC.MsgEnvelope e) -> SrcSpan errMsgSpan = foldr (GHC.combineSrcSpans . GHC.errMsgSpan) X.noSrcSpan #else errMsgSpan :: GHC.ErrorMessages -> SrcSpan errMsgSpan = foldr (GHC.combineSrcSpans . GHC.errMsgSpan) X.noSrcSpan #endif fileTarget :: DynFlags -> FilePath -> GHC.Target #if MIN_VERSION_ghc(9,4,0) fileTarget dflags f = GHC.Target (GHC.TargetFile f $ Just next_phase) True uid Nothing where next_phase = GHC.Cpp GHC.HsSrcFile uid = GHC.homeUnitId_ dflags #else fileTarget _ f = GHC.Target (GHC.TargetFile f $ Just next_phase) True Nothing where next_phase = GHC.Cpp GHC.HsSrcFile #endif guessTarget :: GhcMonad m => String -> Maybe GHC.Phase -> m GHC.Target #if MIN_VERSION_ghc(9,4,0) guessTarget t pM = GHC.guessTarget t Nothing pM #else guessTarget = GHC.guessTarget #endif -- getPrintUnqual #if MIN_VERSION_ghc(9,6,0) getPrintUnqual :: GhcMonad m => m PrintUnqualified getPrintUnqual = GHC.getNamePprCtx #endif hint-0.9.0.7/src/Hint/Internal.hs0000644000000000000000000000217107346545000014622 0ustar0000000000000000-- | 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) hint-0.9.0.7/src/Hint/InterpreterT.hs0000644000000000000000000001603607346545000015502 0ustar0000000000000000module Hint.InterpreterT ( InterpreterT, Interpreter, runInterpreter, runInterpreterWithArgs, runInterpreterWithArgsLibdir, MultipleInstancesNotAllowed(..) ) where import Control.Applicative import Prelude import Hint.Base import Hint.Context import Hint.Configuration import Hint.Extension 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) import Control.Concurrent.MVar import System.IO.Unsafe (unsafePerformIO) import Data.IORef import Data.Maybe import qualified GHC.Paths import qualified Hint.GHC as GHC type Interpreter = InterpreterT IO newtype InterpreterT m a = InterpreterT { unInterpreterT :: ReaderT InterpreterSession (GHC.GhcT m) a } deriving (Functor, Monad, MonadIO, MonadThrow, MonadCatch, MonadMask) execute :: (MonadIO m, MonadMask m) => String -> InterpreterSession -> InterpreterT m a -> m (Either InterpreterError a) execute libdir s = try . GHC.runGhcT (Just libdir) . flip runReaderT s . unInterpreterT instance MonadTrans InterpreterT where lift = InterpreterT . lift . lift runGhcImpl :: (MonadIO m, MonadMask m) => RunGhc (InterpreterT m) a runGhcImpl a = InterpreterT (lift a) `catches` [Handler (\(e :: GHC.SourceError) -> do dynFlags <- runGhc GHC.getSessionDynFlags throwM $ compilationError dynFlags e) ,Handler (\(e :: GHC.GhcApiError) -> throwM $ GhcException $ show e) ,Handler (\(e :: GHC.GhcException) -> throwM $ GhcException $ showGhcEx e) ] where compilationError dynFlags = WontCompile . map (GhcError . GHC.showSDoc dynFlags) . GHC.pprErrorMessages . GHC.srcErrorMessages showGhcEx :: GHC.GhcException -> String showGhcEx = flip (GHC.showGhcException GHC.defaultSDocContext) "" -- ================= Executing the interpreter ================== initialize :: (MonadIO m, MonadThrow m, MonadMask m, Functor m) => [String] -> InterpreterT m () initialize args = do logger <- fromSession ghcLogger -- Set a custom log handler, to intercept error messages :S df0 <- runGhc GHC.getSessionDynFlags let df1 = configureDynFlags df0 (df2, extra) <- runGhc $ parseDynamicFlags logger df1 args unless (null extra) $ throwM $ UnknownError (concat [ "flags: '" , unwords extra , "' not recognized"]) -- Observe that, setSessionDynFlags loads info on packages -- available; calling this function once is mandatory! runGhc $ GHC.modifyLogger (const logger) _ <- runGhc $ GHC.setSessionDynFlags df2 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 supportedExtensions onState (\s -> s{defaultExts = defExts}) reset -- | Executes the interpreter. Returns @Left InterpreterError@ in case of error. -- -- 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) => [String] -> InterpreterT m a -> m (Either InterpreterError a) runInterpreterWithArgs args = runInterpreterWithArgsLibdir args GHC.Paths.libdir 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 = cleanPhantomModules #ifndef THREAD_SAFE_LINKER {-# NOINLINE uniqueToken #-} uniqueToken :: MVar () uniqueToken = unsafePerformIO $ newMVar () ifInterpreterNotRunning :: (MonadIO m, MonadMask m) => m a -> m a 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 -- instance is already running. data MultipleInstancesNotAllowed = MultipleInstancesNotAllowed deriving Typeable instance Exception MultipleInstancesNotAllowed instance Show MultipleInstancesNotAllowed where show _ = "This version of GHC is not thread-safe," ++ "can't safely run two instances of the interpreter simultaneously" initialState :: InterpreterState initialState = St { activePhantoms = [], zombiePhantoms = [], phantomDirectory = Nothing, hintSupportModule = error "No support module loaded!", importQualHackMod = Nothing, qualImports = [], defaultExts = error "defaultExts missing!", configuration = defaultConf } newSessionData :: MonadIO m => a -> m (SessionData a) 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, ghcLogger = GHC.pushLogHook (const $ GHC.mkLogAction GhcError ghc_err_list_ref) logger } -- The MonadInterpreter instance instance (MonadIO m, MonadMask m, Functor m) => MonadInterpreter (InterpreterT m) where fromSession f = InterpreterT $ asks f -- modifySessionRef target f = do ref <- fromSession target liftIO $ atomicModifyIORef ref (\a -> (f a, a)) -- runGhc = runGhcImpl instance (Monad m) => Applicative (InterpreterT m) where pure = return (<*>) = ap hint-0.9.0.7/src/Hint/Parsers.hs0000644000000000000000000000506507346545000014472 0ustar0000000000000000module Hint.Parsers where import Prelude hiding (span) import Hint.Base import Control.Monad.IO.Class (liftIO) import qualified Hint.GHC as GHC data ParseResult = ParseOk | ParseError GHC.SrcSpan GHC.Message parseExpr :: MonadInterpreter m => String -> m ParseResult parseExpr = runParser GHC.parseStmt parseType :: MonadInterpreter m => String -> m ParseResult parseType = runParser GHC.parseType runParser :: MonadInterpreter m => GHC.P a -> String -> m ParseResult runParser parser expr = do dyn_fl <- runGhc GHC.getSessionDynFlags -- buf <- (return . GHC.stringToStringBuffer) expr -- -- ghc >= 7 panics if noSrcLoc is given let srcLoc = GHC.mkRealSrcLoc (GHC.fsLit "") 1 1 let parserOpts = GHC.mkParserOpts dyn_fl let parse_res = GHC.unP parser (GHC.initParserState parserOpts buf srcLoc) -- case parse_res of GHC.POk{} -> return ParseOk -- #if 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 = 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 ghcLogger dflags <- runGhc GHC.getSessionDynFlags let logger' = GHC.putLogMsg logger dflags liftIO $ logger' GHC.NoReason GHC.SevError span err -- -- behave like the rest of the GHC API functions -- do on error... return Nothing hint-0.9.0.7/src/Hint/Reflection.hs0000644000000000000000000000410107346545000015133 0ustar0000000000000000module Hint.Reflection ( ModuleElem(..), Id, name, children, getModuleExports, ) where import Data.List import Data.Maybe import Hint.Base import qualified Hint.GHC as GHC -- | An Id for a class, a type constructor, a data constructor, a binding, etc type Id = String data ModuleElem = Fun Id | Class Id [Id] | Data Id [Id] deriving (Read, Show, Eq) name :: ModuleElem -> Id name (Fun f) = f name (Class c _) = c name (Data d _) = d children :: ModuleElem -> [Id] children (Fun _) = [] children (Class _ ms) = ms children (Data _ dcs) = dcs -- | Gets an abstract representation of all the entities exported by the module. -- It is similar to the @:browse@ command in GHCi. getModuleExports :: MonadInterpreter m => ModuleName -> m [ModuleElem] getModuleExports mn = do module_ <- findModule mn 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 ] 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) getUnqualName :: GHC.NamedThing a => GHC.DynFlags -> a -> String getUnqualName dfs = GHC.showSDoc dfs . GHC.pprParenSymName hint-0.9.0.7/src/Hint/Typecheck.hs0000644000000000000000000000570307346545000014771 0ustar0000000000000000module Hint.Typecheck ( typeOf, typeChecks, kindOf, normalizeType, onCompilationError, typeChecksWithDetails ) where import Control.Monad.Catch import Hint.Base import Hint.Parsers import Hint.Conversions import qualified Hint.GHC as GHC -- | Returns a string representation of the type of the expression. typeOf :: MonadInterpreter m => String -> m String typeOf 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 parseExpr expr -- 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 = (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 = 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 -- (_, kind) <- mayFail $ runGhc $ typeKind type_expr -- 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 GHC.TM_Inst -- add a bogus Maybe, in order to use it with mayFail typeKind :: GHC.GhcMonad m => String -> m (Maybe (GHC.Type, GHC.Kind)) typeKind = fmap Just . GHC.typeKind True onCompilationError :: MonadInterpreter m => ([GhcError] -> m a) -> (InterpreterError -> m a) onCompilationError recover interp_error = case interp_error of WontCompile errs -> recover errs otherErr -> throwM otherErr hint-0.9.0.7/src/Hint/Util.hs0000644000000000000000000000167707346545000013775 0ustar0000000000000000module Hint.Util where import Data.Char type Expr = String -- @safeBndFor expr@ generates a name @e@ such that it does not -- occur free in @expr@ and, thus, it is safe to write something -- like @e = expr@ (otherwise, it will get accidentally bound). -- This ought to do the trick: observe that @safeBndFor expr@ -- contains more digits than @expr@ and, thus, cannot occur inside -- @expr@. safeBndFor :: Expr -> String safeBndFor expr = "e_1" ++ filter isDigit expr partition :: (a -> Bool) -> [a] -> ([a], [a]) partition prop = foldr (select prop) ([],[]) where select p x ~(ts,fs) | p x = (x:ts,fs) | otherwise = (ts, x:fs) partitionEither :: [Either a b] -> ([a],[b]) partitionEither [] = ([],[]) partitionEither (Left a:xs) = let (ls,rs) = partitionEither xs in (a:ls,rs) partitionEither (Right b:xs) = let (ls,rs) = partitionEither xs in (ls,b:rs) quote :: String -> String quote s = concat ["'", s, "'"] hint-0.9.0.7/src/Language/Haskell/0000755000000000000000000000000007346545000014715 5ustar0000000000000000hint-0.9.0.7/src/Language/Haskell/Interpreter.hs0000644000000000000000000000305607346545000017560 0ustar0000000000000000module Language.Haskell.Interpreter( -- * The interpreter monad transformer MonadInterpreter(..), InterpreterT, Interpreter, -- ** Running the interpreter runInterpreter, -- ** Interpreter options Option, OptionVal((:=)), get, set, languageExtensions, availableExtensions, Extension(..), installedModulesInScope, searchPath, -- ** Context handling ModuleName, isModuleInterpreted, ModuleImport(..), ModuleQualification(..), ImportList(..), loadModules, getLoadedModules, setTopLevelModules, setImports, setImportsQ, setImportsF, reset, -- ** Module querying ModuleElem(..), Id, name, children, getModuleExports, -- ** Annotations -- In the snippets below we use \'LBRACE\' and \'RBRACE\' -- to mean \'{\' and \'}\' respectively. We cannot put the -- pragmas inline in the code since GHC scarfs them up. getModuleAnnotations, getValAnnotations, -- ** Type inference typeChecksWithDetails, typeOf, typeChecks, kindOf, normalizeType, -- ** Evaluation interpret, as, infer, eval, runStmt, -- * Error handling InterpreterError(..), GhcError(..), MultipleInstancesNotAllowed(..), -- * Miscellaneous ghcVersion, parens, module Control.Monad.Trans.Class, module Control.Monad.IO.Class, ) where import Hint.Base import Hint.Annotations import Hint.InterpreterT import Hint.Configuration import Hint.Context import Hint.Reflection import Hint.Typecheck import Hint.Eval import Control.Monad.IO.Class import Control.Monad.Trans.Class hint-0.9.0.7/src/Language/Haskell/Interpreter/0000755000000000000000000000000007346545000017220 5ustar0000000000000000hint-0.9.0.7/src/Language/Haskell/Interpreter/Extension.hs0000644000000000000000000000015307346545000021527 0ustar0000000000000000module Language.Haskell.Interpreter.Extension ( module Hint.Extension ) where import Hint.Extension hint-0.9.0.7/src/Language/Haskell/Interpreter/Unsafe.hs0000644000000000000000000000341007346545000020773 0ustar0000000000000000module Language.Haskell.Interpreter.Unsafe ( unsafeSetGhcOption, unsafeRunInterpreterWithArgs, unsafeRunInterpreterWithArgsLibdir, unsafeInterpret ) where import Control.Monad.IO.Class import Control.Monad.Catch import Hint.Base import Hint.Eval import Hint.Configuration import Hint.InterpreterT -- | Set a GHC option for the current session, -- eg. @unsafeSetGhcOption \"-XNoMonomorphismRestriction\"@. -- -- Warning: Some options may interact badly with the Interpreter. unsafeSetGhcOption :: MonadInterpreter m => String -> m () unsafeSetGhcOption = setGhcOption -- | Executes the interpreter, setting the args as though they were -- command-line args. In particular, this means args that have no -- effect with :set in ghci might function properly from this -- context. -- -- Warning: Some options may interact badly with the Interpreter. unsafeRunInterpreterWithArgs :: (MonadMask m, MonadIO m) => [String] -> InterpreterT m a -> m (Either InterpreterError a) unsafeRunInterpreterWithArgs = runInterpreterWithArgs -- | A variant of @unsafeRunInterpreterWithArgs@ which also lets you -- specify the folder in which the GHC bootstrap libraries (base, -- containers, etc.) can be found. This allows you to run hint on -- a machine in which GHC is not installed. -- -- 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) unsafeRunInterpreterWithArgsLibdir = runInterpreterWithArgsLibdir hint-0.9.0.7/unit-tests/0000755000000000000000000000000007346545000013137 5ustar0000000000000000hint-0.9.0.7/unit-tests/run-unit-tests.hs0000644000000000000000000006252507346545000016426 0ustar0000000000000000module Main (main) where import Prelude hiding (catch) import Control.Exception (ArithException(..), AsyncException(UserInterrupt)) import Control.Monad.Catch as MC import Control.Monad (guard, liftM, when, void, (>=>)) 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 ((@?=), (@?), 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 liftIO $ writeFile mod_file mod_v1 f_v1 <- get_f -- liftIO $ writeFile mod_file mod_v2 f_v2 <- get_f -- liftIO $ (f_v1 5, f_v2 5) @?= (5, 6) -- where mod_name = "TEST_ReloadModified" mod_file = mod_name ++ ".hs" -- mod_v1 = unlines ["module " ++ mod_name, "where", "f :: Int -> Int", "f = id"] mod_v2 = unlines ["module " ++ mod_name, "where", "f :: Int -> Int", "f = (1 +)"] -- get_f = do loadModules [mod_file] setTopLevelModules [mod_name] interpret "f" (as :: Int -> Int) test_lang_exts :: TestCase test_lang_exts = TestCase "lang_exts" [mod_file] $ do 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 := [RecordWildCards]] succeeds do_load @@? "now, it should load" -- set [languageExtensions := []] fails do_load @@? "it shouldn't load, again" -- where mod_name = "TEST_LangExts" mod_file = mod_name ++ ".hs" -- do_load = loadModules [mod_name] test_work_in_main :: TestCase test_work_in_main = TestCase "work_in_main" [mod_file] $ do liftIO $ writeFile mod_file "f = id" loadModules [mod_file] setTopLevelModules ["Main"] setImportsQ [("Prelude", Nothing), ("Data.Maybe", Just "Mb")] -- typeOf "f $ (1 + 1 :: Int)" @@?= "Int" eval "f . Mb.fromJust $ Just [1,2]" @@?= "[1,2]" interpret "f $ 1 == 2" infer @@?= False -- where mod_file = "TEST_WorkInMain.hs" test_priv_syms_in_scope :: TestCase test_priv_syms_in_scope = TestCase "private_syms_in_scope" [mod_file] $ do -- must set to True, otherwise won't work with -- ghc 6.8 set [installedModulesInScope := True] liftIO $ writeFile mod_file mod_text loadModules [mod_file] setTopLevelModules ["T"] typeChecks "g" @@? "g is hidden" where mod_text = unlines ["module T(f) where", "f = g", "g = id"] mod_file = "TEST_PrivateSymbolsInScope.hs" test_comments_in_expr :: TestCase test_comments_in_expr = TestCase "comments_in_expr" [] $ do setImports ["Prelude"] let expr = "length $ concat [[1,2],[3]] -- bla" typeChecks expr @@? "comment on expression" _ <- eval expr _ <- interpret expr (as :: Int) return () test_qual_import :: TestCase test_qual_import = TestCase "qual_import" [] $ do setImportsQ [("Prelude", Nothing), ("Data.Map", Just "M")] 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 "()" @@?= "()" test_eval_layout :: TestCase test_eval_layout = TestCase "eval_layout" [] $ eval layout_expr @@?= "10" where layout_expr = unlines ["let x = let y = 10", " in y", "in x"] test_show_in_scope :: TestCase test_show_in_scope = TestCase "show_in_scope" [] $ do setImports ["Prelude"] eval "show ([] :: String)" @@?= show (show "") test_installed_not_in_scope :: TestCase test_installed_not_in_scope = TestCase "installed_not_in_scope" [] $ do b <- get installedModulesInScope succeeds action @@?= b set [installedModulesInScope := False] fails action @@? "now must be out of scope" set [installedModulesInScope := True] succeeds action @@? "must be in scope again" where action = typeOf "Data.Map.singleton" test_search_path :: TestCase test_search_path = TestCase "search_path" files $ do liftIO setup fails (loadModules [mod_1]) @@? "mod_1 should not be in path (1)" fails (loadModules [mod_2]) @@? "mod_2 should not be in path (1)" -- set [searchPath := [dir_1]] succeeds (loadModules [mod_1]) @@? "mod_1 should be in path (2)" fails (loadModules [mod_2]) @@? "mod_2 should not be in path (2)" -- set [searchPath := [dir_2]] fails (loadModules [mod_1]) @@? "mod_1 should not be in path (3)" succeeds (loadModules [mod_2]) @@? "mod_2 should be in path (3)" -- set [searchPath := [dir_1,dir_2]] succeeds (loadModules [mod_1]) @@? "mod_1 should be in path (4)" succeeds (loadModules [mod_2]) @@? "mod_2 should be in path (4)" where dir_1 = "search_path_test_dir_1" mod_1 = "M1" file_1 = dir_1 mod_1 <.> "hs" dir_2 = "search_path_test_dir_2" mod_2 = "M2" file_2 = dir_2 mod_2 <.> "hs" files = [file_1, file_2, dir_1, dir_2] setup = do createDirectory dir_1 createDirectory dir_2 writeFile file_1 $ unlines ["module " ++ mod_1, "where", "x :: Int", "x = 42"] writeFile file_2 $ unlines ["module " ++ mod_2, "where", "y :: Bool", "y = False"] test_search_path_dot :: TestCase test_search_path_dot = TestCase "search_path_dot" [mod_file, dir] $ do liftIO setup succeeds (loadModules [mod1]) @@? "mod1 must be initially in path" set [searchPath := [dir]] succeeds (loadModules [mod1]) @@? "mod1 must be still in path" -- where dir = "search_path_dot_dir" mod1 = "M1" mod_file = mod1 <.> "hs" setup = do createDirectory dir writeFile mod_file $ unlines ["x :: Int", "x = 42"] test_catch :: TestCase test_catch = TestCase "catch" [] $ do setImports ["Prelude"] -- 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 let concurrent = runInterpreter (liftIO $ putMVar r False) `catch` \MultipleInstancesNotAllowed -> do liftIO $ putMVar r True 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 ,test_installed_not_in_scope ,test_priv_syms_in_scope ,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... c1 <- runTests False tests c2 <- runIOTests False ioTests -- then run again, but with sandboxing on... c3 <- runTests True tests c4 <- runIOTests True ioTests -- 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 exitWith exit_code -- `catch` (\_ -> exitWith (ExitFailure $ -1)) printInterpreterError :: InterpreterError -> IO () printInterpreterError = hPrint stderr setSandbox :: Interpreter () setSandbox = set [installedModulesInScope := False] (@@?) :: (HUnit.AssertionPredicable p, MonadIO m) => m p -> String -> m () p @@? msg = do b <- p; liftIO (b @? msg) (@@?=) :: (Eq a, Show a, MonadIO m) => m a -> a -> m () m_a @@?= b = do a <- m_a; liftIO (a @?= b) fails :: (MonadCatch m, MonadIO m) => m a -> m Bool fails action = (action >> return False) `catchIE` (\_ -> return True) where catchIE :: MonadCatch m => m a -> (InterpreterError -> m a) -> m a catchIE = MC.catch succeeds :: (MonadCatch m, MonadIO m) => m a -> m Bool succeeds = fmap not . fails noExceptions :: Either SomeException a -> IO a noExceptions (Left e) = assertFailure (show e) noExceptions (Right a) = pure a 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 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 $ 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