diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,149 +1,166 @@ +### 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 + accross 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,13 +1,14 @@ # hint [![Build Status](https://travis-ci.org/mvdan/hint.svg?branch=master)](https://travis-ci.org/mvdan/hint) +[![Hackage](https://img.shields.io/hackage/v/hint.svg)](https://hackage.haskell.org/package/hint) This library defines an Interpreter monad. It allows to load Haskell modules, browse them, type-check and evaluate strings with Haskell expressions and even coerce them into values. The library is thread-safe and type-safe (even the coercion of expressions to values). -It is, esentially, a huge subset of the GHC API wrapped in a simpler +It is, essentially, a huge subset of the GHC API wrapped in a simpler API. ### Example 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 @@ -31,7 +31,7 @@ -- 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) -- @@ -47,17 +47,16 @@ say . show $ fun (Just 7) -- 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)) + bool_val <- interpret expr3 infer `ap` return (Just False) say (show $ not bool_val) -- 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 say res - say :: String -> Interpreter () say = liftIO . putStrLn printInterpreterError :: InterpreterError -> IO () -printInterpreterError e = putStrLn $ "Ups... " ++ (show e) +printInterpreterError e = putStrLn $ "Ups... " ++ show e diff --git a/hint.cabal b/hint.cabal --- a/hint.cabal +++ b/hint.cabal @@ -1,25 +1,25 @@ -name: hint -version: 0.4.3 +name: hint +version: 0.5.0 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: 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 + extra-source-files: README.md AUTHORS CHANGELOG.md @@ -31,88 +31,60 @@ location: https://github.com/mvdan/hint Test-Suite unit-tests - type: exitcode-stdio-1.0 + 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 -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.*, + hint, + HUnit, + directory, + filepath, + extensible-exceptions, + exceptions - 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 - } +Library + build-depends: base == 4.*, + ghc >= 7.6, + ghc-paths, + mtl, + filepath, + exceptions, + random, + directory 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 - - if impl(ghc >= 6.11) { - other-modules: Hint.Annotations - } + exposed-modules: Language.Haskell.Interpreter + Language.Haskell.Interpreter.Extension + Language.Haskell.Interpreter.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.Util + Hint.Annotations + Control.Monad.Ghc - hs-source-dirs: src + hs-source-dirs: src - ghc-options: -Wall -O2 - extensions: CPP - GeneralizedNewtypeDeriving - MultiParamTypeClasses - DeriveDataTypeable - MagicHash - TypeSynonymInstances - FlexibleInstances - FlexibleContexts - FunctionalDependencies - KindSignatures - Rank2Types - ScopedTypeVariables - ExistentialQuantification - PatternGuards + ghc-options: -Wall + extensions: CPP + GeneralizedNewtypeDeriving + DeriveDataTypeable + MagicHash + FunctionalDependencies + Rank2Types + ScopedTypeVariables + ExistentialQuantification 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,76 @@ +module Control.Monad.Ghc ( + GhcT, runGhcT +) where + +import Control.Applicative +import Prelude + +import Control.Monad +import Control.Monad.Trans +import qualified Control.Monad.Trans as MTL + +import Control.Monad.Catch + +import qualified GHC ( runGhcT ) +import qualified MonadUtils as GHC +import qualified Exception as GHC +import qualified GhcMonad as GHC + +import qualified DynFlags as GHC + +newtype GhcT m a = GhcT { unGhcT :: GHC.GhcT (MTLAdapter m) a } + deriving (Functor, Monad, GHC.HasDynFlags) + +instance (Functor m, Monad m) => Applicative (GhcT m) where + pure = return + (<*>) = ap + +runGhcT :: (Functor m, MonadIO m, MonadCatch m, MonadMask m) => Maybe FilePath -> GhcT m a -> m a +runGhcT f = unMTLA . GHC.runGhcT f . unGhcT + +instance MTL.MonadTrans GhcT where + lift = GhcT . GHC.liftGhcT . MTLAdapter + +instance MTL.MonadIO m => MTL.MonadIO (GhcT m) where + liftIO = GhcT . GHC.liftIO + +#if __GLASGOW_HASKELL__ < 708 + -- ghc started using transformers at some point +instance MTL.MonadIO m => GHC.MonadIO (GhcT m) where + liftIO = MTL.liftIO +#endif + +instance MonadCatch m => MonadThrow (GhcT m) where + throwM = lift . throwM + +instance (MonadIO m,MonadCatch m, MonadMask m) => MonadCatch (GhcT m) where + m `catch` f = GhcT (unGhcT m `GHC.gcatch` (unGhcT . f)) + +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 = mask + +instance (MonadIO m, MonadCatch m, MonadMask m) => GHC.ExceptionMonad (GhcT m) where + gcatch = catch + gmask f = mask (\x -> f x) + +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 MTL.MonadIO m => GHC.MonadIO (MTLAdapter m) where + liftIO = MTLAdapter . MTL.liftIO + +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)) diff --git a/src/Hint/Base.hs b/src/Hint/Base.hs --- a/src/Hint/Base.hs +++ b/src/Hint/Base.hs @@ -1,24 +1,22 @@ module Hint.Base ( MonadInterpreter(..), RunGhc, - -- + GhcError(..), InterpreterError(..), mayFail, catchIE, - -- + InterpreterSession, SessionData(..), GhcErrLogger, InterpreterState(..), fromState, onState, InterpreterConfiguration(..), - -- - runGhc1, runGhc2, runGhc3, runGhc4, runGhc5, - -- + + runGhc1, runGhc2, runGhc3, + ModuleName, PhantomModule(..), findModule, moduleIsLoaded, withDynFlags, - -- + ghcVersion, - -- - debug, showGHC -) -where + debug, showGHC +) where import Control.Monad.Trans import Control.Monad.Catch as MC @@ -29,15 +27,12 @@ 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 +-- * @708@ for GHC 7.8.x -- --- * @610@ for GHC 6.10.x +-- * @710@ for GHC 7.10.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,50 +55,26 @@ | 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 InterpreterState = St { + activePhantoms :: [PhantomModule], + zombiePhantoms :: [PhantomModule], + hintSupportModule :: PhantomModule, + importQualHackMod :: Maybe PhantomModule, + qualImports :: [(ModuleName, String)], + defaultExts :: [(Extension,Bool)], -- R/O + configuration :: InterpreterConfiguration + } data InterpreterConfiguration = Conf { - search_path :: [FilePath], - language_exts :: [Extension], - all_mods_in_scope :: Bool + searchFilePath :: [FilePath], + languageExts :: [Extension], + allModsInScope :: Bool } -#if __GLASGOW_HASKELL__ < 610 -type InterpreterSession = SessionData GHC.Session - -adjust :: (a -> b -> c) -> (b -> a -> c) -adjust f = flip f - -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) - -type RunGhc4 m a b c d e = (GHC.Session -> a -> b -> c -> d -> IO e) - -> (a -> b -> c -> d -> m e) - -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) - -#else - -- ghc >= 6.10 type InterpreterSession = SessionData () instance Exception InterpreterError -adjust :: (a -> b) -> (a -> b) -adjust = id - type RunGhc m a = (forall n.(MonadIO n, MonadMask n,Functor n) => GHC.GhcT n a) -> m a @@ -121,15 +91,6 @@ (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, @@ -150,43 +111,27 @@ -> 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) +runGhc1 f a = runGhc (f a) runGhc2 :: MonadInterpreter m => RunGhc2 m a b c -runGhc2 f a = runGhc1 (adjust f a) +runGhc2 f a = runGhc1 (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) - +runGhc3 f a = runGhc2 (f a) -- ================ Handling the interpreter state ================= @@ -222,19 +167,18 @@ showGHC a = do unqual <- runGhc GHC.getPrintUnqual withDynFlags $ \df -> - return $ Compat.showSDocForUser df unqual (GHC.ppr a) + return $ GHC.showSDocForUser df 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 where mod_name = GHC.mkModuleName mn - moduleIsLoaded :: MonadInterpreter m => ModuleName -> m Bool moduleIsLoaded mn = (findModule mn >> return True) diff --git a/src/Hint/Compat.hs b/src/Hint/Compat.hs --- a/src/Hint/Compat.hs +++ b/src/Hint/Compat.hs @@ -1,16 +1,8 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} -module Hint.Compat - -where - -#if __GLASGOW_HASKELL__ < 702 -import Control.Monad.Trans (liftIO) -#endif +module Hint.Compat where -#if __GLASGOW_HASKELL__ >= 704 import Control.Monad (foldM, liftM) -#endif import qualified Hint.GHC as GHC @@ -18,35 +10,15 @@ -- 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 + 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 @@ -62,66 +34,27 @@ 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) - + (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, @@ -137,12 +70,6 @@ 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 @@ -152,64 +79,9 @@ 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 @@ -217,41 +89,4 @@ 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,15 +1,12 @@ #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__) @@ -20,7 +17,6 @@ import System.Posix.Process #endif - #if defined(mingw32_HOST_OS) || defined(__MINGW32__) -- This function is not yet in the win32 package, so we have to diff --git a/src/Hint/Configuration.hs b/src/Hint/Configuration.hs --- a/src/Hint/Configuration.hs +++ b/src/Hint/Configuration.hs @@ -1,24 +1,20 @@ module Hint.Configuration ( - setGhcOption, setGhcOptions, - defaultConf, fromConf, onConf, + defaultConf, get, set, Option, OptionVal(..), - languageExtensions, availableExtensions, glasgowExtensions, Extension(..), + languageExtensions, availableExtensions, Extension(..), installedModulesInScope, - setUseLanguageExtensions, - - setInstalledModsAreInScopeQualified, searchPath - ) where +) where import Control.Monad import Control.Monad.Catch import Data.Char -import Data.List ( intersect, intercalate ) +import Data.List ( intercalate ) import qualified Hint.GHC as GHC import qualified Hint.Compat as Compat @@ -31,7 +27,7 @@ setGhcOptions opts = do old_flags <- runGhc GHC.getSessionDynFlags (new_flags,not_parsed) <- runGhc2 Compat.parseDynamicFlags old_flags opts - when (not . null $ not_parsed) $ + unless (null not_parsed) $ throwM $ UnknownError $ concat ["flags: ", unwords $ map quote not_parsed, "not recognized"] @@ -43,12 +39,11 @@ defaultConf :: InterpreterConfiguration defaultConf = Conf { - language_exts = [], - all_mods_in_scope = False, - search_path = ["."] + languageExts = [], + allModsInScope = False, + searchFilePath = ["."] } - -- | Available options are: -- -- * 'languageExtensions' @@ -56,8 +51,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 @@ -79,9 +76,9 @@ languageExtensions = Option setter getter where setter es = do resetExtensions setGhcOptions $ map (extFlag True) es - onConf $ \c -> c{language_exts = es} + onConf $ \c -> c{languageExts = es} -- - getter = fromConf language_exts + getter = fromConf languageExts -- resetExtensions = do es <- fromState defaultExts setGhcOptions $ map (uncurry $ flip extFlag) es @@ -95,46 +92,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 +103,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,12 +115,11 @@ -- 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 - fromConf :: MonadInterpreter m => (InterpreterConfiguration -> a) -> m a fromConf f = fromState (f . configuration) @@ -172,13 +127,3 @@ => (InterpreterConfiguration -> InterpreterConfiguration) -> 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 - -{-# DEPRECATED setInstalledModsAreInScopeQualified "Use set [installedModulesInScope := b] instead." #-} -setInstalledModsAreInScopeQualified :: MonadInterpreter m => Bool -> m () -setInstalledModsAreInScopeQualified b = set [installedModulesInScope := b] diff --git a/src/Hint/Context.hs b/src/Hint/Context.hs --- a/src/Hint/Context.hs +++ b/src/Hint/Context.hs @@ -1,27 +1,21 @@ module Hint.Context ( - - ModuleName, isModuleInterpreted, + isModuleInterpreted, loadModules, getLoadedModules, setTopLevelModules, setImports, setImportsQ, reset, - PhantomModule(..), ModuleText, - addPhantomModule, removePhantomModule, getPhantomModules, + PhantomModule(..), cleanPhantomModules, - allModulesInContext, onAnEmptyContext, - - support_String, support_show -) - -where + supportString, supportShow +) where import Prelude hiding ( mod ) import Data.Char import Data.List -import Control.Monad ( liftM, filterM, when, guard ) +import Control.Monad ( liftM, filterM, unless, guard ) import Control.Monad.Trans ( liftIO ) import Control.Monad.Catch @@ -58,7 +52,7 @@ -- tmp_dir <- liftIO getTemporaryDirectory -- - return PhantomModule{pm_name = mod_name, pm_file = tmp_dir nums} + return PhantomModule{pmName = mod_name, pmFile = tmp_dir nums} allModulesInContext :: MonadInterpreter m => m ([ModuleName], [ModuleName]) allModulesInContext = runGhc Compat.getContextNames @@ -68,12 +62,12 @@ -> m PhantomModule addPhantomModule mod_text = do pm <- newPhantomModule - let t = Compat.fileTarget (pm_file pm) - m = GHC.mkModuleName (pm_name pm) + let t = Compat.fileTarget (pmFile pm) + m = GHC.mkModuleName (pmName 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}) + 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 Compat.getContext @@ -102,11 +96,11 @@ -- 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) + mod <- findModule (pmName pm) (mods, imps) <- runGhc Compat.getContext let mods' = filter (mod /=) mods runGhc2 Compat.setContext mods' imps @@ -116,27 +110,27 @@ null `liftM` 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 + runGhc1 GHC.removeTarget (GHC.targetId $ Compat.fileTarget 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}) + liftIO $ removeFile (pmFile pm) + else do onState (\s -> s{zombiePhantoms = pm:zombiePhantoms s}) return () -- 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 @@ -167,10 +161,9 @@ reset 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 +doLoad fs = mayFail $ do + targets <- mapM (\f->runGhc2 GHC.guessTarget f Nothing) fs -- runGhc1 GHC.setTargets targets res <- runGhc1 GHC.load GHC.LoadAllTargets @@ -186,7 +179,7 @@ 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) + return $ ms \\ map pmName (active_pms ++ zombie_pms) modNameFromSummary :: GHC.ModSummary -> ModuleName modNameFromSummary = moduleToString . GHC.ms_mod @@ -205,31 +198,22 @@ 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) $ + 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 - -- | Sets the modules whose exports must be in context. -- -- Warning: 'setImports' and 'setImportsQ' are mutually exclusive. @@ -248,31 +232,31 @@ -- 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 + 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 -- - 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 ) + 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}) + onState (\s -> s{importQualHackMod = Just new_pm}) return $ Just new_pm else return Nothing -- - pm <- maybe (return []) (findModule . pm_name >=> return . return) new_pm + pm <- maybe (return []) (findModule . pmName >=> 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 -- - onState (\s ->s{qual_imports = quals}) + onState (\s ->s{qualImports = quals}) -- | 'cleanPhantomModules' works like 'reset', but skips the -- loading of the support module that installs '_show'. Its purpose @@ -293,13 +277,13 @@ -- 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) -- | All imported modules are cleared from the context, and -- loaded modules are unloaded. It is similar to a @:load@ in @@ -315,8 +299,8 @@ -- 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) + onState (\st -> st{hintSupportModule = mod}) + mod' <- findModule (pmName mod) runGhc2 Compat.setContext [mod'] [] -- where support_module m = unlines [ @@ -339,7 +323,7 @@ -- 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 +reinstallSupportModule = do pm <- fromState hintSupportModule removePhantomModule pm installSupportModule @@ -352,13 +336,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 () 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) + return $ GHC.showSDocForUser df unqual (Compat.pprType t) kindToString :: MonadInterpreter m => Compat.Kind -> m String kindToString (Compat.Kind k) = withDynFlags $ \df -> - return $ Compat.showSDoc df (Compat.pprKind k) - + return $ GHC.showSDoc df (Compat.pprType 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,9 +1,7 @@ module Hint.Eval ( - interpret, as, infer, - eval ,parens) - -where + eval, parens +) where import qualified GHC.Exts ( unsafeCoerce# ) @@ -13,12 +11,10 @@ import Hint.Base import Hint.Context import Hint.Parsers -import Hint.Sandbox import Hint.Util import qualified Hint.Compat as Compat - -- | Convenience functions to be used with @interpret@ to provide witnesses. -- Example: -- @@ -33,26 +29,24 @@ interpret :: (MonadInterpreter m, Typeable a) => String -> a -> m a interpret expr wit = unsafeInterpret expr (show $ Data.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 $ runGhc1 Compat.compileExpr expr_typesig + -- + return (GHC.Exts.unsafeCoerce# expr_val :: a) -- | @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 diff --git a/src/Hint/Extension.hs b/src/Hint/Extension.hs --- a/src/Hint/Extension.hs +++ b/src/Hint/Extension.hs @@ -1,9 +1,8 @@ -- this module was automatically generated. do not edit! -- edit util/mk_extensions_mod.hs instead -module Hint.Extension (Extension(..), - knownExtensions, availableExtensions, asExtension) - -where +module Hint.Extension ( + Extension(..), availableExtensions, asExtension +) where import Hint.Compat as Compat @@ -29,13 +28,14 @@ | RecursiveDo | ParallelListComp | MultiParamTypeClasses - | NoMonomorphismRestriction + | MonomorphismRestriction | FunctionalDependencies | Rank2Types | RankNTypes | PolymorphicComponents | ExistentialQuantification | ScopedTypeVariables + | PatternSignatures | ImplicitParams | FlexibleContexts | FlexibleInstances @@ -48,7 +48,7 @@ | ForeignFunctionInterface | Arrows | Generics - | NoImplicitPrelude + | ImplicitPrelude | NamedFieldPuns | PatternGuards | GeneralizedNewtypeDeriving @@ -59,20 +59,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 +86,7 @@ | PostfixOperators | QuasiQuotes | TransformListComp + | MonadComprehensions | ViewPatterns | XmlSyntax | RegularPatterns @@ -87,6 +94,8 @@ | GHCForeignImportPrim | NPlusKPatterns | DoAndIfThenElse + | MultiWayIf + | LambdaCase | RebindableSyntax | ExplicitForAll | DatatypeContexts @@ -94,6 +103,30 @@ | 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 | UnknownExtension String deriving (Eq, Show, Read) @@ -105,13 +138,14 @@ RecursiveDo, ParallelListComp, MultiParamTypeClasses, - NoMonomorphismRestriction, + MonomorphismRestriction, FunctionalDependencies, Rank2Types, RankNTypes, PolymorphicComponents, ExistentialQuantification, ScopedTypeVariables, + PatternSignatures, ImplicitParams, FlexibleContexts, FlexibleInstances, @@ -124,7 +158,7 @@ ForeignFunctionInterface, Arrows, Generics, - NoImplicitPrelude, + ImplicitPrelude, NamedFieldPuns, PatternGuards, GeneralizedNewtypeDeriving, @@ -135,20 +169,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 +196,7 @@ PostfixOperators, QuasiQuotes, TransformListComp, + MonadComprehensions, ViewPatterns, XmlSyntax, RegularPatterns, @@ -163,11 +204,37 @@ 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 ] diff --git a/src/Hint/GHC.hs b/src/Hint/GHC.hs --- a/src/Hint/GHC.hs +++ b/src/Hint/GHC.hs @@ -2,54 +2,32 @@ 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, -#endif -#if __GLASGOW_HASKELL__ >= 608 module PprTyThing, -#elif __GLASGOW_HASKELL__ < 608 module SrcLoc, -#endif -#if __GLASGOW_HASKELL__ >= 702 - module SrcLoc, -#endif #if __GLASGOW_HASKELL__ >= 708 module ConLike, #endif -) +) where -where -#if __GLASGOW_HASKELL__ >= 610 import GHC hiding ( Phase, GhcT, runGhcT ) import Control.Monad.Ghc ( GhcT, runGhcT ) import HscTypes ( SourceError, srcErrorMessages, GhcApiError ) -import Bag ( bagToList ) -#else -import GHC hiding ( Phase ) -#endif import Outputable ( PprStyle, SDoc, Outputable(ppr), showSDoc, showSDocForUser, showSDocUnqual, withPprStyle, defaultErrStyle ) -import ErrUtils ( mkLocMessage, pprErrMsgBagWithLoc) -#if __GLASGOW_HASKELL__ < 706 -import ErrUtils ( Message ) -#else -import ErrUtils ( MsgDoc ) -- we alias it as Message below -#endif +import ErrUtils ( mkLocMessage, pprErrMsgBagWithLoc, MsgDoc) -- we alias MsgDoc as Message below -import Pretty ( Doc ) import DriverPhases ( Phase(Cpp), HscSource(HsSrcFile) ) import StringBuffer ( stringToStringBuffer ) import Lexer ( P(..), ParseResult(..), mkPState ) @@ -57,31 +35,16 @@ import FastString ( fsLit ) #if __GLASGOW_HASKELL__ >= 710 -import DynFlags ( supportedLanguagesAndExtensions, xFlags, xopt, FlagSpec(..) ) -#elif __GLASGOW_HASKELL__ >= 700 -import DynFlags ( supportedLanguagesAndExtensions, xFlags, xopt ) +import DynFlags ( xFlags, xopt, LogAction, FlagSpec(..) ) #else -import DynFlags ( supportedLanguages ) -#endif - -#if __GLASGOW_HASKELL__ >=704 -import DynFlags ( LogAction ) +import DynFlags ( xFlags, xopt, LogAction ) #endif -#if __GLASGOW_HASKELL__ >= 608 import PprTyThing ( pprTypeForUser ) -#elif __GLASGOW_HASKELL__ < 608 -import SrcLoc ( SrcSpan ) -#endif - -#if __GLASGOW_HASKELL__ >= 702 import SrcLoc ( mkRealSrcLoc ) -#endif #if __GLASGOW_HASKELL__ >= 708 import ConLike ( ConLike(RealDataCon) ) #endif -#if __GLASGOW_HASKELL__ >= 706 type Message = MsgDoc -#endif 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,9 @@ module Hint.InterpreterT ( InterpreterT, Interpreter, runInterpreter, runInterpreterWithArgs, MultipleInstancesNotAllowed(..) -) - -where +) where +import Control.Applicative import Prelude import Hint.Base @@ -12,7 +11,6 @@ import Hint.Configuration import Hint.Extension -import Control.Applicative import Control.Monad.Reader import Control.Monad.Catch as MC @@ -21,11 +19,7 @@ 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 @@ -34,35 +28,9 @@ 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) @@ -74,12 +42,11 @@ . 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, MonadThrow m, MonadMask m, Functor m) => RunGhc (InterpreterT m) a +runGhcImpl a = InterpreterT (lift a) `catches` [Handler (\(e :: GHC.SourceError) -> do @@ -91,14 +58,9 @@ where compilationError dynFlags = WontCompile -#if __GLASGOW_HASKELL__ >= 706 . map (GhcError . GHC.showSDoc dynFlags) -#else - . map (GhcError . GHC.showSDoc) -#endif . GHC.pprErrMsgBagWithLoc . GHC.srcErrorMessages -#endif showGhcEx :: GHC.GhcException -> String showGhcEx = flip GHC.showGhcException "" @@ -115,40 +77,29 @@ let df1 = Compat.configureDynFlags df0 (df2, extra) <- runGhc2 Compat.parseDynamicFlags df1 args - when (not . null $ extra) $ + 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} -#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 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 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 @@ -169,22 +120,13 @@ runInterpreterWithArgs args action = ifInterpreterNotRunning $ do s <- newInterpreterSession `MC.catch` rethrowGhcException - -- SH.protectHandlers $ execute s (initialize args >> action) execute 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 {-# NOINLINE uniqueToken #-} uniqueToken :: MVar () @@ -195,7 +137,7 @@ do maybe_token <- liftIO $ tryTakeMVar uniqueToken case maybe_token of Nothing -> throwM MultipleInstancesNotAllowed - Just x -> action `finally` (liftIO $ putMVar uniqueToken x) + Just x -> action `finally` liftIO (putMVar uniqueToken x) -- | The installed version of ghc is not thread-safe. This exception -- is thrown whenever you try to execute @runInterpreter@ while another @@ -209,20 +151,21 @@ "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 = [], +initialState = St { + activePhantoms = [], + zombiePhantoms = [], + hintSupportModule = error "No support module loaded!", + importQualHackMod = Nothing, + qualImports = [], defaultExts = error "defaultExts missing!", - configuration = defaultConf} - + configuration = defaultConf + } newSessionData :: MonadIO m => a -> m (SessionData a) newSessionData a = do initial_state <- liftIO $ newIORef initialState ghc_err_list_ref <- liftIO $ newIORef [] - return SessionData{ + return SessionData { internalState = initial_state, versionSpecific = a, ghcErrListRef = ghc_err_list_ref, @@ -230,14 +173,8 @@ } 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 +mkLogHandler r df _ src style msg = + let renderErrMsg = GHC.showSDoc df errorEntry = mkGhcError renderErrMsg src style msg in modifyIORef r (errorEntry :) @@ -246,19 +183,16 @@ 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 -- 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 diff --git a/src/Hint/Parsers.hs b/src/Hint/Parsers.hs --- a/src/Hint/Parsers.hs +++ b/src/Hint/Parsers.hs @@ -1,6 +1,4 @@ -module Hint.Parsers - -where +module Hint.Parsers where import Prelude hiding(span) @@ -26,8 +24,8 @@ buf <- Compat.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 parse_res = GHC.unP parser (GHC.mkPState dyn_fl buf srcLoc) -- case parse_res of GHC.POk{} -> return ParseOk @@ -50,15 +48,9 @@ do -- parsing failed, so we report it just as all -- other errors get reported.... logger <- fromSession ghcErrLogger -#if __GLASGOW_HASKELL__ >= 706 dflags <- runGhc GHC.getSessionDynFlags let logger' = logger dflags errStyle = GHC.defaultErrStyle dflags -#else - let logger' = logger - errStyle = GHC.defaultErrStyle - -#endif liftIO $ logger' GHC.SevError span errStyle 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,7 +25,6 @@ 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] @@ -46,18 +40,13 @@ asModElemList df xs = concat [ cs', ts', - ds \\ (concatMap (map Fun . children) ts'), - fs \\ (concatMap (map Fun . children) cs') + 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 @@ -67,8 +56,7 @@ ) 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)) - + alsoIn es = (`elem` map name es) asModElem :: GHC.DynFlags -> GHC.TyThing -> ModuleElem asModElem df (GHC.AnId f) = Fun $ getUnqualName df f @@ -77,18 +65,11 @@ #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 getUnqualName :: GHC.NamedThing a => GHC.DynFlags -> a -> String -getUnqualName dfs = Compat.showSDocUnqual dfs . GHC.pprParenSymName +getUnqualName dfs = GHC.showSDocUnqual 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,28 +1,18 @@ module Hint.Typecheck ( - typeOf, typeChecks, kindOf, - - typeOf_unsandboxed, typeChecks_unsandboxed - -) - -where +) where import Control.Monad.Catch import Hint.Base import Hint.Parsers import Hint.Conversions -import Hint.Sandbox import qualified Hint.Compat as Compat -- | 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 @@ -34,30 +24,26 @@ -- | Tests if the expression type checks. 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 = (typeOf expr >> return True) `catchIE` onCompilationError (\_ -> return False) -- | 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 $ runGhc1 Compat.typeKind type_expr + -- + kindToString (Compat.Kind kind) 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,7 +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) 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 @@ -17,11 +17,9 @@ -- ** Interpreter options Option, OptionVal((:=)), get, set, - languageExtensions, availableExtensions, glasgowExtensions, Extension(..), + languageExtensions, availableExtensions, Extension(..), installedModulesInScope, searchPath, - setUseLanguageExtensions, - setInstalledModsAreInScopeQualified, -- ** Context handling ModuleName, isModuleInterpreted, loadModules, getLoadedModules, setTopLevelModules, @@ -30,15 +28,11 @@ -- ** Module querying ModuleElem(..), Id, name, children, getModuleExports, -#if __GLASGOW_HASKELL__ >= 611 -- ** Anotations - -- | Please note below that annotations are an experimental - -- feature in GHC HEAD. -- 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, -- ** Evaluation @@ -47,14 +41,11 @@ InterpreterError(..), GhcError(..), MultipleInstancesNotAllowed(..), -- * Miscellaneous ghcVersion,parens, - module Control.Monad.Trans) - -where + module Control.Monad.Trans +) where import Hint.Base -#if __GLASGOW_HASKELL__ >= 611 import Hint.Annotations -#endif import Hint.InterpreterT import Hint.Configuration import Hint.Context 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,8 +1,6 @@ module Language.Haskell.Interpreter.Unsafe ( unsafeSetGhcOption, unsafeRunInterpreterWithArgs -) - -where +) where import Control.Monad.Trans import Control.Monad.Catch 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 @@ -5,7 +5,7 @@ import Control.Exception.Extensible ( ArithException(..) ) import Control.Monad.Catch as MC -import Control.Monad ( liftM, when ) +import Control.Monad ( liftM, when, void ) import Control.Concurrent ( forkIO ) import Control.Concurrent.MVar @@ -15,7 +15,6 @@ import System.Directory import System.Exit - import Test.HUnit ( (@?=), (@?) ) import qualified Test.HUnit as HUnit @@ -45,8 +44,7 @@ -- get_f = do loadModules [mod_file] setTopLevelModules [mod_name] - r <- interpret "f" (as :: Int -> Int) - return r + interpret "f" (as :: Int -> Int) test_lang_exts :: TestCase test_lang_exts = TestCase "lang_exts" [mod_file] $ do @@ -114,9 +112,9 @@ 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"] + 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 +169,6 @@ "y :: Bool", "y = False"] - test_search_path_dot :: TestCase test_search_path_dot = TestCase "search_path_dot" [mod_file, dir] $ do @@ -187,7 +184,6 @@ writeFile mod_file $ unlines ["x :: Int", "x = 42"] - test_catch :: TestCase test_catch = TestCase "catch" [] $ do setImports ["Prelude"] @@ -197,7 +193,6 @@ action = do s <- eval "1 `div` 0 :: Int" return $! s - test_only_one_instance :: TestCase test_only_one_instance = TestCase "only_one_instance" [] $ do liftIO $ do @@ -206,10 +201,9 @@ `catch` \MultipleInstancesNotAllowed -> do liftIO $ putMVar r True return $ Right () - _ <- forkIO $ concurrent >> return () + _ <- forkIO $ Control.Monad.void concurrent readMVar r @? "concurrent instance did not fail" - tests :: [TestCase] tests = [test_reload_modified ,test_lang_exts @@ -242,7 +236,7 @@ -- `catch` (\_ -> exitWith (ExitFailure $ -1)) printInterpreterError :: InterpreterError -> IO () -printInterpreterError = hPutStrLn stderr . show +printInterpreterError = hPrint stderr setSandbox :: Interpreter () setSandbox = set [installedModulesInScope := False] @@ -264,7 +258,6 @@ succeeds :: (MonadCatch m, MonadIO m) => m a -> m Bool succeeds = liftM not . fails - data TestCase = TestCase String [FilePath] (Interpreter ())