diff --git a/AUTHORS b/AUTHORS --- a/AUTHORS +++ b/AUTHORS @@ -2,8 +2,10 @@ Austin Seipp Bertram Felgenhauer +Brandon Chinn Bryan O'Sullivan Carl Howells +Christiaan Baaij Conrad Parker Corentin Dupont Daniel Gorin @@ -12,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 Samuel Gélineau +Sid Kapur diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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.hs` instead of `` + - Improved cleanup of phantom module source files + - ghc 8.4 only: phantom modules are put into a temporary directory +* Add `typeChecksWithDetails` to obtain type-checking errors +* Stop GHC from overwriting the Ctrl-C signal handler +* Add `SetImportsF` to allow finer imports control + +### 0.7.0 + +* Support for GHC 8.2 +* Support use in a dynamically-linked executable +* Add `normalizeType`, like ghci's :kind! +* Drop support for GHC 7.6 + +### 0.6.0 + +* Support for GHC 8.0 +* Add `displayException` to InterpreterError + +### 0.5.2 + +* Add `runInterpreter` variant that takes a GHC libdir at runtime +* Add missing negated extensions to the `Extension` type +* Do not throw GHC warnings as errors + +### 0.5.1 + +* Expose `unsafeInterpret` in `Language.Haskell.Interpreter.Unsafe` + +### 0.5.0 + +* Drop support for GHC 7.4 +* Remove deprecated functions and modules: + - `glasgowExtensions` + - `setUseLanguageExtensions` + - `setInstalledModsAreInScopeQualified` + - `Language.Haskell.Interpreter.GHC` + - `Language.Haskell.Interpreter.GHC.Unsafe` +* Drop dependencies on `ghc-mtl` and `extensible-exceptions` + ### 0.4.3 - * New maintainer and source code repo +* 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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,16 +1,109 @@ -# hint +# hint [![Hackage](https://img.shields.io/hackage/v/hint.svg)](https://hackage.haskell.org/package/hint) [![Build Status](https://github.com/haskell-hint/hint/workflows/CI/badge.svg)](https://github.com/haskell-hint/hint/actions) -[![Build Status](https://travis-ci.org/mvdan/hint.svg?branch=master)](https://travis-ci.org/mvdan/hint) +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.` in the current +directory. At runtime, hint will look for that file in the current directory. + +For more advanced use cases, you can use +[`unsafeRunInterpreterWithArgs`](https://hackage.haskell.org/package/hint/docs/Language-Haskell-Interpreter-Unsafe.html#v:unsafeRunInterpreterWithArgs) +to pass arguments to the underlying ghc library, such as +[`-package-db`](https://downloads.haskell.org/~ghc/latest/docs/users_guide/packages.html?highlight=package%20db#ghc-flag--package-db%20%E2%9F%A8file%E2%9F%A9) +to specify a path to a package database, or +[`-package-env`](https://downloads.haskell.org/~ghc/latest/docs/users_guide/packages.html?highlight=package%20db#ghc-flag--package-env%20%E2%9F%A8file%E2%9F%A9%7C%E2%9F%A8name%E2%9F%A9) +to specify a path to a GHC environment file. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,5 +0,0 @@ -#!/usr/bin/env runhaskell -> module Main where -> import Distribution.Simple -> main :: IO () -> main = defaultMainWithHooks defaultUserHooks diff --git a/examples/example.hs b/examples/example.hs --- a/examples/example.hs +++ b/examples/example.hs @@ -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 diff --git a/hint.cabal b/hint.cabal --- a/hint.cabal +++ b/hint.cabal @@ -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" +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 diff --git a/src/Control/Monad/Ghc.hs b/src/Control/Monad/Ghc.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Ghc.hs @@ -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 diff --git a/src/Hint/Annotations.hs b/src/Hint/Annotations.hs --- a/src/Hint/Annotations.hs +++ b/src/Hint/Annotations.hs @@ -1,72 +1,43 @@ --- - extract annotations from modules etc. with the GHC API. --- - requires GHC >= 6.11 --- --- austin seipp -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 diff --git a/src/Hint/Base.hs b/src/Hint/Base.hs --- a/src/Hint/Base.hs +++ b/src/Hint/Base.hs @@ -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 diff --git a/src/Hint/Compat.hs b/src/Hint/Compat.hs deleted file mode 100644 --- a/src/Hint/Compat.hs +++ /dev/null @@ -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 diff --git a/src/Hint/CompatPlatform.hs b/src/Hint/CompatPlatform.hs --- a/src/Hint/CompatPlatform.hs +++ b/src/Hint/CompatPlatform.hs @@ -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 diff --git a/src/Hint/Configuration.hs b/src/Hint/Configuration.hs --- a/src/Hint/Configuration.hs +++ b/src/Hint/Configuration.hs @@ -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) diff --git a/src/Hint/Context.hs b/src/Hint/Context.hs --- a/src/Hint/Context.hs +++ b/src/Hint/Context.hs @@ -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 () diff --git a/src/Hint/Conversions.hs b/src/Hint/Conversions.hs --- a/src/Hint/Conversions.hs +++ b/src/Hint/Conversions.hs @@ -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 -------------------------- diff --git a/src/Hint/Eval.hs b/src/Hint/Eval.hs --- a/src/Hint/Eval.hs +++ b/src/Hint/Eval.hs @@ -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 diff --git a/src/Hint/Extension.hs b/src/Hint/Extension.hs --- a/src/Hint/Extension.hs +++ b/src/Hint/Extension.hs @@ -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 ] diff --git a/src/Hint/GHC.hs b/src/Hint/GHC.hs --- a/src/Hint/GHC.hs +++ b/src/Hint/GHC.hs @@ -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 diff --git a/src/Hint/Internal.hs b/src/Hint/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Hint/Internal.hs @@ -0,0 +1,33 @@ +-- | In this module we intend to export some internal functions. +-- +-- __Important note__: the authors of this library imply no assurance whatsoever +-- of the stability or functionality of the API exposed here, and compatibility +-- may break even by minor version changes. Rely on these at your +-- own risk. +-- +-- The reason for showing them here is to aid discoverability +-- of already written code and prevent having to reinvent the wheel from +-- scratch if said wheel is already invented. +-- +-- In case you find something here especially useful, please submit +-- an issue or a pull request at https://github.com/haskell-hint/hint so +-- we can discuss making it part of the official public API. +-- +-- Some further context can be found here: +-- https://github.com/haskell-hint/hint/pull/48#issuecomment-358722638 + + + +module Hint.Internal ( + onCompilationError +) where + +import Hint.Typecheck (onCompilationError) + + + +-- todo: Consider refactoring like the following when +-- https://github.com/haskell/haddock/issues/563 is fixed +-- +-- module Hint.Internal (module ReExport) where +-- import Hint.Typecheck as ReExport (onCompilationError) diff --git a/src/Hint/InterpreterT.hs b/src/Hint/InterpreterT.hs --- a/src/Hint/InterpreterT.hs +++ b/src/Hint/InterpreterT.hs @@ -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 diff --git a/src/Hint/Parsers.hs b/src/Hint/Parsers.hs --- a/src/Hint/Parsers.hs +++ b/src/Hint/Parsers.hs @@ -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 "") 1 1 - let parse_res = GHC.unP parser (Compat.mkPState dyn_fl buf srcLoc) + let srcLoc = GHC.mkRealSrcLoc (GHC.fsLit "") 1 1 + let parserOpts = GHC.mkParserOpts dyn_fl + let parse_res = GHC.unP parser (GHC.initParserState parserOpts buf srcLoc) -- case parse_res of GHC.POk{} -> return ParseOk -- - 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 diff --git a/src/Hint/Reflection.hs b/src/Hint/Reflection.hs --- a/src/Hint/Reflection.hs +++ b/src/Hint/Reflection.hs @@ -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 diff --git a/src/Hint/Sandbox.hs b/src/Hint/Sandbox.hs deleted file mode 100644 --- a/src/Hint/Sandbox.hs +++ /dev/null @@ -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 diff --git a/src/Hint/SignalHandlers.hs b/src/Hint/SignalHandlers.hs deleted file mode 100644 --- a/src/Hint/SignalHandlers.hs +++ /dev/null @@ -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 diff --git a/src/Hint/Typecheck.hs b/src/Hint/Typecheck.hs --- a/src/Hint/Typecheck.hs +++ b/src/Hint/Typecheck.hs @@ -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 diff --git a/src/Hint/Typecheck.hs-boot b/src/Hint/Typecheck.hs-boot deleted file mode 100644 --- a/src/Hint/Typecheck.hs-boot +++ /dev/null @@ -1,5 +0,0 @@ -module Hint.Typecheck where - -import Hint.Base (MonadInterpreter) - -typeChecks_unsandboxed :: MonadInterpreter m => String -> m Bool diff --git a/src/Hint/Util.hs b/src/Hint/Util.hs --- a/src/Hint/Util.hs +++ b/src/Hint/Util.hs @@ -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, "'"] diff --git a/src/Language/Haskell/Interpreter.hs b/src/Language/Haskell/Interpreter.hs --- a/src/Language/Haskell/Interpreter.hs +++ b/src/Language/Haskell/Interpreter.hs @@ -1,14 +1,3 @@ ------------------------------------------------------------------------------ --- | --- Module : Language.Haskell.Interpreter --- License : BSD-style --- --- Maintainer : mvdan@mvdan.cc --- Stability : experimental --- Portability : non-portable (GHC API) --- --- A Haskell interpreter built on top of the GHC API ------------------------------------------------------------------------------ module Language.Haskell.Interpreter( -- * The interpreter monad transformer MonadInterpreter(..), InterpreterT, Interpreter, @@ -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 diff --git a/src/Language/Haskell/Interpreter/Extension.hs b/src/Language/Haskell/Interpreter/Extension.hs --- a/src/Language/Haskell/Interpreter/Extension.hs +++ b/src/Language/Haskell/Interpreter/Extension.hs @@ -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 diff --git a/src/Language/Haskell/Interpreter/GHC.hs b/src/Language/Haskell/Interpreter/GHC.hs deleted file mode 100644 --- a/src/Language/Haskell/Interpreter/GHC.hs +++ /dev/null @@ -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 diff --git a/src/Language/Haskell/Interpreter/GHC/Unsafe.hs b/src/Language/Haskell/Interpreter/GHC/Unsafe.hs deleted file mode 100644 --- a/src/Language/Haskell/Interpreter/GHC/Unsafe.hs +++ /dev/null @@ -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 diff --git a/src/Language/Haskell/Interpreter/Unsafe.hs b/src/Language/Haskell/Interpreter/Unsafe.hs --- a/src/Language/Haskell/Interpreter/Unsafe.hs +++ b/src/Language/Haskell/Interpreter/Unsafe.hs @@ -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 diff --git a/unit-tests/run-unit-tests.hs b/unit-tests/run-unit-tests.hs --- a/unit-tests/run-unit-tests.hs +++ b/unit-tests/run-unit-tests.hs @@ -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. 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