hint 0.4.3 → 0.5.0
raw patch · 30 files changed
+505/−995 lines, 30 filesdep −ghc-mtldep −utf8-stringdep ~HUnitdep ~basedep ~ghcsetup-changedPVP ok
version bump matches the API change (PVP)
Dependencies removed: ghc-mtl, utf8-string
Dependency ranges changed: HUnit, base, ghc
API changes (from Hackage documentation)
- Language.Haskell.Interpreter: NoImplicitPrelude :: Extension
- Language.Haskell.Interpreter: NoMonoPatBinds :: Extension
- Language.Haskell.Interpreter: NoMonomorphismRestriction :: Extension
- Language.Haskell.Interpreter: glasgowExtensions :: [Extension]
- Language.Haskell.Interpreter: setInstalledModsAreInScopeQualified :: MonadInterpreter m => Bool -> m ()
- Language.Haskell.Interpreter: setUseLanguageExtensions :: MonadInterpreter m => Bool -> m ()
- Language.Haskell.Interpreter.Extension: NoImplicitPrelude :: Extension
- Language.Haskell.Interpreter.Extension: NoMonoPatBinds :: Extension
- Language.Haskell.Interpreter.Extension: NoMonomorphismRestriction :: Extension
- Language.Haskell.Interpreter.Extension: knownExtensions :: [Extension]
+ Language.Haskell.Interpreter: AllowAmbiguousTypes :: Extension
+ Language.Haskell.Interpreter: AutoDeriveTypeable :: Extension
+ Language.Haskell.Interpreter: BinaryLiterals :: Extension
+ Language.Haskell.Interpreter: CApiFFI :: Extension
+ Language.Haskell.Interpreter: ConstraintKinds :: Extension
+ Language.Haskell.Interpreter: DataKinds :: Extension
+ Language.Haskell.Interpreter: DefaultSignatures :: Extension
+ Language.Haskell.Interpreter: DeriveAnyClass :: Extension
+ Language.Haskell.Interpreter: DeriveGeneric :: Extension
+ Language.Haskell.Interpreter: EmptyCase :: Extension
+ Language.Haskell.Interpreter: ExplicitNamespaces :: Extension
+ Language.Haskell.Interpreter: GADTSyntax :: Extension
+ Language.Haskell.Interpreter: ImplicitPrelude :: Extension
+ Language.Haskell.Interpreter: InstanceSigs :: Extension
+ Language.Haskell.Interpreter: InterruptibleFFI :: Extension
+ Language.Haskell.Interpreter: JavaScriptFFI :: Extension
+ Language.Haskell.Interpreter: LambdaCase :: Extension
+ Language.Haskell.Interpreter: MonadComprehensions :: Extension
+ Language.Haskell.Interpreter: MonoPatBinds :: Extension
+ Language.Haskell.Interpreter: MonomorphismRestriction :: Extension
+ Language.Haskell.Interpreter: MultiWayIf :: Extension
+ Language.Haskell.Interpreter: NamedWildCards :: Extension
+ Language.Haskell.Interpreter: NegativeLiterals :: Extension
+ Language.Haskell.Interpreter: NondecreasingIndentation :: Extension
+ Language.Haskell.Interpreter: NullaryTypeClasses :: Extension
+ Language.Haskell.Interpreter: NumDecimals :: Extension
+ Language.Haskell.Interpreter: OverloadedLists :: Extension
+ Language.Haskell.Interpreter: ParallelArrays :: Extension
+ Language.Haskell.Interpreter: PartialTypeSignatures :: Extension
+ Language.Haskell.Interpreter: PatternSynonyms :: Extension
+ Language.Haskell.Interpreter: PolyKinds :: Extension
+ Language.Haskell.Interpreter: RoleAnnotations :: Extension
+ Language.Haskell.Interpreter: Safe :: Extension
+ Language.Haskell.Interpreter: SafeImports :: Extension
+ Language.Haskell.Interpreter: TraditionalRecordSyntax :: Extension
+ Language.Haskell.Interpreter: Trustworthy :: Extension
+ Language.Haskell.Interpreter: Unsafe :: Extension
+ Language.Haskell.Interpreter.Extension: AllowAmbiguousTypes :: Extension
+ Language.Haskell.Interpreter.Extension: AutoDeriveTypeable :: Extension
+ Language.Haskell.Interpreter.Extension: BinaryLiterals :: Extension
+ Language.Haskell.Interpreter.Extension: CApiFFI :: Extension
+ Language.Haskell.Interpreter.Extension: ConstraintKinds :: Extension
+ Language.Haskell.Interpreter.Extension: DataKinds :: Extension
+ Language.Haskell.Interpreter.Extension: DefaultSignatures :: Extension
+ Language.Haskell.Interpreter.Extension: DeriveAnyClass :: Extension
+ Language.Haskell.Interpreter.Extension: DeriveGeneric :: Extension
+ Language.Haskell.Interpreter.Extension: EmptyCase :: Extension
+ Language.Haskell.Interpreter.Extension: ExplicitNamespaces :: Extension
+ Language.Haskell.Interpreter.Extension: GADTSyntax :: Extension
+ Language.Haskell.Interpreter.Extension: ImplicitPrelude :: Extension
+ Language.Haskell.Interpreter.Extension: InstanceSigs :: Extension
+ Language.Haskell.Interpreter.Extension: InterruptibleFFI :: Extension
+ Language.Haskell.Interpreter.Extension: JavaScriptFFI :: Extension
+ Language.Haskell.Interpreter.Extension: LambdaCase :: Extension
+ Language.Haskell.Interpreter.Extension: MonadComprehensions :: Extension
+ Language.Haskell.Interpreter.Extension: MonoPatBinds :: Extension
+ Language.Haskell.Interpreter.Extension: MonomorphismRestriction :: Extension
+ Language.Haskell.Interpreter.Extension: MultiWayIf :: Extension
+ Language.Haskell.Interpreter.Extension: NamedWildCards :: Extension
+ Language.Haskell.Interpreter.Extension: NegativeLiterals :: Extension
+ Language.Haskell.Interpreter.Extension: NondecreasingIndentation :: Extension
+ Language.Haskell.Interpreter.Extension: NullaryTypeClasses :: Extension
+ Language.Haskell.Interpreter.Extension: NumDecimals :: Extension
+ Language.Haskell.Interpreter.Extension: OverloadedLists :: Extension
+ Language.Haskell.Interpreter.Extension: ParallelArrays :: Extension
+ Language.Haskell.Interpreter.Extension: PartialTypeSignatures :: Extension
+ Language.Haskell.Interpreter.Extension: PatternSynonyms :: Extension
+ Language.Haskell.Interpreter.Extension: PolyKinds :: Extension
+ Language.Haskell.Interpreter.Extension: RoleAnnotations :: Extension
+ Language.Haskell.Interpreter.Extension: Safe :: Extension
+ Language.Haskell.Interpreter.Extension: SafeImports :: Extension
+ Language.Haskell.Interpreter.Extension: TraditionalRecordSyntax :: Extension
+ Language.Haskell.Interpreter.Extension: Trustworthy :: Extension
+ Language.Haskell.Interpreter.Extension: Unsafe :: Extension
Files
- CHANGELOG.md +83/−66
- README.md +2/−1
- Setup.hs +2/−0
- Setup.lhs +0/−5
- examples/example.hs +3/−4
- hint.cabal +63/−91
- src/Control/Monad/Ghc.hs +76/−0
- src/Hint/Base.hs +31/−87
- src/Hint/Compat.hs +4/−169
- src/Hint/CompatPlatform.hs +3/−7
- src/Hint/Configuration.hs +22/−77
- src/Hint/Context.hs +50/−66
- src/Hint/Conversions.hs +5/−14
- src/Hint/Eval.hs +14/−20
- src/Hint/Extension.hs +80/−13
- src/Hint/GHC.hs +4/−41
- src/Hint/InterpreterT.hs +24/−90
- src/Hint/Parsers.hs +3/−11
- src/Hint/Reflection.hs +5/−24
- src/Hint/Sandbox.hs +0/−74
- src/Hint/SignalHandlers.hs +0/−40
- src/Hint/Typecheck.hs +16/−30
- src/Hint/Typecheck.hs-boot +0/−5
- src/Hint/Util.hs +1/−2
- src/Language/Haskell/Interpreter.hs +3/−12
- src/Language/Haskell/Interpreter/Extension.hs +3/−3
- src/Language/Haskell/Interpreter/GHC.hs +0/−13
- src/Language/Haskell/Interpreter/GHC/Unsafe.hs +0/−13
- src/Language/Haskell/Interpreter/Unsafe.hs +1/−3
- unit-tests/run-unit-tests.hs +7/−14
CHANGELOG.md view
@@ -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
README.md view
@@ -1,13 +1,14 @@ # hint [](https://travis-ci.org/mvdan/hint)+[](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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
− Setup.lhs
@@ -1,5 +0,0 @@-#!/usr/bin/env runhaskell-> module Main where-> import Distribution.Simple-> main :: IO ()-> main = defaultMainWithHooks defaultUserHooks
examples/example.hs view
@@ -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
hint.cabal view
@@ -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
+ src/Control/Monad/Ghc.hs view
@@ -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))
src/Hint/Base.hs view
@@ -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)
src/Hint/Compat.hs view
@@ -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
src/Hint/CompatPlatform.hs view
@@ -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
src/Hint/Configuration.hs view
@@ -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]
src/Hint/Context.hs view
@@ -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 ()
src/Hint/Conversions.hs view
@@ -1,35 +1,26 @@-module Hint.Conversions- (- typeToString- ,kindToString- ,moduleToString- ,isSucceeded- )--where+module Hint.Conversions (+ typeToString, kindToString, moduleToString, isSucceeded+) where import qualified Hint.GHC as GHC import Hint.Base import qualified Hint.Compat as Compat - -- --------- Types / Kinds ----------------------- - typeToString :: MonadInterpreter m => GHC.Type -> m String typeToString t = do -- Unqualify necessary types -- (i.e., do not expose internals) unqual <- runGhc GHC.getPrintUnqual withDynFlags $ \df ->- return $ Compat.showSDocForUser df unqual (Compat.pprType t)+ 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 --------------------------
src/Hint/Eval.hs view
@@ -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
src/Hint/Extension.hs view
@@ -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 ]
src/Hint/GHC.hs view
@@ -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
src/Hint/InterpreterT.hs view
@@ -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
src/Hint/Parsers.hs view
@@ -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 "<hint>") 1 1- let parse_res = GHC.unP parser (Compat.mkPState dyn_fl buf srcLoc)+ let srcLoc = GHC.mkRealSrcLoc (GHC.fsLit "<hint>") 1 1+ let 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
src/Hint/Reflection.hs view
@@ -1,18 +1,13 @@ module Hint.Reflection (- ModuleElem(..), Id, name, children, getModuleExports,--)--where+) where import Data.List import Data.Maybe import Hint.Base import qualified Hint.GHC as GHC-import qualified Hint.Compat as Compat -- | An Id for a class, a type constructor, a data constructor, a binding, etc type Id = String@@ -30,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
− src/Hint/Sandbox.hs
@@ -1,74 +0,0 @@-module Hint.Sandbox ( sandboxed ) where--import Hint.Base-import Hint.Context-import Hint.Configuration-import Hint.Util--import {-# SOURCE #-} Hint.Typecheck ( typeChecks_unsandboxed )--import Control.Monad.Catch--sandboxed :: MonadInterpreter m => (Expr -> m a) -> (Expr -> m a)-sandboxed = if ghcVersion >= 610 then id else old_sandboxed--old_sandboxed :: MonadInterpreter m => (Expr -> m a) -> (Expr -> m a)-old_sandboxed do_stuff = \expr -> do no_sandbox <- fromConf all_mods_in_scope- if no_sandbox- then do_stuff expr- else usingAModule do_stuff expr--usingAModule :: MonadInterpreter m => (Expr -> m a) -> (Expr -> m a)-usingAModule do_stuff_on = \expr ->- --- -- To avoid defaulting, we will evaluate this expression without the- -- monomorphism-restriction. This means that expressions that normally- -- would not typecheck, suddenly will. Thus, we first check if the- -- expression typechecks as is. If it doesn't, there is no need in- -- going on (if it does, it may not typecheck once we restrict the- -- context; that is the whole idea of this!)- --- do type_checks <- typeChecks_unsandboxed expr- case type_checks of- False -> do_stuff_on expr -- fail as you wish...- True ->- do (loaded, imports) <- allModulesInContext- zombies <- fromState zombie_phantoms- quals <- fromState qual_imports- --- let e = safeBndFor expr- let mod_text no_prel mod_name = textify [- ["{-# LANGUAGE NoMonomorphismRestriction #-}"],- ["{-# LANGUAGE NoImplicitPrelude #-}" | no_prel],- ["module " ++ mod_name],- ["where"],- ["import " ++ m | m <- loaded ++ imports,- not $ m `elem` (map pm_name zombies)],- ["import qualified " ++ m ++ " as " ++ q | (m,q) <- quals],- [e ++ " = " ++ expr] ]- --- let go no_prel = do pm <- addPhantomModule (mod_text no_prel)- setTopLevelModules [pm_name pm]- r <- do_stuff_on e- `catchIE` (\err ->- case err of- WontCompile _ ->- do removePhantomModule pm- throwM err- _ -> throwM err)- removePhantomModule pm- return r- -- If the Prelude was not explicitly imported but implicitly- -- imported in some interpreted module, then the user may- -- get very unintuitive errors when turning sandboxing on. Thus- -- we will import the Prelude if the operation fails...- -- I guess this may lead to even more obscure errors, but- -- hopefully in much less frequent situations...- r <- onAnEmptyContext $ go True- `catchIE` (\err -> case err of- WontCompile _ -> go False- _ -> throwM err)- --- return r- --- where textify = unlines . concat
− src/Hint/SignalHandlers.hs
@@ -1,40 +0,0 @@-module Hint.SignalHandlers (- protectHandlers-)-where--import Control.Monad.Catch-import Control.Monad.Trans--#ifdef mingw32_HOST_OS-import GHC.ConsoleHandler as C--saveHandlers :: MonadIO m => m C.Handler-saveHandlers = liftIO $ C.installHandler Ignore--restoreHandlers :: MonadIO m => C.Handler -> m C.Handler-restoreHandlers = liftIO . C.installHandler--#else-import qualified System.Posix.Signals as S--helper :: MonadIO m => S.Handler -> S.Signal -> m S.Handler-helper handler signal = liftIO $ S.installHandler signal handler Nothing--signals :: [S.Signal]-signals = [ S.sigQUIT- , S.sigINT- , S.sigHUP- , S.sigTERM- ]--saveHandlers :: MonadIO m => m [S.Handler]-saveHandlers = liftIO $ mapM (helper S.Ignore) signals--restoreHandlers :: MonadIO m => [S.Handler] -> m [S.Handler]-restoreHandlers h = liftIO . sequence $ zipWith helper h signals--#endif--protectHandlers :: (MonadIO m, MonadMask m) => m a -> m a-protectHandlers a = bracket saveHandlers restoreHandlers $ const a
src/Hint/Typecheck.hs view
@@ -1,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
− src/Hint/Typecheck.hs-boot
@@ -1,5 +0,0 @@-module Hint.Typecheck where--import Hint.Base (MonadInterpreter)--typeChecks_unsandboxed :: MonadInterpreter m => String -> m Bool
src/Hint/Util.hs view
@@ -14,7 +14,7 @@ safeBndFor expr = "e_1" ++ filter isDigit expr partition :: (a -> Bool) -> [a] -> ([a], [a])-partition prop xs = foldr (select prop) ([],[]) xs+partition prop = foldr (select prop) ([],[]) where select p x ~(ts,fs) | p x = (x:ts,fs) | otherwise = (ts, x:fs) @@ -22,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)
src/Language/Haskell/Interpreter.hs view
@@ -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
src/Language/Haskell/Interpreter/Extension.hs view
@@ -1,5 +1,5 @@-module Language.Haskell.Interpreter.Extension ( module Hint.Extension )--where+module Language.Haskell.Interpreter.Extension (+ module Hint.Extension+) where import Hint.Extension
− src/Language/Haskell/Interpreter/GHC.hs
@@ -1,13 +0,0 @@--------------------------------------------------------------------------------- |--- DEPRECATED: use @Language.Haskell.Interpreter.Unsafe@ instead.-------------------------------------------------------------------------------module Language.Haskell.Interpreter.GHC-{-# DEPRECATED "Import Language.Haskell.Interpreter instead." #-}-(- module Language.Haskell.Interpreter-)--where--import Language.Haskell.Interpreter
− src/Language/Haskell/Interpreter/GHC/Unsafe.hs
@@ -1,13 +0,0 @@--------------------------------------------------------------------------------- |--- DEPRECATED: use @Language.Haskell.Interpreter.Unsafe@ instead.-------------------------------------------------------------------------------module Language.Haskell.Interpreter.GHC.Unsafe-{-# DEPRECATED "Import Language.Haskell.Interpreter.Unsafe instead." #-}-(- module Language.Haskell.Interpreter.Unsafe-)--where--import Language.Haskell.Interpreter.Unsafe
src/Language/Haskell/Interpreter/Unsafe.hs view
@@ -1,8 +1,6 @@ module Language.Haskell.Interpreter.Unsafe ( unsafeSetGhcOption, unsafeRunInterpreterWithArgs-)--where+) where import Control.Monad.Trans import Control.Monad.Catch
unit-tests/run-unit-tests.hs view
@@ -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 ())