hint 0.4.3 → 0.9.0.9
raw patch · 33 files changed
Files
- AUTHORS +5/−0
- CHANGELOG.md +168/−66
- README.md +104/−11
- Setup.hs +2/−0
- Setup.lhs +0/−5
- examples/example.hs +45/−27
- hint.cabal +99/−90
- src/Control/Monad/Ghc.hs +133/−0
- src/Hint/Annotations.hs +31/−60
- src/Hint/Base.hs +66/−126
- src/Hint/Compat.hs +0/−257
- src/Hint/CompatPlatform.hs +4/−15
- src/Hint/Configuration.hs +48/−81
- src/Hint/Context.hs +210/−137
- src/Hint/Conversions.hs +8/−17
- src/Hint/Eval.hs +44/−26
- src/Hint/Extension.hs +350/−14
- src/Hint/GHC.hs +668/−60
- src/Hint/Internal.hs +33/−0
- src/Hint/InterpreterT.hs +83/−148
- src/Hint/Parsers.hs +23/−26
- src/Hint/Reflection.hs +15/−54
- src/Hint/Sandbox.hs +0/−74
- src/Hint/SignalHandlers.hs +0/−40
- src/Hint/Typecheck.hs +51/−35
- src/Hint/Typecheck.hs-boot +0/−5
- src/Hint/Util.hs +1/−6
- src/Language/Haskell/Interpreter.hs +13/−29
- src/Language/Haskell/Interpreter/Extension.hs +3/−3
- src/Language/Haskell/Interpreter/GHC.hs +0/−13
- src/Language/Haskell/Interpreter/GHC/Unsafe.hs +0/−13
- src/Language/Haskell/Interpreter/Unsafe.hs +22/−9
- unit-tests/run-unit-tests.hs +375/−52
AUTHORS view
@@ -2,8 +2,10 @@ Austin Seipp Bertram Felgenhauer+Brandon Chinn Bryan O'Sullivan Carl Howells+Christiaan Baaij Conrad Parker Corentin Dupont Daniel Gorin <jcpetruzza@gmail.com>@@ -12,9 +14,12 @@ Evan Laforge Fernando Benavides Gwern Branwen+Heinrich Apfelmus Jean Philippe Bernardy Jens Petersen Mark Wright Nathaniel W. Filardo Pasqualino Titto Assini+Rob Zinkov <rob@zinkov.com> Samuel Gélineau+Sid Kapur
CHANGELOG.md view
@@ -1,149 +1,251 @@+### 0.9.0.9++* Support GHC 9.10, GHC 9.12, and GHC 9.14+* Remove noncanonical monad instance definitions for future GHC compatibility++### 0.9.0.8++* Support GHC 9.8++### 0.9.0.7++* Support GHC 9.4+* Support GHC 9.6+* Improved documentation++### 0.9.0.6++* Fixes the 0.9.0.5 regression+* Small fix in documentation (thanks to Ed Behn)++### 0.9.0.5 (deprecated)++* Support GHC 9.2.1+* Deprecated because it breaks the common pattern of using+ 'unsafeRunInterpreterWithArgs' to load a custom package database.++### 0.9.0.4++* Support GHC 9.0.1++### 0.9.0.3++* Support GHC 8.10+* Drop support for GHC 8.4+* Hint can now be used concurrently from multiple threads on GHC 8.10+++### 0.9.0.2++* Support GHC 8.8+* Drop support for GHC 8.2++### 0.9.0.1++* Make tests pass with stack 2.1.1++### 0.9.0++* Support GHC 8.6+* Drop support for GHC 8.0++### 0.8.0++* Support GHC 8.4+* Drop support for GHC 7.8 and 7.10+* Add `runStmt` to execute statements in the IO monad and bind new names+* Internal changes of temporary files for phantom modules+ - The files are now called `M<nnn>.hs` instead of `<nnn>`+ - Improved cleanup of phantom module source files+ - ghc 8.4 only: phantom modules are put into a temporary directory+* Add `typeChecksWithDetails` to obtain type-checking errors+* Stop GHC from overwriting the Ctrl-C signal handler+* Add `SetImportsF` to allow finer imports control++### 0.7.0++* Support for GHC 8.2+* Support use in a dynamically-linked executable+* Add `normalizeType`, like ghci's :kind!+* Drop support for GHC 7.6++### 0.6.0++* Support for GHC 8.0+* 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+* New maintainer and source code repo ### 0.4.2.3 - * It builds against 7.4.2 (not 7.4.1), so update the constraints.+* 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+* 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)+* Better error reporting (thanks to Corentin Dupont) ### 0.4.2.0 - * Based on exceptions-0.6+* Based on exceptions-0.6 ### 0.4.1.0 - * Based on exceptions-0.4+* 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+* 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)+* 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)+* 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)+* 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+* Works on GHC 7.4.1 ### 0.3.3.3 - * Works on GHC 7.2.1+* Works on GHC 7.2.1 ### 0.3.3.2 - * Supports GHC 7+* 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...)+* 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+* 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+* 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)+* 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+* 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- accross different ghc versions- * Provides an Applicative instance for IntepreterT- * Adds an option to configurate the searchPath+* 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.+* 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)+* 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)+* setImportsQ added (modules can be imported both qualified and+ unqualified) ### 0.2.4.1 - * BUGFIX: No longer fails on expressions ending in a -- comment+* 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)+* 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+* 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+* 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+* 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+* 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
README.md view
@@ -1,16 +1,109 @@-# hint+# hint [](https://hackage.haskell.org/package/hint) [](https://github.com/haskell-hint/hint/actions) -[](https://travis-ci.org/mvdan/hint)+This library defines an Interpreter monad within which you can interpret+strings like `"[1,2] ++ [3]"` into values like `[1,2,3]`. You can easily+exchange data between your compiled program and your interpreted program, as+long as the data has a `Typeable` instance. -This library defines an Interpreter monad. It allows to load Haskell-modules, browse them, type-check and evaluate strings with Haskell-expressions and even coerce them into values. The library is thread-safe-and type-safe (even the coercion of expressions to values).+You can choose which modules should be in scope while evaluating these+expressions, you can browse the contents of those modules, and you can ask for+the type of the identifiers you're browsing. -It is, esentially, a huge subset of the GHC API wrapped in a simpler-API.+## Example -### Example+```haskell+{-# LANGUAGE LambdaCase, ScopedTypeVariables, TypeApplications #-}+import Control.Exception (throwIO)+import Control.Monad (when)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Writer (execWriterT, tell)+import Data.Foldable (for_)+import Data.List (isPrefixOf)+import Data.Typeable (Typeable)+import qualified Language.Haskell.Interpreter as Hint -Check [example.hs](examples/example.hs) to see a simple but-comprehensive example (it must be run from the `examples` directory).+-- |+-- Interpret expressions into values:+--+-- >>> eval @[Int] "[1,2] ++ [3]"+-- Right [1,2,3]+--+-- Send values from your compiled program to your interpreted program by+-- interpreting a function:+--+-- >>> Right f <- eval @(Int -> [Int]) "\\x -> [1..x]"+-- >>> f 5+-- [1,2,3,4,5]+eval :: forall t. Typeable t+ => String -> IO (Either Hint.InterpreterError t)+eval s = Hint.runInterpreter $ do+ Hint.setImports ["Prelude"]+ Hint.interpret s (Hint.as :: t)++-- |+-- >>> :{+-- do Right contents <- browse "Prelude"+-- for_ contents $ \(identifier, tp) -> do+-- when ("put" `isPrefixOf` identifier) $ do+-- putStrLn $ identifier ++ " :: " ++ tp+-- :}+-- putChar :: Char -> IO ()+-- putStr :: String -> IO ()+-- putStrLn :: String -> IO ()+browse :: Hint.ModuleName -> IO (Either Hint.InterpreterError [(String, String)])+browse moduleName = Hint.runInterpreter $ do+ Hint.setImports ["Prelude", "Data.Typeable", moduleName]+ exports <- Hint.getModuleExports moduleName+ execWriterT $ do+ for_ exports $ \case+ Hint.Fun identifier -> do+ tp <- lift $ Hint.typeOf identifier+ tell [(identifier, tp)]+ _ -> pure () -- skip datatypes and typeclasses+```++Check [example.hs](examples/example.hs) for a longer example (it must be run+from hint's base directory).++## Limitations++Importing a module from the current package is not supported. It might look+like it works on one day and then segfault the next day. You have been warned.++To work around this limitation, move those modules to a separate package. Now+the part of your code which calls hint and the code interpreted by hint can+both import that module.++It is not possible to exchange a value [whose type involves an implicit kind+parameter](https://github.com/haskell-hint/hint/issues/159#issuecomment-1575629607).+This includes type-level lists. To work around this limitation, [define a+newtype wrapper which wraps the type you+want](https://github.com/haskell-hint/hint/issues/159#issuecomment-1575640606).++It is possible to run the interpreter inside a thread, but on GHC 8.8 and+below, you can't run two instances of the interpreter simultaneously.++GHC must be installed on the system on which the compiled executable is+running. There is a workaround for this but [it's not trivial](https://github.com/haskell-hint/hint/issues/80#issuecomment-963109968).++The packages used by the interpreted code must be installed in a package+database, and hint needs to be told about that package database at runtime.++The most common use case for package databases is for the interpreted code to+have access to the same packages as the compiled code (but not compiled code+itself). The easiest way to accomplish this is via a+[GHC environment file](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/packages.html#package-environments),+and the easiest way to generate a GHC environment file is+[via cabal](https://cabal.readthedocs.io/en/3.4/cabal-project.html#cfg-field-write-ghc-environment-files).+Compile your code using `cabal build --write-ghc-environment-files=always`;+this will create a file named `.ghc.environment.<something>` in the current+directory. At runtime, hint will look for that file in the current directory.++For more advanced use cases, you can use+[`unsafeRunInterpreterWithArgs`](https://hackage.haskell.org/package/hint/docs/Language-Haskell-Interpreter-Unsafe.html#v:unsafeRunInterpreterWithArgs)+to pass arguments to the underlying ghc library, such as+[`-package-db`](https://downloads.haskell.org/~ghc/latest/docs/users_guide/packages.html?highlight=package%20db#ghc-flag--package-db%20%E2%9F%A8file%E2%9F%A9)+to specify a path to a package database, or+[`-package-env`](https://downloads.haskell.org/~ghc/latest/docs/users_guide/packages.html?highlight=package%20db#ghc-flag--package-env%20%E2%9F%A8file%E2%9F%A9%7C%E2%9F%A8name%E2%9F%A9)+to specify a path to a GHC environment file.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
− Setup.lhs
@@ -1,5 +0,0 @@-#!/usr/bin/env runhaskell-> module Main where-> import Distribution.Simple-> main :: IO ()-> main = defaultMainWithHooks defaultUserHooks
examples/example.hs view
@@ -1,63 +1,81 @@+import Data.List+ import Control.Monad import Language.Haskell.Interpreter+import System.Directory main :: IO ()-main = do r <- runInterpreter testHint+main = do setCurrentDirectory "examples"+ r <- runInterpreter testHint case r of- Left err -> printInterpreterError err- Right () -> putStrLn "that's all folks"+ 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)- --+ 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 $ concat ["e.g. eval ", show expr1]+ say $ "e.g. eval " ++ show expr2 a <- eval expr2- say (show a)- --+ 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)- --+ 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)- --+ 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)- --+ 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 <- interpret "head $ map show [\"Worked!\", \"Didn't work\"]" infer >>= flip interpret infer+ res <- do+ s <- interpret "head $ map show [\"Worked!\", \"Didn't work\"]" infer+ interpret s infer say res---say :: String -> Interpreter ()-say = liftIO . putStrLn--printInterpreterError :: InterpreterError -> IO ()-printInterpreterError e = putStrLn $ "Ups... " ++ (show e)-+ emptyLine+ say "We can also execute statements in the IO monad and bind new names, e.g."+ let stmts = ["x <- return 42", "print x"]+ forM_ stmts $ \s -> do+ say $ " " ++ s+ runStmt s+ emptyLine
hint.cabal view
@@ -1,25 +1,36 @@-name: hint-version: 0.4.3+name: hint+version: 0.9.0.9 description:- This library defines an @Interpreter@ monad. It allows to load Haskell+ 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).+ 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: Runtime Haskell interpreter (GHC API wrapper)-category: Language, Compilers/Interpreters-license: BSD3-license-file: LICENSE-author: The Hint Authors-maintainer: mvdan@mvdan.cc-homepage: https://github.com/mvdan/hint -cabal-version: >= 1.9.2-build-type: Simple+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" <gelisam@gmail.com>+homepage: https://github.com/haskell-hint/hint+tested-with: ghc == 8.10.7+ , ghc == 8.6.5+ , ghc == 8.8.4+ , ghc == 9.0.2+ , ghc == 9.2.8+ , ghc == 9.4.8+ , ghc == 9.6.6+ , ghc == 9.8.4+ , ghc == 9.10.3+ , ghc == 9.12.3+ , ghc == 9.14.1 +cabal-version: >= 1.10+build-type: Simple+ extra-source-files: README.md AUTHORS CHANGELOG.md@@ -28,91 +39,89 @@ source-repository head type: git- location: https://github.com/mvdan/hint+ location: https://github.com/haskell-hint/hint -Test-Suite unit-tests- type: exitcode-stdio-1.0+test-suite unit-tests+ type: exitcode-stdio-1.0 hs-source-dirs: unit-tests- main-is: run-unit-tests.hs- build-depends: base < 5- ,hint- ,HUnit==1.2.*- ,directory- ,filepath- ,mtl- ,extensible-exceptions- ,exceptions+ main-is: run-unit-tests.hs+ default-language: Haskell2010 -Library- build-depends: ghc >= 7.4.2,- ghc-paths,- mtl,- filepath,- extensible-exceptions,- exceptions- if impl(ghc >= 6.8) {- build-depends: random,- directory+ build-depends: base == 4.*,+ bytestring,+ hint,+ HUnit,+ directory,+ filepath,+ exceptions >= 0.10.0,+ stm,+ text,+ typed-process, - if impl(ghc >= 6.10) {- build-depends: base >= 4, base < 5,- ghc-mtl == 1.2.1.*- -- version 1.1.* uses exceptions instead of MonadCatchIO- -- version 1.2.* uses the exceptions-0.4 api- -- version 1.2.1.* uses the exceptions-0.6 api- } else {- build-depends: base >= 3, base < 4- }- }- else {- -- ghc < 6.8- build-depends: utf8-string < 0.3+ -- 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+ build-depends: unix >= 2.2.0.0 } - exposed-modules: Language.Haskell.Interpreter- Language.Haskell.Interpreter.Extension- Language.Haskell.Interpreter.Unsafe- Language.Haskell.Interpreter.GHC- Language.Haskell.Interpreter.GHC.Unsafe- other-modules: Hint.GHC- Hint.Base- Hint.InterpreterT- Hint.Compat- Hint.CompatPlatform- Hint.Configuration- Hint.Extension- Hint.Context- Hint.Conversions- Hint.Eval- Hint.Parsers- Hint.Reflection- Hint.Typecheck- Hint.Sandbox- Hint.SignalHandlers- Hint.Util+ default-extensions: CPP - if impl(ghc >= 6.11) {- other-modules: Hint.Annotations+library+ default-language: Haskell2010+ build-depends: base == 4.*,+ containers,+ ghc >= 8.4 && < 9.15,+ ghc-paths,+ ghc-boot,+ transformers,+ filepath,+ exceptions == 0.10.*,+ random,+ directory,+ temporary++ if impl(ghc >= 8.10) {+ cpp-options: -DTHREAD_SAFE_LINKER } - hs-source-dirs: src+ if !os(windows) {+ build-depends: unix >= 2.2.0.0+ } - ghc-options: -Wall -O2- extensions: CPP- GeneralizedNewtypeDeriving- MultiParamTypeClasses- DeriveDataTypeable- MagicHash- TypeSynonymInstances- FlexibleInstances- FlexibleContexts- FunctionalDependencies- KindSignatures- Rank2Types- ScopedTypeVariables- ExistentialQuantification- PatternGuards+ 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
+ src/Control/Monad/Ghc.hs view
@@ -0,0 +1,133 @@+module 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 = GhcT . pure+ (<*>) = 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
src/Hint/Annotations.hs view
@@ -1,72 +1,43 @@--- - extract annotations from modules etc. with the GHC API.--- - requires GHC >= 6.11------ austin seipp <as@nijoruj.org>-module Hint.Annotations-( getModuleAnnotations -- :: (Data a, MonadInterpreter m) => a -> String -> m [a]-, getValAnnotations -- :: (Data a, MonadInterpreter m) => a -> String -> m [a]+module Hint.Annotations (+ getModuleAnnotations,+ getValAnnotations ) where-import Control.Monad+ import Data.Data-import Annotations-import Serialized+import GHC.Serialized import Hint.Base-import HscTypes (hsc_mod_graph, ms_mod) import qualified Hint.GHC as GHC --- | Get the annotations associated with a particular module.------ For example, given:------ @--- RBRACE-\# ANN module (1 :: Int) \#-LBRACE--- module SomeModule(g, h) where--- ...--- @------ Then after using 'loadModule' to load SomeModule into scope:------ @--- x <- getModuleAnnotations (as :: Int) "SomeModule"--- liftIO $ print x--- -- result is [1]--- @+#if MIN_VERSION_ghc(9,2,0)+import GHC (ms_mod)+import GHC.Driver.Env (hsc_mod_graph)+#elif MIN_VERSION_ghc(9,0,0)+import GHC.Driver.Types (hsc_mod_graph, ms_mod)+#else+import HscTypes (hsc_mod_graph, ms_mod)+#endif++#if MIN_VERSION_ghc(9,0,0)+import GHC.Types.Annotations+import GHC.Utils.Monad (concatMapM)+#else+import Annotations+import MonadUtils (concatMapM)+#endif++-- Get the annotations associated with a particular module. getModuleAnnotations :: (Data a, MonadInterpreter m) => a -> String -> m [a] getModuleAnnotations _ x = do- mods <- liftM hsc_mod_graph $ runGhc GHC.getSession- let x' = filter ((==) x . GHC.moduleNameString . GHC.moduleName . ms_mod) mods- v <- mapM (anns . ModuleTarget . ms_mod) x'- return $ concat v+ 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------ For example, given:------ @--- module SomeModule(g, h) where------ LBRACE-\# ANN g (Just 1 :: Maybe Int) \#-RBRACE--- g = f [f]------ LBRACE-\# ANN h (Just 2 :: Maybe Int) \#-RBRACE--- h = f--- @------ Then after using 'loadModule' to bring SomeModule into scope:------ @--- x <- liftM concat $ mapM (getValAnnotations (as :: Maybe Int)) [\"g\",\"h\"]--- liftIO $ print x--- -- result is [Just 2, Just 1]--- @------ This can also work on data constructors and types with annotations.+-- Get the annotations associated with a particular function. getValAnnotations :: (Data a, MonadInterpreter m) => a -> String -> m [a]-getValAnnotations _ x = do- x' <- runGhc1 GHC.parseName x- v <- mapM (anns . NamedTarget) x'- return $ concat v+getValAnnotations _ s = do+ names <- runGhc $ GHC.parseName s+ concatMapM (anns . NamedTarget) names anns :: (MonadInterpreter m, Data a) => AnnTarget GHC.Name -> m [a]-anns = runGhc1 (GHC.findGlobalAnns deserializeWithData)+anns target = runGhc $ GHC.findGlobalAnns deserializeWithData target
src/Hint/Base.hs view
@@ -1,43 +1,38 @@ module Hint.Base ( MonadInterpreter(..), RunGhc,- --+ GhcError(..), InterpreterError(..), mayFail, catchIE,- --- InterpreterSession, SessionData(..), GhcErrLogger,++ InterpreterSession, SessionData(..), InterpreterState(..), fromState, onState, InterpreterConfiguration(..),- --- runGhc1, runGhc2, runGhc3, runGhc4, runGhc5,- --+ ImportList(..), ModuleQualification(..), ModuleImport(..),+ ModuleName, PhantomModule(..), findModule, moduleIsLoaded, withDynFlags,- --+ ghcVersion,- --- debug, showGHC-) -where+ debug, showGHC+) where -import Control.Monad.Trans+import Control.Monad.IO.Class import Control.Monad.Catch as MC import Data.IORef import Data.Dynamic+import qualified Data.List import qualified Hint.GHC as GHC import Hint.Extension-import Hint.Compat as Compat -- | Version of the underlying ghc api. Values are: ----- * @606@ for GHC 6.6.x------ * @608@ for GHC 6.8.x+-- * @804@ for GHC 8.4.x ----- * @610@ for GHC 6.10.x+-- * @806@ for GHC 8.6.x -- -- * etc... ghcVersion :: Int@@ -52,7 +47,6 @@ 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@@ -61,80 +55,53 @@ | GhcException String deriving (Show, Typeable) -data InterpreterState = St{active_phantoms :: [PhantomModule],- zombie_phantoms :: [PhantomModule],- hint_support_module :: PhantomModule,- import_qual_hack_mod :: Maybe PhantomModule,- qual_imports :: [(ModuleName, String)],- defaultExts :: [(Extension,Bool)], -- R/O- configuration :: InterpreterConfiguration}--data InterpreterConfiguration = Conf {- search_path :: [FilePath],- language_exts :: [Extension],- all_mods_in_scope :: Bool- }--#if __GLASGOW_HASKELL__ < 610-type InterpreterSession = SessionData GHC.Session--adjust :: (a -> b -> c) -> (b -> a -> c)-adjust f = flip f+data InterpreterState = St {+ activePhantoms :: [PhantomModule],+ zombiePhantoms :: [PhantomModule],+ phantomDirectory :: Maybe FilePath,+ hintSupportModule :: PhantomModule,+ importQualHackMod :: Maybe PhantomModule,+ qualImports :: [ModuleImport],+ defaultExts :: [(Extension, Bool)], -- R/O+ configuration :: InterpreterConfiguration+ } -type RunGhc m a = (GHC.Session -> IO a)- -> m a-type RunGhc1 m a b = (GHC.Session -> a -> IO b)- -> (a -> m b)-type RunGhc2 m a b c = (GHC.Session -> a -> b -> IO c)- -> (a -> b -> m c)-type RunGhc3 m a b c d = (GHC.Session -> a -> b -> c -> IO d)- -> (a -> b -> c -> m d)+data ImportList = NoImportList | ImportList [String] | HidingList [String]+ deriving (Eq, Show)+data ModuleQualification = NotQualified | ImportAs String | QualifiedAs (Maybe String)+ deriving (Eq, Show) -type RunGhc4 m a b c d e = (GHC.Session -> a -> b -> c -> d -> IO e)- -> (a -> b -> c -> d -> m e)+-- | Represent module import statement.+-- See 'setImportsF'+data ModuleImport = ModuleImport { modName :: String+ , modQual :: ModuleQualification+ , modImp :: ImportList+ } deriving (Show) -type RunGhc5 m a b c d e f = (GHC.Session -> a -> b -> c -> d -> e -> IO f)- -> (a -> b -> c -> d -> e -> m f)+data InterpreterConfiguration = Conf {+ searchFilePath :: [FilePath],+ languageExts :: [Extension],+ allModsInScope :: Bool+ } -#else- -- ghc >= 6.10 type InterpreterSession = SessionData () instance Exception InterpreterError--adjust :: (a -> b) -> (a -> b)-adjust = id+ 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,Functor n) => GHC.GhcT n a)+ (forall n.(MonadIO n, MonadMask n) => GHC.GhcT n a) -> m a -type RunGhc1 m a b =- (forall n.(MonadIO n, MonadMask n, Functor n) => a -> GHC.GhcT n b)- -> (a -> m b)--type RunGhc2 m a b c =- (forall n.(MonadIO n, MonadMask n, Functor n) => a -> b -> GHC.GhcT n c)- -> (a -> b -> m c)--type RunGhc3 m a b c d =- (forall n.(MonadIO n, MonadMask n, Functor n) => a -> b -> c -> GHC.GhcT n d)- -> (a -> b -> c -> m d)--type RunGhc4 m a b c d e =- (forall n.(MonadIO n, MonadMask n, Functor n) => a -> b -> c -> d -> GHC.GhcT n e)- -> (a -> b -> c -> d -> m e)--type RunGhc5 m a b c d e f =- (forall n.(MonadIO n, MonadMask n, Functor n) => a->b->c->d->e->GHC.GhcT n f)- -> (a -> b -> c -> d -> e -> m f)-#endif- data SessionData a = SessionData { internalState :: IORef InterpreterState, versionSpecific :: a, ghcErrListRef :: IORef [GhcError],- ghcErrLogger :: GhcErrLogger+ ghcLogger :: GHC.Logger } -- When intercepting errors reported by GHC, we only get a ErrUtils.Message@@ -150,52 +117,26 @@ -> m a -> m a mapGhcExceptions buildEx action =- do action- `MC.catch` (\err -> case err of- GhcException s -> throwM (buildEx s)- _ -> throwM err)+ 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 --#if __GLASGOW_HASKELL__ < 704-type GhcErrLogger = GHC.Severity- -> GHC.SrcSpan- -> GHC.PprStyle- -> GHC.Message- -> IO ()-#else-type GhcErrLogger = GHC.LogAction-#endif- -- | Module names are _not_ filepaths. type ModuleName = String -runGhc1 :: MonadInterpreter m => RunGhc1 m a b-runGhc1 f a = runGhc (adjust f a)--runGhc2 :: MonadInterpreter m => RunGhc2 m a b c-runGhc2 f a = runGhc1 (adjust f a)--runGhc3 :: MonadInterpreter m => RunGhc3 m a b c d-runGhc3 f a = runGhc2 (adjust f a)--runGhc4 :: MonadInterpreter m => RunGhc4 m a b c d e-runGhc4 f a = runGhc3 (adjust f a)--runGhc5 :: MonadInterpreter m => RunGhc5 m a b c d e f-runGhc5 f a = runGhc4 (adjust f a)-- -- ================ Handling the interpreter state ================= fromState :: MonadInterpreter m => (InterpreterState -> a) -> m a-fromState f = do ref_st <- fromSession internalState- liftIO $ f `fmap` readIORef ref_st+fromState f = do+ ref_st <- fromSession internalState+ liftIO $ f <$> readIORef ref_st onState :: MonadInterpreter m => (InterpreterState -> InterpreterState) -> m ()-onState f = modifySessionRef internalState f >> return ()+onState f = () <$ modifySessionRef internalState f -- =============== Error handling ============================== @@ -207,11 +148,9 @@ 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, True) -> return a- (Just _, False) -> fail $ "GHC returned a result but said: " ++- show es+ (Nothing, True) -> throwM $ UnknownError "Got no error message"+ (Nothing, False) -> throwM $ WontCompile (reverse es)+ (Just a, _) -> return a -- ================= Debugging stuff =============== @@ -222,27 +161,28 @@ showGHC a = do unqual <- runGhc GHC.getPrintUnqual withDynFlags $ \df ->- return $ Compat.showSDocForUser df unqual (GHC.ppr a)+ -- 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{pm_name :: ModuleName, pm_file :: FilePath}+data PhantomModule = PhantomModule{pmName :: ModuleName, pmFile :: FilePath} deriving (Eq, Show) findModule :: MonadInterpreter m => ModuleName -> m GHC.Module findModule mn = mapGhcExceptions NotAllowed $- runGhc2 GHC.findModule mod_name Nothing+ runGhc $ GHC.findModule mod_name Nothing where mod_name = GHC.mkModuleName mn - moduleIsLoaded :: MonadInterpreter m => ModuleName -> m Bool-moduleIsLoaded mn = (findModule mn >> return True)+moduleIsLoaded mn = (True <$ findModule mn) `catchIE` (\e -> case e of- NotAllowed{} -> return False- _ -> throwM e)+ NotAllowed{} -> return False+ WontCompile{} -> return False+ _ -> throwM e) withDynFlags :: MonadInterpreter m => (GHC.DynFlags -> m a) -> m a-withDynFlags action- = do df <- runGhc GHC.getSessionDynFlags- action df+withDynFlags action = do+ df <- runGhc GHC.getSessionDynFlags+ action df
− src/Hint/Compat.hs
@@ -1,257 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}-module Hint.Compat--where--#if __GLASGOW_HASKELL__ < 702-import Control.Monad.Trans (liftIO)-#endif--#if __GLASGOW_HASKELL__ >= 704-import Control.Monad (foldM, liftM)-#endif--import qualified Hint.GHC as GHC---- Kinds became a synonym for Type in GHC 6.8. We define this wrapper--- to be able to define a FromGhcRep instance for both versions-newtype Kind = Kind GHC.Kind--#if __GLASGOW_HASKELL__ >= 700--- supportedLanguages :: [String]-supportedExtensions = map f GHC.xFlags- where-#if (__GLASGOW_HASKELL__ >= 710)- f = GHC.flagSpecName-#elif (__GLASGOW_HASKELL__ < 702) || (__GLASGOW_HASKELL__ >= 704)- f (e,_,_) = e-#else- f (e,_,_,_) = e-#endif--#if __GLASGOW_HASKELL__ < 702--- setContext :: GHC.GhcMonad m => [GHC.Module] -> [GHC.Module] -> m ()-setContext xs = GHC.setContext xs . map (\y -> (y,Nothing))--getContext :: GHC.GhcMonad m => m ([GHC.Module], [GHC.Module])-getContext = fmap (\(as,bs) -> (as,map fst bs)) GHC.getContext-#elif __GLASGOW_HASKELL__ < 704--- Keep setContext/getContext unmodified for use where the results of getContext--- are simply restored by setContext, in which case we don't really care about the--- particular type of b.---- setContext :: GHC.GhcMonad m => [GHC.Module] -> [b] -> m ()-setContext = GHC.setContext---- getContext :: GHC.GhcMonad m => m ([GHC.Module], [b])-getContext = GHC.getContext-#else-setContext :: GHC.GhcMonad m => [GHC.Module] -> [GHC.ImportDecl GHC.RdrName] -> m ()-setContext ms ds =- let ms' = map modToIIMod ms- ds' = map GHC.IIDecl ds- is = ms' ++ ds'- in GHC.setContext is--getContext :: GHC.GhcMonad m => m ([GHC.Module], [GHC.ImportDecl GHC.RdrName])-getContext = GHC.getContext >>= foldM f ([], [])- where- f :: (GHC.GhcMonad m) =>- ([GHC.Module], [GHC.ImportDecl GHC.RdrName]) ->- GHC.InteractiveImport ->- m ([GHC.Module], [GHC.ImportDecl GHC.RdrName])- f (ns, ds) i = case i of- (GHC.IIDecl d) -> return (ns, (d:ds))- m@(GHC.IIModule _) -> do n <- iiModToMod m; return ((n:ns), ds)---modToIIMod :: GHC.Module -> GHC.InteractiveImport-iiModToMod :: GHC.GhcMonad m => GHC.InteractiveImport -> m GHC.Module-#if __GLASGOW_HASKELL__ < 706-modToIIMod = GHC.IIModule-iiModToMod (GHC.IIModule m) = return m-#else-modToIIMod = GHC.IIModule . GHC.moduleName-iiModToMod (GHC.IIModule m) = GHC.findModule m Nothing-#endif-iiModToMod _ = error "iiModToMod!"--#endif--mkPState = GHC.mkPState--#else--- supportedExtensions :: [String]-supportedExtensions = GHC.supportedLanguages---- setContext :: GHC.GhcMonad m => [GHC.Module] -> [GHC.Module] -> m ()--- i don't want to check the signature on every ghc version....-setContext = GHC.setContext--getContext = GHC.getContext--mkPState df buf loc = GHC.mkPState buf loc df-#endif---- Explicitly-typed variants of getContext/setContext, for use where we modify--- or override the context.-#if __GLASGOW_HASKELL__ < 702-setContextModules :: GHC.GhcMonad m => [GHC.Module] -> [GHC.Module] -> m ()-setContextModules = setContext--getContextNames :: GHC.GhcMonad m => m([String], [String])-getContextNames = fmap (\(as,bs) -> (map name as, map name bs)) getContext- where name = GHC.moduleNameString . GHC.moduleName-#else-setContextModules :: GHC.GhcMonad m => [GHC.Module] -> [GHC.Module] -> m ()-setContextModules as = setContext as . map (GHC.simpleImportDecl . GHC.moduleName)--getContextNames :: GHC.GhcMonad m => m([String], [String])-getContextNames = fmap (\(as,bs) -> (map name as, map decl bs)) getContext- where name = GHC.moduleNameString . GHC.moduleName- decl = GHC.moduleNameString . GHC.unLoc . GHC.ideclName-#endif--#if __GLASGOW_HASKELL__ < 702-mkSrcLoc = GHC.mkSrcLoc-stringToStringBuffer = liftIO . GHC.stringToStringBuffer-#else-mkSrcLoc = GHC.mkRealSrcLoc-stringToStringBuffer = return . GHC.stringToStringBuffer-#endif--#if __GLASGOW_HASKELL__ >= 610-configureDynFlags :: GHC.DynFlags -> GHC.DynFlags-configureDynFlags dflags = dflags{GHC.ghcMode = GHC.CompManager,- GHC.hscTarget = GHC.HscInterpreted,- GHC.ghcLink = GHC.LinkInMemory,- GHC.verbosity = 0}--parseDynamicFlags :: GHC.GhcMonad m- => GHC.DynFlags -> [String] -> m (GHC.DynFlags, [String])-parseDynamicFlags d = fmap firstTwo . GHC.parseDynamicFlags d . map GHC.noLoc- where firstTwo (a,b,_) = (a, map GHC.unLoc b)--fileTarget :: FilePath -> GHC.Target-fileTarget f = GHC.Target (GHC.TargetFile f $ Just next_phase) True Nothing- where next_phase = GHC.Cpp GHC.HsSrcFile--targetId :: GHC.Target -> GHC.TargetId-targetId = GHC.targetId--guessTarget :: GHC.GhcMonad m => String -> Maybe GHC.Phase -> m GHC.Target-guessTarget = GHC.guessTarget---- 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---- 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---- add a bogus Maybe, in order to use it with mayFail-#if __GLASGOW_HASKELL__ < 704-typeKind :: GHC.GhcMonad m => String -> m (Maybe GHC.Kind)-typeKind = fmap Just . GHC.typeKind-#else-typeKind :: GHC.GhcMonad m => String -> m (Maybe GHC.Kind)-typeKind = fmap Just . (liftM snd) . (GHC.typeKind True)-#endif-#else--- add a bogus session parameter, in order to use it with runGhc2-parseDynamicFlags :: GHC.Session- -> GHC.DynFlags- -> [String] -> IO (GHC.DynFlags, [String])-parseDynamicFlags = const GHC.parseDynamicFlags--fileTarget :: FilePath -> GHC.Target-fileTarget f = GHC.Target (GHC.TargetFile f $ Just next_phase) Nothing- where next_phase = GHC.Cpp GHC.HsSrcFile--targetId :: GHC.Target -> GHC.TargetId-targetId (GHC.Target _id _) = _id---- add a bogus session parameter, in order to use it with runGhc2-guessTarget :: GHC.Session -> String -> Maybe GHC.Phase -> IO GHC.Target-guessTarget = const GHC.guessTarget--compileExpr :: GHC.Session -> String -> IO (Maybe GHC.HValue)-compileExpr = GHC.compileExpr--exprType :: GHC.Session -> String -> IO (Maybe GHC.Type)-exprType = GHC.exprType--typeKind :: GHC.Session -> String -> IO (Maybe GHC.Kind)-typeKind = GHC.typeKind--#endif--#if __GLASGOW_HASKELL__ >= 608-#if __GLASGOW_HASKELL__ < 610- -- 6.08 only-newSession :: FilePath -> IO GHC.Session-newSession ghc_root = GHC.newSession (Just ghc_root)--configureDynFlags :: GHC.DynFlags -> GHC.DynFlags-configureDynFlags dflags = dflags{GHC.ghcMode = GHC.CompManager,- GHC.hscTarget = GHC.HscInterpreted,- GHC.ghcLink = GHC.LinkInMemory}-#endif--#if __GLASGOW_HASKELL__ < 701- -- 6.08 - 7.0.4-pprType :: GHC.Type -> (GHC.PprStyle -> GHC.Doc)-pprType = GHC.pprTypeForUser False -- False means drop explicit foralls--pprKind :: GHC.Kind -> (GHC.PprStyle -> GHC.Doc)-pprKind = pprType-#else- -- 7.2.1 and above--pprType :: GHC.Type -> GHC.SDoc-#if __GLASGOW_HASKELL__ < 708-pprType = GHC.pprTypeForUser False -- False means drop explicit foralls-#else-pprType = GHC.pprTypeForUser-#endif--pprKind :: GHC.Kind -> GHC.SDoc-pprKind = pprType-#endif--#elif __GLASGOW_HASKELL__ >= 606- -- 6.6 only--newSession :: FilePath -> IO GHC.Session-newSession ghc_root = GHC.newSession GHC.Interactive (Just ghc_root)--configureDynFlags :: GHC.DynFlags -> GHC.DynFlags-configureDynFlags dflags = dflags{GHC.hscTarget = GHC.HscInterpreted}--pprType :: GHC.Type -> (GHC.PprStyle -> GHC.Doc)-pprType = GHC.ppr . GHC.dropForAlls--pprKind :: GHC.Kind -> (GHC.PprStyle -> GHC.Doc)-pprKind = GHC.ppr--#endif--#if __GLASGOW_HASKELL__ >= 706-showSDoc = GHC.showSDoc-showSDocForUser = GHC.showSDocForUser-showSDocUnqual = GHC.showSDocUnqual-#else- -- starting from ghc 7.6, they started to receive a DynFlags argument (sigh)-showSDoc _ = GHC.showSDoc-showSDocForUser _ = GHC.showSDocForUser-showSDocUnqual _ = GHC.showSDocUnqual-#endif---#if __GLASGOW_HASKELL__ >= 706-mkLocMessage = GHC.mkLocMessage GHC.SevError-#else-mkLocMessage = GHC.mkLocMessage-#endif
src/Hint/CompatPlatform.hs view
@@ -1,26 +1,20 @@ #if defined(mingw32_HOST_OS) || defined(__MINGW32__) {-# LANGUAGE ForeignFunctionInterface #-} #endif-module Hint.CompatPlatform- (+module Hint.CompatPlatform ( getPID- )--where+) 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@@ -31,12 +25,7 @@ foreign import stdcall unsafe "winbase.h GetCurrentProcessId" c_GetCurrentProcessId :: IO Word32 -getPID :: IO Int getPID = fromIntegral <$> c_GetCurrentProcessId- #else--getPID :: IO Int getPID = fromIntegral <$> getProcessID- #endif
src/Hint/Configuration.hs view
@@ -1,41 +1,41 @@ module Hint.Configuration (- setGhcOption, setGhcOptions, - defaultConf, fromConf, onConf,+ defaultConf, get, set, Option, OptionVal(..), - languageExtensions, availableExtensions, glasgowExtensions, Extension(..),+ languageExtensions, availableExtensions, Extension(..), installedModulesInScope, - setUseLanguageExtensions,+ searchPath, - setInstalledModsAreInScopeQualified,- searchPath- ) where+ configureDynFlags, parseDynamicFlags, +) where+ import Control.Monad import Control.Monad.Catch import Data.Char-import Data.List ( intersect, intercalate )+import Data.Maybe (maybe)+import Data.List (intercalate) import qualified Hint.GHC as GHC-import qualified Hint.Compat as Compat import Hint.Base-import Hint.Util ( quote )+import Hint.Util (quote) import Hint.Extension setGhcOptions :: MonadInterpreter m => [String] -> m () setGhcOptions opts = do old_flags <- runGhc GHC.getSessionDynFlags- (new_flags,not_parsed) <- runGhc2 Compat.parseDynamicFlags old_flags opts- when (not . null $ not_parsed) $+ logger <- fromSession ghcLogger+ (new_flags,not_parsed) <- runGhc $ parseDynamicFlags logger old_flags opts+ unless (null not_parsed) $ throwM $ UnknownError $ concat ["flags: ", unwords $ map quote not_parsed, "not recognized"]- _ <- runGhc1 GHC.setSessionDynFlags new_flags+ _ <- runGhc $ GHC.setSessionDynFlags new_flags return () setGhcOption :: MonadInterpreter m => String -> m ()@@ -43,12 +43,11 @@ defaultConf :: InterpreterConfiguration defaultConf = Conf {- language_exts = [],- all_mods_in_scope = False,- search_path = ["."]+ languageExts = [],+ allModsInScope = False,+ searchFilePath = ["."] } - -- | Available options are: -- -- * 'languageExtensions'@@ -56,8 +55,10 @@ -- * 'installedModulesInScope' -- -- * 'searchPath'-data Option m a = Option{_set :: MonadInterpreter m => a -> m (),- _get :: MonadInterpreter m => m a}+data Option m a = Option{+ _set :: MonadInterpreter m => a -> m (),+ _get :: MonadInterpreter m => m a+ } data OptionVal m = forall a . (Option m a) := a @@ -70,7 +71,7 @@ -- | Retrieves the value of an option. get :: MonadInterpreter m => Option m a -> m a-get = _get+get = \o -> _get o -- | Language extensions in use by the interpreter. --@@ -78,13 +79,13 @@ languageExtensions :: MonadInterpreter m => Option m [Extension] languageExtensions = Option setter getter where setter es = do resetExtensions- setGhcOptions $ map (extFlag True) es- onConf $ \c -> c{language_exts = es}+ setGhcOptions $ map (extFlag True) es+ onConf $ \c -> c{languageExts = es} --- getter = fromConf language_exts+ getter = fromConf languageExts -- resetExtensions = do es <- fromState defaultExts- setGhcOptions $ map (uncurry $ flip extFlag) es+ setGhcOptions $ uncurry (flip extFlag) <$> es extFlag :: Bool -> Extension -> String extFlag = mkFlag@@ -95,46 +96,6 @@ | isUpper c = "-X" ++ drop (if b then 0 else 2) o strToFlag b o = "-X" ++ concat ["No"|not b] ++ o ----- | List of extensions turned on when the @-fglasgow-exts@ flag is used-{-# DEPRECATED glasgowExtensions "glasgowExtensions list is no longer maintained, will be removed soon" #-}-glasgowExtensions :: [Extension]-glasgowExtensions = intersect availableExtensions exts612 -- works also for 608 and 610- where exts612 = map asExtension ["PrintExplicitForalls",- "ForeignFunctionInterface",- "UnliftedFFITypes",- "GADTs",- "ImplicitParams",- "ScopedTypeVariables",- "UnboxedTuples",- "TypeSynonymInstances",- "StandaloneDeriving",- "DeriveDataTypeable",- "FlexibleContexts",- "FlexibleInstances",- "ConstrainedClassMethods",- "MultiParamTypeClasses",- "FunctionalDependencies",- "MagicHash",- "PolymorphicComponents",- "ExistentialQuantification",- "UnicodeSyntax",- "PostfixOperators",- "PatternGuards",- "LiberalTypeSynonyms",- "ExplicitForAll",- "RankNTypes",- "ImpredicativeTypes",- "TypeOperators",- "RecursiveDo",- "DoRec",- "ParallelListComp",- "EmptyDataDecls",- "KindSignatures",- "GeneralizedNewtypeDeriving",- "TypeFamilies" ]- -- | 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@@ -146,12 +107,11 @@ -- private symbols in interpreted modules will not be in scope. installedModulesInScope :: MonadInterpreter m => Option m Bool installedModulesInScope = Option setter getter- where getter = fromConf all_mods_in_scope- setter b = do onConf $ \c -> c{all_mods_in_scope = b}- when ( ghcVersion >= 610 ) $- setGhcOption $ "-f" ++- concat ["no-" | not b] ++- "implicit-import-qualified"+ 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 @[\".\"]@.@@ -159,11 +119,14 @@ -- 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 search_path- setter p = do onConf $ \c -> c{search_path = p}- setGhcOption $ "-i" -- clear the old path+ 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)@@ -173,12 +136,16 @@ -> m () onConf f = onState $ \st -> st{configuration = f (configuration st)} -{-# DEPRECATED setUseLanguageExtensions "Use set [languageExtensions := (ExtendedDefaultRules:glasgowExtensions)] instead." #-}-setUseLanguageExtensions :: MonadInterpreter m => Bool -> m ()-setUseLanguageExtensions False = set [languageExtensions := []]-setUseLanguageExtensions True = set [languageExtensions := exts]- where exts = ExtendedDefaultRules : glasgowExtensions+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} -{-# DEPRECATED setInstalledModsAreInScopeQualified "Use set [installedModulesInScope := b] instead." #-}-setInstalledModsAreInScopeQualified :: MonadInterpreter m => Bool -> m ()-setInstalledModsAreInScopeQualified b = set [installedModulesInScope := b]+parseDynamicFlags :: GHC.GhcMonad m+ => GHC.Logger -> GHC.DynFlags -> [String] -> m (GHC.DynFlags, [String])+parseDynamicFlags l d = fmap firstTwo . GHC.parseDynamicFlags l d . map GHC.noLoc+ where firstTwo (a,b,_) = (a, map GHC.unLoc b)
src/Hint/Context.hs view
@@ -1,35 +1,29 @@ module Hint.Context (-- ModuleName, isModuleInterpreted,+ isModuleInterpreted, loadModules, getLoadedModules, setTopLevelModules,- setImports, setImportsQ,+ setImports, setImportsQ, setImportsF, reset, - PhantomModule(..), ModuleText,- addPhantomModule, removePhantomModule, getPhantomModules,+ PhantomModule(..), cleanPhantomModules, - allModulesInContext, onAnEmptyContext,-- support_String, support_show-)--where+ supportString, supportShow+) where -import Prelude hiding ( mod )+import Prelude hiding (mod) import Data.Char+import Data.Either (partitionEithers) import Data.List -import Control.Monad ( liftM, filterM, when, guard )-import Control.Monad.Trans ( liftIO )+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.Util ( (>=>) ) -- compat version import Hint.Conversions-import qualified Hint.Util as Util-import qualified Hint.Compat as Compat import qualified Hint.CompatPlatform as Compat import qualified Hint.GHC as GHC@@ -38,6 +32,9 @@ import System.FilePath import System.Directory +import Hint.Configuration (setGhcOption)+import System.IO.Temp+ type ModuleText = String -- When creating a phantom module we have a situation similar to that of@@ -56,33 +53,81 @@ let nums = concat [show (abs n::Int), show p, filter isDigit $ concat (ls ++ is)] let mod_name = 'M':nums --- tmp_dir <- liftIO getTemporaryDirectory+ tmp_dir <- getPhantomDirectory --- return PhantomModule{pm_name = mod_name, pm_file = tmp_dir </> nums}+ return PhantomModule{pmName = mod_name, pmFile = tmp_dir </> mod_name <.> "hs"} +getPhantomDirectory :: MonadInterpreter m => m FilePath+getPhantomDirectory =+ -- When a module is loaded by file name, ghc-8.4.1 loses track of the+ -- file location after the first time it has been loaded, so we create+ -- a directory for the phantom modules and add it to the search path.+ do mfp <- fromState phantomDirectory+ case mfp of+ Just fp -> return fp+ Nothing -> do tmp_dir <- liftIO getTemporaryDirectory+ fp <- liftIO $ createTempDirectory tmp_dir "hint"+ onState (\s -> s{ phantomDirectory = Just fp })+ setGhcOption $ "-i" ++ fp+ return fp+ allModulesInContext :: MonadInterpreter m => m ([ModuleName], [ModuleName])-allModulesInContext = runGhc Compat.getContextNames+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)+ _ -> do+ mMod <- GHC.interactiveImportToModule i+ case mMod of+ Just n -> return (n : ns, ds)+ Nothing -> return (ns, ds)++getContextNames :: GHC.GhcMonad m => m([String], [String])+getContextNames = fmap (map name *** map decl) getContext+ where name = GHC.moduleNameString . GHC.moduleName+ decl = GHC.moduleNameString . GHC.unLoc . GHC.ideclName++setContext :: GHC.GhcMonad m => [GHC.Module] -> [GHC.ImportDecl GHC.GhcPs] -> m ()+setContext ms ds =+ let ms' = map GHC.moduleToInteractiveImport 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- let t = Compat.fileTarget (pm_file pm)- m = GHC.mkModuleName (pm_name pm)+ df <- runGhc GHC.getSessionDynFlags+ let t = GHC.fileTarget df (pmFile pm) --- liftIO $ writeFile (pm_file pm) (mod_text $ pm_name pm)+ liftIO $ writeFile (pmFile pm) (mod_text $ pmName pm) --- onState (\s -> s{active_phantoms = pm:active_phantoms s})- mayFail (do -- GHC.load will remove all the modules from scope, so first- -- we save the context...- (old_top, old_imps) <- runGhc Compat.getContext+ 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 --- runGhc1 GHC.addTarget t- res <- runGhc1 GHC.load (GHC.LoadUpTo m)+ runGhc $ GHC.addTarget t+ res <- runGhc $ GHC.load GHC.LoadAllTargets -- if isSucceeded res- then do runGhc2 Compat.setContext old_top old_imps+ then do runGhc $ setContext old_top old_imps return $ Just () else return Nothing) `catchIE` (\err -> case err of@@ -92,7 +137,7 @@ -- return pm -removePhantomModule :: MonadInterpreter m => PhantomModule -> m ()+removePhantomModule :: forall m. MonadInterpreter m => PhantomModule -> m () removePhantomModule pm = do -- We don't want to actually unload this module, because that -- would mean that all the real modules might get reloaded and the@@ -102,45 +147,49 @@ -- and mark it as "delete me when possible" (i.e., next time the -- @loadModules@ function is called). --- isLoaded <- moduleIsLoaded $ pm_name pm+ isLoaded <- moduleIsLoaded $ pmName pm safeToRemove <- if isLoaded then do -- take it out of scope- mod <- findModule (pm_name pm)- (mods, imps) <- runGhc Compat.getContext+ mod <- findModule (pmName pm)+ (mods, imps) <- runGhc getContext let mods' = filter (mod /=) mods- runGhc2 Compat.setContext mods' imps+ runGhc $ setContext mods' imps --- let isNotPhantom = isPhantomModule . moduleToString >=>- return . not- null `liftM` filterM isNotPhantom mods'+ let isNotPhantom :: GHC.Module -> m Bool+ isNotPhantom mod' = do+ not <$> isPhantomModule (moduleToString mod')+ null <$> filterM isNotPhantom mods' else return True --- let file_name = pm_file pm- runGhc1 GHC.removeTarget (Compat.targetId $ Compat.fileTarget file_name)+ let file_name = pmFile pm+ runGhc $ do df <- GHC.getSessionDynFlags+ GHC.removeTarget (GHC.targetId $ GHC.fileTarget df file_name) --- onState (\s -> s{active_phantoms = filter (pm /=) $ active_phantoms s})+ onState (\s -> s{activePhantoms = filter (pm /=) $ activePhantoms s}) -- if safeToRemove- then do mayFail $ do res <- runGhc1 GHC.load GHC.LoadAllTargets- return $ guard (isSucceeded res) >> Just ()- liftIO $ removeFile (pm_file pm)- else do onState (\s -> s{zombie_phantoms = pm:zombie_phantoms s})- return ()+ 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 active_phantoms- zombie <- fromState zombie_phantoms+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 pm_name $ as ++ zs)+ 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.+-- 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.@@ -165,36 +214,33 @@ 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 fs `catchIE` (\e -> reset >> throwM e) doLoad :: MonadInterpreter m => [String] -> m ()-doLoad fs = do mayFail $ do- targets <- mapM (\f->runGhc2 Compat.guessTarget f Nothing) fs- --- runGhc1 GHC.setTargets targets- res <- runGhc1 GHC.load GHC.LoadAllTargets- -- loading the targets removes the support module- reinstallSupportModule- return $ guard (isSucceeded res) >> Just ()+doLoad fs = do targets <- mapM (\f->runGhc $ GHC.guessTarget f Nothing) fs+ --+ reinstallSupportModule targets -- | Returns True if the module was interpreted. isModuleInterpreted :: MonadInterpreter m => ModuleName -> m Bool-isModuleInterpreted m = findModule m >>= runGhc1 GHC.moduleIsInterpreted+isModuleInterpreted moduleName = do+ mod <- findModule moduleName+ runGhc $ GHC.moduleIsInterpreted mod -- | Returns the list of modules loaded with 'loadModules'. getLoadedModules :: MonadInterpreter m => m [ModuleName] getLoadedModules = do (active_pms, zombie_pms) <- getPhantomModules- ms <- map modNameFromSummary `liftM` getLoadedModSummaries- return $ ms \\ (map pm_name $ active_pms ++ zombie_pms)+ ms <- map modNameFromSummary <$> getLoadedModSummaries+ return $ ms \\ map pmName (active_pms ++ zombie_pms) modNameFromSummary :: GHC.ModSummary -> ModuleName-modNameFromSummary = moduleToString . GHC.ms_mod+modNameFromSummary = moduleToString . GHC.ms_mod getLoadedModSummaries :: MonadInterpreter m => m [GHC.ModSummary]-getLoadedModSummaries =- do all_mod_summ <- runGhc GHC.getModuleGraph- filterM (runGhc1 GHC.isLoaded . GHC.ms_mod_name) all_mod_summ+getLoadedModSummaries = do+ modGraph <- runGhc GHC.getModuleGraph+ let modSummaries = GHC.mgModSummaries modGraph+ filterM (\modl -> runGhc $ GHC.isLoaded $ GHC.ms_mod_name modl) modSummaries -- | Sets the modules whose context is used during evaluation. All bindings -- of these modules are in scope, not only those exported.@@ -205,74 +251,96 @@ do loaded_mods_ghc <- getLoadedModSummaries -- let not_loaded = ms \\ map modNameFromSummary loaded_mods_ghc- when (not . null $ not_loaded) $+ unless (null not_loaded) $ throwM $ NotAllowed ("These modules have not been loaded:\n" ++ unlines not_loaded) --- active_pms <- fromState active_phantoms- ms_mods <- mapM findModule (nub $ ms ++ map pm_name active_pms)+ active_pms <- fromState activePhantoms+ ms_mods <- mapM findModule (nub $ ms ++ map pmName active_pms) --- let mod_is_interpr = runGhc1 GHC.moduleIsInterpreted- not_interpreted <- filterM (liftM not . mod_is_interpr) ms_mods- when (not . null $ not_interpreted) $+ 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 Compat.getContext- runGhc2 Compat.setContext ms_mods old_imports--onAnEmptyContext :: MonadInterpreter m => m a -> m a-onAnEmptyContext action =- do (old_mods, old_imps) <- runGhc Compat.getContext- runGhc2 Compat.setContext [] []- let restore = runGhc2 Compat.setContext old_mods old_imps- a <- action `catchIE` (\e -> do restore; throwM e)- restore- return a+ (_, old_imports) <- runGhc getContext+ runGhc $ setContext ms_mods old_imports --- | Sets the modules whose exports must be in context.+-- | Sets the modules whose exports must be in context. These can be modules+-- previously loaded with 'loadModules', or modules from packages which hint is+-- aware of. This includes package databases specified to+-- 'unsafeRunInterpreterWithArgs' by the @-package-db=...@ parameter, and+-- packages specified by a ghc environment file created by @cabal build --write-ghc-environment-files=always@. ----- Warning: 'setImports' and 'setImportsQ' are mutually exclusive.+-- Warning: 'setImports', 'setImportsQ', and 'setImportsF' are mutually exclusive. -- If you have a list of modules to be used qualified and another list -- unqualified, then you need to do something like -- -- > setImportsQ ((zip unqualified $ repeat Nothing) ++ qualifieds) setImports :: MonadInterpreter m => [ModuleName] -> m ()-setImports ms = setImportsQ $ zip ms (repeat Nothing)+setImports ms = setImportsF $ map (\m -> ModuleImport m NotQualified NoImportList) ms --- | Sets the modules whose exports must be in context; some--- of them may be qualified. E.g.:+-- | A variant of 'setImports' where modules them may be qualified. e.g.: -- -- @setImportsQ [("Prelude", Nothing), ("Data.Map", Just "M")]@. -- -- Here, "map" will refer to Prelude.map and "M.map" to Data.Map.map. setImportsQ :: MonadInterpreter m => [(ModuleName, Maybe String)] -> m ()-setImportsQ ms =- do let qualOrNot = \(a,mb) -> maybe (Right a) (Left . (,) a) mb- (quals,unquals) = Util.partitionEither $ map qualOrNot ms- --- unqual_mods <- mapM findModule unquals- mapM_ (findModule . fst) quals -- just to be sure they exist+setImportsQ ms = setImportsF $ map (\(m,q) -> ModuleImport m (maybe NotQualified (QualifiedAs . Just) q) NoImportList) ms++-- | A variant of 'setImportsQ' where modules may have an explicit import list. e.g.:+--+-- @setImportsF [ModuleImport "Prelude" NotQualified NoImportList, ModuleImport "Data.Text" (QualifiedAs $ Just "Text") (HidingList ["pack"])]@++setImportsF :: MonadInterpreter m => [ModuleImport] -> m ()+setImportsF moduleImports = do+ regularMods <- mapM (findModule . modName) regularImports+ mapM_ (findModule . modName) phantomImports -- just to be sure they exist --- old_qual_hack_mod <- fromState import_qual_hack_mod+ old_qual_hack_mod <- fromState importQualHackMod maybe (return ()) removePhantomModule old_qual_hack_mod --- new_pm <- if ( not $ null quals )- then do- new_pm <- addPhantomModule $ \mod_name -> unlines $- ("module " ++ mod_name ++ " where ") :- ["import qualified " ++ m ++ " as " ++ n |- (m,n) <- quals]- onState (\s -> s{import_qual_hack_mod = Just new_pm})- return $ Just new_pm- else return Nothing+ maybe_phantom_module <- do+ if null phantomImports+ then return Nothing+ else do+ let moduleContents = map newImportLine phantomImports+ new_phantom_module <- addPhantomModule $ \mod_name+ -> unlines $ ("module " ++ mod_name ++ " where ")+ : moduleContents+ onState (\s -> s{importQualHackMod = Just new_phantom_module})+ return $ Just new_phantom_module --- pm <- maybe (return []) (findModule . pm_name >=> return . return) new_pm- (old_top_level, _) <- runGhc Compat.getContext- let new_top_level = pm ++ old_top_level- runGhc2 Compat.setContextModules new_top_level unqual_mods+ 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{qual_imports = quals})+ onState (\s ->s{qualImports = phantomImports})+ where+ (regularImports, phantomImports) = partitionEithers+ $ map (\m -> if isQualified m || hasImportList m+ then Right m -- phantom+ else Left m)+ moduleImports+ isQualified m = modQual m /= NotQualified+ hasImportList m = modImp m /= NoImportList+ newImportLine m = concat ["import ", case modQual m of+ NotQualified -> modName m+ ImportAs q -> modName m ++ " as " ++ q+ QualifiedAs Nothing -> "qualified " ++ modName m+ QualifiedAs (Just q) -> "qualified " ++ modName m ++ " as " ++ q+ ,case modImp m of+ NoImportList -> ""+ ImportList l -> " (" ++ intercalate "," l ++ ")"+ HidingList l -> " hiding (" ++ intercalate "," l ++ ")"+ ] -- | 'cleanPhantomModules' works like 'reset', but skips the -- loading of the support module that installs '_show'. Its purpose@@ -280,11 +348,11 @@ cleanPhantomModules :: MonadInterpreter m => m () cleanPhantomModules = do -- Remove all modules from context- runGhc2 Compat.setContext [] []+ runGhc $ setContext [] [] -- -- Unload all previously loaded modules- runGhc1 GHC.setTargets []- _ <- runGhc1 GHC.load GHC.LoadAllTargets+ runGhc $ GHC.setTargets []+ _ <- runGhc $ GHC.load GHC.LoadAllTargets -- -- At this point, GHCi would call rts_revertCAFs and -- reset the buffering of stdin, stdout and stderr.@@ -293,14 +361,18 @@ -- liftIO $ rts_revertCAFs -- -- We now remove every phantom module and forget about qual imports- old_active <- fromState active_phantoms- old_zombie <- fromState zombie_phantoms- onState (\s -> s{active_phantoms = [],- zombie_phantoms = [],- import_qual_hack_mod = Nothing,- qual_imports = []})- liftIO $ mapM_ (removeFile . pm_file) (old_active ++ old_zombie)+ 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@@ -310,14 +382,15 @@ cleanPhantomModules -- -- Now, install a support module- installSupportModule+ installSupportModule [] -- Load a phantom module with all the symbols from the prelude we need-installSupportModule :: MonadInterpreter m => m ()-installSupportModule = do mod <- addPhantomModule support_module- onState (\st -> st{hint_support_module = mod})- mod' <- findModule (pm_name mod)- runGhc2 Compat.setContext [mod'] []+installSupportModule :: MonadInterpreter m => [GHC.Target] -> m ()+installSupportModule ts = do runGhc $ GHC.setTargets ts+ mod <- addPhantomModule support_module+ onState (\st -> st{hintSupportModule = mod})+ mod' <- findModule (pmName mod)+ runGhc $ setContext [mod'] [] -- where support_module m = unlines [ "module " ++ m ++ "( ",@@ -338,10 +411,10 @@ -- Call it when the support module is an active phantom module but has been -- unloaded as a side effect by GHC (e.g. by calling GHC.loadTargets)-reinstallSupportModule :: MonadInterpreter m => m ()-reinstallSupportModule = do pm <- fromState hint_support_module- removePhantomModule pm- installSupportModule+reinstallSupportModule :: [GHC.Target] -> MonadInterpreter m => m ()+reinstallSupportModule ts = do pm <- fromState hintSupportModule+ removePhantomModule pm+ installSupportModule ts altStringName :: ModuleName -> String altStringName mod_name = "String_" ++ mod_name@@ -352,13 +425,13 @@ altPreludeName :: ModuleName -> String altPreludeName mod_name = "Prelude_" ++ mod_name -support_String :: MonadInterpreter m => m String-support_String = do mod_name <- fromState (pm_name . hint_support_module)- return $ concat [mod_name, ".", altStringName mod_name]+supportString :: MonadInterpreter m => m String+supportString = do mod_name <- fromState (pmName . hintSupportModule)+ return $ concat [mod_name, ".", altStringName mod_name] -support_show :: MonadInterpreter m => m String-support_show = do mod_name <- fromState (pm_name . hint_support_module)- return $ concat [mod_name, ".", altShowName 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 ()+-- foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
src/Hint/Conversions.hs view
@@ -1,35 +1,26 @@-module Hint.Conversions- (- typeToString- ,kindToString- ,moduleToString- ,isSucceeded- )--where+module Hint.Conversions (+ typeToString, kindToString, moduleToString, isSucceeded+) where import qualified Hint.GHC as GHC import Hint.Base-import qualified Hint.Compat as Compat - -- --------- 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 ->- return $ Compat.showSDocForUser df unqual (Compat.pprType t)+ -- TODO: get unit state from somewhere?+ return $ GHC.showSDocForUser df GHC.emptyUnitState unqual (GHC.pprTypeForUser t) -kindToString :: MonadInterpreter m => Compat.Kind -> m String-kindToString (Compat.Kind k)+kindToString :: MonadInterpreter m => GHC.Kind -> m String+kindToString k = withDynFlags $ \df ->- return $ Compat.showSDoc df (Compat.pprKind k)-+ return $ GHC.showSDoc df (GHC.pprTypeForUser k) -- ---------------- Modules --------------------------
src/Hint/Eval.hs view
@@ -1,23 +1,23 @@ module Hint.Eval (- interpret, as, infer,- eval ,parens)+ unsafeInterpret,+ eval, runStmt,+ parens+) where -where+import qualified GHC.Exts (unsafeCoerce#) -import qualified GHC.Exts ( unsafeCoerce# )+import Control.Exception -import Data.Typeable hiding ( typeOf )-import qualified Data.Typeable ( typeOf )+import Data.Typeable (Typeable)+import qualified Data.Typeable as Typeable import Hint.Base import Hint.Context import Hint.Parsers-import Hint.Sandbox import Hint.Util -import qualified Hint.Compat as Compat-+import qualified Hint.GHC as GHC -- | Convenience functions to be used with @interpret@ to provide witnesses. -- Example:@@ -31,31 +31,49 @@ -- | Evaluates an expression, given a witness for its monomorphic type. interpret :: (MonadInterpreter m, Typeable a) => String -> a -> m a-interpret expr wit = unsafeInterpret expr (show $ Data.Typeable.typeOf wit)-+interpret expr wit = unsafeInterpret expr (show $ Typeable.typeOf wit) unsafeInterpret :: (MonadInterpreter m) => String -> String -> m a-unsafeInterpret expr type_str = sandboxed go expr- where go e =- 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 e- --- let expr_typesig = concat [parens e, " :: ", type_str]- expr_val <- mayFail $ runGhc1 Compat.compileExpr expr_typesig- --- return (GHC.Exts.unsafeCoerce# expr_val :: 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 <- support_show- in_scope_String <- support_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@@ -63,8 +81,8 @@ -- put the closing parenthesis in a different line. However, now we are -- messing with the layout rules and we don't know where @s@ is going to -- be used!--- Solution: @parens s = \"(let {foo =\n\" ++ s ++ \"\\n ;} in foo)\"@ where @foo@ does not occur in @s@+-- Solution: @parens s = \"(let {foo =\\n\" ++ s ++ \"\\n ;} in foo)\"@ where @foo@ does not occur in @s@ parens :: String -> String parens s = concat ["(let {", foo, " =\n", s, "\n",- " ;} in ", foo, ")"]+ " ;} in ", foo, ")"] where foo = safeBndFor s
src/Hint/Extension.hs view
@@ -1,15 +1,19 @@ -- this module was automatically generated. do not edit! -- edit util/mk_extensions_mod.hs instead-module Hint.Extension (Extension(..),- knownExtensions, availableExtensions, asExtension)+module Hint.Extension (+ Extension(..), supportedExtensions, availableExtensions, asExtension+) where -where+import qualified Hint.GHC as GHC -import Hint.Compat as Compat+supportedExtensions :: [String]+supportedExtensions = map f GHC.xFlags+ where+ f = GHC.flagSpecName -- | List of the extensions known by the interpreter. availableExtensions :: [Extension]-availableExtensions = map asExtension Compat.supportedExtensions+availableExtensions = map asExtension supportedExtensions asExtension :: String -> Extension asExtension s = if isKnown s@@ -29,13 +33,14 @@ | RecursiveDo | ParallelListComp | MultiParamTypeClasses- | NoMonomorphismRestriction+ | MonomorphismRestriction | FunctionalDependencies | Rank2Types | RankNTypes | PolymorphicComponents | ExistentialQuantification | ScopedTypeVariables+ | PatternSignatures | ImplicitParams | FlexibleContexts | FlexibleInstances@@ -48,7 +53,7 @@ | ForeignFunctionInterface | Arrows | Generics- | NoImplicitPrelude+ | ImplicitPrelude | NamedFieldPuns | PatternGuards | GeneralizedNewtypeDeriving@@ -59,20 +64,26 @@ | TypeFamilies | StandaloneDeriving | UnicodeSyntax- | PatternSignatures | UnliftedFFITypes+ | InterruptibleFFI+ | CApiFFI | LiberalTypeSynonyms | TypeOperators | RecordWildCards | RecordPuns | DisambiguateRecordFields+ | TraditionalRecordSyntax | OverloadedStrings | GADTs- | NoMonoPatBinds+ | GADTSyntax+ | MonoPatBinds | RelaxedPolyRec | ExtendedDefaultRules | UnboxedTuples | DeriveDataTypeable+ | DeriveGeneric+ | DefaultSignatures+ | InstanceSigs | ConstrainedClassMethods | PackageImports | ImpredicativeTypes@@ -80,6 +91,7 @@ | PostfixOperators | QuasiQuotes | TransformListComp+ | MonadComprehensions | ViewPatterns | XmlSyntax | RegularPatterns@@ -87,6 +99,8 @@ | GHCForeignImportPrim | NPlusKPatterns | DoAndIfThenElse+ | MultiWayIf+ | LambdaCase | RebindableSyntax | ExplicitForAll | DatatypeContexts@@ -94,6 +108,162 @@ | 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) @@ -105,13 +275,14 @@ RecursiveDo, ParallelListComp, MultiParamTypeClasses,- NoMonomorphismRestriction,+ MonomorphismRestriction, FunctionalDependencies, Rank2Types, RankNTypes, PolymorphicComponents, ExistentialQuantification, ScopedTypeVariables,+ PatternSignatures, ImplicitParams, FlexibleContexts, FlexibleInstances,@@ -124,7 +295,7 @@ ForeignFunctionInterface, Arrows, Generics,- NoImplicitPrelude,+ ImplicitPrelude, NamedFieldPuns, PatternGuards, GeneralizedNewtypeDeriving,@@ -135,20 +306,26 @@ TypeFamilies, StandaloneDeriving, UnicodeSyntax,- PatternSignatures, UnliftedFFITypes,+ InterruptibleFFI,+ CApiFFI, LiberalTypeSynonyms, TypeOperators, RecordWildCards, RecordPuns, DisambiguateRecordFields,+ TraditionalRecordSyntax, OverloadedStrings, GADTs,- NoMonoPatBinds,+ GADTSyntax,+ MonoPatBinds, RelaxedPolyRec, ExtendedDefaultRules, UnboxedTuples, DeriveDataTypeable,+ DeriveGeneric,+ DefaultSignatures,+ InstanceSigs, ConstrainedClassMethods, PackageImports, ImpredicativeTypes,@@ -156,6 +333,7 @@ PostfixOperators, QuasiQuotes, TransformListComp,+ MonadComprehensions, ViewPatterns, XmlSyntax, RegularPatterns,@@ -163,11 +341,169 @@ GHCForeignImportPrim, NPlusKPatterns, DoAndIfThenElse,+ MultiWayIf,+ LambdaCase, RebindableSyntax, ExplicitForAll, DatatypeContexts, MonoLocalBinds, DeriveFunctor, DeriveTraversable,- DeriveFoldable+ 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 ]
src/Hint/GHC.hs view
@@ -1,87 +1,695 @@+{-# LANGUAGE TypeApplications #-} module Hint.GHC (- module GHC,- module Outputable,- module ErrUtils, Message,- module Pretty,- module DriverPhases,- module StringBuffer,- module Lexer,- module Parser,- module DynFlags,- module FastString,-#if __GLASGOW_HASKELL__ >= 610- module Control.Monad.Ghc,- module HscTypes,- module Bag,+ -- * Shims+ dynamicGhc,+ Message,+ Logger,+ WarnReason(NoReason),+ initLogger,+ putLogMsg,+ pushLogHook,+ modifyLogger,+ mkLogAction,+ UnitState,+ emptyUnitState,+ showSDocForUser,+ ParserOpts,+ mkParserOpts,+ initParserState,+ getErrorMessages,+ pprErrorMessages,+ SDocContext,+ defaultSDocContext,+ showGhcException,+ addWay,+ setBackendToInterpreter,+ parseDynamicFlags,+ pprTypeForUser,+ errMsgSpan,+ fileTarget,+ guessTarget,+ moduleToInteractiveImport,+ interactiveImportToModule,+#if MIN_VERSION_ghc(9,6,0)+ getPrintUnqual, #endif-#if __GLASGOW_HASKELL__ >= 608- module PprTyThing,-#elif __GLASGOW_HASKELL__ < 608- module SrcLoc,+ -- * 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-#if __GLASGOW_HASKELL__ >= 702- module SrcLoc,+ )+import Control.Monad.Ghc as X (GhcT, runGhcT)++#if MIN_VERSION_ghc(9,8,0)+import GHC.Types.Error (ResolvedDiagnosticReason(..), Messages)+import GHC.Driver.Errors.Types (DriverMessage) #endif-#if __GLASGOW_HASKELL__ >= 708- module ConLike,++#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-) -where-#if __GLASGOW_HASKELL__ >= 610-import GHC hiding ( Phase, GhcT, runGhcT )-import Control.Monad.Ghc ( GhcT, runGhcT )+#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 HscTypes ( SourceError, srcErrorMessages, GhcApiError )-import Bag ( bagToList )+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 GHC hiding ( Phase )+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 -import Outputable ( PprStyle, SDoc, Outputable(ppr),- showSDoc, showSDocForUser, showSDocUnqual,- withPprStyle, defaultErrStyle )+{-------------------- Imports for Shims --------------------} -import ErrUtils ( mkLocMessage, pprErrMsgBagWithLoc)-#if __GLASGOW_HASKELL__ < 706-import ErrUtils ( Message )+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-import ErrUtils ( MsgDoc ) -- we alias it as Message below+-- 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 -import Pretty ( Doc )-import DriverPhases ( Phase(Cpp), HscSource(HsSrcFile) )-import StringBuffer ( stringToStringBuffer )-import Lexer ( P(..), ParseResult(..), mkPState )-import Parser ( parseStmt, parseType )-import FastString ( fsLit )+-- showGhcException+import qualified GHC (showGhcException) -#if __GLASGOW_HASKELL__ >= 710-import DynFlags ( supportedLanguagesAndExtensions, xFlags, xopt, FlagSpec(..) )-#elif __GLASGOW_HASKELL__ >= 700-import DynFlags ( supportedLanguagesAndExtensions, xFlags, xopt )+-- 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-import DynFlags ( supportedLanguages )+dynamicGhc = GHC.dynamicGhc #endif -#if __GLASGOW_HASKELL__ >=704-import DynFlags ( LogAction )+-- Message+#if MIN_VERSION_ghc(9,2,0)+type Message = SDoc+#else+type Message = GHC.MsgDoc #endif -#if __GLASGOW_HASKELL__ >= 608-import PprTyThing ( pprTypeForUser )-#elif __GLASGOW_HASKELL__ < 608-import SrcLoc ( SrcSpan )+-- Logger+initLogger :: IO Logger+putLogMsg :: Logger -> DynFlags -> WarnReason -> Severity -> SrcSpan -> SDoc -> IO ()+pushLogHook :: (GHC.LogAction -> GHC.LogAction) -> Logger -> Logger+modifyLogger :: GhcMonad m => (Logger -> Logger) -> m ()+mkLogAction :: (String -> a) -> IORef [a] -> GHC.LogAction+#if MIN_VERSION_ghc(9,8,0)+data WarnReason = NoReason+type Logger = GHC.Logger+initLogger = GHC.initLogger+putLogMsg logger _df _wn sev = GHC.putLogMsg logger (GHC.logFlags logger) (GHC.MCDiagnostic sev (ResolvedDiagnosticReason GHC.ErrorWithoutFlag) Nothing)+pushLogHook = GHC.pushLogHook+modifyLogger = GHC.modifyLogger+mkLogAction f r = \lf mc src msg ->+ let renderErrMsg = GHC.renderWithContext (GHC.log_default_user_context lf)+ errorEntry = f (renderErrMsg (GHC.mkLocMessage mc src msg))+ in modifyIORef r (errorEntry :)+#elif MIN_VERSION_ghc(9,6,0)+data WarnReason = NoReason+type Logger = GHC.Logger+initLogger = GHC.initLogger+putLogMsg logger _df _wn sev = GHC.putLogMsg logger (GHC.logFlags logger) (GHC.MCDiagnostic sev GHC.ErrorWithoutFlag Nothing)+pushLogHook = GHC.pushLogHook+modifyLogger = GHC.modifyLogger+mkLogAction f r = \lf mc src msg ->+ let renderErrMsg = GHC.renderWithContext (GHC.log_default_user_context lf)+ errorEntry = f (renderErrMsg (GHC.mkLocMessage mc src msg))+ in modifyIORef r (errorEntry :)+#elif MIN_VERSION_ghc(9,4,0)+data WarnReason = NoReason+type Logger = GHC.Logger+initLogger = GHC.initLogger+putLogMsg logger _df _wn sev = GHC.putLogMsg logger (GHC.logFlags logger) (GHC.MCDiagnostic sev GHC.ErrorWithoutFlag)+pushLogHook = GHC.pushLogHook+modifyLogger = GHC.modifyLogger+mkLogAction f r = \lf mc src msg ->+ let renderErrMsg = GHC.renderWithContext (GHC.log_default_user_context lf)+ errorEntry = f (renderErrMsg (GHC.mkLocMessage mc src msg))+ in modifyIORef r (errorEntry :)+#elif MIN_VERSION_ghc(9,2,0)+type Logger = GHC.Logger+initLogger = GHC.initLogger+putLogMsg = GHC.putLogMsg+pushLogHook = GHC.pushLogHook+modifyLogger = GHC.modifyLogger+mkLogAction f r = \df _ sev src msg ->+ let renderErrMsg = GHC.showSDoc df+ errorEntry = f (renderErrMsg (GHC.mkLocMessage sev src msg))+ in modifyIORef r (errorEntry :)+#elif MIN_VERSION_ghc(9,0,0)+type Logger = GHC.LogAction+initLogger = pure GHC.defaultLogAction+putLogMsg = id+pushLogHook = id+modifyLogger f = do+ df <- getSessionDynFlags+ _ <- setSessionDynFlags df{log_action = f $ DynFlags.log_action df}+ return ()+mkLogAction f r = \df _ sev src msg ->+ let renderErrMsg = GHC.showSDoc df+ errorEntry = f (renderErrMsg (GHC.mkLocMessage sev src msg))+ in modifyIORef r (errorEntry :)+#else+type Logger = GHC.LogAction+initLogger = pure GHC.defaultLogAction+putLogMsg l = \df wr sev src msg -> l df wr sev src (GHC.defaultErrStyle df) msg+pushLogHook = id+modifyLogger f = do+ df <- getSessionDynFlags+ _ <- setSessionDynFlags df{log_action = f $ DynFlags.log_action df}+ return ()+mkLogAction f r = \df _ sev src style msg ->+ let renderErrMsg s = GHC.renderWithStyle df s style+ errorEntry = f (renderErrMsg (GHC.mkLocMessage sev src msg))+ in modifyIORef r (errorEntry :) #endif -#if __GLASGOW_HASKELL__ >= 702-import SrcLoc ( mkRealSrcLoc )+-- UnitState+emptyUnitState :: UnitState+#if MIN_VERSION_ghc(9,2,0)+type UnitState = GHC.UnitState+emptyUnitState = GHC.emptyUnitState+#else+type UnitState = ()+emptyUnitState = () #endif -#if __GLASGOW_HASKELL__ >= 708-import ConLike ( ConLike(RealDataCon) )+-- showSDocForUser+#if MIN_VERSION_ghc(9,6,0)+type PrintUnqualified = NamePprCtx #endif -#if __GLASGOW_HASKELL__ >= 706-type Message = MsgDoc+showSDocForUser :: DynFlags -> UnitState -> PrintUnqualified -> SDoc -> String+#if MIN_VERSION_ghc(9,2,0)+showSDocForUser = GHC.showSDocForUser+#else+showSDocForUser df _ = GHC.showSDocForUser df+#endif++-- PState+mkParserOpts :: DynFlags -> ParserOpts+initParserState :: ParserOpts -> StringBuffer -> RealSrcLoc -> GHC.PState+#if MIN_VERSION_ghc(9,4,0)+type ParserOpts = GHC.ParserOpts+mkParserOpts = GHC.initParserOpts++initParserState = GHC.initParserState+#elif MIN_VERSION_ghc(9,2,0)+type ParserOpts = GHC.ParserOpts+mkParserOpts =+ -- adapted from+ -- https://hackage.haskell.org/package/ghc-8.10.2/docs/src/Lexer.html#line-2437+ GHC.mkParserOpts+ <$> DynFlags.warningFlags+ <*> DynFlags.extensionFlags+ <*> DynFlags.safeImportsOn+ <*> gopt Opt_Haddock+ <*> gopt Opt_KeepRawTokenStream+ <*> const True++initParserState = GHC.initParserState+#else+type ParserOpts = GHC.ParserFlags+mkParserOpts = GHC.mkParserFlags++initParserState = GHC.mkPStatePure+#endif++-- ErrorMessages+getErrorMessages :: GHC.PState -> DynFlags -> GHC.ErrorMessages+pprErrorMessages :: GHC.ErrorMessages -> [SDoc]+#if MIN_VERSION_ghc(9,6,0)+getErrorMessages pstate _ = fmap GHC.GhcPsMessage $ GHC.getPsErrorMessages pstate+pprErrorMessages = bagToList . fmap pprErrorMessage . GHC.getMessages+ where+ pprErrorMessage = vcat . GHC.unDecorated . GHC.diagnosticMessage (GHC.defaultDiagnosticOpts @GHC.GhcMessage) . GHC.errMsgDiagnostic+#elif MIN_VERSION_ghc(9,4,0)+getErrorMessages pstate _ = fmap GHC.GhcPsMessage $ GHC.getPsErrorMessages pstate+pprErrorMessages = bagToList . fmap pprErrorMessage . GHC.getMessages+ where+ pprErrorMessage = vcat . GHC.unDecorated . GHC.diagnosticMessage . GHC.errMsgDiagnostic+#elif MIN_VERSION_ghc(9,2,0)+getErrorMessages pstate _ = fmap GHC.pprError $ GHC.getErrorMessages pstate+pprErrorMessages = bagToList . fmap pprErrorMessage+ where+ pprErrorMessage = vcat . GHC.unDecorated . GHC.errMsgDiagnostic+#elif MIN_VERSION_ghc(8,10,0)+getErrorMessages = GHC.getErrorMessages+pprErrorMessages = GHC.pprErrMsgBagWithLoc+#else+getErrorMessages _ _ = emptyBag+pprErrorMessages = GHC.pprErrMsgBagWithLoc+#endif++-- SDocContext+defaultSDocContext :: SDocContext+#if MIN_VERSION_ghc(9,2,0)+type SDocContext = GHC.SDocContext+defaultSDocContext = GHC.defaultSDocContext+#else+type SDocContext = ()+defaultSDocContext = ()+#endif++-- showGhcException+showGhcException :: SDocContext -> GhcException -> ShowS+#if MIN_VERSION_ghc(9,2,0)+showGhcException = GHC.showGhcException+#else+showGhcException _ = GHC.showGhcException+#endif++-- addWay+addWay :: Way -> DynFlags -> DynFlags+#if MIN_VERSION_ghc(9,2,0)+addWay way df =+ df+ { targetWays_ = Set.insert way $ DynFlags.targetWays_ df+ }+#else+addWay = GHC.addWay'+#endif++-- setBackendToInterpreter+setBackendToInterpreter :: DynFlags -> DynFlags+#if MIN_VERSION_ghc(9,6,0)+setBackendToInterpreter df = df{backend = interpreterBackend}+#elif MIN_VERSION_ghc(9,2,0)+setBackendToInterpreter df = df{backend = Interpreter}+#else+setBackendToInterpreter df = df{hscTarget = HscInterpreted}+#endif++-- parseDynamicFlags++#if MIN_VERSION_ghc(9,8,0)+parseDynamicFlags :: MonadIO m => Logger -> DynFlags -> [Located String] -> m (DynFlags, [Located String], Messages DriverMessage)+parseDynamicFlags = GHC.parseDynamicFlags+#else+#if MIN_VERSION_ghc(9,2,0)+parseDynamicFlags :: MonadIO m => Logger -> DynFlags -> [Located String] -> m (DynFlags, [Located String], [Warn])+parseDynamicFlags = GHC.parseDynamicFlags+#else+parseDynamicFlags _ = GHC.parseDynamicFlags+#endif+#endif++pprTypeForUser :: Type -> SDoc+#if MIN_VERSION_ghc(9,4,0)+pprTypeForUser = GHC.pprSigmaType+#else+pprTypeForUser = GHC.pprTypeForUser+#endif++#if MIN_VERSION_ghc(9,4,0)+errMsgSpan :: GHC.Messages e -> SrcSpan+errMsgSpan msgs = foldr (GHC.combineSrcSpans . GHC.errMsgSpan) X.noSrcSpan (GHC.getMessages msgs)+#elif MIN_VERSION_ghc(9,2,0)+errMsgSpan :: GHC.Bag (GHC.MsgEnvelope e) -> SrcSpan+errMsgSpan = foldr (GHC.combineSrcSpans . GHC.errMsgSpan) X.noSrcSpan+#else+errMsgSpan :: GHC.ErrorMessages -> SrcSpan+errMsgSpan = foldr (GHC.combineSrcSpans . GHC.errMsgSpan) X.noSrcSpan+#endif++fileTarget :: DynFlags -> FilePath -> GHC.Target+#if MIN_VERSION_ghc(9,4,0)+fileTarget dflags f = GHC.Target (GHC.TargetFile f $ Just next_phase) True uid Nothing+ where next_phase = GHC.Cpp GHC.HsSrcFile+ uid = GHC.homeUnitId_ dflags+#else+fileTarget _ f = GHC.Target (GHC.TargetFile f $ Just next_phase) True Nothing+ where next_phase = GHC.Cpp GHC.HsSrcFile+#endif++guessTarget :: GhcMonad m => String -> Maybe GHC.Phase -> m GHC.Target+#if MIN_VERSION_ghc(9,4,0)+guessTarget t pM = GHC.guessTarget t Nothing pM+#else+guessTarget = GHC.guessTarget+#endif++-- moduleToInteractiveImport / interactiveImportToModule+-- In GHC 9.14+, IIModule takes a Module directly instead of ModuleName+moduleToInteractiveImport :: Module -> InteractiveImport+interactiveImportToModule :: InteractiveImport -> GhcMonad m => m (Maybe Module)+#if MIN_VERSION_ghc(9,14,0)+moduleToInteractiveImport = IIModule+interactiveImportToModule (IIModule m) = return $ Just m+interactiveImportToModule _ = return Nothing+#else+moduleToInteractiveImport = IIModule . moduleName+interactiveImportToModule (IIModule mn) = do+ m <- findModule mn Nothing+ return $ Just m+interactiveImportToModule _ = return Nothing+#endif++-- getPrintUnqual+#if MIN_VERSION_ghc(9,6,0)+getPrintUnqual :: GhcMonad m => m PrintUnqualified+getPrintUnqual = GHC.getNamePprCtx #endif
+ src/Hint/Internal.hs view
@@ -0,0 +1,33 @@+-- | In this module we intend to export some internal functions.+--+-- __Important note__: the authors of this library imply no assurance whatsoever+-- of the stability or functionality of the API exposed here, and compatibility+-- may break even by minor version changes. Rely on these at your+-- own risk.+--+-- The reason for showing them here is to aid discoverability+-- of already written code and prevent having to reinvent the wheel from+-- scratch if said wheel is already invented.+--+-- In case you find something here especially useful, please submit+-- an issue or a pull request at https://github.com/haskell-hint/hint so+-- we can discuss making it part of the official public API.+--+-- Some further context can be found here:+-- https://github.com/haskell-hint/hint/pull/48#issuecomment-358722638++++module Hint.Internal (+ onCompilationError+) where++import Hint.Typecheck (onCompilationError)++++-- todo: Consider refactoring like the following when+-- https://github.com/haskell/haddock/issues/563 is fixed+--+-- module Hint.Internal (module ReExport) where+-- import Hint.Typecheck as ReExport (onCompilationError)
src/Hint/InterpreterT.hs view
@@ -1,10 +1,10 @@ module Hint.InterpreterT (- InterpreterT, Interpreter, runInterpreter, runInterpreterWithArgs,+ InterpreterT, Interpreter,+ runInterpreter, runInterpreterWithArgs, runInterpreterWithArgsLibdir, MultipleInstancesNotAllowed(..)-)--where+) where +import Control.Applicative import Prelude import Hint.Base@@ -12,74 +12,46 @@ import Hint.Configuration import Hint.Extension -import Control.Applicative-import Control.Monad.Reader+import Control.Monad (ap, unless)+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader import Control.Monad.Catch as MC -import Data.Typeable ( Typeable )+import Data.Typeable (Typeable) import Control.Concurrent.MVar-import System.IO.Unsafe ( unsafePerformIO )+import System.IO.Unsafe (unsafePerformIO) import Data.IORef-import Data.List import Data.Maybe-#if __GLASGOW_HASKELL__ < 610-import Data.Dynamic-#endif import qualified GHC.Paths import qualified Hint.GHC as GHC-import qualified Hint.Compat as Compat type Interpreter = InterpreterT IO -#if __GLASGOW_HASKELL__ < 610--newtype InterpreterT m a = InterpreterT{- unInterpreterT :: ReaderT InterpreterSession- (ErrorT InterpreterError m) a}- deriving (Functor, Monad, MonadIO, MonadThrow,MonadCatch,MonadMask)--execute :: (MonadIO m, MonadMask m, Functor m)- => InterpreterSession- -> InterpreterT m a- -> m (Either InterpreterError a)-execute s = runErrorT . flip runReaderT s . unInterpreterT--instance MonadTrans InterpreterT where- lift = InterpreterT . lift . lift--runGhc_impl :: (MonadIO m, MonadThrow m, MonadMask m, Functor m) => RunGhc (InterpreterT m) a-runGhc_impl f = do s <- fromSession versionSpecific -- i.e. the ghc session- r <- liftIO $ f' s- either throwError return r- where f' = tryJust (fmap (GhcException . showGhcEx) . ghcExceptions) . f- ghcExceptions (DynException e) = fromDynamic e- ghcExceptions _ = Nothing--#else- -- ghc >= 6.10-newtype InterpreterT m a = InterpreterT{- unInterpreterT :: ReaderT InterpreterSession- (GHC.GhcT m) a}+newtype InterpreterT m a = InterpreterT {+ unInterpreterT :: ReaderT InterpreterSession (GHC.GhcT m) a+ } deriving (Functor, Monad, MonadIO, MonadThrow, MonadCatch, MonadMask) -execute :: (MonadIO m, MonadMask m, Functor m)- => InterpreterSession+execute :: (MonadIO m, MonadMask m)+ => String+ -> InterpreterSession -> InterpreterT m a -> m (Either InterpreterError a)-execute s = try- . GHC.runGhcT (Just GHC.Paths.libdir)- . flip runReaderT s- . unInterpreterT-+execute libdir s = try+ . GHC.runGhcT (Just libdir)+ . flip runReaderT s+ . unInterpreterT instance MonadTrans InterpreterT where lift = InterpreterT . lift . lift -runGhc_impl :: (MonadIO m, MonadThrow m, MonadMask m, Functor m) => RunGhc (InterpreterT m) a-runGhc_impl a =+runGhcImpl :: (MonadIO m, MonadMask m)+ => RunGhc (InterpreterT m) a+runGhcImpl a = InterpreterT (lift a) `catches` [Handler (\(e :: GHC.SourceError) -> do@@ -91,70 +63,53 @@ where compilationError dynFlags = WontCompile-#if __GLASGOW_HASKELL__ >= 706 . map (GhcError . GHC.showSDoc dynFlags)-#else- . map (GhcError . GHC.showSDoc)-#endif- . GHC.pprErrMsgBagWithLoc+ . GHC.pprErrorMessages . GHC.srcErrorMessages-#endif showGhcEx :: GHC.GhcException -> String-showGhcEx = flip GHC.showGhcException ""+showGhcEx = flip (GHC.showGhcException GHC.defaultSDocContext) "" -- ================= Executing the interpreter ================== initialize :: (MonadIO m, MonadThrow m, MonadMask m, Functor m)- => [String]- -> InterpreterT m ()+ => [String]+ -> InterpreterT m () initialize args =- do log_handler <- fromSession ghcErrLogger+ do logger <- fromSession ghcLogger -- Set a custom log handler, to intercept error messages :S df0 <- runGhc GHC.getSessionDynFlags - let df1 = Compat.configureDynFlags df0- (df2, extra) <- runGhc2 Compat.parseDynamicFlags df1 args- when (not . null $ extra) $+ let df1 = configureDynFlags df0+ (df2, extra) <- runGhc $ parseDynamicFlags logger df1 args+ unless (null extra) $ throwM $ UnknownError (concat [ "flags: '"- , intercalate " " extra+ , unwords extra , "' not recognized"]) -- Observe that, setSessionDynFlags loads info on packages -- available; calling this function once is mandatory!- _ <- runGhc1 GHC.setSessionDynFlags df2{GHC.log_action = log_handler}+ runGhc $ GHC.modifyLogger (const logger)+ _ <- runGhc $ GHC.setSessionDynFlags df2 -#if __GLASGOW_HASKELL__ >= 700-#if __GLASGOW_HASKELL__ >= 702-#if __GLASGOW_HASKELL__ >= 710- let extMap = map (\fs -> (GHC.flagSpecName fs, GHC.flagSpecFlag fs)) GHC.xFlags-#elif __GLASGOW_HASKELL__ >= 704- let extMap = map (\(a,b,_) -> (a,b)) GHC.xFlags-#else- let extMap = map (\(a,_,b,_) -> (a,b)) GHC.xFlags-#endif-#else- let extMap = map (\(a,b,_) -> (a,b)) GHC.xFlags-#endif+ let extMap = [ (GHC.flagSpecName flagSpec, GHC.flagSpecFlag flagSpec)+ | flagSpec <- GHC.xFlags+ ] let toOpt e = let err = error ("init error: unknown ext:" ++ show e) in fromMaybe err (lookup e extMap) let getOptVal e = (asExtension e, GHC.xopt (toOpt e) df2)- let defExts = map getOptVal Compat.supportedExtensions-#else- let defExts = zip availableExtensions (repeat False)-#endif+ let defExts = map getOptVal supportedExtensions onState (\s -> s{defaultExts = defExts}) reset - -- | Executes the interpreter. Returns @Left InterpreterError@ in case of error. ----- NB. The underlying ghc will overwrite certain signal handlers--- (SIGINT, SIGHUP, SIGTERM, SIGQUIT on Posix systems, Ctrl-C handler on Windows).--- In future versions of hint, this might be controlled by the user.-runInterpreter :: (MonadIO m, MonadMask m, Functor m)+-- 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 []@@ -162,40 +117,37 @@ -- | 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, Functor m)- => [String]- -> InterpreterT m a- -> m (Either InterpreterError a)-runInterpreterWithArgs args action =+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- -- SH.protectHandlers $ execute s (initialize args >> action)- execute s (initialize args >> action `finally` cleanSession)+ execute libdir s (initialize args >> action `finally` cleanSession) where rethrowGhcException = throwM . GhcException . showGhcEx-#if __GLASGOW_HASKELL__ < 610- newInterpreterSession = do s <- liftIO $- Compat.newSession GHC.Paths.libdir- newSessionData s- cleanSession = cleanPhantomModules -- clean ghc session, too?-#else- -- GHC >= 610 newInterpreterSession = newSessionData ()- cleanSession =- do cleanPhantomModules- runGhc $ do dflags <- GHC.getSessionDynFlags- GHC.defaultCleanupHandler dflags (return ())-#endif+ cleanSession = cleanPhantomModules +#ifndef THREAD_SAFE_LINKER {-# NOINLINE uniqueToken #-} uniqueToken :: MVar () uniqueToken = unsafePerformIO $ newMVar () ifInterpreterNotRunning :: (MonadIO m, MonadMask m) => m a -> m a-ifInterpreterNotRunning action =- do maybe_token <- liftIO $ tryTakeMVar uniqueToken- case maybe_token of- Nothing -> throwM MultipleInstancesNotAllowed- Just x -> action `finally` (liftIO $ putMVar uniqueToken x)+ifInterpreterNotRunning action = liftIO (tryTakeMVar uniqueToken) >>= \ case+ Nothing -> throwM MultipleInstancesNotAllowed+ Just x -> action `finally` liftIO (putMVar uniqueToken x)+#endif -- | The installed version of ghc is not thread-safe. This exception -- is thrown whenever you try to execute @runInterpreter@ while another@@ -209,57 +161,40 @@ "can't safely run two instances of the interpreter simultaneously" initialState :: InterpreterState-initialState = St {active_phantoms = [],- zombie_phantoms = [],- hint_support_module = error "No support module loaded!",- import_qual_hack_mod = Nothing,- qual_imports = [],- defaultExts = error "defaultExts missing!",- configuration = defaultConf}-+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 =+newSessionData a = do initial_state <- liftIO $ newIORef initialState ghc_err_list_ref <- liftIO $ newIORef []- return SessionData{+ logger <- liftIO $ GHC.initLogger+ return SessionData { internalState = initial_state, versionSpecific = a, ghcErrListRef = ghc_err_list_ref,- ghcErrLogger = mkLogHandler ghc_err_list_ref+ ghcLogger = GHC.pushLogHook (const $ GHC.mkLogAction GhcError ghc_err_list_ref) logger } -mkLogHandler :: IORef [GhcError] -> GhcErrLogger-mkLogHandler r =-#if __GLASGOW_HASKELL__ < 706- \_ src style msg ->- let renderErrMsg = Compat.showSDoc ()-#else- \df _ src style msg ->- let renderErrMsg = Compat.showSDoc df-#endif- errorEntry = mkGhcError renderErrMsg src style msg- in modifyIORef r (errorEntry :)--mkGhcError :: (GHC.SDoc -> String) -> GHC.SrcSpan -> GHC.PprStyle -> GHC.Message -> GhcError-mkGhcError render src_span style msg = GhcError{errMsg = niceErrMsg}- where niceErrMsg = render . GHC.withPprStyle style $- Compat.mkLocMessage src_span msg-- -- The MonadInterpreter instance instance (MonadIO m, MonadMask m, Functor m) => MonadInterpreter (InterpreterT m) where- fromSession f = InterpreterT $ fmap f ask+ fromSession f = InterpreterT $ asks f -- modifySessionRef target f =- do ref <- fromSession target- old_val <- liftIO $ atomicModifyIORef ref (\a -> (f a, a))- return old_val+ do ref <- fromSession target+ liftIO $ atomicModifyIORef ref (\a -> (f a, a)) --- runGhc a = runGhc_impl a-+ runGhc = runGhcImpl -instance (Monad m, Applicative m) => Applicative (InterpreterT m) where- pure = return+instance (Monad m) => Applicative (InterpreterT m) where+ pure = InterpreterT . pure (<*>) = ap
src/Hint/Parsers.hs view
@@ -1,13 +1,10 @@-module Hint.Parsers--where+module Hint.Parsers where -import Prelude hiding(span)+import Prelude hiding (span) import Hint.Base-import qualified Hint.Compat as Compat -import Control.Monad.Trans ( liftIO )+import Control.Monad.IO.Class (liftIO) import qualified Hint.GHC as GHC @@ -23,45 +20,45 @@ runParser parser expr = do dyn_fl <- runGhc GHC.getSessionDynFlags --- buf <- Compat.stringToStringBuffer expr+ buf <- (return . GHC.stringToStringBuffer) expr -- -- ghc >= 7 panics if noSrcLoc is given- let srcLoc = Compat.mkSrcLoc (GHC.fsLit "<hint>") 1 1- let parse_res = GHC.unP parser (Compat.mkPState dyn_fl buf srcLoc)+ let srcLoc = GHC.mkRealSrcLoc (GHC.fsLit "<hint>") 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 --- GHC.PFailed span err -> return (ParseError span err)+#if MIN_VERSION_ghc(8,10,0)+ GHC.PFailed pst -> let errMsgs = GHC.getErrorMessages pst dyn_fl+ span = GHC.errMsgSpan errMsgs+ err = GHC.vcat $ GHC.pprErrorMessages errMsgs+ in pure (ParseError span err)+#else+ GHC.PFailed _ span err -> return (ParseError span err)+#endif failOnParseError :: MonadInterpreter m => (String -> m ParseResult) -> String -> m () failOnParseError parser expr = mayFail go- where go = do parsed <- parser expr- --- -- If there was a parsing error,- -- do the "standard" error reporting- case parsed of+ where go = parser expr >>= \ case ParseOk -> return (Just ())- --+ -- If there was a parsing error,+ -- do the "standard" error reporting ParseError span err -> do -- parsing failed, so we report it just as all -- other errors get reported....- logger <- fromSession ghcErrLogger-#if __GLASGOW_HASKELL__ >= 706+ logger <- fromSession ghcLogger dflags <- runGhc GHC.getSessionDynFlags- let logger' = logger dflags- errStyle = GHC.defaultErrStyle dflags-#else- let logger' = logger- errStyle = GHC.defaultErrStyle+ let logger' = GHC.putLogMsg logger dflags -#endif- liftIO $ logger' GHC.SevError+ liftIO $ logger'+ GHC.NoReason+ GHC.SevError span- errStyle err -- -- behave like the rest of the GHC API functions
src/Hint/Reflection.hs view
@@ -1,18 +1,13 @@ module Hint.Reflection (- ModuleElem(..), Id, name, children, getModuleExports,--)--where+) where import Data.List import Data.Maybe import Hint.Base import qualified Hint.GHC as GHC-import qualified Hint.Compat as Compat -- | An Id for a class, a type constructor, a data constructor, a binding, etc type Id = String@@ -30,65 +25,31 @@ 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 $ runGhc1 GHC.getModuleInfo module_- exports <- mapM (runGhc1 GHC.lookupName) (GHC.modInfoExports mod_info)+ mod_info <- mayFail $ runGhc $ GHC.getModuleInfo module_+ exports <- mapM (\n -> runGhc $ GHC.lookupName n) (GHC.modInfoExports mod_info) dflags <- runGhc GHC.getSessionDynFlags -- return $ asModElemList dflags (catMaybes exports) asModElemList :: GHC.DynFlags -> [GHC.TyThing] -> [ModuleElem] asModElemList df xs = concat [- cs',- ts',- ds \\ (concatMap (map Fun . children) ts'),- fs \\ (concatMap (map Fun . children) cs')+ cs,+ ts,+ ds \\ concatMap (map Fun . children) ts,+ fs \\ concatMap (map Fun . children) cs ]- where (cs,ts,ds,fs) =- (-#if __GLASGOW_HASKELL__ < 704- [asModElem df c | c@GHC.AClass{} <- xs],- [asModElem df t | t@GHC.ATyCon{} <- xs],-#else- [asModElem df c | c@(GHC.ATyCon c') <- xs, GHC.isClassTyCon c'],- [asModElem df t | t@(GHC.ATyCon c') <- xs, (not . GHC.isClassTyCon) c'],-#endif-#if __GLASGOW_HASKELL__ < 708- [asModElem df d | d@GHC.ADataCon{} <- xs],-#else- [asModElem df d | d@(GHC.AConLike (GHC.RealDataCon{})) <- xs],-#endif- [asModElem df f | f@GHC.AnId{} <- xs]- )- cs' = [Class n $ filter (alsoIn fs) ms | Class n ms <- cs]- ts' = [Data t $ filter (alsoIn ds) dcs | Data t dcs <- ts]- alsoIn es = (`elem` (map name es))---asModElem :: GHC.DynFlags -> GHC.TyThing -> ModuleElem-asModElem df (GHC.AnId f) = Fun $ getUnqualName df f-#if __GLASGOW_HASKELL__ < 708-asModElem df (GHC.ADataCon dc) = Fun $ getUnqualName df dc-#else-asModElem df (GHC.AConLike (GHC.RealDataCon dc)) = Fun $ getUnqualName df dc-#endif-#if __GLASGOW_HASKELL__ < 704-asModElem df(GHC.ATyCon tc) = Data (getUnqualName df tc)- (map (getUnqualName df) $ GHC.tyConDataCons tc)-asModElem df (GHC.AClass c) = Class (getUnqualName df c)- (map (getUnqualName df) $ GHC.classMethods c)-#else-asModElem df (GHC.ATyCon tc) =- if GHC.isClassTyCon tc- then Class (getUnqualName df tc) (map (getUnqualName df) $ (GHC.classMethods . fromJust . GHC.tyConClass_maybe) tc)- else Data (getUnqualName df tc) (map (getUnqualName df) $ GHC.tyConDataCons tc)-asModElem _ _ = error "asModElem: can't happen!"-#endif+ 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 = Compat.showSDocUnqual dfs . GHC.pprParenSymName+getUnqualName dfs = GHC.showSDoc dfs . GHC.pprParenSymName
− src/Hint/Sandbox.hs
@@ -1,74 +0,0 @@-module Hint.Sandbox ( sandboxed ) where--import Hint.Base-import Hint.Context-import Hint.Configuration-import Hint.Util--import {-# SOURCE #-} Hint.Typecheck ( typeChecks_unsandboxed )--import Control.Monad.Catch--sandboxed :: MonadInterpreter m => (Expr -> m a) -> (Expr -> m a)-sandboxed = if ghcVersion >= 610 then id else old_sandboxed--old_sandboxed :: MonadInterpreter m => (Expr -> m a) -> (Expr -> m a)-old_sandboxed do_stuff = \expr -> do no_sandbox <- fromConf all_mods_in_scope- if no_sandbox- then do_stuff expr- else usingAModule do_stuff expr--usingAModule :: MonadInterpreter m => (Expr -> m a) -> (Expr -> m a)-usingAModule do_stuff_on = \expr ->- --- -- To avoid defaulting, we will evaluate this expression without the- -- monomorphism-restriction. This means that expressions that normally- -- would not typecheck, suddenly will. Thus, we first check if the- -- expression typechecks as is. If it doesn't, there is no need in- -- going on (if it does, it may not typecheck once we restrict the- -- context; that is the whole idea of this!)- --- do type_checks <- typeChecks_unsandboxed expr- case type_checks of- False -> do_stuff_on expr -- fail as you wish...- True ->- do (loaded, imports) <- allModulesInContext- zombies <- fromState zombie_phantoms- quals <- fromState qual_imports- --- let e = safeBndFor expr- let mod_text no_prel mod_name = textify [- ["{-# LANGUAGE NoMonomorphismRestriction #-}"],- ["{-# LANGUAGE NoImplicitPrelude #-}" | no_prel],- ["module " ++ mod_name],- ["where"],- ["import " ++ m | m <- loaded ++ imports,- not $ m `elem` (map pm_name zombies)],- ["import qualified " ++ m ++ " as " ++ q | (m,q) <- quals],- [e ++ " = " ++ expr] ]- --- let go no_prel = do pm <- addPhantomModule (mod_text no_prel)- setTopLevelModules [pm_name pm]- r <- do_stuff_on e- `catchIE` (\err ->- case err of- WontCompile _ ->- do removePhantomModule pm- throwM err- _ -> throwM err)- removePhantomModule pm- return r- -- If the Prelude was not explicitly imported but implicitly- -- imported in some interpreted module, then the user may- -- get very unintuitive errors when turning sandboxing on. Thus- -- we will import the Prelude if the operation fails...- -- I guess this may lead to even more obscure errors, but- -- hopefully in much less frequent situations...- r <- onAnEmptyContext $ go True- `catchIE` (\err -> case err of- WontCompile _ -> go False- _ -> throwM err)- --- return r- --- where textify = unlines . concat
− src/Hint/SignalHandlers.hs
@@ -1,40 +0,0 @@-module Hint.SignalHandlers (- protectHandlers-)-where--import Control.Monad.Catch-import Control.Monad.Trans--#ifdef mingw32_HOST_OS-import GHC.ConsoleHandler as C--saveHandlers :: MonadIO m => m C.Handler-saveHandlers = liftIO $ C.installHandler Ignore--restoreHandlers :: MonadIO m => C.Handler -> m C.Handler-restoreHandlers = liftIO . C.installHandler--#else-import qualified System.Posix.Signals as S--helper :: MonadIO m => S.Handler -> S.Signal -> m S.Handler-helper handler signal = liftIO $ S.installHandler signal handler Nothing--signals :: [S.Signal]-signals = [ S.sigQUIT- , S.sigINT- , S.sigHUP- , S.sigTERM- ]--saveHandlers :: MonadIO m => m [S.Handler]-saveHandlers = liftIO $ mapM (helper S.Ignore) signals--restoreHandlers :: MonadIO m => [S.Handler] -> m [S.Handler]-restoreHandlers h = liftIO . sequence $ zipWith helper h signals--#endif--protectHandlers :: (MonadIO m, MonadMask m) => m a -> m a-protectHandlers a = bracket saveHandlers restoreHandlers $ const a
src/Hint/Typecheck.hs view
@@ -1,63 +1,79 @@ module Hint.Typecheck (-- typeOf, typeChecks, kindOf,-- typeOf_unsandboxed, typeChecks_unsandboxed--)--where+ typeOf, typeChecks, kindOf, normalizeType, onCompilationError, typeChecksWithDetails+) where import Control.Monad.Catch import Hint.Base import Hint.Parsers import Hint.Conversions-import Hint.Sandbox -import qualified Hint.Compat as Compat+import qualified Hint.GHC as GHC -- | Returns a string representation of the type of the expression. typeOf :: MonadInterpreter m => String -> m String-typeOf = sandboxed typeOf_unsandboxed--typeOf_unsandboxed :: MonadInterpreter m => String -> m String-typeOf_unsandboxed expr =+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 --- ty <- mayFail $ runGhc1 Compat.exprType expr- --- typeToString ty+ type_ <- mayFail (runGhc $ exprType expr)+ typeToString type_ -- | Tests if the expression type checks.+--+-- NB. Be careful if @unsafeSetGhcOption "-fdefer-type-errors"@ is used.+-- Perhaps unsurprisingly, that can falsely make @typeChecks@ and @typeChecksWithDetails@+-- return @True@ and @Right _@ respectively. typeChecks :: MonadInterpreter m => String -> m Bool-typeChecks = sandboxed typeChecks_unsandboxed--typeChecks_unsandboxed :: MonadInterpreter m => String -> m Bool-typeChecks_unsandboxed expr = (typeOf_unsandboxed expr >> return True)+typeChecks expr = (True <$ typeOf expr) `catchIE` onCompilationError (\_ -> return False) +-- | Similar to @typeChecks@, but gives more information, e.g. the type errors.+typeChecksWithDetails :: MonadInterpreter m => String -> m (Either [GhcError] String)+typeChecksWithDetails expr = (Right <$> typeOf expr)+ `catchIE`+ onCompilationError (return . Left)+ -- | Returns a string representation of the kind of the type expression. kindOf :: MonadInterpreter m => String -> m String-kindOf = sandboxed go- where go 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 $ runGhc1 Compat.typeKind type_expr- --- kindToString (Compat.Kind kind)+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+onCompilationError recover interp_error+ = case interp_error of+ WontCompile errs -> recover errs+ otherErr -> throwM otherErr
− src/Hint/Typecheck.hs-boot
@@ -1,5 +0,0 @@-module Hint.Typecheck where--import Hint.Base (MonadInterpreter)--typeChecks_unsandboxed :: MonadInterpreter m => String -> m Bool
src/Hint/Util.hs view
@@ -14,7 +14,7 @@ safeBndFor expr = "e_1" ++ filter isDigit expr partition :: (a -> Bool) -> [a] -> ([a], [a])-partition prop xs = foldr (select prop) ([],[]) xs+partition prop = foldr (select prop) ([],[]) where select p x ~(ts,fs) | p x = (x:ts,fs) | otherwise = (ts, x:fs) @@ -22,11 +22,6 @@ 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)---infixr 1 >=>-(>=>) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c)-f >=> g = \x -> f x >>= g quote :: String -> String quote s = concat ["'", s, "'"]
src/Language/Haskell/Interpreter.hs view
@@ -1,14 +1,3 @@--------------------------------------------------------------------------------- |--- Module : Language.Haskell.Interpreter--- License : BSD-style------ Maintainer : mvdan@mvdan.cc--- Stability : experimental--- Portability : non-portable (GHC API)------ A Haskell interpreter built on top of the GHC API------------------------------------------------------------------------------ module Language.Haskell.Interpreter( -- * The interpreter monad transformer MonadInterpreter(..), InterpreterT, Interpreter,@@ -17,44 +6,38 @@ -- ** Interpreter options Option, OptionVal((:=)), get, set,- languageExtensions, availableExtensions, glasgowExtensions, Extension(..),+ languageExtensions, availableExtensions, Extension(..), installedModulesInScope, searchPath, - setUseLanguageExtensions,- setInstalledModsAreInScopeQualified, -- ** Context handling ModuleName, isModuleInterpreted,+ ModuleImport(..), ModuleQualification(..), ImportList(..), loadModules, getLoadedModules, setTopLevelModules,- setImports, setImportsQ,+ setImports, setImportsQ, setImportsF, reset, -- ** Module querying ModuleElem(..), Id, name, children, getModuleExports,-#if __GLASGOW_HASKELL__ >= 611- -- ** Anotations- -- | Please note below that annotations are an experimental- -- feature in GHC HEAD.+ -- ** 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,-#endif -- ** Type inference- typeOf, typeChecks, kindOf,+ typeChecksWithDetails,+ typeOf, typeChecks, kindOf, normalizeType, -- ** Evaluation- interpret, as, infer, eval,+ interpret, as, infer, eval, runStmt, -- * Error handling InterpreterError(..), GhcError(..), MultipleInstancesNotAllowed(..), -- * Miscellaneous- ghcVersion,parens,- module Control.Monad.Trans)--where+ ghcVersion, parens,+ module Control.Monad.Trans.Class,+ module Control.Monad.IO.Class,+) where import Hint.Base-#if __GLASGOW_HASKELL__ >= 611 import Hint.Annotations-#endif import Hint.InterpreterT import Hint.Configuration import Hint.Context@@ -62,4 +45,5 @@ import Hint.Typecheck import Hint.Eval -import Control.Monad.Trans+import Control.Monad.IO.Class+import Control.Monad.Trans.Class
src/Language/Haskell/Interpreter/Extension.hs view
@@ -1,5 +1,5 @@-module Language.Haskell.Interpreter.Extension ( module Hint.Extension )--where+module Language.Haskell.Interpreter.Extension (+ module Hint.Extension+) where import Hint.Extension
− src/Language/Haskell/Interpreter/GHC.hs
@@ -1,13 +0,0 @@--------------------------------------------------------------------------------- |--- DEPRECATED: use @Language.Haskell.Interpreter.Unsafe@ instead.-------------------------------------------------------------------------------module Language.Haskell.Interpreter.GHC-{-# DEPRECATED "Import Language.Haskell.Interpreter instead." #-}-(- module Language.Haskell.Interpreter-)--where--import Language.Haskell.Interpreter
− src/Language/Haskell/Interpreter/GHC/Unsafe.hs
@@ -1,13 +0,0 @@--------------------------------------------------------------------------------- |--- DEPRECATED: use @Language.Haskell.Interpreter.Unsafe@ instead.-------------------------------------------------------------------------------module Language.Haskell.Interpreter.GHC.Unsafe-{-# DEPRECATED "Import Language.Haskell.Interpreter.Unsafe instead." #-}-(- module Language.Haskell.Interpreter.Unsafe-)--where--import Language.Haskell.Interpreter.Unsafe
src/Language/Haskell/Interpreter/Unsafe.hs view
@@ -1,13 +1,13 @@ module Language.Haskell.Interpreter.Unsafe (- unsafeSetGhcOption, unsafeRunInterpreterWithArgs-)--where+ unsafeSetGhcOption, unsafeRunInterpreterWithArgs, unsafeRunInterpreterWithArgsLibdir,+ unsafeInterpret+) where -import Control.Monad.Trans+import Control.Monad.IO.Class import Control.Monad.Catch import Hint.Base+import Hint.Eval import Hint.Configuration import Hint.InterpreterT @@ -24,8 +24,21 @@ -- context. -- -- Warning: Some options may interact badly with the Interpreter.-unsafeRunInterpreterWithArgs :: (MonadMask m, MonadIO m, Functor m)- => [String]- -> InterpreterT m a- -> m (Either InterpreterError a)+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
unit-tests/run-unit-tests.hs view
@@ -1,25 +1,38 @@-module Main ( main ) where+module Main (main) where -import Prelude hiding ( catch )+import Prelude hiding (catch) -import Control.Exception.Extensible ( ArithException(..) )+import Control.Exception (ArithException(..), AsyncException(UserInterrupt)) import Control.Monad.Catch as MC -import Control.Monad ( liftM, when )+import Control.Monad (guard, liftM, when, void, (>=>)) -import Control.Concurrent ( forkIO )+import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.MVar+import Control.Concurrent.STM +import qualified Data.ByteString.Lazy as ByteString+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Data.Function ((&))+import Data.IORef+ import System.IO import System.FilePath import System.Directory+import System.Environment (getEnvironment, unsetEnv) import System.Exit-+import System.Process.Typed+#if defined(mingw32_HOST_OS) || defined(__MINGW32__)+#else+import System.Posix.Signals+#endif -import Test.HUnit ( (@?=), (@?) )+import Test.HUnit ((@?=), (@?), assertFailure) import qualified Test.HUnit as HUnit import Language.Haskell.Interpreter+import Language.Haskell.Interpreter.Unsafe test_reload_modified :: TestCase test_reload_modified = TestCase "reload_modified" [mod_file] $ do@@ -43,17 +56,19 @@ "f :: Int -> Int", "f = (1 +)"] --- get_f = do loadModules [mod_file]- setTopLevelModules [mod_name]- r <- interpret "f" (as :: Int -> Int)- return r+ 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 "data T where T :: T"+ liftIO $ writeFile mod_file $ unlines+ [ "data Foo = Foo { a :: Int }"+ , "f Foo{..} = a * 10"+ ] fails do_load @@? "first time, it shouldn't load" --- set [languageExtensions := [GADTs]]+ set [languageExtensions := [RecordWildCards]] succeeds do_load @@? "now, it should load" -- set [languageExtensions := []]@@ -69,8 +84,8 @@ liftIO $ writeFile mod_file "f = id" loadModules [mod_file] setTopLevelModules ["Main"]- setImportsQ [("Prelude",Nothing),- ("Data.Maybe", Just "Mb")]+ setImportsQ [("Prelude", Nothing),+ ("Data.Maybe", Just "Mb")] -- typeOf "f $ (1 + 1 :: Int)" @@?= "Int" eval "f . Mb.fromJust $ Just [1,2]" @@?= "[1,2]"@@ -105,18 +120,23 @@ ("Data.Map", Just "M")] typeChecks "null []" @@? "Unqual null" typeChecks "M.null M.empty" @@? "Qual null"- return () +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" [] $ do- eval "()" @@?= "()"+test_basic_eval = TestCase "basic_eval" [] $ eval "()" @@?= "()" test_eval_layout :: TestCase-test_eval_layout = TestCase "eval_layout" [] $ do- eval layout_expr @@?= "10"- where layout_expr = unlines $ ["let x = let y = 10",- " in y",- "in x"]+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@@ -171,7 +191,6 @@ "y :: Bool", "y = False"] - test_search_path_dot :: TestCase test_search_path_dot = TestCase "search_path_dot" [mod_file, dir] $ do@@ -187,35 +206,302 @@ writeFile mod_file $ unlines ["x :: Int", "x = 42"] - test_catch :: TestCase test_catch = TestCase "catch" [] $ do setImports ["Prelude"]- succeeds (action `catch` handler) @@? "catch failed"- where handler DivideByZero = return "catched"- handler e = throwM e- action = do s <- eval "1 `div` 0 :: Int"- return $! s + -- make sure we catch exceptions in return, and that the interpreter is+ -- still in a good state afterwards+ explosiveThunk <- eval "1 `div` 0 :: Int"+ (detonate explosiveThunk `catch` handleDivideByZero) @@?= "caught"+ eval "2 + 2 :: Int" @@?= "4" + -- make sure we catch exceptions in eval, and that the interpreter is+ -- still in a good state afterwards+ (eval "2 +" `catch` handleWontCompile) @@?= "caught"+ eval "2 + 2 :: Int" @@?= "4"++ -- make sure we catch exceptions in setImports, and that the interpreter+ -- is still in a good state afterwards+ (importNonsense `catch` handleWontCompile) @@?= "caught"+ eval "2 + 2 :: Int" @@?= "4"++ -- make sure we catch exceptions in loadModules+ (loadNonsense `catch` handleWontCompile) @@?= "caught"+ + -- loadModules resets the interpreter state, so we do _not_ expect that+ -- the Prelude is still in scope after loadNonsense+ fails (eval "2 + 2 :: Int") @@? "Prelude should not be in path"+ + -- but we do expect the interpreter state to be in a good enough state+ -- to evaluate builtins+ (eval "[1..4]" @@?= "[1,2,3,4]")++ -- bring the prelude back into scope for the rest of the tests+ setImports ["Prelude"]++ -- make sure we catch exceptions in setTopLevelModules, and that the+ -- interpreter is still in a good state afterwards+ (setTopLevelNonsense1 `catch` handleNotAllowed) @@?= "caught"+ eval "2 + 2 :: Int" @@?= "4"+ (setTopLevelNonsense2 `catch` handleNotAllowed) @@?= "caught"+ eval "2 + 2 :: Int" @@?= "4"+ where detonate explosiveThunk = return $! explosiveThunk+ importNonsense = do+ setImports ["NonExistentModule"]+ return "imported a non-existent module"+ loadNonsense = do+ loadModules ["NonExistentFile.hs"]+ return "loaded a non-existent file"+ setTopLevelNonsense1 = do+ setTopLevelModules ["Prelude"]+ return "looking inside the Prelude's internals"+ setTopLevelNonsense2 = do+ setTopLevelModules ["NonLoadedModule"]+ return "looking inside a module which wasn't loaded"+ handleDivideByZero DivideByZero = return "caught"+ handleDivideByZero e = throwM e+ handleWontCompile (WontCompile _) = return "caught"+ handleWontCompile e = throwM e+ handleNotAllowed (NotAllowed _) = return "caught"+ handleNotAllowed e = throwM e++#ifndef THREAD_SAFE_LINKER+-- Prior to ghc-8.10, the linker wasn't thread-safe, and so running multiple+-- instances of hint in different threads can lead to mysterious errors of the+-- form "Could not load '*_closure', dependency unresolved". To make that error+-- less mysterious, 'ifInterpreterNotRunning' throw a clearer error earlier, as+-- soon as it detects that the user is trying to run multiple instances of hint+-- in parallel. This test ensures that this nicer error is thrown. test_only_one_instance :: TestCase-test_only_one_instance = TestCase "only_one_instance" [] $ do- liftIO $ do+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 $ concurrent >> return ()+ _ <- forkIO $ Control.Monad.void concurrent readMVar r @? "concurrent instance did not fail"+#else+-- Prior to ghc-8.10, the linker wasn't thread-safe, and so running multiple+-- instances of hint in different threads can lead to mysterious errors of the+-- form "Could not load '*_closure', dependency unresolved". This test ensures+-- that this error no longer occurs. The important thing about this test is+-- that it should _fail_ if 'ifInterpreterNotRunning' is deleted and this test+-- is run on an older ghc version. Otherwise this test is not testing what it's+-- meant to.+test_multiple_instances :: TestCase+test_multiple_instances = TestCase "multiple_instances" [mod_file] $ liftIO $ do+ writeFile mod_file "f = id" + -- ensure the two threads interleave in a deterministic way+ tvar <- newTVarIO 1+ let step n = liftIO $ atomically $ do+ nextStep <- readTVar tvar+ guard (nextStep >= n)+ writeTVar tvar (n + 1)+ skipToStep n = liftIO $ atomically $ do+ modifyTVar tvar (max n) + mvar1 <- newEmptyMVar+ mvar2 <- newEmptyMVar+ void $ forkIO $ do+ r1 <- try $ runInterpreter $ do+ step 1+ loadModules [mod_file]+ step 3+ setTopLevelModules ["Main"]+ step 5+ setImports ["Prelude"]+ step 7+ eval "f [1,2]" @@?= "[1,2]"+ step 9+ skipToStep 9+ putMVar mvar1 r1+ void $ forkIO $ do+ r2 <- try $ runInterpreter $ do+ step 2+ loadModules [mod_file]+ step 4+ setTopLevelModules ["Main"]+ step 6+ setImports ["Prelude"]+ step 8+ eval "f [1,2]" @@?= "[1,2]"+ step 10+ skipToStep 10+ putMVar mvar2 r2+ noInterpreterError =<< noExceptions =<< takeMVar mvar1+ noInterpreterError =<< noExceptions =<< takeMVar mvar2+ where mod_file = "TEST_MultipleInstances.hs"+#endif++test_normalize_type :: TestCase+test_normalize_type = TestCase "normalize_type" [mod_file] $ do+ liftIO $ writeFile mod_file mod_text+ loadModules [mod_file]+ setTopLevelModules ["T"]+ normalizeType "Foo Int" @@?= "()"++ where mod_text = unlines ["{-# LANGUAGE TypeFamilies #-}"+ ,"module T where"+ ,"type family Foo x"+ ,"type instance Foo x = ()"]+ mod_file = "TEST_NormalizeType.hs"++test_package_db :: IOTestCase+test_package_db = IOTestCase "package_db" [dir] $ \wrapInterp -> do+ setup+ ghcVersionOutput <- readProcessStdout_ $ proc "ghc" ["--version"]+ let ghcVersion+ :: String+ ghcVersion+ = ghcVersionOutput+ -- "The Glorious Glasgow Haskell Compilation System, version 8.8.4" :: ByteString.Lazy+ & ByteString.toStrict+ -- "The Glorious Glasgow Haskell Compilation System, version 8.8.4" :: ByteString+ & Text.decodeUtf8+ -- "The Glorious Glasgow Haskell Compilation System, version 8.8.4" :: Text+ & Text.unpack+ -- "The Glorious Glasgow Haskell Compilation System, version 8.8.4" :: String+ & words+ -- ["The","Glorious","Glasgow","Haskell","Compilation","System,","version","8.8.4"]+ & last+ -- "8.8.4"+ let pkgdb = dir </> "dist-newstyle" </> "packagedb" </> ("ghc-" ++ ghcVersion)+ ghc_args = ["-package-db=" ++ pkgdb,"-package-env","-"]++ -- stack sets GHC_ENVIRONMENT to a file which pins down the versions of+ -- all the packages we can load, and since it does not list my-package,+ -- we cannot load it.+ unsetEnv "GHC_ENVIRONMENT"++ wrapInterp (unsafeRunInterpreterWithArgs ghc_args) $ do+ succeeds (setImports [mod]) @@? "module from package-db must be visible"+ --+ where pkg = "my-package"+ dir = pkg+ mod_file = dir </> mod <.> "hs"+ mod = "MyModule"+ cabal_file = dir </> pkg <.> "cabal"+ setup = do createDirectory dir+ writeFile cabal_file $ unlines+ [ "cabal-version: 2.4"+ , "name: " ++ pkg+ , "version: 0.1.0.0"+ , ""+ , "library"+ , " exposed-modules: " ++ mod+ ]+ writeFile mod_file $ unlines+ [ "{-# LANGUAGE NoImplicitPrelude #-}"+ , "module " ++ mod ++ " where"+ ]+ env <- getEnvironment+ runProcess_+ $ setWorkingDir dir+ $ -- stack sets GHC_PACKAGE_PATH, but cabal complains+ -- that it cannot run if that variable is set.+ setEnv (filter ((/= "GHC_PACKAGE_PATH") . fst) env)+ $ proc "cabal" ["build"]++test_ghc_environment_file :: IOTestCase+test_ghc_environment_file = IOTestCase "ghc_environment_file" [dir] $ \wrapInterp -> do+ setup++ -- stack sets GHC_ENVIRONMENT to a file which pins down the versions of+ -- all the packages we can load, and since it does not list my-package,+ -- we cannot load it.+ unsetEnv "GHC_ENVIRONMENT"++ wrapInterp runInterpreter $ do+ fails (setImports ["Acme.Dont"]) @@? "acme-dont should not be in path"++ -- in dir, there is a file .ghc.environment.<something> which lists the+ -- acme-dont package because it is a dependency of my-package. hint+ -- should detect that file and make containers available to the+ -- interpreted code.+ withCurrentDirectory dir $ do+ wrapInterp runInterpreter $ do+ succeeds (setImports ["Acme.Dont"]) @@? "acme-dont should be in path"+ --+ where pkg = "my-package"+ dir = pkg+ mod_file = dir </> mod <.> "hs"+ mod = "MyModule"+ cabal_file = dir </> pkg <.> "cabal"+ setup = do createDirectory dir+ writeFile cabal_file $ unlines+ [ "cabal-version: 2.4"+ , "name: " ++ pkg+ , "version: 0.1.0.0"+ , ""+ , "library"+ , " exposed-modules: " ++ mod+ , " build-depends: acme-dont"+ ]+ writeFile mod_file $ unlines+ [ "{-# LANGUAGE NoImplicitPrelude #-}"+ , "module " ++ mod ++ " where"+ ]+ env <- getEnvironment+ runProcess_+ $ proc "cabal" ["update"]+ runProcess_+ $ setWorkingDir dir+ $ -- stack sets GHC_PACKAGE_PATH, but cabal complains+ -- that it cannot run if that variable is set.+ setEnv (filter ((/= "GHC_PACKAGE_PATH") . fst) env)+ $ proc "cabal" ["build", "--write-ghc-environment-files=always"]++-- earlier versions of hint were accidentally overwriting the signal handlers+-- for ^C and others.+--+-- note that hint was _not_ overwriting the signal handlers when the hint interpreter+-- was itself executed inside the ghci interpreter. for this reason, this test always+-- succeeds when executed from ghci and ghcid, regardless of whether the problematic+-- behaviour has been fixed or not.+test_signal_handlers :: IOTestCase+test_signal_handlers = IOTestCase "signal_handlers" [] $ \wrapInterp -> do+#if defined(mingw32_HOST_OS) || defined(__MINGW32__)+ wrapInterp runInterpreter $ do+ pure ()+#else+ signalDetectedRef <- newIORef False+ interruptDetectedRef <- newIORef False+ let detectSignal = writeIORef signalDetectedRef True+ detectInterrupt = writeIORef interruptDetectedRef True+ acquire = installHandler sigINT (Catch detectSignal) Nothing+ release handler = installHandler sigINT handler Nothing+ r <- bracket acquire release $ \_ -> do+ wrapInterp runInterpreter $ do+ liftIO $ do+ r <- try $ do+ raiseSignal sigINT+ threadDelay 1000000 -- will be interrupted by the above signal+ case r of+ Left UserInterrupt -> do+ -- hint is _still_ accidentally overwriting the signal handler :(+ detectInterrupt+ Left e -> do+ -- some other async exception, rethrow+ throwM e+ Right () ->+ return ()+ signalDetected <- readIORef signalDetectedRef+ signalDetected @?= True+ interruptDetected <- readIORef interruptDetectedRef+ interruptDetected @?= False+ return r+#endif+ tests :: [TestCase] tests = [test_reload_modified ,test_lang_exts ,test_work_in_main ,test_comments_in_expr ,test_qual_import+ ,test_full_import ,test_basic_eval ,test_eval_layout ,test_show_in_scope@@ -224,17 +510,32 @@ ,test_search_path ,test_search_path_dot ,test_catch+#ifndef THREAD_SAFE_LINKER ,test_only_one_instance+#else+ ,test_multiple_instances+#endif+ ,test_normalize_type ] +ioTests :: [IOTestCase]+ioTests = [test_signal_handlers+ ,test_package_db+ ,test_ghc_environment_file+ ]+ main :: IO () main = do -- run the tests...- c <- runTests False tests+ c1 <- runTests False tests+ c2 <- runIOTests False ioTests -- then run again, but with sandboxing on...- c' <- runTests True tests+ c3 <- runTests True tests+ c4 <- runIOTests True ioTests --- let failures = HUnit.errors c + HUnit.failures c +- HUnit.errors c' + HUnit.failures c'+ let failures = HUnit.errors c1 + HUnit.failures c1 ++ HUnit.errors c2 + HUnit.failures c2 ++ HUnit.errors c3 + HUnit.failures c3 ++ HUnit.errors c4 + HUnit.failures c4 exit_code | failures > 0 = ExitFailure failures | otherwise = ExitSuccess@@ -242,14 +543,11 @@ -- `catch` (\_ -> exitWith (ExitFailure $ -1)) printInterpreterError :: InterpreterError -> IO ()-printInterpreterError = hPutStrLn stderr . show+printInterpreterError = hPrint stderr setSandbox :: Interpreter () setSandbox = set [installedModulesInScope := False] -(>=>) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c)-f >=> g = \a -> f a >>= g- (@@?) :: (HUnit.AssertionPredicable p, MonadIO m) => m p -> String -> m () p @@? msg = do b <- p; liftIO (b @? msg) @@ -263,25 +561,50 @@ catchIE = MC.catch succeeds :: (MonadCatch m, MonadIO m) => m a -> m Bool-succeeds = liftM not . fails+succeeds = fmap not . fails +noExceptions :: Either SomeException a -> IO a+noExceptions (Left e) = assertFailure (show e)+noExceptions (Right a) = pure a -data TestCase = TestCase String [FilePath] (Interpreter ())+noInterpreterError :: Either InterpreterError a -> IO a+noInterpreterError (Left e) = assertFailure (show e)+noInterpreterError (Right a) = pure a -runTests :: Bool -> [TestCase] -> IO HUnit.Counts-runTests sandboxed = HUnit.runTestTT . HUnit.TestList . map build- where build (TestCase title tmps test) = HUnit.TestLabel title $- HUnit.TestCase test_case+data IOTestCase = IOTestCase+ String -- test name+ [FilePath] -- temporary files and folders to delete after the test+ ( ( (Interpreter () -> IO (Either InterpreterError ()))+ -> (Interpreter () -> IO (Either InterpreterError ()))+ ) -- please wrap your 'runInterpreter' calls with this+ -> IO (Either InterpreterError ()) -- create temporary files and run the test+ )++runIOTests :: Bool -> [IOTestCase] -> IO HUnit.Counts+runIOTests sandboxed = HUnit.runTestTT . HUnit.TestList . map build+ where build (IOTestCase title tmps test)+ = HUnit.TestLabel title $ HUnit.TestCase test_case where test_case = go `finally` clean_up clean_up = mapM_ removeIfExists tmps- go = do r <- runInterpreter- (when sandboxed setSandbox >> test)- either (printInterpreterError >=> (fail . show))- return r+ wrapInterp runInterp body = runInterp (when sandboxed setSandbox >> body)+ go = do r <- test wrapInterp+ noInterpreterError r removeIfExists f = do existsF <- doesFileExist f if existsF then removeFile f else do existsD <- doesDirectoryExist f when existsD $- removeDirectory f+ removeDirectoryRecursive f++data TestCase = TestCase+ String -- test name+ [FilePath] -- temporary files and folders to delete after the test+ (Interpreter ()) -- create temporary files and run the test++runTests :: Bool -> [TestCase] -> IO HUnit.Counts+runTests sandboxed = runIOTests sandboxed . map toIOTestCase+ where+ toIOTestCase :: TestCase -> IOTestCase+ toIOTestCase (TestCase title tmps test) = IOTestCase title tmps $ \wrapInterp -> do+ wrapInterp runInterpreter test