hinter (empty) → 0.1.0.0
raw patch · 28 files changed
+3026/−0 lines, 28 filesdep +HUnitdep +basedep +directorysetup-changed
Dependencies added: HUnit, base, directory, exceptions, extensible-exceptions, filepath, ghc, ghc-boot, ghc-paths, hinter, mtl, random, temporary, unix
Files
- AUTHORS +23/−0
- CHANGELOG.md +201/−0
- LICENSE +27/−0
- README.md +21/−0
- Setup.hs +2/−0
- examples/SomeModule.hs +7/−0
- examples/example.hs +77/−0
- hinter.cabal +102/−0
- src/Control/Monad/Ghc.hs +95/−0
- src/Hint/Annotations.hs +31/−0
- src/Hint/Base.hs +206/−0
- src/Hint/CompatPlatform.hs +31/−0
- src/Hint/Configuration.hs +152/−0
- src/Hint/Context.hs +436/−0
- src/Hint/Conversions.hs +33/−0
- src/Hint/Eval.hs +77/−0
- src/Hint/Extension.hs +509/−0
- src/Hint/GHC.hs +46/−0
- src/Hint/Internal.hs +33/−0
- src/Hint/InterpreterT.hs +205/−0
- src/Hint/Parsers.hs +67/−0
- src/Hint/Reflection.hs +67/−0
- src/Hint/Typecheck.hs +84/−0
- src/Hint/Util.hs +27/−0
- src/Language/Haskell/Interpreter.hs +58/−0
- src/Language/Haskell/Interpreter/Extension.hs +5/−0
- src/Language/Haskell/Interpreter/Unsafe.hs +44/−0
- unit-tests/run-unit-tests.hs +360/−0
+ AUTHORS view
@@ -0,0 +1,23 @@+# Please keep the list sorted.++Austin Seipp+Bertram Felgenhauer+Bryan O'Sullivan+Carl Howells+Conrad Parker+Corentin Dupont+Daniel Gorin <jcpetruzza@gmail.com>+Daniel Martí <mvdan@mvdan.cc>+Daniel Wagner+Evan Laforge+Fernando Benavides+Gwern Branwen+Heinrich Apfelmus+Jean Philippe Bernardy+Jens Petersen+Mark Wright+Nathaniel W. Filardo+Pasqualino Titto Assini+Rob Zinkov <rob@zinkov.com>+Samuel Gélineau+Sid Kapur
+ CHANGELOG.md view
@@ -0,0 +1,201 @@+### 0.8.0++* Support GHC 8.4+* Drop support for GHC 7.8 and 7.10+* Add `runStmt` to execute statements in the IO monad and bind new names+* Internal changes of temporary files for phantom modules+ - The files are now called `M<nnn>.hs` instead of `<nnn>`+ - Improved cleanup of phantom module source files+ - ghc 8.4 only: phantom modules are put into a temporary directory+* Add `typeChecksWithDetails` to obtain type-checking errors+* Stop GHC from overwriting the Ctrl-C signal handler+* Add `SetImportsF` to allow finer imports control++### 0.7.0++* Support for GHC 8.2+* Support use in a dynamically-linked executable+* Add `normalizeType`, like ghci's :kind!+* Drop support for GHC 7.6++### 0.6.0++* Support for GHC 8.0+* Add `displayException` to InterpreterError++### 0.5.2++* Add `runInterpreter` variant that takes a GHC libdir at runtime+* Add missing negated extensions to the `Extension` type+* Do not throw GHC warnings as errors++### 0.5.1++* Expose `unsafeInterpret` in `Language.Haskell.Interpreter.Unsafe`++### 0.5.0++* Drop support for GHC 7.4+* Remove deprecated functions and modules:+ - `glasgowExtensions`+ - `setUseLanguageExtensions`+ - `setInstalledModsAreInScopeQualified`+ - `Language.Haskell.Interpreter.GHC`+ - `Language.Haskell.Interpreter.GHC.Unsafe`+* Drop dependencies on `ghc-mtl` and `extensible-exceptions`++### 0.4.3++* New maintainer and source code repo++### 0.4.2.3++* It builds against 7.4.2 (not 7.4.1), so update the constraints.++### 0.4.2.2++* Builds with GHC 7.10+* Builds again with GHC 7.4+* Drops dependency on `utf8-string`++### 0.4.2.1++* Better error reporting (thanks to Corentin Dupont)++### 0.4.2.0++* Based on exceptions-0.6++### 0.4.1.0++* Based on exceptions-0.4++### 0.4.0.0++* Compiles with GHC 7.8+* Fixed an issue where `P` was available as a qualified version of+ Prelude (thanks to Samuel Gélineau)+* Uses `exceptions` package instead of `MonadCatchIO-mtl` (API breakage+ expected)+* No longer depends on `haskell-src`+* Changelog should now appear in Hackage+* Integrated unit tests with cabal++### 0.3.3.7++* Fixed a race condition that would happen, for instance, when two+ process where run one next to the other, making them, on some+ platforms, to get the same random number seed (thanks to Mario+ Pastorelli and Samuel Gélineau)+* Small fix in documentation (thanks to Daniil Frumin)++### 0.3.3.6++* Works again on GHC 7.2.x (thanks to Björn Peemöller)++### 0.3.3.5++* Works on GHC 7.4.6+* Cleans up files for phantom modules that were left behind (thanks to+ Beltram Felgenhauer)++### 0.3.3.4++* Works on GHC 7.4.1++### 0.3.3.3++* Works on GHC 7.2.1++### 0.3.3.2++* Supports GHC 7++### 0.3.3.1++* Instance declaration for Applicative (InterpreterT m) works with mtl-2+ (requires Applicative m, this shouldn't break anything...)++### 0.3.3.0++* Add unsafeRunInterpreterWithArgs+* Check that only one instance of the interpreter is run at any time++### 0.3.2.3++* Can be built against MonadCatchIO-mtl-0.3.x.x++### 0.3.2.2++* Fixed a bug that would make expressions using heavy use of the layout+ rule to fail to be interpreted (see parens)++### 0.3.2.1++* hint.cabal includes version bounds for package ghc-mtl. This is to+ avoid the accidental selection of the completely unrelated ghc-mtl+ internal to GHC and, apparently, installed in the hackage server++### 0.3.2.0++* Exports functions parens and isInterpretedModule+* Experimental support for module annotations+* Uses extensible-exceptions in order to provide a uniform interface+ across different ghc versions+* Provides an Applicative instance for IntepreterT+* Adds an option to configurate the searchPath++### 0.3.1.0++* No longer uses Language.Haskell.Extension due to configuration+ problems with Cabal. Instead, it uses its own+ Language.Haskell.Interpreter.Extension module.++### 0.3.0.0++* Updated API:+ + InterpreterT monad transformer (Interpreter = InterpreterT IO)+ + No more Sessions, use runInterpreter only once+ + New options handling functions+ - but observe that there is no setOptimizations equivalent; since+ GHC does no optimization on interpreted code, this was actually+ doing nothing+* Works with GHC 6.10 and 6.8 (untested with 6.6)++### 0.2.5++* setImportsQ added (modules can be imported both qualified and+ unqualified)++### 0.2.4.1++* BUGFIX: No longer fails on expressions ending in a -- comment++### 0.2.4++* setInstalledModsAreInScopeQualified added+* Now depends on ghc-paths (no longer needs a custom cabal script)++### 0.2.2++* setOptimizations added+* Module Language.Haskell.Interpreter.GHC.Unsafe added (contains+ unsafeSetGhcOption)+* Unit tests now based on HUnit++### 0.2.1++* BUGFIX: Module reloading was broken under 6.8+* GHC.GhcExceptions are catched and turned into InterpreterErrors++### 0.2.0.1++* Adds the requirement cabal-version < 1.3++### 0.2++* Works also with GHC 6.8 and 6.6+* Added the getModuleExports function+* withSession function throws a dynamic exception instead of returning+ Either Error a+* Requires Cabal 1.2.x
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2007 The Hint Authors. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+notice, this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above+copyright notice, this list of conditions and the following disclaimer+in the documentation and/or other materials provided with the+distribution.+ * Neither the name of the copyright holder nor the names of its+contributors may be used to endorse or promote products derived from+this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,21 @@+# 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, essentially, a huge subset of the GHC API wrapped in a simpler+API.++Compatibility is kept with the three last major GHC releases. For+example, if the current version is GHC 8.4, Hint will work on 8.4, 8.2+and 8.0.++### Example++Check [example.hs](examples/example.hs) to see a simple but+comprehensive example (it must be run from the `examples` directory).
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/SomeModule.hs view
@@ -0,0 +1,7 @@+module SomeModule(g, h) where++f = head++g = f [f]++h = f
+ examples/example.hs view
@@ -0,0 +1,77 @@+import Data.List++import Control.Monad+import Language.Haskell.Interpreter++main :: IO ()+main = do r <- runInterpreter testHint+ case r of+ Left err -> putStrLn $ errorString err+ Right () -> return ()++errorString :: InterpreterError -> String+errorString (WontCompile es) = intercalate "\n" (header : map unbox es)+ where+ header = "ERROR: Won't compile:"+ unbox (GhcError e) = e+errorString e = show e++say :: String -> Interpreter ()+say = liftIO . putStrLn++emptyLine :: Interpreter ()+emptyLine = say ""++-- observe that Interpreter () is an alias for InterpreterT IO ()+testHint :: Interpreter ()+testHint =+ do+ say "Load SomeModule.hs"+ loadModules ["SomeModule.hs"]+ emptyLine+ say "Put the Prelude, Data.Map and *SomeModule in scope"+ say "Data.Map is qualified as M!"+ setTopLevelModules ["SomeModule"]+ setImportsQ [("Prelude", Nothing), ("Data.Map", Just "M")]+ emptyLine+ say "Now we can query the type of an expression"+ let expr1 = "M.singleton (f, g, h, 42)"+ say $ "e.g. typeOf " ++ expr1+ say =<< typeOf expr1+ emptyLine+ say $ "Observe that f, g and h are defined in SomeModule.hs, " +++ "but f is not exported. Let's check it..."+ exports <- getModuleExports "SomeModule"+ say $ show exports+ emptyLine+ say "We can also evaluate an expression; the result will be a string"+ let expr2 = "length $ concat [[f,g],[h]]"+ say $ "e.g. eval " ++ show expr2+ a <- eval expr2+ say $ show a+ emptyLine+ say "Or we can interpret it as a proper, say, int value!"+ a_int <- interpret expr2 (as :: Int)+ say $ show a_int+ emptyLine+ say "This works for any monomorphic type, even for function types"+ let expr3 = "\\(Just x) -> succ x"+ say $ "e.g. we interpret " ++ expr3 +++ " with type Maybe Int -> Int and apply it on Just 7"+ fun <- interpret expr3 (as :: Maybe Int -> Int)+ say $ show $ fun (Just 7)+ emptyLine+ say "And sometimes we can even use the type system to infer the expected type (eg Maybe Bool -> Bool)!"+ bool_val <- interpret expr3 infer `ap` return (Just False)+ say $ show $ not bool_val+ emptyLine+ say "Here we evaluate an expression of type string, that when evaluated (again) leads to a string"+ res <- interpret "head $ map show [\"Worked!\", \"Didn't work\"]" infer >>= flip interpret infer+ say res+ emptyLine+ say "We can also execute statements in the IO monad and bind new names, e.g."+ let stmts = ["x <- return 42", "print x"]+ forM_ stmts $ \s -> do+ say $ " " ++ s+ runStmt s+ emptyLine
+ hinter.cabal view
@@ -0,0 +1,102 @@+name: hinter+version: 0.1.0.0+description:+ This library defines an Interpreter monad. It allows to load Haskell+ modules, browse them, type-check and evaluate strings with Haskell+ expressions and even coerce them into values. The library is thread-safe+ and type-safe (even the coercion of expressions to values).++ It is, essentially, a huge subset of the GHC API wrapped in a simpler+ API.++synopsis: Runtime Haskell interpreter (GHC API wrapper)+category: Language, Compilers/Interpreters+license: BSD3+license-file: LICENSE+author: The Hint Authors+maintainer: strake888@gmail.com+homepage: https://github.com/strake/hint.hs++cabal-version: >= 1.9.2+build-type: Simple++extra-source-files: README.md+ AUTHORS+ CHANGELOG.md+ examples/example.hs+ examples/SomeModule.hs++source-repository head+ type: git+ location: https://github.com/strake/hint.hs++test-suite unit-tests+ type: exitcode-stdio-1.0+ hs-source-dirs: unit-tests+ main-is: run-unit-tests.hs++ build-depends: base == 4.*,+ hinter,+ HUnit,+ directory,+ filepath,+ extensible-exceptions,+ exceptions >= 0.10.0++ if !os(windows) {+ build-depends: unix >= 2.2.0.0+ }++ extensions: CPP++library+ build-depends: base == 4.*,+ ghc >= 8.0 && < 8.6,+ ghc-paths,+ ghc-boot,+ mtl,+ filepath,+ exceptions == 0.10.*,+ random,+ directory++ if impl(ghc >= 8.4 && < 8.6) {+ build-depends: temporary+ cpp-options: -DNEED_PHANTOM_DIRECTORY+ }++ if !os(windows) {+ build-depends: unix >= 2.2.0.0+ }++ exposed-modules: Language.Haskell.Interpreter+ Language.Haskell.Interpreter.Extension+ Language.Haskell.Interpreter.Unsafe+ Hint.Internal+ other-modules: Hint.GHC+ Hint.Base+ Hint.InterpreterT+ Hint.CompatPlatform+ Hint.Configuration+ Hint.Extension+ Hint.Context+ Hint.Conversions+ Hint.Eval+ Hint.Parsers+ Hint.Reflection+ Hint.Typecheck+ Hint.Util+ Hint.Annotations+ Control.Monad.Ghc++ hs-source-dirs: src++ ghc-options: -Wall+ extensions: CPP+ GeneralizedNewtypeDeriving+ DeriveDataTypeable+ MagicHash+ FunctionalDependencies+ Rank2Types+ ScopedTypeVariables+ ExistentialQuantification
+ src/Control/Monad/Ghc.hs view
@@ -0,0 +1,95 @@+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 Data.IORef++import qualified GHC+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++-- adapted from https://github.com/ghc/ghc/blob/ghc-8.2/compiler/main/GHC.hs#L450-L459+-- modified to _not_ catch ^C+rawRunGhcT :: (MonadIO m, MonadMask m) => Maybe FilePath -> GHC.GhcT (MTLAdapter m) a -> MTLAdapter m a+rawRunGhcT mb_top_dir ghct = do+ ref <- liftIO $ newIORef (error "empty session")+ let session = GHC.Session ref+ flip GHC.unGhcT session $ {-GHC.withSignalHandlers $-} do -- do _not_ catch ^C+ GHC.initGhcMonad mb_top_dir+ GHC.withCleanupSession ghct++runGhcT :: (MonadIO m, MonadMask m) => Maybe FilePath -> GhcT m a -> m a+runGhcT f = unMTLA . rawRunGhcT f . unGhcT++instance MTL.MonadTrans GhcT where+ lift = GhcT . GHC.liftGhcT . MTLAdapter++instance MTL.MonadIO m => MTL.MonadIO (GhcT m) where+ liftIO = GhcT . GHC.liftIO++instance MonadCatch m => MonadThrow (GhcT m) where+ throwM = lift . throwM++instance (MonadIO m, MonadCatch m, MonadMask m) => MonadCatch (GhcT m) where+ 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 f = wrap $ \s ->+ uninterruptibleMask $ \io_restore ->+ unwrap (f $ \m -> (wrap $ \s' -> io_restore (unwrap m s'))) s+ where+ wrap g = GhcT $ GHC.GhcT $ \s -> MTLAdapter (g s)+ unwrap m = unMTLA . GHC.unGhcT (unGhcT m)++ generalBracket acquire release body+ = wrap $ \s -> generalBracket (unwrap acquire s)+ (\a exitCase -> unwrap (release a exitCase) s)+ (\a -> unwrap (body a) s)+ where+ wrap g = GhcT $ GHC.GhcT $ \s -> MTLAdapter (g s)+ unwrap m = unMTLA . GHC.unGhcT (unGhcT m)++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/Annotations.hs view
@@ -0,0 +1,31 @@+module Hint.Annotations (+ getModuleAnnotations,+ getValAnnotations+) where++import Control.Monad+import Data.Data+import Annotations+import GHC.Serialized++import Hint.Base+import HscTypes (hsc_mod_graph, ms_mod)+import qualified Hint.GHC as GHC++-- Get the annotations associated with a particular module.+getModuleAnnotations :: (Data a, MonadInterpreter m) => a -> String -> m [a]+getModuleAnnotations _ x = do+ mods <- liftM (GHC.mgModSummaries . hsc_mod_graph) $ runGhc GHC.getSession+ let x' = filter ((==) x . GHC.moduleNameString . GHC.moduleName . ms_mod) mods+ v <- mapM (anns . ModuleTarget . ms_mod) x'+ return $ concat v++-- Get the annotations associated with a particular function.+getValAnnotations :: (Data a, MonadInterpreter m) => a -> String -> m [a]+getValAnnotations _ x = do+ x' <- runGhc1 GHC.parseName x+ v <- mapM (anns . NamedTarget) x'+ return $ concat v++anns :: (MonadInterpreter m, Data a) => AnnTarget GHC.Name -> m [a]+anns = runGhc1 (GHC.findGlobalAnns deserializeWithData)
+ src/Hint/Base.hs view
@@ -0,0 +1,206 @@+module Hint.Base (+ MonadInterpreter(..), RunGhc,++ GhcError(..), InterpreterError(..), mayFail, catchIE,++ InterpreterSession, SessionData(..), GhcErrLogger,+ InterpreterState(..), fromState, onState,+ InterpreterConfiguration(..),+ ImportList(..), ModuleQualification(..), ModuleImport(..),++ runGhc1, runGhc2,++ ModuleName, PhantomModule(..),+ findModule, moduleIsLoaded,+ withDynFlags,++ ghcVersion,++ debug, showGHC+) where++import Control.Monad.Trans+import Control.Monad.Catch as MC++import Data.IORef+import Data.Dynamic+import qualified Data.List++import qualified Hint.GHC as GHC++import Hint.Extension++-- | Version of the underlying ghc api. Values are:+--+-- * @802@ for GHC 8.2.x+--+-- * @804@ for GHC 8.4.x+--+-- * etc...+ghcVersion :: Int+ghcVersion = __GLASGOW_HASKELL__++class (MonadIO m, MonadMask m) => MonadInterpreter m where+ fromSession :: FromSession m a+ modifySessionRef :: ModifySessionRef m a+ runGhc :: RunGhc m a++-- this is for hiding the actual types in haddock+type FromSession m a = (InterpreterSession -> a) -> m a+type ModifySessionRef m a = (InterpreterSession -> IORef a) -> (a -> a) -> m a++data InterpreterError = UnknownError String+ | WontCompile [GhcError]+ | NotAllowed String+ -- | GhcExceptions from the underlying GHC API are caught+ -- and rethrown as this.+ | GhcException String+ deriving (Show, Typeable)++data InterpreterState = St {+ activePhantoms :: [PhantomModule],+ zombiePhantoms :: [PhantomModule],+#if defined(NEED_PHANTOM_DIRECTORY)+ phantomDirectory :: Maybe FilePath,+#endif+ hintSupportModule :: PhantomModule,+ importQualHackMod :: Maybe PhantomModule,+ qualImports :: [ModuleImport],+ defaultExts :: [(Extension, Bool)], -- R/O+ configuration :: InterpreterConfiguration+ }++data ImportList = NoImportList | ImportList [String] | HidingList [String]+ deriving (Eq, Show)+data ModuleQualification = NotQualified | ImportAs String | QualifiedAs (Maybe String)+ deriving (Eq, Show)++-- | Represent module import statement.+-- See 'setImportsF'+data ModuleImport = ModuleImport { modName :: String+ , modQual :: ModuleQualification+ , modImp :: ImportList+ } deriving (Show)++data InterpreterConfiguration = Conf {+ searchFilePath :: [FilePath],+ languageExts :: [Extension],+ allModsInScope :: Bool+ }++type InterpreterSession = SessionData ()++instance Exception InterpreterError+ where+ displayException (UnknownError err) = "UnknownError: " ++ err+ displayException (WontCompile es) = unlines . Data.List.nub . map errMsg $ es+ displayException (NotAllowed err) = "NotAllowed: " ++ err+ displayException (GhcException err) = "GhcException: " ++ err++type RunGhc m a =+ (forall n.(MonadIO n, MonadMask n) => GHC.GhcT n a)+ -> m a++type RunGhc1 m a b =+ (forall n.(MonadIO n, MonadMask n) => a -> GHC.GhcT n b)+ -> (a -> m b)++type RunGhc2 m a b c =+ (forall n.(MonadIO n, MonadMask n) => a -> b -> GHC.GhcT n c)+ -> (a -> b -> m c)++data SessionData a = SessionData {+ internalState :: IORef InterpreterState,+ versionSpecific :: a,+ ghcErrListRef :: IORef [GhcError],+ ghcErrLogger :: GhcErrLogger+ }++-- When intercepting errors reported by GHC, we only get a ErrUtils.Message+-- and a SrcLoc.SrcSpan. The latter holds the file name and the location+-- of the error. However, SrcSpan is abstract and it doesn't provide+-- functions to retrieve the line and column of the error... we can only+-- generate a string with this information. Maybe I can parse this string+-- later.... (sigh)+newtype GhcError = GhcError{errMsg :: String} deriving Show++mapGhcExceptions :: MonadInterpreter m+ => (String -> InterpreterError)+ -> m a+ -> m a+mapGhcExceptions buildEx action =+ action+ `MC.catch` (\err -> case err of+ GhcException s -> throwM (buildEx s)+ _ -> throwM err)++catchIE :: MonadInterpreter m => m a -> (InterpreterError -> m a) -> m a+catchIE = MC.catch++type GhcErrLogger = GHC.LogAction++-- | Module names are _not_ filepaths.+type ModuleName = String++runGhc1 :: MonadInterpreter m => RunGhc1 m a b+runGhc1 f a = runGhc (f a)++runGhc2 :: MonadInterpreter m => RunGhc2 m a b c+runGhc2 f a = runGhc1 (f a)++-- ================ Handling the interpreter state =================++fromState :: MonadInterpreter m => (InterpreterState -> a) -> m a+fromState f = do ref_st <- fromSession internalState+ liftIO $ f `fmap` readIORef ref_st++onState :: MonadInterpreter m => (InterpreterState -> InterpreterState) -> m ()+onState f = modifySessionRef internalState f >> return ()++-- =============== Error handling ==============================++mayFail :: MonadInterpreter m => m (Maybe a) -> m a+mayFail action =+ do+ maybe_res <- action+ --+ es <- modifySessionRef ghcErrListRef (const [])+ --+ case (maybe_res, null es) of+ (Nothing, True) -> throwM $ UnknownError "Got no error message"+ (Nothing, False) -> throwM $ WontCompile (reverse es)+ (Just a, _) -> return a++-- ================= Debugging stuff ===============++debug :: MonadInterpreter m => String -> m ()+debug = liftIO . putStrLn . ("!! " ++)++showGHC :: (MonadInterpreter m, GHC.Outputable a) => a -> m String+showGHC a+ = do unqual <- runGhc GHC.getPrintUnqual+ withDynFlags $ \df ->+ 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{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)+ `catchIE` (\e -> case e of+ NotAllowed{} -> return False+ WontCompile{} -> return False+ _ -> throwM e)++withDynFlags :: MonadInterpreter m => (GHC.DynFlags -> m a) -> m a+withDynFlags action+ = do df <- runGhc GHC.getSessionDynFlags+ action df
+ src/Hint/CompatPlatform.hs view
@@ -0,0 +1,31 @@+#if defined(mingw32_HOST_OS) || defined(__MINGW32__)+{-# LANGUAGE ForeignFunctionInterface #-}+#endif+module Hint.CompatPlatform (+ getPID+) where++import Control.Applicative+import Prelude++#if defined(mingw32_HOST_OS) || defined(__MINGW32__)+import Data.Word+#else+import System.Posix.Process+#endif++getPID :: IO Int++#if defined(mingw32_HOST_OS) || defined(__MINGW32__)+-- This function is not yet in the win32 package, so we have to+-- roll down our own definition.+--+-- Credit goes where it is deserved:+-- http://www.haskell.org/pipermail/haskell-cafe/2009-February/055097.html+foreign import stdcall unsafe "winbase.h GetCurrentProcessId"+ c_GetCurrentProcessId :: IO Word32++getPID = fromIntegral <$> c_GetCurrentProcessId+#else+getPID = fromIntegral <$> getProcessID+#endif
+ src/Hint/Configuration.hs view
@@ -0,0 +1,152 @@+module Hint.Configuration (+ setGhcOption, setGhcOptions,++ defaultConf,++ get, set, Option, OptionVal(..),++ languageExtensions, availableExtensions, Extension(..),+ installedModulesInScope,++ searchPath,++ configureDynFlags, parseDynamicFlags,++) where++import Control.Monad+import Control.Monad.Catch+import Data.Char+#if defined(NEED_PHANTOM_DIRECTORY)+import Data.Maybe (maybe)+#endif+import Data.List (intercalate)++import qualified Hint.GHC as GHC+import Hint.Base+import Hint.Util (quote)++import Hint.Extension++setGhcOptions :: MonadInterpreter m => [String] -> m ()+setGhcOptions opts =+ do old_flags <- runGhc GHC.getSessionDynFlags+ (new_flags,not_parsed) <- runGhc2 parseDynamicFlags old_flags opts+ unless (null not_parsed) $+ throwM $ UnknownError+ $ concat ["flags: ", unwords $ map quote not_parsed,+ "not recognized"]+ _ <- runGhc1 GHC.setSessionDynFlags new_flags+ return ()++setGhcOption :: MonadInterpreter m => String -> m ()+setGhcOption opt = setGhcOptions [opt]++defaultConf :: InterpreterConfiguration+defaultConf = Conf {+ languageExts = [],+ allModsInScope = False,+ searchFilePath = ["."]+ }++-- | Available options are:+--+-- * 'languageExtensions'+--+-- * 'installedModulesInScope'+--+-- * 'searchPath'+data Option m a = Option{+ _set :: MonadInterpreter m => a -> m (),+ _get :: MonadInterpreter m => m a+ }++data OptionVal m = forall a . (Option m a) := a++-- | Use this function to set or modify the value of any option. It is+-- invoked like this:+--+-- @set [opt1 := val1, opt2 := val2,... optk := valk]@+set :: MonadInterpreter m => [OptionVal m] -> m ()+set = mapM_ $ \(opt := val) -> _set opt val++-- | Retrieves the value of an option.+get :: MonadInterpreter m => Option m a -> m a+get = _get++-- | Language extensions in use by the interpreter.+--+-- Default is: @[]@ (i.e. none, pure Haskell 98)+languageExtensions :: MonadInterpreter m => Option m [Extension]+languageExtensions = Option setter getter+ where setter es = do resetExtensions+ setGhcOptions $ map (extFlag True) es+ onConf $ \c -> c{languageExts = es}+ --+ getter = fromConf languageExts+ --+ resetExtensions = do es <- fromState defaultExts+ setGhcOptions $ map (uncurry $ flip extFlag) es++extFlag :: Bool -> Extension -> String+extFlag = mkFlag+ where mkFlag b (UnknownExtension o) = strToFlag b o+ mkFlag b o = strToFlag b (show o)+ --+ strToFlag b o@('N':'o':(c:_))+ | isUpper c = "-X" ++ drop (if b then 0 else 2) o+ strToFlag b o = "-X" ++ concat ["No"|not b] ++ o++-- | When set to @True@, every module in every available package is implicitly+-- imported qualified. This is very convenient for interactive+-- evaluation, but can be a problem in sandboxed environments+-- (e.g. 'System.Unsafe.unsafePerformIO' is in scope).+--+-- Default value is @True@.+--+-- Observe that due to limitations in the GHC-API, when set to @False@, the+-- private symbols in interpreted modules will not be in scope.+installedModulesInScope :: MonadInterpreter m => Option m Bool+installedModulesInScope = Option setter getter+ where getter = fromConf allModsInScope+ setter b = do onConf $ \c -> c{allModsInScope = b}+ setGhcOption $ "-f" +++ concat ["no-" | not b] +++ "implicit-import-qualified"++-- | The search path for source files. Observe that every time it is set,+-- it overrides the previous search path. The default is @[\".\"]@.+--+-- Keep in mind that by a limitation in ghc, @\".\"@ is always in scope.+searchPath :: MonadInterpreter m => Option m [FilePath]+searchPath = Option setter getter+ where getter = fromConf searchFilePath+ setter p = do onConf $ \c -> c{searchFilePath = p}+ setGhcOption "-i" -- clear the old path+ setGhcOption $ "-i" ++ intercalate ":" p+#if defined(NEED_PHANTOM_DIRECTORY)+ mfp <- fromState phantomDirectory+ maybe (return ())+ (\fp -> setGhcOption $ "-i" ++ fp) mfp+#endif++fromConf :: MonadInterpreter m => (InterpreterConfiguration -> a) -> m a+fromConf f = fromState (f . configuration)++onConf :: MonadInterpreter m+ => (InterpreterConfiguration -> InterpreterConfiguration)+ -> m ()+onConf f = onState $ \st -> st{configuration = f (configuration st)}++configureDynFlags :: GHC.DynFlags -> GHC.DynFlags+configureDynFlags dflags =+ (if GHC.dynamicGhc then GHC.addWay' GHC.WayDyn else id)+ dflags{GHC.ghcMode = GHC.CompManager,+ GHC.hscTarget = GHC.HscInterpreted,+ GHC.ghcLink = GHC.LinkInMemory,+ GHC.verbosity = 0}++parseDynamicFlags :: GHC.GhcMonad m+ => GHC.DynFlags -> [String] -> m (GHC.DynFlags, [String])+parseDynamicFlags d = fmap firstTwo . GHC.parseDynamicFlags d . map GHC.noLoc+ where firstTwo (a,b,_) = (a, map GHC.unLoc b)
+ src/Hint/Context.hs view
@@ -0,0 +1,436 @@+module Hint.Context (+ isModuleInterpreted,+ loadModules, getLoadedModules, setTopLevelModules,+ setImports, setImportsQ, setImportsF,+ reset,++ PhantomModule(..),+ cleanPhantomModules,++ supportString, supportShow+) where++import Prelude hiding (mod)++import Data.Char+import Data.Either (partitionEithers)+import Data.List++import Control.Arrow ((***))++import Control.Monad (liftM, filterM, unless, guard, foldM, (>=>))+import Control.Monad.Trans (liftIO)+import Control.Monad.Catch++import Hint.Base+import Hint.Conversions+import qualified Hint.CompatPlatform as Compat++import qualified Hint.GHC as GHC++import System.Random+import System.FilePath+import System.Directory++#if defined(NEED_PHANTOM_DIRECTORY)+import Data.Maybe (maybe)+import Hint.Configuration (setGhcOption)+import System.IO.Temp+#endif++type ModuleText = String++-- When creating a phantom module we have a situation similar to that of+-- @Hint.Util.safeBndFor@: we want to avoid picking a module name that is+-- already in-scope. Additionally, since this may be used with sandboxing in+-- mind we want to avoid easy-to-guess names. Thus, we do a trick similar+-- to the one in safeBndFor, but including a random number instead of an+-- additional digit. Finally, to avoid clashes between two processes+-- that are concurrently running with the same random seed (e.g., initialized+-- with the system time with not enough resolution), we also include the process id+newPhantomModule :: MonadInterpreter m => m PhantomModule+newPhantomModule =+ do n <- liftIO randomIO+ p <- liftIO Compat.getPID+ (ls,is) <- allModulesInContext+ let nums = concat [show (abs n::Int), show p, filter isDigit $ concat (ls ++ is)]+ let mod_name = 'M':nums+ --+ tmp_dir <- getPhantomDirectory+ --+ return PhantomModule{pmName = mod_name, pmFile = tmp_dir </> mod_name <.> "hs"}++getPhantomDirectory :: MonadInterpreter m => m FilePath+getPhantomDirectory =+#if defined(NEED_PHANTOM_DIRECTORY)+ -- When a module is loaded by file name, ghc-8.4.1 loses track of the+ -- file location after the first time it has been loaded, so we create+ -- a directory for the phantom modules and add it to the search path.+ do mfp <- fromState phantomDirectory+ case mfp of+ Just fp -> return fp+ Nothing -> do tmp_dir <- liftIO getTemporaryDirectory+ fp <- liftIO $ createTempDirectory tmp_dir "hint"+ onState (\s -> s{ phantomDirectory = Just fp })+ setGhcOption $ "-i" ++ fp+ return fp+#else+ do liftIO getTemporaryDirectory+#endif++allModulesInContext :: MonadInterpreter m => m ([ModuleName], [ModuleName])+allModulesInContext = runGhc getContextNames++getContext :: GHC.GhcMonad m => m ([GHC.Module], [GHC.ImportDecl GHC.GhcPs])+getContext = GHC.getContext >>= foldM f ([], [])+ where+ f :: (GHC.GhcMonad m) =>+ ([GHC.Module], [GHC.ImportDecl GHC.GhcPs]) ->+ GHC.InteractiveImport ->+ m ([GHC.Module], [GHC.ImportDecl GHC.GhcPs])+ f (ns, ds) i = case i of+ (GHC.IIDecl d) -> return (ns, d : ds)+ m@(GHC.IIModule _) -> do n <- iiModToMod m; return (n : ns, ds)++modToIIMod :: GHC.Module -> GHC.InteractiveImport+modToIIMod = GHC.IIModule . GHC.moduleName++iiModToMod :: GHC.GhcMonad m => GHC.InteractiveImport -> m GHC.Module+iiModToMod (GHC.IIModule m) = GHC.findModule m Nothing+iiModToMod _ = error "iiModToMod!"++getContextNames :: GHC.GhcMonad m => m([String], [String])+getContextNames = fmap (map name *** map decl) getContext+ where name = GHC.moduleNameString . GHC.moduleName+ decl = GHC.moduleNameString . GHC.unLoc . GHC.ideclName++setContext :: GHC.GhcMonad m => [GHC.Module] -> [GHC.ImportDecl GHC.GhcPs] -> m ()+setContext ms ds =+ let ms' = map modToIIMod ms+ ds' = map GHC.IIDecl ds+ is = ms' ++ ds'+ in GHC.setContext is++-- Explicitly-typed variants of getContext/setContext, for use where we modify+-- or override the context.+setContextModules :: GHC.GhcMonad m => [GHC.Module] -> [GHC.Module] -> m ()+setContextModules as = setContext as . map (GHC.simpleImportDecl . GHC.moduleName)++fileTarget :: FilePath -> GHC.Target+fileTarget f = GHC.Target (GHC.TargetFile f $ Just next_phase) True Nothing+ where next_phase = GHC.Cpp GHC.HsSrcFile++addPhantomModule :: MonadInterpreter m+ => (ModuleName -> ModuleText)+ -> m PhantomModule+addPhantomModule mod_text =+ do pm <- newPhantomModule+ let t = fileTarget (pmFile pm)+ m = GHC.mkModuleName (pmName pm)+ --+ liftIO $ writeFile (pmFile pm) (mod_text $ pmName pm)+ --+ onState (\s -> s{activePhantoms = pm:activePhantoms s})+ mayFail (do -- GHC.load will remove all the modules from scope, so first+ -- we save the context...+ (old_top, old_imps) <- runGhc getContext+ --+ runGhc1 GHC.addTarget t+ res <- runGhc1 GHC.load (GHC.LoadUpTo m)+ --+ if isSucceeded res+ then do runGhc2 setContext old_top old_imps+ return $ Just ()+ else return Nothing)+ `catchIE` (\err -> case err of+ WontCompile _ -> do removePhantomModule pm+ throwM err+ _ -> throwM err)+ --+ return pm++removePhantomModule :: MonadInterpreter m => PhantomModule -> m ()+removePhantomModule pm =+ do -- We don't want to actually unload this module, because that+ -- would mean that all the real modules might get reloaded and the+ -- user didn't require that (they may be in a non-compiling state!).+ -- However, this means that we can't actually delete the file, because+ -- it is an active target. Therefore, we simply take it out of scope+ -- and mark it as "delete me when possible" (i.e., next time the+ -- @loadModules@ function is called).+ --+ isLoaded <- moduleIsLoaded $ pmName pm+ safeToRemove <-+ if isLoaded+ then do -- take it out of scope+ mod <- findModule (pmName pm)+ (mods, imps) <- runGhc getContext+ let mods' = filter (mod /=) mods+ runGhc2 setContext mods' imps+ --+ let isNotPhantom = isPhantomModule . moduleToString >=>+ return . not+ null `liftM` filterM isNotPhantom mods'+ else return True+ --+ let file_name = pmFile pm+ runGhc1 GHC.removeTarget (GHC.targetId $ fileTarget file_name)+ --+ 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 ()+ `finally` do liftIO $ removeFile (pmFile pm)+ else onState (\s -> s{zombiePhantoms = pm:zombiePhantoms s})++-- Returns a tuple with the active and zombie phantom modules respectively+getPhantomModules :: MonadInterpreter m => m ([PhantomModule], [PhantomModule])+getPhantomModules = do active <- fromState activePhantoms+ zombie <- fromState zombiePhantoms+ return (active, zombie)++isPhantomModule :: MonadInterpreter m => ModuleName -> m Bool+isPhantomModule mn = do (as,zs) <- getPhantomModules+ return $ mn `elem` map pmName (as ++ zs)++-- | Tries to load all the requested modules from their source file.+-- Modules my be indicated by their ModuleName (e.g. \"My.Module\") or+-- by the full path to its source file.+--+-- The interpreter is 'reset' both before loading the modules and in the event+-- of an error.+--+-- /IMPORTANT/: Like in a ghci session, this will also load (and interpret)+-- any dependency that is not available via an installed package. Make+-- sure that you are not loading any module that is also being used to+-- compile your application. In particular, you need to avoid modules+-- that define types that will later occur in an expression that you will+-- want to interpret.+--+-- The problem in doing this is that those types will have two incompatible+-- representations at runtime: 1) the one in the compiled code and 2) the+-- one in the interpreted code. When interpreting such an expression (bringing+-- it to program-code) you will likely get a segmentation fault, since the+-- latter representation will be used where the program assumes the former.+--+-- The rule of thumb is: never make the interpreter run on the directory+-- with the source code of your program! If you want your interpreted code to+-- use some type that is defined in your program, then put the defining module+-- on a library and make your program depend on that package.+loadModules :: MonadInterpreter m => [String] -> m ()+loadModules fs = do -- first, unload everything, and do some clean-up+ reset+ doLoad fs `catchIE` (\e -> reset >> throwM e)++doLoad :: MonadInterpreter m => [String] -> m ()+doLoad fs = mayFail $ do+ targets <- mapM (\f->runGhc2 GHC.guessTarget f Nothing) fs+ --+ runGhc1 GHC.setTargets targets+ res <- runGhc1 GHC.load GHC.LoadAllTargets+ -- loading the targets removes the support module+ reinstallSupportModule+ return $ guard (isSucceeded res) >> Just ()++-- | Returns True if the module was interpreted.+isModuleInterpreted :: MonadInterpreter m => ModuleName -> m Bool+isModuleInterpreted m = findModule m >>= runGhc1 GHC.moduleIsInterpreted++-- | Returns the list of modules loaded with 'loadModules'.+getLoadedModules :: MonadInterpreter m => m [ModuleName]+getLoadedModules = do (active_pms, zombie_pms) <- getPhantomModules+ ms <- map modNameFromSummary `liftM` getLoadedModSummaries+ return $ ms \\ map pmName (active_pms ++ zombie_pms)++modNameFromSummary :: GHC.ModSummary -> ModuleName+modNameFromSummary = moduleToString . GHC.ms_mod++getLoadedModSummaries :: MonadInterpreter m => m [GHC.ModSummary]+getLoadedModSummaries =+ do all_mod_summ <- runGhc GHC.getModuleGraph+ filterM (runGhc1 GHC.isLoaded . GHC.ms_mod_name)+ (GHC.mgModSummaries all_mod_summ)++-- | Sets the modules whose context is used during evaluation. All bindings+-- of these modules are in scope, not only those exported.+--+-- Modules must be interpreted to use this function.+setTopLevelModules :: MonadInterpreter m => [ModuleName] -> m ()+setTopLevelModules ms =+ do loaded_mods_ghc <- getLoadedModSummaries+ --+ let not_loaded = ms \\ map modNameFromSummary loaded_mods_ghc+ unless (null not_loaded) $+ throwM $ NotAllowed ("These modules have not been loaded:\n" +++ unlines not_loaded)+ --+ active_pms <- fromState activePhantoms+ ms_mods <- mapM findModule (nub $ ms ++ map pmName active_pms)+ --+ let mod_is_interpr = runGhc1 GHC.moduleIsInterpreted+ not_interpreted <- filterM (liftM not . mod_is_interpr) ms_mods+ unless (null not_interpreted) $+ throwM $ NotAllowed ("These modules are not interpreted:\n" +++ unlines (map moduleToString not_interpreted))+ --+ (_, old_imports) <- runGhc getContext+ runGhc2 setContext ms_mods old_imports++-- | Sets the modules whose exports must be in context.+--+-- Warning: 'setImports', 'setImportsQ', and 'setImportsF' are mutually exclusive.+-- If you have a list of modules to be used qualified and another list+-- unqualified, then you need to do something like+--+-- > setImportsQ ((zip unqualified $ repeat Nothing) ++ qualifieds)+setImports :: MonadInterpreter m => [ModuleName] -> m ()+setImports ms = setImportsF $ map (\m -> ModuleImport m NotQualified NoImportList) ms++-- | Sets the modules whose exports must be in context; some+-- of them may be qualified. E.g.:+--+-- @setImportsQ [("Prelude", Nothing), ("Data.Map", Just "M")]@.+--+-- Here, "map" will refer to Prelude.map and "M.map" to Data.Map.map.+setImportsQ :: MonadInterpreter m => [(ModuleName, Maybe String)] -> m ()+setImportsQ ms = setImportsF $ map (\(m,q) -> ModuleImport m (maybe NotQualified (QualifiedAs . Just) q) NoImportList) ms++-- | Sets the modules whose exports must be in context; some+-- may be qualified or have imports lists. E.g.:+--+-- @setImportsF [ModuleImport "Prelude" NotQualified NoImportList, ModuleImport "Data.Text" (QualifiedAs $ Just "Text") (HidingList ["pack"])]@++setImportsF :: MonadInterpreter m => [ModuleImport] -> m ()+setImportsF ms = do+ regularMods <- mapM (findModule . modName) regularImports+ mapM_ (findModule . modName) phantomImports -- just to be sure they exist+ --+ old_qual_hack_mod <- fromState importQualHackMod+ maybe (return ()) removePhantomModule old_qual_hack_mod+ --+ new_pm <- if null phantomImports+ then return Nothing+ else do+ new_pm <- addPhantomModule $ \mod_name -> unlines $+ ("module " ++ mod_name ++ " where ") :+ map newImportLine phantomImports+ onState (\s -> s{importQualHackMod = Just new_pm})+ return $ Just new_pm+ --+ pm <- maybe (return []) (findModule . pmName >=> return . return) new_pm+ (old_top_level, _) <- runGhc getContext+ let new_top_level = pm ++ old_top_level+ runGhc2 setContextModules new_top_level regularMods+ --+ onState (\s ->s{qualImports = phantomImports})+ where+ (regularImports, phantomImports) = partitionEithers $ map (\m -> if isQualified m || hasImportList m+ then Right m+ else Left m) ms+ isQualified m = modQual m /= NotQualified+ hasImportList m = modImp m /= NoImportList+ newImportLine m = concat ["import ", case modQual m of+ NotQualified -> modName m+ ImportAs q -> modName m ++ " as " ++ q+ QualifiedAs Nothing -> "qualified " ++ modName m+ QualifiedAs (Just q) -> "qualified " ++ modName m ++ " as " ++ q+ ,case modImp m of+ NoImportList -> ""+ ImportList l -> " (" ++ intercalate "," l ++ ")"+ HidingList l -> " hiding (" ++ intercalate "," l ++ ")"+ ]++-- | 'cleanPhantomModules' works like 'reset', but skips the+-- loading of the support module that installs '_show'. Its purpose+-- is to clean up all temporary files generated for phantom modules.+cleanPhantomModules :: MonadInterpreter m => m ()+cleanPhantomModules =+ do -- Remove all modules from context+ runGhc2 setContext [] []+ --+ -- Unload all previously loaded modules+ runGhc1 GHC.setTargets []+ _ <- runGhc1 GHC.load GHC.LoadAllTargets+ --+ -- At this point, GHCi would call rts_revertCAFs and+ -- reset the buffering of stdin, stdout and stderr.+ -- Should we do any of these?+ --+ -- liftIO $ rts_revertCAFs+ --+ -- We now remove every phantom module and forget about qual imports+ old_active <- fromState activePhantoms+ old_zombie <- fromState zombiePhantoms+ onState (\s -> s{activePhantoms = [],+ zombiePhantoms = [],+ importQualHackMod = Nothing,+ qualImports = []})+ liftIO $ mapM_ (removeFile . pmFile) (old_active ++ old_zombie)+#if defined(NEED_PHANTOM_DIRECTORY)+ old_phantomdir <- fromState phantomDirectory+ onState (\s -> s{phantomDirectory = Nothing})+ liftIO $ do maybe (return ()) removeDirectory old_phantomdir+#endif++-- | All imported modules are cleared from the context, and+-- loaded modules are unloaded. It is similar to a @:load@ in+-- GHCi, but observe that not even the Prelude will be in+-- context after a reset.+reset :: MonadInterpreter m => m ()+reset = do -- clean up context+ cleanPhantomModules+ --+ -- Now, install a support module+ installSupportModule++-- Load a phantom module with all the symbols from the prelude we need+installSupportModule :: MonadInterpreter m => m ()+installSupportModule = do mod <- addPhantomModule support_module+ onState (\st -> st{hintSupportModule = mod})+ mod' <- findModule (pmName mod)+ runGhc2 setContext [mod'] []+ --+ where support_module m = unlines [+ "module " ++ m ++ "( ",+ " " ++ _String ++ ",",+ " " ++ _show ++ ")",+ "where",+ "",+ "import qualified Prelude as " ++ _P ++ " (String, Show(show))",+ "",+ "type " ++ _String ++ " = " ++ _P ++ ".String",+ "",+ _show ++ " :: " ++ _P ++ ".Show a => a -> " ++ _P ++ ".String",+ _show ++ " = " ++ _P ++ ".show"+ ]+ where _String = altStringName m+ _show = altShowName m+ _P = altPreludeName m++-- Call it when the support module is an active phantom module but has been+-- unloaded as a side effect by GHC (e.g. by calling GHC.loadTargets)+reinstallSupportModule :: MonadInterpreter m => m ()+reinstallSupportModule = do pm <- fromState hintSupportModule+ removePhantomModule pm+ installSupportModule++altStringName :: ModuleName -> String+altStringName mod_name = "String_" ++ mod_name++altShowName :: ModuleName -> String+altShowName mod_name = "show_" ++ mod_name++altPreludeName :: ModuleName -> String+altPreludeName mod_name = "Prelude_" ++ mod_name++supportString :: MonadInterpreter m => m String+supportString = do mod_name <- fromState (pmName . hintSupportModule)+ return $ concat [mod_name, ".", altStringName mod_name]++supportShow :: MonadInterpreter m => m String+supportShow = do mod_name <- fromState (pmName . hintSupportModule)+ return $ concat [mod_name, ".", altShowName mod_name]++-- SHOULD WE CALL THIS WHEN MODULES ARE LOADED / UNLOADED?+-- foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
+ src/Hint/Conversions.hs view
@@ -0,0 +1,33 @@+module Hint.Conversions (+ typeToString, kindToString, moduleToString, isSucceeded+) where++import qualified Hint.GHC as GHC++import Hint.Base++-- --------- Types / Kinds -----------------------++typeToString :: MonadInterpreter m => GHC.Type -> m String+typeToString t+ = do -- Unqualify necessary types+ -- (i.e., do not expose internals)+ unqual <- runGhc GHC.getPrintUnqual+ withDynFlags $ \df ->+ return $ GHC.showSDocForUser df unqual (GHC.pprTypeForUser t)++kindToString :: MonadInterpreter m => GHC.Kind -> m String+kindToString k+ = withDynFlags $ \df ->+ return $ GHC.showSDoc df (GHC.pprTypeForUser k)++-- ---------------- Modules --------------------------++moduleToString :: GHC.Module -> String+moduleToString = GHC.moduleNameString . GHC.moduleName++-- ---------------- Misc -----------------------------++isSucceeded :: GHC.SuccessFlag -> Bool+isSucceeded GHC.Succeeded = True+isSucceeded GHC.Failed = False
+ src/Hint/Eval.hs view
@@ -0,0 +1,77 @@+module Hint.Eval (+ interpret, unsafeInterpret,+ eval, runStmt,+ parens+) where++import qualified GHC.Exts (unsafeCoerce#)++import Control.Exception++import Data.Proxy+import Data.Typeable hiding (typeOf)++import Hint.Base+import Hint.Context+import Hint.Parsers+import Hint.Util++import qualified Hint.GHC as GHC++-- | Evaluates an expression, given a witness for its monomorphic type.+interpret :: (MonadInterpreter m, Typeable a) => Proxy a -> String -> m a+interpret = unsafeInterpret . show . typeRep++unsafeInterpret :: (MonadInterpreter m) => String -> String -> m a+unsafeInterpret type_str expr =+ do -- First, make sure the expression has no syntax errors,+ -- for this is the only way we have to "intercept" this+ -- kind of errors+ failOnParseError parseExpr expr+ --+ let expr_typesig = concat [parens expr, " :: ", type_str]+ expr_val <- mayFail $ runGhc1 compileExpr expr_typesig+ --+ return (GHC.Exts.unsafeCoerce# expr_val :: a)++-- add a bogus Maybe, in order to use it with mayFail+compileExpr :: GHC.GhcMonad m => String -> m (Maybe GHC.HValue)+compileExpr = fmap Just . GHC.compileExpr++-- | @eval expr@ will evaluate @show expr@.+-- It will succeed only if @expr@ has type t and there is a 'Show'+-- instance for t.+eval :: MonadInterpreter m => String -> m String+eval expr = do in_scope_show <- supportShow+ in_scope_String <- supportString+ let show_expr = unwords [in_scope_show, parens expr]+ unsafeInterpret in_scope_String show_expr++-- | Evaluate a statement in the 'IO' monad, possibly binding new names.+--+-- Example:+--+-- > runStmt "x <- return 42"+-- > runStmt "print x"+runStmt :: (MonadInterpreter m) => String -> m ()+runStmt = mayFail . runGhc1 go+ where+ go statements = do+ result <- GHC.execStmt statements GHC.execOptions+ return $ case result of+ GHC.ExecComplete { GHC.execResult = Right _ } -> Just ()+ GHC.ExecComplete { GHC.execResult = Left e } -> throw e+ _ -> Nothing++-- | Conceptually, @parens s = \"(\" ++ s ++ \")\"@, where s is any valid haskell+-- expression. In practice, it is harder than this.+-- Observe that if @s@ ends with a trailing comment, then @parens s@ would+-- be a malformed expression. The straightforward solution for this is to+-- put the closing parenthesis in a different line. However, now we are+-- messing with the layout rules and we don't know where @s@ is going to+-- be used!+-- Solution: @parens s = \"(let {foo =\n\" ++ s ++ \"\\n ;} in foo)\"@ where @foo@ does not occur in @s@+parens :: String -> String+parens s = concat ["(let {", foo, " =\n", s, "\n",+ " ;} in ", foo, ")"]+ where foo = safeBndFor s
+ src/Hint/Extension.hs view
@@ -0,0 +1,509 @@+-- this module was automatically generated. do not edit!+-- edit util/mk_extensions_mod.hs instead+module Hint.Extension (+ Extension(..), supportedExtensions, availableExtensions, asExtension+) where++import qualified Hint.GHC as GHC++supportedExtensions :: [String]+supportedExtensions = map f GHC.xFlags+ where+ f = GHC.flagSpecName++-- | List of the extensions known by the interpreter.+availableExtensions :: [Extension]+availableExtensions = map asExtension supportedExtensions++asExtension :: String -> Extension+asExtension s = if isKnown s+ then read s+ else let no_s = "No" ++ s+ in if isKnown no_s then read no_s+ else UnknownExtension s+ where isKnown e = e `elem` map show knownExtensions++-- | This represents language extensions beyond Haskell 98+-- that are supported by GHC (it was taken from+-- Cabal's @Language.Haskell.Extension@)+data Extension = OverlappingInstances+ | UndecidableInstances+ | IncoherentInstances+ | DoRec+ | RecursiveDo+ | ParallelListComp+ | MultiParamTypeClasses+ | MonomorphismRestriction+ | FunctionalDependencies+ | Rank2Types+ | RankNTypes+ | PolymorphicComponents+ | ExistentialQuantification+ | ScopedTypeVariables+ | PatternSignatures+ | ImplicitParams+ | FlexibleContexts+ | FlexibleInstances+ | EmptyDataDecls+ | CPP+ | KindSignatures+ | BangPatterns+ | TypeSynonymInstances+ | TemplateHaskell+ | ForeignFunctionInterface+ | Arrows+ | Generics+ | ImplicitPrelude+ | NamedFieldPuns+ | PatternGuards+ | GeneralizedNewtypeDeriving+ | ExtensibleRecords+ | RestrictedTypeSynonyms+ | HereDocuments+ | MagicHash+ | TypeFamilies+ | StandaloneDeriving+ | UnicodeSyntax+ | UnliftedFFITypes+ | InterruptibleFFI+ | CApiFFI+ | LiberalTypeSynonyms+ | TypeOperators+ | RecordWildCards+ | RecordPuns+ | DisambiguateRecordFields+ | TraditionalRecordSyntax+ | OverloadedStrings+ | GADTs+ | GADTSyntax+ | MonoPatBinds+ | RelaxedPolyRec+ | ExtendedDefaultRules+ | UnboxedTuples+ | DeriveDataTypeable+ | DeriveGeneric+ | DefaultSignatures+ | InstanceSigs+ | ConstrainedClassMethods+ | PackageImports+ | ImpredicativeTypes+ | NewQualifiedOperators+ | PostfixOperators+ | QuasiQuotes+ | TransformListComp+ | MonadComprehensions+ | ViewPatterns+ | XmlSyntax+ | RegularPatterns+ | TupleSections+ | GHCForeignImportPrim+ | NPlusKPatterns+ | DoAndIfThenElse+ | MultiWayIf+ | LambdaCase+ | RebindableSyntax+ | ExplicitForAll+ | DatatypeContexts+ | MonoLocalBinds+ | DeriveFunctor+ | DeriveTraversable+ | DeriveFoldable+ | NondecreasingIndentation+ | SafeImports+ | Safe+ | Trustworthy+ | Unsafe+ | ConstraintKinds+ | PolyKinds+ | DataKinds+ | ParallelArrays+ | RoleAnnotations+ | OverloadedLists+ | EmptyCase+ | AutoDeriveTypeable+ | NegativeLiterals+ | BinaryLiterals+ | NumDecimals+ | NullaryTypeClasses+ | ExplicitNamespaces+ | AllowAmbiguousTypes+ | JavaScriptFFI+ | PatternSynonyms+ | PartialTypeSignatures+ | NamedWildCards+ | DeriveAnyClass+ | DeriveLift+ | StaticPointers+ | StrictData+ | Strict+ | ApplicativeDo+ | DuplicateRecordFields+ | TypeApplications+ | TypeInType+ | UndecidableSuperClasses+ | MonadFailDesugaring+ | TemplateHaskellQuotes+ | OverloadedLabels+ | TypeFamilyDependencies+ | NoOverlappingInstances+ | NoUndecidableInstances+ | NoIncoherentInstances+ | NoDoRec+ | NoRecursiveDo+ | NoParallelListComp+ | NoMultiParamTypeClasses+ | NoMonomorphismRestriction+ | NoFunctionalDependencies+ | NoRank2Types+ | NoRankNTypes+ | NoPolymorphicComponents+ | NoExistentialQuantification+ | NoScopedTypeVariables+ | NoPatternSignatures+ | NoImplicitParams+ | NoFlexibleContexts+ | NoFlexibleInstances+ | NoEmptyDataDecls+ | NoCPP+ | NoKindSignatures+ | NoBangPatterns+ | NoTypeSynonymInstances+ | NoTemplateHaskell+ | NoForeignFunctionInterface+ | NoArrows+ | NoGenerics+ | NoImplicitPrelude+ | NoNamedFieldPuns+ | NoPatternGuards+ | NoGeneralizedNewtypeDeriving+ | NoExtensibleRecords+ | NoRestrictedTypeSynonyms+ | NoHereDocuments+ | NoMagicHash+ | NoTypeFamilies+ | NoStandaloneDeriving+ | NoUnicodeSyntax+ | NoUnliftedFFITypes+ | NoInterruptibleFFI+ | NoCApiFFI+ | NoLiberalTypeSynonyms+ | NoTypeOperators+ | NoRecordWildCards+ | NoRecordPuns+ | NoDisambiguateRecordFields+ | NoTraditionalRecordSyntax+ | NoOverloadedStrings+ | NoGADTs+ | NoGADTSyntax+ | NoMonoPatBinds+ | NoRelaxedPolyRec+ | NoExtendedDefaultRules+ | NoUnboxedTuples+ | NoDeriveDataTypeable+ | NoDeriveGeneric+ | NoDefaultSignatures+ | NoInstanceSigs+ | NoConstrainedClassMethods+ | NoPackageImports+ | NoImpredicativeTypes+ | NoNewQualifiedOperators+ | NoPostfixOperators+ | NoQuasiQuotes+ | NoTransformListComp+ | NoMonadComprehensions+ | NoViewPatterns+ | NoXmlSyntax+ | NoRegularPatterns+ | NoTupleSections+ | NoGHCForeignImportPrim+ | NoNPlusKPatterns+ | NoDoAndIfThenElse+ | NoMultiWayIf+ | NoLambdaCase+ | NoRebindableSyntax+ | NoExplicitForAll+ | NoDatatypeContexts+ | NoMonoLocalBinds+ | NoDeriveFunctor+ | NoDeriveTraversable+ | NoDeriveFoldable+ | NoNondecreasingIndentation+ | NoSafeImports+ | NoSafe+ | NoTrustworthy+ | NoUnsafe+ | NoConstraintKinds+ | NoPolyKinds+ | NoDataKinds+ | NoParallelArrays+ | NoRoleAnnotations+ | NoOverloadedLists+ | NoEmptyCase+ | NoAutoDeriveTypeable+ | NoNegativeLiterals+ | NoBinaryLiterals+ | NoNumDecimals+ | NoNullaryTypeClasses+ | NoExplicitNamespaces+ | NoAllowAmbiguousTypes+ | NoJavaScriptFFI+ | NoPatternSynonyms+ | NoPartialTypeSignatures+ | NoNamedWildCards+ | NoDeriveAnyClass+ | NoDeriveLift+ | NoStaticPointers+ | NoStrictData+ | NoStrict+ | NoApplicativeDo+ | NoDuplicateRecordFields+ | NoTypeApplications+ | NoTypeInType+ | NoUndecidableSuperClasses+ | NoMonadFailDesugaring+ | NoTemplateHaskellQuotes+ | NoOverloadedLabels+ | NoTypeFamilyDependencies+ | UnknownExtension String+ deriving (Eq, Show, Read)++knownExtensions :: [Extension]+knownExtensions = [OverlappingInstances,+ UndecidableInstances,+ IncoherentInstances,+ DoRec,+ RecursiveDo,+ ParallelListComp,+ MultiParamTypeClasses,+ MonomorphismRestriction,+ FunctionalDependencies,+ Rank2Types,+ RankNTypes,+ PolymorphicComponents,+ ExistentialQuantification,+ ScopedTypeVariables,+ PatternSignatures,+ ImplicitParams,+ FlexibleContexts,+ FlexibleInstances,+ EmptyDataDecls,+ CPP,+ KindSignatures,+ BangPatterns,+ TypeSynonymInstances,+ TemplateHaskell,+ ForeignFunctionInterface,+ Arrows,+ Generics,+ ImplicitPrelude,+ NamedFieldPuns,+ PatternGuards,+ GeneralizedNewtypeDeriving,+ ExtensibleRecords,+ RestrictedTypeSynonyms,+ HereDocuments,+ MagicHash,+ TypeFamilies,+ StandaloneDeriving,+ UnicodeSyntax,+ UnliftedFFITypes,+ InterruptibleFFI,+ CApiFFI,+ LiberalTypeSynonyms,+ TypeOperators,+ RecordWildCards,+ RecordPuns,+ DisambiguateRecordFields,+ TraditionalRecordSyntax,+ OverloadedStrings,+ GADTs,+ GADTSyntax,+ MonoPatBinds,+ RelaxedPolyRec,+ ExtendedDefaultRules,+ UnboxedTuples,+ DeriveDataTypeable,+ DeriveGeneric,+ DefaultSignatures,+ InstanceSigs,+ ConstrainedClassMethods,+ PackageImports,+ ImpredicativeTypes,+ NewQualifiedOperators,+ PostfixOperators,+ QuasiQuotes,+ TransformListComp,+ MonadComprehensions,+ ViewPatterns,+ XmlSyntax,+ RegularPatterns,+ TupleSections,+ GHCForeignImportPrim,+ NPlusKPatterns,+ DoAndIfThenElse,+ MultiWayIf,+ LambdaCase,+ RebindableSyntax,+ ExplicitForAll,+ DatatypeContexts,+ MonoLocalBinds,+ DeriveFunctor,+ DeriveTraversable,+ DeriveFoldable,+ NondecreasingIndentation,+ SafeImports,+ Safe,+ Trustworthy,+ Unsafe,+ ConstraintKinds,+ PolyKinds,+ DataKinds,+ ParallelArrays,+ RoleAnnotations,+ OverloadedLists,+ EmptyCase,+ AutoDeriveTypeable,+ NegativeLiterals,+ BinaryLiterals,+ NumDecimals,+ NullaryTypeClasses,+ ExplicitNamespaces,+ AllowAmbiguousTypes,+ JavaScriptFFI,+ PatternSynonyms,+ PartialTypeSignatures,+ NamedWildCards,+ DeriveAnyClass,+ DeriveLift,+ StaticPointers,+ StrictData,+ Strict,+ ApplicativeDo,+ DuplicateRecordFields,+ TypeApplications,+ TypeInType,+ UndecidableSuperClasses,+ MonadFailDesugaring,+ TemplateHaskellQuotes,+ OverloadedLabels,+ TypeFamilyDependencies,+ NoOverlappingInstances,+ NoUndecidableInstances,+ NoIncoherentInstances,+ NoDoRec,+ NoRecursiveDo,+ NoParallelListComp,+ NoMultiParamTypeClasses,+ NoMonomorphismRestriction,+ NoFunctionalDependencies,+ NoRank2Types,+ NoRankNTypes,+ NoPolymorphicComponents,+ NoExistentialQuantification,+ NoScopedTypeVariables,+ NoPatternSignatures,+ NoImplicitParams,+ NoFlexibleContexts,+ NoFlexibleInstances,+ NoEmptyDataDecls,+ NoCPP,+ NoKindSignatures,+ NoBangPatterns,+ NoTypeSynonymInstances,+ NoTemplateHaskell,+ NoForeignFunctionInterface,+ NoArrows,+ NoGenerics,+ NoImplicitPrelude,+ NoNamedFieldPuns,+ NoPatternGuards,+ NoGeneralizedNewtypeDeriving,+ NoExtensibleRecords,+ NoRestrictedTypeSynonyms,+ NoHereDocuments,+ NoMagicHash,+ NoTypeFamilies,+ NoStandaloneDeriving,+ NoUnicodeSyntax,+ NoUnliftedFFITypes,+ NoInterruptibleFFI,+ NoCApiFFI,+ NoLiberalTypeSynonyms,+ NoTypeOperators,+ NoRecordWildCards,+ NoRecordPuns,+ NoDisambiguateRecordFields,+ NoTraditionalRecordSyntax,+ NoOverloadedStrings,+ NoGADTs,+ NoGADTSyntax,+ NoMonoPatBinds,+ NoRelaxedPolyRec,+ NoExtendedDefaultRules,+ NoUnboxedTuples,+ NoDeriveDataTypeable,+ NoDeriveGeneric,+ NoDefaultSignatures,+ NoInstanceSigs,+ NoConstrainedClassMethods,+ NoPackageImports,+ NoImpredicativeTypes,+ NoNewQualifiedOperators,+ NoPostfixOperators,+ NoQuasiQuotes,+ NoTransformListComp,+ NoMonadComprehensions,+ NoViewPatterns,+ NoXmlSyntax,+ NoRegularPatterns,+ NoTupleSections,+ NoGHCForeignImportPrim,+ NoNPlusKPatterns,+ NoDoAndIfThenElse,+ NoMultiWayIf,+ NoLambdaCase,+ NoRebindableSyntax,+ NoExplicitForAll,+ NoDatatypeContexts,+ NoMonoLocalBinds,+ NoDeriveFunctor,+ NoDeriveTraversable,+ NoDeriveFoldable,+ NoNondecreasingIndentation,+ NoSafeImports,+ NoSafe,+ NoTrustworthy,+ NoUnsafe,+ NoConstraintKinds,+ NoPolyKinds,+ NoDataKinds,+ NoParallelArrays,+ NoRoleAnnotations,+ NoOverloadedLists,+ NoEmptyCase,+ NoAutoDeriveTypeable,+ NoNegativeLiterals,+ NoBinaryLiterals,+ NoNumDecimals,+ NoNullaryTypeClasses,+ NoExplicitNamespaces,+ NoAllowAmbiguousTypes,+ NoJavaScriptFFI,+ NoPatternSynonyms,+ NoPartialTypeSignatures,+ NoNamedWildCards,+ NoDeriveAnyClass,+ NoDeriveLift,+ NoStaticPointers,+ NoStrictData,+ NoStrict,+ NoApplicativeDo,+ NoDuplicateRecordFields,+ NoTypeApplications,+ NoTypeInType,+ NoUndecidableSuperClasses,+ NoMonadFailDesugaring,+ NoTemplateHaskellQuotes,+ NoOverloadedLabels,+ NoTypeFamilyDependencies+ ]
+ src/Hint/GHC.hs view
@@ -0,0 +1,46 @@+module Hint.GHC (+ Message, module X,+#if __GLASGOW_HASKELL__ < 804+ GhcPs, mgModSummaries+#endif+) where++import GHC as X hiding (Phase, GhcT, runGhcT)+import Control.Monad.Ghc as X (GhcT, runGhcT)++import HscTypes as X (SourceError, srcErrorMessages, GhcApiError)+#if __GLASGOW_HASKELL__ >= 804+import HscTypes as X (mgModSummaries)+#endif++import Outputable as X (PprStyle, SDoc, Outputable(ppr),+ showSDoc, showSDocForUser, showSDocUnqual,+ withPprStyle, defaultErrStyle)++import ErrUtils as X (mkLocMessage, pprErrMsgBagWithLoc, MsgDoc) -- we alias MsgDoc as Message below++import DriverPhases as X (Phase(Cpp), HscSource(HsSrcFile))+import StringBuffer as X (stringToStringBuffer)+import Lexer as X (P(..), ParseResult(..), mkPState)+import Parser as X (parseStmt, parseType)+import FastString as X (fsLit)++import DynFlags as X (xFlags, xopt, LogAction, FlagSpec(..))++import DynFlags as X (WarnReason(NoReason))++import PprTyThing as X (pprTypeForUser)+import SrcLoc as X (mkRealSrcLoc)++import ConLike as X (ConLike(RealDataCon))++import DynFlags as X (addWay', Way(..), dynamicGhc)++type Message = MsgDoc++#if __GLASGOW_HASKELL__ < 804+type GhcPs = RdrName++mgModSummaries :: ModuleGraph -> [ModSummary]+mgModSummaries = id+#endif
+ src/Hint/Internal.hs view
@@ -0,0 +1,33 @@+-- | In this module we intend to export some internal functions.+--+-- __Important note__: the authors of this library imply no assurance whatsoever+-- of the stability or functionality of the API exposed here, and compatibility+-- may break even by minor version changes. Rely on these at your+-- own risk.+--+-- The reason for showing them here is to aid discoverability+-- of already written code and prevent having to reinvent the wheel from+-- scratch if said wheel is already invented.+--+-- In case you find something here especially useful, please submit+-- an issue or a pull request at https://github.com/mvdan/hint so+-- we can discuss making it part of the official public API.+--+-- Some further context can be found here:+-- https://github.com/mvdan/hint/pull/48#issuecomment-358722638++++module Hint.Internal (+ onCompilationError+) where++import Hint.Typecheck (onCompilationError)++++-- todo: Consider refactoring like the following when+-- https://github.com/haskell/haddock/issues/563 is fixed+--+-- module Hint.Internal (module ReExport) where+-- import Hint.Typecheck as ReExport (onCompilationError)
+ src/Hint/InterpreterT.hs view
@@ -0,0 +1,205 @@+module Hint.InterpreterT (+ InterpreterT, Interpreter,+ runInterpreter, runInterpreterWithArgs, runInterpreterWithArgsLibdir,+ MultipleInstancesNotAllowed(..)+) where++import Control.Applicative+import Prelude++import Hint.Base+import Hint.Context+import Hint.Configuration+import Hint.Extension++import Control.Monad.Reader+import Control.Monad.Catch as MC++import Data.Typeable (Typeable)+import Control.Concurrent.MVar+import System.IO.Unsafe (unsafePerformIO)++import Data.IORef+import Data.Maybe++import qualified GHC.Paths++import qualified Hint.GHC as GHC++type Interpreter = InterpreterT IO++newtype InterpreterT m a = InterpreterT {+ unInterpreterT :: ReaderT InterpreterSession (GHC.GhcT m) a+ }+ deriving (Functor, Monad, MonadIO, MonadThrow, MonadCatch, MonadMask)++execute :: (MonadIO m, MonadMask m)+ => String+ -> InterpreterSession+ -> InterpreterT m a+ -> m (Either InterpreterError a)+execute libdir s = try+ . GHC.runGhcT (Just libdir)+ . flip runReaderT s+ . unInterpreterT++instance MonadTrans InterpreterT where+ lift = InterpreterT . lift . lift++runGhcImpl :: (MonadIO m, MonadMask m)+ => RunGhc (InterpreterT m) a+runGhcImpl a =+ InterpreterT (lift a)+ `catches`+ [Handler (\(e :: GHC.SourceError) -> do+ dynFlags <- runGhc GHC.getSessionDynFlags+ throwM $ compilationError dynFlags e)+ ,Handler (\(e :: GHC.GhcApiError) -> throwM $ GhcException $ show e)+ ,Handler (\(e :: GHC.GhcException) -> throwM $ GhcException $ showGhcEx e)+ ]+ where+ compilationError dynFlags+ = WontCompile+ . map (GhcError . GHC.showSDoc dynFlags)+ . GHC.pprErrMsgBagWithLoc+ . GHC.srcErrorMessages++showGhcEx :: GHC.GhcException -> String+showGhcEx = flip GHC.showGhcException ""++-- ================= Executing the interpreter ==================++initialize :: (MonadIO m, MonadThrow m, MonadMask m, Functor m)+ => [String]+ -> InterpreterT m ()+initialize args =+ do log_handler <- fromSession ghcErrLogger+ -- Set a custom log handler, to intercept error messages :S+ df0 <- runGhc GHC.getSessionDynFlags++ let df1 = configureDynFlags df0+ (df2, extra) <- runGhc2 parseDynamicFlags df1 args+ unless (null extra) $+ throwM $ UnknownError (concat [ "flags: '"+ , unwords extra+ , "' not recognized"])++ -- Observe that, setSessionDynFlags loads info on packages+ -- available; calling this function once is mandatory!+ _ <- runGhc1 GHC.setSessionDynFlags df2{GHC.log_action = log_handler}++ let extMap = map (\fs -> (GHC.flagSpecName fs, GHC.flagSpecFlag fs)) GHC.xFlags+ let toOpt e = let err = error ("init error: unknown ext:" ++ show e)+ in fromMaybe err (lookup e extMap)+ let getOptVal e = (asExtension e, GHC.xopt (toOpt e) df2)+ let defExts = map getOptVal supportedExtensions++ onState (\s -> s{defaultExts = defExts})++ reset++-- | Executes the interpreter. Returns @Left InterpreterError@ in case of error.+--+-- NB. In hint-0.7.0 and earlier, the underlying ghc was accidentally+-- overwriting certain signal handlers (SIGINT, SIGHUP, SIGTERM, SIGQUIT on+-- Posix systems, Ctrl-C handler on Windows).+runInterpreter :: (MonadIO m, MonadMask m)+ => InterpreterT m a+ -> m (Either InterpreterError a)+runInterpreter = runInterpreterWithArgs []++-- | Executes the interpreter, setting args passed in as though they+-- were command-line args. Returns @Left InterpreterError@ in case of+-- error.+runInterpreterWithArgs :: (MonadIO m, MonadMask m)+ => [String]+ -> InterpreterT m a+ -> m (Either InterpreterError a)+runInterpreterWithArgs args = runInterpreterWithArgsLibdir args GHC.Paths.libdir++runInterpreterWithArgsLibdir :: (MonadIO m, MonadMask m)+ => [String]+ -> String+ -> InterpreterT m a+ -> m (Either InterpreterError a)+runInterpreterWithArgsLibdir args libdir action =+ ifInterpreterNotRunning $+ do s <- newInterpreterSession `MC.catch` rethrowGhcException+ execute libdir s (initialize args >> action `finally` cleanSession)+ where rethrowGhcException = throwM . GhcException . showGhcEx+ newInterpreterSession = newSessionData ()+ cleanSession =+ do cleanPhantomModules++{-# NOINLINE uniqueToken #-}+uniqueToken :: MVar ()+uniqueToken = unsafePerformIO $ newMVar ()++ifInterpreterNotRunning :: (MonadIO m, MonadMask m) => m a -> m a+ifInterpreterNotRunning action =+ do maybe_token <- liftIO $ tryTakeMVar uniqueToken+ case maybe_token of+ Nothing -> throwM MultipleInstancesNotAllowed+ Just x -> action `finally` liftIO (putMVar uniqueToken x)++-- | The installed version of ghc is not thread-safe. This exception+-- is thrown whenever you try to execute @runInterpreter@ while another+-- instance is already running.+data MultipleInstancesNotAllowed = MultipleInstancesNotAllowed deriving Typeable++instance Exception MultipleInstancesNotAllowed++instance Show MultipleInstancesNotAllowed where+ show _ = "This version of GHC is not thread-safe," +++ "can't safely run two instances of the interpreter simultaneously"++initialState :: InterpreterState+initialState = St {+ activePhantoms = [],+ zombiePhantoms = [],+#if defined(NEED_PHANTOM_DIRECTORY)+ phantomDirectory = Nothing,+#endif+ hintSupportModule = error "No support module loaded!",+ importQualHackMod = Nothing,+ qualImports = [],+ defaultExts = error "defaultExts missing!",+ configuration = defaultConf+ }++newSessionData :: MonadIO m => a -> m (SessionData a)+newSessionData a =+ do initial_state <- liftIO $ newIORef initialState+ ghc_err_list_ref <- liftIO $ newIORef []+ return SessionData {+ internalState = initial_state,+ versionSpecific = a,+ ghcErrListRef = ghc_err_list_ref,+ ghcErrLogger = mkLogHandler ghc_err_list_ref+ }++mkLogHandler :: IORef [GhcError] -> GhcErrLogger+mkLogHandler r df _ _ src style msg =+ let renderErrMsg = GHC.showSDoc df+ errorEntry = mkGhcError renderErrMsg src style msg+ in modifyIORef r (errorEntry :)++mkGhcError :: (GHC.SDoc -> String) -> GHC.SrcSpan -> GHC.PprStyle -> GHC.Message -> GhcError+mkGhcError render src_span style msg = GhcError{errMsg = niceErrMsg}+ where niceErrMsg = render . GHC.withPprStyle style $+ GHC.mkLocMessage GHC.SevError 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+ liftIO $ atomicModifyIORef ref (\a -> (f a, a))+ --+ runGhc = runGhcImpl++instance (Monad m) => Applicative (InterpreterT m) where+ pure = return+ (<*>) = ap
+ src/Hint/Parsers.hs view
@@ -0,0 +1,67 @@+module Hint.Parsers where++import Prelude hiding (span)++import Hint.Base++import Control.Monad.Trans (liftIO)++import qualified Hint.GHC as GHC++data ParseResult = ParseOk | ParseError GHC.SrcSpan GHC.Message++parseExpr :: MonadInterpreter m => String -> m ParseResult+parseExpr = runParser GHC.parseStmt++parseType :: MonadInterpreter m => String -> m ParseResult+parseType = runParser GHC.parseType++runParser :: MonadInterpreter m => GHC.P a -> String -> m ParseResult+runParser parser expr =+ do dyn_fl <- runGhc GHC.getSessionDynFlags+ --+ buf <- (return . GHC.stringToStringBuffer) expr+ --+ -- ghc >= 7 panics if noSrcLoc is given+ let srcLoc = GHC.mkRealSrcLoc (GHC.fsLit "<hint>") 1 1+ let parse_res = GHC.unP parser (GHC.mkPState dyn_fl buf srcLoc)+ --+ case parse_res of+ GHC.POk{} -> return ParseOk+ --+#if __GLASGOW_HASKELL__ >= 804+ GHC.PFailed _ span err+#else+ GHC.PFailed span err+#endif+ -> return (ParseError span err)++failOnParseError :: MonadInterpreter m+ => (String -> m ParseResult)+ -> String+ -> m ()+failOnParseError parser expr = mayFail go+ where go = do parsed <- parser expr+ --+ -- If there was a parsing error,+ -- do the "standard" error reporting+ case parsed of+ ParseOk -> return (Just ())+ --+ ParseError span err ->+ do -- parsing failed, so we report it just as all+ -- other errors get reported....+ logger <- fromSession ghcErrLogger+ dflags <- runGhc GHC.getSessionDynFlags+ let logger' = logger dflags+ errStyle = GHC.defaultErrStyle dflags+ liftIO $ logger'+ GHC.NoReason+ GHC.SevError+ span+ errStyle+ err+ --+ -- behave like the rest of the GHC API functions+ -- do on error...+ return Nothing
+ src/Hint/Reflection.hs view
@@ -0,0 +1,67 @@+module Hint.Reflection (+ ModuleElem(..), Id, name, children,+ getModuleExports,+) where++import Data.List+import Data.Maybe++import Hint.Base+import qualified Hint.GHC as GHC++-- | An Id for a class, a type constructor, a data constructor, a binding, etc+type Id = String++data ModuleElem = Fun Id | Class Id [Id] | Data Id [Id]+ deriving (Read, Show, Eq)++name :: ModuleElem -> Id+name (Fun f) = f+name (Class c _) = c+name (Data d _) = d++children :: ModuleElem -> [Id]+children (Fun _) = []+children (Class _ ms) = ms+children (Data _ dcs) = dcs++-- | Gets an abstract representation of all the entities exported by the module.+-- It is similar to the @:browse@ command in GHCi.+getModuleExports :: MonadInterpreter m => ModuleName -> m [ModuleElem]+getModuleExports mn =+ do module_ <- findModule mn+ mod_info <- mayFail $ runGhc1 GHC.getModuleInfo module_+ exports <- mapM (runGhc1 GHC.lookupName) (GHC.modInfoExports mod_info)+ dflags <- runGhc GHC.getSessionDynFlags+ --+ return $ asModElemList dflags (catMaybes exports)++asModElemList :: GHC.DynFlags -> [GHC.TyThing] -> [ModuleElem]+asModElemList df xs = concat [+ cs',+ ts',+ ds \\ concatMap (map Fun . children) ts',+ fs \\ concatMap (map Fun . children) cs'+ ]+ where (cs,ts,ds,fs) =+ (+ [asModElem df c | c@(GHC.ATyCon c') <- xs, GHC.isClassTyCon c'],+ [asModElem df t | t@(GHC.ATyCon c') <- xs, (not . GHC.isClassTyCon) c'],+ [asModElem df d | d@(GHC.AConLike GHC.RealDataCon{}) <- xs],+ [asModElem df f | f@GHC.AnId{} <- xs]+ )+ cs' = [Class n $ filter (alsoIn fs) ms | Class n ms <- cs]+ ts' = [Data t $ filter (alsoIn ds) dcs | Data t dcs <- ts]+ alsoIn es = (`elem` map name es)++asModElem :: GHC.DynFlags -> GHC.TyThing -> ModuleElem+asModElem df (GHC.AnId f) = Fun $ getUnqualName df f+asModElem df (GHC.AConLike (GHC.RealDataCon dc)) = Fun $ getUnqualName df dc+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!"++getUnqualName :: GHC.NamedThing a => GHC.DynFlags -> a -> String+getUnqualName dfs = GHC.showSDocUnqual dfs . GHC.pprParenSymName
+ src/Hint/Typecheck.hs view
@@ -0,0 +1,84 @@+module Hint.Typecheck (+ typeOf, typeChecks, kindOf, normalizeType, onCompilationError, typeChecksWithDetails+) where++import Control.Monad.Catch++import Hint.Base+import Hint.Parsers+import Hint.Conversions++import qualified Hint.GHC as GHC++-- | Returns a string representation of the type of the expression.+typeOf :: MonadInterpreter m => String -> m String+typeOf expr =+ do -- First, make sure the expression has no syntax errors,+ -- for this is the only way we have to "intercept" this+ -- kind of errors+ failOnParseError parseExpr expr+ --+ ty <- mayFail $ runGhc1 exprType expr+ --+ typeToString ty++-- | Tests if the expression type checks.+--+-- NB. Be careful if there is `-fdefer-type-errors` involved.+-- Perhaps unsurprisingly, that can falsely make @typeChecks@ and @getType@+-- return @True@ and @Right _@ respectively.+typeChecks :: MonadInterpreter m => String -> m Bool+typeChecks expr = (typeOf expr >> return True)+ `catchIE`+ onCompilationError (\_ -> return False)++-- | Similar to @typeChecks@, but gives more information, e.g. the type errors.+typeChecksWithDetails :: MonadInterpreter m => String -> m (Either [GhcError] String)+typeChecksWithDetails expr = (Right <$> typeOf expr)+ `catchIE`+ onCompilationError (return . Left)++-- | Returns a string representation of the kind of the type expression.+kindOf :: MonadInterpreter m => String -> m String+kindOf type_expr =+ do -- First, make sure the expression has no syntax errors,+ -- for this is the only way we have to "intercept" this+ -- kind of errors+ failOnParseError parseType type_expr+ --+ (_, kind) <- mayFail $ runGhc1 typeKind type_expr+ --+ kindToString kind++-- | Returns a string representation of the normalized type expression.+-- This is what the @:kind!@ GHCi command prints after @=@.+normalizeType :: MonadInterpreter m => String -> m String+normalizeType type_expr =+ do -- First, make sure the expression has no syntax errors,+ -- for this is the only way we have to "intercept" this+ -- kind of errors+ failOnParseError parseType type_expr+ --+ (ty, _) <- mayFail $ runGhc1 typeKind type_expr+ --+ typeToString ty++-- add a bogus Maybe, in order to use it with mayFail+exprType :: GHC.GhcMonad m => String -> m (Maybe GHC.Type)+#if __GLASGOW_HASKELL__ < 802+exprType = fmap Just . GHC.exprType+#else+exprType = fmap Just . GHC.exprType GHC.TM_Inst+#endif++-- add a bogus Maybe, in order to use it with mayFail+typeKind :: GHC.GhcMonad m => String -> m (Maybe (GHC.Type, GHC.Kind))+typeKind = fmap Just . GHC.typeKind True++onCompilationError :: MonadInterpreter m+ => ([GhcError] -> m a)+ -> (InterpreterError -> m a)+onCompilationError recover interp_error+ = case interp_error of+ WontCompile errs -> recover errs+ otherErr -> throwM otherErr
+ src/Hint/Util.hs view
@@ -0,0 +1,27 @@+module Hint.Util where++import Data.Char++type Expr = String++-- @safeBndFor expr@ generates a name @e@ such that it does not+-- occur free in @expr@ and, thus, it is safe to write something+-- like @e = expr@ (otherwise, it will get accidentally bound).+-- This ought to do the trick: observe that @safeBndFor expr@+-- contains more digits than @expr@ and, thus, cannot occur inside+-- @expr@.+safeBndFor :: Expr -> String+safeBndFor expr = "e_1" ++ filter isDigit expr++partition :: (a -> Bool) -> [a] -> ([a], [a])+partition prop = foldr (select prop) ([],[])+ where select p x ~(ts,fs) | p x = (x:ts,fs)+ | otherwise = (ts, x:fs)++partitionEither :: [Either a b] -> ([a],[b])+partitionEither [] = ([],[])+partitionEither (Left a:xs) = let (ls,rs) = partitionEither xs in (a:ls,rs)+partitionEither (Right b:xs) = let (ls,rs) = partitionEither xs in (ls,b:rs)++quote :: String -> String+quote s = concat ["'", s, "'"]
+ src/Language/Haskell/Interpreter.hs view
@@ -0,0 +1,58 @@+-----------------------------------------------------------------------------+-- |+-- Module : Language.Haskell.Interpreter+-- License : BSD-style+--+-- Maintainer : mvdan@mvdan.cc+-- Stability : experimental+-- Portability : non-portable (GHC API)+--+-- A Haskell interpreter built on top of the GHC API+-----------------------------------------------------------------------------+module Language.Haskell.Interpreter(+ -- * The interpreter monad transformer+ MonadInterpreter(..), InterpreterT, Interpreter,+ -- ** Running the interpreter+ runInterpreter,+ -- ** Interpreter options+ Option, OptionVal((:=)),+ get, set,+ languageExtensions, availableExtensions, Extension(..),+ installedModulesInScope, searchPath,++ -- ** Context handling+ ModuleName, isModuleInterpreted,+ ModuleImport(..), ModuleQualification(..), ImportList(..),+ loadModules, getLoadedModules, setTopLevelModules,+ setImports, setImportsQ, setImportsF,+ reset,+ -- ** Module querying+ ModuleElem(..), Id, name, children,+ getModuleExports,+ -- ** Annotations+ -- In the snippets below we use \'LBRACE\' and \'RBRACE\'+ -- to mean \'{\' and \'}\' respectively. We cannot put the+ -- pragmas inline in the code since GHC scarfs them up.+ getModuleAnnotations, getValAnnotations,+ -- ** Type inference+ typeChecksWithDetails,+ typeOf, typeChecks, kindOf, normalizeType,+ -- ** Evaluation+ interpret, eval, runStmt,+ -- * Error handling+ InterpreterError(..), GhcError(..), MultipleInstancesNotAllowed(..),+ -- * Miscellaneous+ ghcVersion, parens,+ module Control.Monad.Trans+) where++import Hint.Base+import Hint.Annotations+import Hint.InterpreterT+import Hint.Configuration+import Hint.Context+import Hint.Reflection+import Hint.Typecheck+import Hint.Eval++import Control.Monad.Trans
+ src/Language/Haskell/Interpreter/Extension.hs view
@@ -0,0 +1,5 @@+module Language.Haskell.Interpreter.Extension (+ module Hint.Extension+) where++import Hint.Extension
+ src/Language/Haskell/Interpreter/Unsafe.hs view
@@ -0,0 +1,44 @@+module Language.Haskell.Interpreter.Unsafe (+ unsafeSetGhcOption, unsafeRunInterpreterWithArgs, unsafeRunInterpreterWithArgsLibdir,+ unsafeInterpret+) where++import Control.Monad.Trans+import Control.Monad.Catch++import Hint.Base+import Hint.Eval+import Hint.Configuration+import Hint.InterpreterT++-- | Set a GHC option for the current session,+-- eg. @unsafeSetGhcOption \"-XNoMonomorphismRestriction\"@.+--+-- Warning: Some options may interact badly with the Interpreter.+unsafeSetGhcOption :: MonadInterpreter m => String -> m ()+unsafeSetGhcOption = setGhcOption++-- | Executes the interpreter, setting the args as though they were+-- command-line args. In particular, this means args that have no+-- effect with :set in ghci might function properly from this+-- context.+--+-- Warning: Some options may interact badly with the Interpreter.+unsafeRunInterpreterWithArgs :: (MonadMask m, MonadIO m)+ => [String]+ -> InterpreterT m a+ -> m (Either InterpreterError a)+unsafeRunInterpreterWithArgs = runInterpreterWithArgs++-- | A variant of @unsafeRunInterpreterWithArgs@ which also lets you+-- specify the folder in which the GHC bootstrap libraries (base,+-- containers, etc.) can be found. This allows you to run hint on+-- a machine in which GHC is not installed.+--+-- A typical libdir value could be "/usr/lib/ghc-8.0.1/ghc-8.0.1".+unsafeRunInterpreterWithArgsLibdir :: (MonadIO m, MonadMask m)+ => [String]+ -> String+ -> InterpreterT m a+ -> m (Either InterpreterError a)+unsafeRunInterpreterWithArgsLibdir = runInterpreterWithArgsLibdir
+ unit-tests/run-unit-tests.hs view
@@ -0,0 +1,360 @@+module Main (main) where++import Prelude hiding (catch)++import Control.Exception.Extensible (ArithException(..), AsyncException(UserInterrupt))+import Control.Monad.Catch as MC++import Control.Monad (liftM, when, void, (>=>))++import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.MVar++import Data.IORef+import Data.Proxy++import System.IO+import System.FilePath+import System.Directory+import System.Exit+#if defined(mingw32_HOST_OS) || defined(__MINGW32__)+#else+import System.Posix.Signals+#endif++import Test.HUnit ((@?=), (@?))+import qualified Test.HUnit as HUnit++import Language.Haskell.Interpreter++test_reload_modified :: TestCase+test_reload_modified = TestCase "reload_modified" [mod_file] $ do+ liftIO $ writeFile mod_file mod_v1+ f_v1 <- get_f+ --+ liftIO $ writeFile mod_file mod_v2+ f_v2 <- get_f+ --+ liftIO $ (f_v1 5, f_v2 5) @?= (5, 6)+ --+ where mod_name = "TEST_ReloadModified"+ mod_file = mod_name ++ ".hs"+ --+ mod_v1 = unlines ["module " ++ mod_name,+ "where",+ "f :: Int -> Int",+ "f = id"]+ mod_v2 = unlines ["module " ++ mod_name,+ "where",+ "f :: Int -> Int",+ "f = (1 +)"]+ --+ get_f = do loadModules [mod_file]+ setTopLevelModules [mod_name]+ interpret (Proxy :: Proxy (Int -> Int)) "f"++test_lang_exts :: TestCase+test_lang_exts = TestCase "lang_exts" [mod_file] $ do+ liftIO $ writeFile mod_file "data T where T :: T"+ fails do_load @@? "first time, it shouldn't load"+ --+ set [languageExtensions := [GADTs]]+ succeeds do_load @@? "now, it should load"+ --+ set [languageExtensions := []]+ fails do_load @@? "it shouldn't load, again"+ --+ where mod_name = "TEST_LangExts"+ mod_file = mod_name ++ ".hs"+ --+ do_load = loadModules [mod_name]++test_work_in_main :: TestCase+test_work_in_main = TestCase "work_in_main" [mod_file] $ do+ liftIO $ writeFile mod_file "f = id"+ loadModules [mod_file]+ setTopLevelModules ["Main"]+ setImportsQ [("Prelude", Nothing),+ ("Data.Maybe", Just "Mb")]+ --+ typeOf "f $ (1 + 1 :: Int)" @@?= "Int"+ eval "f . Mb.fromJust $ Just [1,2]" @@?= "[1,2]"+ interpret Proxy "f $ 1 == 2" @@?= False+ --+ where mod_file = "TEST_WorkInMain.hs"++test_priv_syms_in_scope :: TestCase+test_priv_syms_in_scope = TestCase "private_syms_in_scope" [mod_file] $ do+ -- must set to True, otherwise won't work with+ -- ghc 6.8+ set [installedModulesInScope := True]+ liftIO $ writeFile mod_file mod_text+ loadModules [mod_file]+ setTopLevelModules ["T"]+ typeChecks "g" @@? "g is hidden"+ where mod_text = unlines ["module T(f) where", "f = g", "g = id"]+ mod_file = "TEST_PrivateSymbolsInScope.hs"++test_comments_in_expr :: TestCase+test_comments_in_expr = TestCase "comments_in_expr" [] $ do+ setImports ["Prelude"]+ let expr = "length $ concat [[1,2],[3]] -- bla"+ typeChecks expr @@? "comment on expression"+ _ <- eval expr+ _ <- interpret (Proxy :: Proxy Int) expr+ return ()++test_qual_import :: TestCase+test_qual_import = TestCase "qual_import" [] $ do+ setImportsQ [("Prelude", Nothing),+ ("Data.Map", Just "M")]+ typeChecks "null []" @@? "Unqual null"+ typeChecks "M.null M.empty" @@? "Qual null"++test_full_import :: TestCase+test_full_import = TestCase "full_import" [] $ do+ setImportsF [ ModuleImport "Prelude" (QualifiedAs Nothing) NoImportList+ , ModuleImport "Data.List" (QualifiedAs $ Just "List") $ ImportList ["null"]+ ]+ typeChecks "Prelude.null []" @@? "Qual prelude null"+ typeChecks "List.null []" @@? "Qual list null"++test_basic_eval :: TestCase+test_basic_eval = TestCase "basic_eval" [] $ eval "()" @@?= "()"++test_eval_layout :: TestCase+test_eval_layout = TestCase "eval_layout" [] $ eval layout_expr @@?= "10"+ where layout_expr = unlines ["let x = let y = 10",+ " in y",+ "in x"]++test_show_in_scope :: TestCase+test_show_in_scope = TestCase "show_in_scope" [] $ do+ setImports ["Prelude"]+ eval "show ([] :: String)" @@?= show (show "")++test_installed_not_in_scope :: TestCase+test_installed_not_in_scope = TestCase "installed_not_in_scope" [] $ do+ b <- get installedModulesInScope+ succeeds action @@?= b+ set [installedModulesInScope := False]+ fails action @@? "now must be out of scope"+ set [installedModulesInScope := True]+ succeeds action @@? "must be in scope again"+ where action = typeOf "Data.Map.singleton"++test_search_path :: TestCase+test_search_path =+ TestCase "search_path" files $ do+ liftIO setup+ fails (loadModules [mod_1]) @@? "mod_1 should not be in path (1)"+ fails (loadModules [mod_2]) @@? "mod_2 should not be in path (1)"+ --+ set [searchPath := [dir_1]]+ succeeds (loadModules [mod_1]) @@? "mod_1 should be in path (2)"+ fails (loadModules [mod_2]) @@? "mod_2 should not be in path (2)"+ --+ set [searchPath := [dir_2]]+ fails (loadModules [mod_1]) @@? "mod_1 should not be in path (3)"+ succeeds (loadModules [mod_2]) @@? "mod_2 should be in path (3)"+ --+ set [searchPath := [dir_1,dir_2]]+ succeeds (loadModules [mod_1]) @@? "mod_1 should be in path (4)"+ succeeds (loadModules [mod_2]) @@? "mod_2 should be in path (4)"+ where dir_1 = "search_path_test_dir_1"+ mod_1 = "M1"+ file_1 = dir_1 </> mod_1 <.> "hs"+ dir_2 = "search_path_test_dir_2"+ mod_2 = "M2"+ file_2 = dir_2 </> mod_2 <.> "hs"+ files = [file_1, file_2, dir_1, dir_2]+ setup = do createDirectory dir_1+ createDirectory dir_2+ writeFile file_1 $+ unlines ["module " ++ mod_1,+ "where",+ "x :: Int",+ "x = 42"]+ writeFile file_2 $+ unlines ["module " ++ mod_2,+ "where",+ "y :: Bool",+ "y = False"]++test_search_path_dot :: TestCase+test_search_path_dot =+ TestCase "search_path_dot" [mod_file, dir] $ do+ liftIO setup+ succeeds (loadModules [mod1]) @@? "mod1 must be initially in path"+ set [searchPath := [dir]]+ succeeds (loadModules [mod1]) @@? "mod1 must be still in path"+ --+ where dir = "search_path_dot_dir"+ mod1 = "M1"+ mod_file = mod1 <.> "hs"+ setup = do createDirectory dir+ writeFile mod_file $+ unlines ["x :: Int", "x = 42"]++test_catch :: TestCase+test_catch = TestCase "catch" [] $ do+ setImports ["Prelude"]+ succeeds (action `catch` handler) @@? "catch failed"+ where handler DivideByZero = return "catched"+ handler e = throwM e+ action = do s <- eval "1 `div` 0 :: Int"+ return $! s++test_only_one_instance :: TestCase+test_only_one_instance = TestCase "only_one_instance" [] $ liftIO $ do+ r <- newEmptyMVar+ let concurrent = runInterpreter (liftIO $ putMVar r False)+ `catch` \MultipleInstancesNotAllowed ->+ do liftIO $ putMVar r True+ return $ Right ()+ _ <- forkIO $ Control.Monad.void concurrent+ readMVar r @? "concurrent instance did not fail"++test_normalize_type :: TestCase+test_normalize_type = TestCase "normalize_type" [mod_file] $ do+ liftIO $ writeFile mod_file mod_text+ loadModules [mod_file]+ setTopLevelModules ["T"]+ normalizeType "Foo Int" @@?= "()"++ where mod_text = unlines ["{-# LANGUAGE TypeFamilies #-}"+ ,"module T where"+ ,"type family Foo x"+ ,"type instance Foo x = ()"]+ mod_file = "TEST_NormalizeType.hs"++-- earlier versions of hint were accidentally overwriting the signal handlers+-- for ^C and others.+--+-- note that hint was _not_ overwriting the signal handlers when the hint interpreter+-- was itself executed inside the ghci interpreter. for this reason, this test always+-- succeeds when executed from ghci and ghcid, regardless of whether the problematic+-- behaviour has been fixed or not.+test_signal_handlers :: IOTestCase+test_signal_handlers = IOTestCase "signal_handlers" [] $ \runInterp -> do+#if defined(mingw32_HOST_OS) || defined(__MINGW32__)+ runInterp $ do+ pure ()+#else+ signalDetectedRef <- newIORef False+ interruptDetectedRef <- newIORef False+ let detectSignal = writeIORef signalDetectedRef True+ detectInterrupt = writeIORef interruptDetectedRef True+ acquire = installHandler sigINT (Catch detectSignal) Nothing+ release handler = installHandler sigINT handler Nothing+ r <- bracket acquire release $ \_ -> do+ runInterp $ do+ liftIO $ do+ r <- try $ do+ raiseSignal sigINT+ threadDelay 1000000 -- will be interrupted by the above signal+ case r of+ Left UserInterrupt -> do+ -- hint is _still_ accidentally overwriting the signal handler :(+ detectInterrupt+ Left e -> do+ -- some other async exception, rethrow+ throwM e+ Right () ->+ return ()+ signalDetected <- readIORef signalDetectedRef+ signalDetected @?= True+ interruptDetected <- readIORef interruptDetectedRef+ interruptDetected @?= False+ return r+#endif++tests :: [TestCase]+tests = [test_reload_modified+ ,test_lang_exts+ ,test_work_in_main+ ,test_comments_in_expr+ ,test_qual_import+ ,test_full_import+ ,test_basic_eval+ ,test_eval_layout+ ,test_show_in_scope+ ,test_installed_not_in_scope+ ,test_priv_syms_in_scope+ ,test_search_path+ ,test_search_path_dot+ ,test_catch+ ,test_only_one_instance+ ,test_normalize_type+ ]++ioTests :: [IOTestCase]+ioTests = [test_signal_handlers+ ]++main :: IO ()+main = do -- run the tests...+ c1 <- runTests False tests+ c2 <- runIOTests False ioTests+ -- then run again, but with sandboxing on...+ c3 <- runTests True tests+ c4 <- runIOTests True ioTests+ --+ let failures = HUnit.errors c1 + HUnit.failures c1 ++ HUnit.errors c2 + HUnit.failures c2 ++ HUnit.errors c3 + HUnit.failures c3 ++ HUnit.errors c4 + HUnit.failures c4+ exit_code+ | failures > 0 = ExitFailure failures+ | otherwise = ExitSuccess+ exitWith exit_code+ -- `catch` (\_ -> exitWith (ExitFailure $ -1))++printInterpreterError :: InterpreterError -> IO ()+printInterpreterError = hPrint stderr++setSandbox :: Interpreter ()+setSandbox = set [installedModulesInScope := False]++(@@?) :: (HUnit.AssertionPredicable p, MonadIO m) => m p -> String -> m ()+p @@? msg = do b <- p; liftIO (b @? msg)++(@@?=) :: (Eq a, Show a, MonadIO m) => m a -> a -> m ()+m_a @@?= b = do a <- m_a; liftIO (a @?= b)++fails :: (MonadCatch m, MonadIO m) => m a -> m Bool+fails action = (action >> return False) `catchIE` (\_ -> return True)+ where+ catchIE :: MonadCatch m => m a -> (InterpreterError -> m a) -> m a+ catchIE = MC.catch++succeeds :: (MonadCatch m, MonadIO m) => m a -> m Bool+succeeds = liftM not . fails++data IOTestCase = IOTestCase String [FilePath] ((Interpreter () -> IO (Either InterpreterError ())) -> IO (Either InterpreterError ()))++runIOTests :: Bool -> [IOTestCase] -> IO HUnit.Counts+runIOTests sandboxed = HUnit.runTestTT . HUnit.TestList . map build+ where build (IOTestCase title tmps test) = HUnit.TestLabel title $+ HUnit.TestCase test_case+ where test_case = go `finally` clean_up+ clean_up = mapM_ removeIfExists tmps+ go = do r <- test (\body -> runInterpreter+ (when sandboxed setSandbox >> body))+ either (printInterpreterError >=> (fail . show))+ return r+ removeIfExists f = do existsF <- doesFileExist f+ if existsF+ then removeFile f+ else+ do existsD <- doesDirectoryExist f+ when existsD $+ removeDirectory f++data TestCase = TestCase String [FilePath] (Interpreter ())++runTests :: Bool -> [TestCase] -> IO HUnit.Counts+runTests sandboxed = runIOTests sandboxed . map toIOTestCase+ where+ toIOTestCase :: TestCase -> IOTestCase+ toIOTestCase (TestCase title tmps test) = IOTestCase title tmps ($ test)