hint-0.4.2.3/0000755000000000000000000000000012527106264011013 5ustar0000000000000000hint-0.4.2.3/AUTHORS0000644000000000000000000000045212527106264012064 0ustar0000000000000000Daniel Gorin Contributions from: Evan Laforge Gwern Branwen Jean Philippe Bernardy Austin Seipp Fernando Benavides Pasqualino Titto Assini Carl Howells Daniel Wagner Bryan O'Sullivan Conrad Parker Mark Wright Bertram Felgenhauer Samuel Gélineau Jens Petersen Corentin Dupont Nathaniel W. Filardo hint-0.4.2.3/CHANGELOG.markdown0000644000000000000000000000731012527106264014047 0ustar00000000000000000.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 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. 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 hint-0.4.2.3/hint.cabal0000644000000000000000000000735012527106264012746 0ustar0000000000000000name: hint version: 0.4.2.3 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: Daniel Gorin maintainer: jcpetruzza@gmail.com homepage: http://hub.darcs.net/jcpetruzza/hint cabal-version: >= 1.9.2 build-type: Simple extra-source-files: README AUTHORS CHANGELOG.markdown examples/example.hs examples/SomeModule.hs source-repository head type: darcs location: http://hub.darcs.net/jcpetruzza/hint Test-Suite unit-tests type: exitcode-stdio-1.0 hs-source-dirs: unit-tests main-is: run-unit-tests.hs build-depends: base < 5 ,hint ,HUnit==1.2.* ,directory ,filepath ,mtl ,extensible-exceptions ,exceptions Library build-depends: ghc >= 7.4.2, ghc-paths, mtl, filepath, extensible-exceptions, exceptions if impl(ghc >= 6.8) { build-depends: random, directory 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 } if !os(windows) { 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 } hs-source-dirs: src ghc-options: -Wall -O2 extensions: CPP GeneralizedNewtypeDeriving MultiParamTypeClasses DeriveDataTypeable MagicHash TypeSynonymInstances FlexibleInstances FlexibleContexts FunctionalDependencies KindSignatures Rank2Types ScopedTypeVariables ExistentialQuantification PatternGuards hint-0.4.2.3/LICENSE0000644000000000000000000000271312527106264012023 0ustar0000000000000000Copyright 2007, Daniel Gorin. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the name of the author 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.hint-0.4.2.3/README0000644000000000000000000000162612527106264011700 0ustar0000000000000000=== 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, esentially, a huge subset of the GHC API wrapped in a simpler API. === Documentation === The library cames with haddock documentation you can build (see above). Also, check examples/example.hs to see a simple but comprehensive example (it must be run from the examples directory, since it expects to find the SomeModule.hs file located there). === Contact === Bug-reports, questions, suggestions and patches are all welcome. To get a copy of the darcs repository: darcs get http://hub.darcs.net/jcpetruzza/hint If you report an issue, please send me an email as well, since otherwise I get no notifications... hint-0.4.2.3/Setup.lhs0000644000000000000000000000021212527106264012616 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > main :: IO () > main = defaultMainWithHooks defaultUserHooks hint-0.4.2.3/examples/0000755000000000000000000000000012527106264012631 5ustar0000000000000000hint-0.4.2.3/examples/example.hs0000644000000000000000000000440512527106264014623 0ustar0000000000000000import Control.Monad import Language.Haskell.Interpreter main :: IO () main = do r <- runInterpreter testHint case r of Left err -> printInterpreterError err Right () -> putStrLn "that's all folks" -- observe that Interpreter () is an alias for InterpreterT IO () testHint :: Interpreter () testHint = do say "Load SomeModule.hs" loadModules ["SomeModule.hs"] -- 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")] -- 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 -- say $ "Observe that f, g and h are defined in SomeModule.hs, " ++ "but f is not exported. Let's check it..." exports <- getModuleExports "SomeModule" say (show exports) -- say "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] a <- eval expr2 say (show a) -- say "Or we can interpret it as a proper, say, int value!" a_int <- interpret expr2 (as :: Int) say (show a_int) -- say "This works for any monomorphic type, even for function types" let expr3 = "\\(Just x) -> succ x" say $ "e.g. we interpret " ++ expr3 ++ " with type Maybe Int -> Int and apply it on Just 7" fun <- interpret expr3 (as :: Maybe Int -> Int) say . show $ fun (Just 7) -- say "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) -- 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) hint-0.4.2.3/examples/SomeModule.hs0000644000000000000000000000007112527106264015234 0ustar0000000000000000module SomeModule(g, h) where f = head g = f [f] h = fhint-0.4.2.3/src/0000755000000000000000000000000012527106264011602 5ustar0000000000000000hint-0.4.2.3/src/Hint/0000755000000000000000000000000012527106264012504 5ustar0000000000000000hint-0.4.2.3/src/Hint/Annotations.hs0000644000000000000000000000403412527106264015336 0ustar0000000000000000-- - extract annotations from modules etc. with the GHC API. -- - requires GHC >= 6.11 -- -- austin seipp module Hint.Annotations ( getModuleAnnotations -- :: (Data a, MonadInterpreter m) => a -> String -> m [a] , getValAnnotations -- :: (Data a, MonadInterpreter m) => a -> String -> m [a] ) where import Control.Monad import Data.Data import Annotations import Serialized import Hint.Base import HscTypes (hsc_mod_graph, ms_mod) import qualified Hint.GHC as GHC -- | Get the annotations associated with a particular module. -- -- For example, given: -- -- @ -- RBRACE-\# ANN module (1 :: Int) \#-LBRACE -- module SomeModule(g, h) where -- ... -- @ -- -- Then after using 'loadModule' to load SomeModule into scope: -- -- @ -- x <- getModuleAnnotations (as :: Int) "SomeModule" -- liftIO $ print x -- -- result is [1] -- @ getModuleAnnotations :: (Data a, MonadInterpreter m) => a -> String -> m [a] getModuleAnnotations _ x = do mods <- liftM hsc_mod_graph $ runGhc GHC.getSession let x' = filter ((==) x . GHC.moduleNameString . GHC.moduleName . ms_mod) mods v <- mapM (anns . ModuleTarget . ms_mod) x' return $ concat v -- | Get the annotations associated with a particular function -- -- For example, given: -- -- @ -- module SomeModule(g, h) where -- -- LBRACE-\# ANN g (Just 1 :: Maybe Int) \#-RBRACE -- g = f [f] -- -- LBRACE-\# ANN h (Just 2 :: Maybe Int) \#-RBRACE -- h = f -- @ -- -- Then after using 'loadModule' to bring SomeModule into scope: -- -- @ -- x <- liftM concat $ mapM (getValAnnotations (as :: Maybe Int)) [\"g\",\"h\"] -- liftIO $ print x -- -- result is [Just 2, Just 1] -- @ -- -- This can also work on data constructors and types with annotations. 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) hint-0.4.2.3/src/Hint/Base.hs0000644000000000000000000002002612527106264013712 0ustar0000000000000000module Hint.Base ( MonadInterpreter(..), RunGhc, -- GhcError(..), InterpreterError(..), mayFail, catchIE, -- InterpreterSession, SessionData(..), GhcErrLogger, InterpreterState(..), fromState, onState, InterpreterConfiguration(..), -- runGhc1, runGhc2, runGhc3, runGhc4, runGhc5, -- 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 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 -- -- * @610@ for GHC 6.10.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{active_phantoms :: [PhantomModule], zombie_phantoms :: [PhantomModule], hint_support_module :: PhantomModule, import_qual_hack_mod :: Maybe PhantomModule, qual_imports :: [(ModuleName, String)], defaultExts :: [(Extension,Bool)], -- R/O configuration :: InterpreterConfiguration} data InterpreterConfiguration = Conf { search_path :: [FilePath], language_exts :: [Extension], all_mods_in_scope :: Bool } #if __GLASGOW_HASKELL__ < 610 type InterpreterSession = SessionData GHC.Session adjust :: (a -> b -> c) -> (b -> a -> c) adjust f = flip f 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 type RunGhc1 m a b = (forall n.(MonadIO n, MonadMask n, Functor n) => a -> GHC.GhcT n b) -> (a -> m b) type RunGhc2 m a b c = (forall n.(MonadIO n, MonadMask n, Functor n) => a -> b -> GHC.GhcT n c) -> (a -> b -> m c) type RunGhc3 m a b c d = (forall n.(MonadIO n, MonadMask n, Functor n) => a -> b -> c -> GHC.GhcT n d) -> (a -> b -> c -> m d) type RunGhc4 m a b c d e = (forall n.(MonadIO n, MonadMask n, Functor n) => a -> b -> c -> d -> GHC.GhcT n e) -> (a -> b -> c -> d -> m e) type RunGhc5 m a b c d e f = (forall n.(MonadIO n, MonadMask n, Functor n) => a->b->c->d->e->GHC.GhcT n f) -> (a -> b -> c -> d -> e -> m f) #endif data SessionData a = SessionData { internalState :: IORef InterpreterState, versionSpecific :: a, ghcErrListRef :: IORef [GhcError], ghcErrLogger :: GhcErrLogger } -- 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 = do action `MC.catch` (\err -> case err of GhcException s -> throwM (buildEx s) _ -> throwM err) catchIE :: MonadInterpreter m => m a -> (InterpreterError -> m a) -> m a catchIE = MC.catch #if __GLASGOW_HASKELL__ < 704 type GhcErrLogger = GHC.Severity -> GHC.SrcSpan -> GHC.PprStyle -> GHC.Message -> IO () #else type GhcErrLogger = GHC.LogAction #endif -- | Module names are _not_ filepaths. type ModuleName = String runGhc1 :: MonadInterpreter m => RunGhc1 m a b runGhc1 f a = runGhc (adjust f a) runGhc2 :: MonadInterpreter m => RunGhc2 m a b c runGhc2 f a = runGhc1 (adjust f a) runGhc3 :: MonadInterpreter m => RunGhc3 m a b c d runGhc3 f a = runGhc2 (adjust f a) runGhc4 :: MonadInterpreter m => RunGhc4 m a b c d e runGhc4 f a = runGhc3 (adjust f a) runGhc5 :: MonadInterpreter m => RunGhc5 m a b c d e f runGhc5 f a = runGhc4 (adjust f a) -- ================ Handling the interpreter state ================= fromState :: MonadInterpreter m => (InterpreterState -> a) -> m a fromState f = do ref_st <- fromSession internalState liftIO $ f `fmap` readIORef ref_st 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, True) -> return a (Just _, False) -> fail $ "GHC returned a result but said: " ++ show es -- ================= 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 $ Compat.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} 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 _ -> throwM e) withDynFlags :: MonadInterpreter m => (GHC.DynFlags -> m a) -> m a withDynFlags action = do df <- runGhc GHC.getSessionDynFlags action df hint-0.4.2.3/src/Hint/Compat.hs0000644000000000000000000002004212527106264014261 0ustar0000000000000000{-# LANGUAGE NoMonomorphismRestriction #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} module Hint.Compat where #if __GLASGOW_HASKELL__ < 702 import Control.Monad.Trans (liftIO) #endif #if __GLASGOW_HASKELL__ >= 704 import Control.Monad (foldM, liftM) #endif import qualified Hint.GHC as GHC -- Kinds became a synonym for Type in GHC 6.8. We define this wrapper -- to be able to define a FromGhcRep instance for both versions newtype Kind = Kind GHC.Kind #if __GLASGOW_HASKELL__ >= 700 -- supportedLanguages :: [String] supportedExtensions = map f GHC.xFlags where #if (__GLASGOW_HASKELL__ >= 710) f = GHC.flagSpecName #elif (__GLASGOW_HASKELL__ < 702) || (__GLASGOW_HASKELL__ >= 704) f (e,_,_) = e #else f (e,_,_,_) = e #endif #if __GLASGOW_HASKELL__ < 702 -- setContext :: GHC.GhcMonad m => [GHC.Module] -> [GHC.Module] -> m () setContext xs = GHC.setContext xs . map (\y -> (y,Nothing)) getContext :: GHC.GhcMonad m => m ([GHC.Module], [GHC.Module]) getContext = fmap (\(as,bs) -> (as,map fst bs)) GHC.getContext #elif __GLASGOW_HASKELL__ < 704 -- Keep setContext/getContext unmodified for use where the results of getContext -- are simply restored by setContext, in which case we don't really care about the -- particular type of b. -- setContext :: GHC.GhcMonad m => [GHC.Module] -> [b] -> m () setContext = GHC.setContext -- getContext :: GHC.GhcMonad m => m ([GHC.Module], [b]) getContext = GHC.getContext #else setContext :: GHC.GhcMonad m => [GHC.Module] -> [GHC.ImportDecl GHC.RdrName] -> m () setContext ms ds = let ms' = map modToIIMod ms ds' = map GHC.IIDecl ds is = ms' ++ ds' in GHC.setContext is getContext :: GHC.GhcMonad m => m ([GHC.Module], [GHC.ImportDecl GHC.RdrName]) getContext = GHC.getContext >>= foldM f ([], []) where f :: (GHC.GhcMonad m) => ([GHC.Module], [GHC.ImportDecl GHC.RdrName]) -> GHC.InteractiveImport -> m ([GHC.Module], [GHC.ImportDecl GHC.RdrName]) f (ns, ds) i = case i of (GHC.IIDecl d) -> return (ns, (d:ds)) m@(GHC.IIModule _) -> do n <- iiModToMod m; return ((n:ns), ds) modToIIMod :: GHC.Module -> GHC.InteractiveImport iiModToMod :: GHC.GhcMonad m => GHC.InteractiveImport -> m GHC.Module #if __GLASGOW_HASKELL__ < 706 modToIIMod = GHC.IIModule iiModToMod (GHC.IIModule m) = return m #else modToIIMod = GHC.IIModule . GHC.moduleName iiModToMod (GHC.IIModule m) = GHC.findModule m Nothing #endif iiModToMod _ = error "iiModToMod!" #endif mkPState = GHC.mkPState #else -- supportedExtensions :: [String] supportedExtensions = GHC.supportedLanguages -- setContext :: GHC.GhcMonad m => [GHC.Module] -> [GHC.Module] -> m () -- i don't want to check the signature on every ghc version.... setContext = GHC.setContext getContext = GHC.getContext mkPState df buf loc = GHC.mkPState buf loc df #endif -- Explicitly-typed variants of getContext/setContext, for use where we modify -- or override the context. #if __GLASGOW_HASKELL__ < 702 setContextModules :: GHC.GhcMonad m => [GHC.Module] -> [GHC.Module] -> m () setContextModules = setContext getContextNames :: GHC.GhcMonad m => m([String], [String]) getContextNames = fmap (\(as,bs) -> (map name as, map name bs)) getContext where name = GHC.moduleNameString . GHC.moduleName #else setContextModules :: GHC.GhcMonad m => [GHC.Module] -> [GHC.Module] -> m () setContextModules as = setContext as . map (GHC.simpleImportDecl . GHC.moduleName) getContextNames :: GHC.GhcMonad m => m([String], [String]) getContextNames = fmap (\(as,bs) -> (map name as, map decl bs)) getContext where name = GHC.moduleNameString . GHC.moduleName decl = GHC.moduleNameString . GHC.unLoc . GHC.ideclName #endif #if __GLASGOW_HASKELL__ < 702 mkSrcLoc = GHC.mkSrcLoc stringToStringBuffer = liftIO . GHC.stringToStringBuffer #else mkSrcLoc = GHC.mkRealSrcLoc stringToStringBuffer = return . GHC.stringToStringBuffer #endif #if __GLASGOW_HASKELL__ >= 610 configureDynFlags :: GHC.DynFlags -> GHC.DynFlags configureDynFlags dflags = dflags{GHC.ghcMode = GHC.CompManager, GHC.hscTarget = GHC.HscInterpreted, GHC.ghcLink = GHC.LinkInMemory, GHC.verbosity = 0} parseDynamicFlags :: GHC.GhcMonad m => GHC.DynFlags -> [String] -> m (GHC.DynFlags, [String]) parseDynamicFlags d = fmap firstTwo . GHC.parseDynamicFlags d . map GHC.noLoc where firstTwo (a,b,_) = (a, map GHC.unLoc b) fileTarget :: FilePath -> GHC.Target fileTarget f = GHC.Target (GHC.TargetFile f $ Just next_phase) True Nothing where next_phase = GHC.Cpp GHC.HsSrcFile targetId :: GHC.Target -> GHC.TargetId targetId = GHC.targetId guessTarget :: GHC.GhcMonad m => String -> Maybe GHC.Phase -> m GHC.Target guessTarget = GHC.guessTarget -- add a bogus Maybe, in order to use it with mayFail compileExpr :: GHC.GhcMonad m => String -> m (Maybe GHC.HValue) compileExpr = fmap Just . GHC.compileExpr -- add a bogus Maybe, in order to use it with mayFail exprType :: GHC.GhcMonad m => String -> m (Maybe GHC.Type) exprType = fmap Just . GHC.exprType -- add a bogus Maybe, in order to use it with mayFail #if __GLASGOW_HASKELL__ < 704 typeKind :: GHC.GhcMonad m => String -> m (Maybe GHC.Kind) typeKind = fmap Just . GHC.typeKind #else typeKind :: GHC.GhcMonad m => String -> m (Maybe GHC.Kind) typeKind = fmap Just . (liftM snd) . (GHC.typeKind True) #endif #else -- add a bogus session parameter, in order to use it with runGhc2 parseDynamicFlags :: GHC.Session -> GHC.DynFlags -> [String] -> IO (GHC.DynFlags, [String]) parseDynamicFlags = const GHC.parseDynamicFlags fileTarget :: FilePath -> GHC.Target fileTarget f = GHC.Target (GHC.TargetFile f $ Just next_phase) Nothing where next_phase = GHC.Cpp GHC.HsSrcFile targetId :: GHC.Target -> GHC.TargetId targetId (GHC.Target _id _) = _id -- add a bogus session parameter, in order to use it with runGhc2 guessTarget :: GHC.Session -> String -> Maybe GHC.Phase -> IO GHC.Target guessTarget = const GHC.guessTarget compileExpr :: GHC.Session -> String -> IO (Maybe GHC.HValue) compileExpr = GHC.compileExpr exprType :: GHC.Session -> String -> IO (Maybe GHC.Type) exprType = GHC.exprType typeKind :: GHC.Session -> String -> IO (Maybe GHC.Kind) typeKind = GHC.typeKind #endif #if __GLASGOW_HASKELL__ >= 608 #if __GLASGOW_HASKELL__ < 610 -- 6.08 only newSession :: FilePath -> IO GHC.Session newSession ghc_root = GHC.newSession (Just ghc_root) configureDynFlags :: GHC.DynFlags -> GHC.DynFlags configureDynFlags dflags = dflags{GHC.ghcMode = GHC.CompManager, GHC.hscTarget = GHC.HscInterpreted, GHC.ghcLink = GHC.LinkInMemory} #endif #if __GLASGOW_HASKELL__ < 701 -- 6.08 - 7.0.4 pprType :: GHC.Type -> (GHC.PprStyle -> GHC.Doc) pprType = GHC.pprTypeForUser False -- False means drop explicit foralls pprKind :: GHC.Kind -> (GHC.PprStyle -> GHC.Doc) pprKind = pprType #else -- 7.2.1 and above pprType :: GHC.Type -> GHC.SDoc #if __GLASGOW_HASKELL__ < 708 pprType = GHC.pprTypeForUser False -- False means drop explicit foralls #else pprType = GHC.pprTypeForUser #endif pprKind :: GHC.Kind -> GHC.SDoc pprKind = pprType #endif #elif __GLASGOW_HASKELL__ >= 606 -- 6.6 only newSession :: FilePath -> IO GHC.Session newSession ghc_root = GHC.newSession GHC.Interactive (Just ghc_root) configureDynFlags :: GHC.DynFlags -> GHC.DynFlags configureDynFlags dflags = dflags{GHC.hscTarget = GHC.HscInterpreted} pprType :: GHC.Type -> (GHC.PprStyle -> GHC.Doc) pprType = GHC.ppr . GHC.dropForAlls pprKind :: GHC.Kind -> (GHC.PprStyle -> GHC.Doc) pprKind = GHC.ppr #endif #if __GLASGOW_HASKELL__ >= 706 showSDoc = GHC.showSDoc showSDocForUser = GHC.showSDocForUser showSDocUnqual = GHC.showSDocUnqual #else -- starting from ghc 7.6, they started to receive a DynFlags argument (sigh) showSDoc _ = GHC.showSDoc showSDocForUser _ = GHC.showSDocForUser showSDocUnqual _ = GHC.showSDocUnqual #endif #if __GLASGOW_HASKELL__ >= 706 mkLocMessage = GHC.mkLocMessage GHC.SevError #else mkLocMessage = GHC.mkLocMessage #endif hint-0.4.2.3/src/Hint/CompatPlatform.hs0000644000000000000000000000145312527106264015773 0ustar0000000000000000#if defined(mingw32_HOST_OS) || defined(__MINGW32__) {-# LANGUAGE ForeignFunctionInterface #-} #endif module Hint.CompatPlatform ( getPID ) where import Control.Applicative #if defined(mingw32_HOST_OS) || defined(__MINGW32__) import Data.Word #else 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 -- 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 :: IO Int getPID = fromIntegral <$> c_GetCurrentProcessId #else getPID :: IO Int getPID = fromIntegral <$> getProcessID #endif hint-0.4.2.3/src/Hint/Configuration.hs0000644000000000000000000001670012527106264015653 0ustar0000000000000000module Hint.Configuration ( setGhcOption, setGhcOptions, defaultConf, fromConf, onConf, get, set, Option, OptionVal(..), languageExtensions, availableExtensions, glasgowExtensions, Extension(..), installedModulesInScope, setUseLanguageExtensions, setInstalledModsAreInScopeQualified, searchPath ) where import Control.Monad import Control.Monad.Catch import Data.Char import Data.List ( intersect, intercalate ) import qualified Hint.GHC as GHC import qualified Hint.Compat as Compat 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 Compat.parseDynamicFlags old_flags opts when (not . 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 { language_exts = [], all_mods_in_scope = False, search_path = ["."] } -- | 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{language_exts = es} -- getter = fromConf language_exts -- 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 -- | 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 -- (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 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" -- | 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 search_path setter p = do onConf $ \c -> c{search_path = p} setGhcOption $ "-i" -- clear the old path setGhcOption $ "-i" ++ intercalate ":" p 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)} {-# 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] hint-0.4.2.3/src/Hint/Context.hs0000644000000000000000000003673512527106264014502 0ustar0000000000000000module Hint.Context ( ModuleName, isModuleInterpreted, loadModules, getLoadedModules, setTopLevelModules, setImports, setImportsQ, reset, PhantomModule(..), ModuleText, addPhantomModule, removePhantomModule, getPhantomModules, cleanPhantomModules, allModulesInContext, onAnEmptyContext, support_String, support_show ) where import Prelude hiding ( mod ) import Data.Char import Data.List import Control.Monad ( liftM, filterM, when, guard ) import Control.Monad.Trans ( liftIO ) import Control.Monad.Catch import Hint.Base import Hint.Util ( (>=>) ) -- compat version import Hint.Conversions import qualified Hint.Util as Util import qualified Hint.Compat as Compat import qualified Hint.CompatPlatform as Compat import qualified Hint.GHC as GHC import System.Random import System.FilePath import System.Directory 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 <- liftIO getTemporaryDirectory -- return PhantomModule{pm_name = mod_name, pm_file = tmp_dir nums} allModulesInContext :: MonadInterpreter m => m ([ModuleName], [ModuleName]) allModulesInContext = runGhc Compat.getContextNames addPhantomModule :: MonadInterpreter m => (ModuleName -> ModuleText) -> m PhantomModule addPhantomModule mod_text = do pm <- newPhantomModule let t = Compat.fileTarget (pm_file pm) m = GHC.mkModuleName (pm_name pm) -- liftIO $ writeFile (pm_file pm) (mod_text $ pm_name pm) -- onState (\s -> s{active_phantoms = pm:active_phantoms s}) mayFail (do -- GHC.load will remove all the modules from scope, so first -- we save the context... (old_top, old_imps) <- runGhc Compat.getContext -- runGhc1 GHC.addTarget t res <- runGhc1 GHC.load (GHC.LoadUpTo m) -- if isSucceeded res then do runGhc2 Compat.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 $ pm_name pm safeToRemove <- if isLoaded then do -- take it out of scope mod <- findModule (pm_name pm) (mods, imps) <- runGhc Compat.getContext let mods' = filter (mod /=) mods runGhc2 Compat.setContext mods' imps -- let isNotPhantom = isPhantomModule . moduleToString >=> return . not null `liftM` filterM isNotPhantom mods' else return True -- let file_name = pm_file pm runGhc1 GHC.removeTarget (Compat.targetId $ Compat.fileTarget file_name) -- onState (\s -> s{active_phantoms = filter (pm /=) $ active_phantoms s}) -- if safeToRemove then do mayFail $ do res <- runGhc1 GHC.load GHC.LoadAllTargets return $ guard (isSucceeded res) >> Just () liftIO $ removeFile (pm_file pm) else do onState (\s -> s{zombie_phantoms = pm:zombie_phantoms s}) return () -- 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 return (active, zombie) isPhantomModule :: MonadInterpreter m => ModuleName -> m Bool isPhantomModule mn = do (as,zs) <- getPhantomModules return $ mn `elem` (map pm_name $ 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 = do mayFail $ do targets <- mapM (\f->runGhc2 Compat.guessTarget f Nothing) fs -- runGhc1 GHC.setTargets targets res <- runGhc1 GHC.load GHC.LoadAllTargets -- loading the targets removes the support module reinstallSupportModule return $ guard (isSucceeded res) >> Just () -- | 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 pm_name $ 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) 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 when (not . 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) -- let mod_is_interpr = runGhc1 GHC.moduleIsInterpreted not_interpreted <- filterM (liftM not . mod_is_interpr) ms_mods when (not . 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. -- If you have a list of modules to be used qualified and another list -- unqualified, then you need to do something like -- -- > setImportsQ ((zip unqualified $ repeat Nothing) ++ qualifieds) setImports :: MonadInterpreter m => [ModuleName] -> m () setImports ms = setImportsQ $ zip ms (repeat Nothing) -- | 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 = 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 maybe (return ()) removePhantomModule old_qual_hack_mod -- new_pm <- if ( not $ null quals ) then do new_pm <- addPhantomModule $ \mod_name -> unlines $ ("module " ++ mod_name ++ " where ") : ["import qualified " ++ m ++ " as " ++ n | (m,n) <- quals] onState (\s -> s{import_qual_hack_mod = Just new_pm}) return $ Just new_pm else return Nothing -- pm <- maybe (return []) (findModule . pm_name >=> return . return) new_pm (old_top_level, _) <- runGhc Compat.getContext let new_top_level = pm ++ old_top_level runGhc2 Compat.setContextModules new_top_level unqual_mods -- onState (\s ->s{qual_imports = quals}) -- | '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 Compat.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 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) -- | 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{hint_support_module = mod}) mod' <- findModule (pm_name mod) runGhc2 Compat.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 hint_support_module 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 support_String :: MonadInterpreter m => m String support_String = do mod_name <- fromState (pm_name . hint_support_module) 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] -- SHOULD WE CALL THIS WHEN MODULES ARE LOADED / UNLOADED? -- foreign import ccall "revertCAFs" rts_revertCAFs :: IO () hint-0.4.2.3/src/Hint/Conversions.hs0000644000000000000000000000177712527106264015364 0ustar0000000000000000module 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) kindToString :: MonadInterpreter m => Compat.Kind -> m String kindToString (Compat.Kind k) = withDynFlags $ \df -> return $ Compat.showSDoc df (Compat.pprKind k) -- ---------------- Modules -------------------------- moduleToString :: GHC.Module -> String moduleToString = GHC.moduleNameString . GHC.moduleName -- ---------------- Misc ----------------------------- isSucceeded :: GHC.SuccessFlag -> Bool isSucceeded GHC.Succeeded = True isSucceeded GHC.Failed = False hint-0.4.2.3/src/Hint/Eval.hs0000644000000000000000000000476612527106264013744 0ustar0000000000000000module Hint.Eval ( interpret, as, infer, eval ,parens) where import qualified GHC.Exts ( unsafeCoerce# ) import Data.Typeable hiding ( typeOf ) import qualified Data.Typeable ( typeOf ) 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: -- -- * @interpret \"head [True,False]\" (as :: Bool)@ -- -- * @interpret \"head $ map show [True,False]\" infer >>= flip interpret (as :: Bool)@ as, infer :: Typeable a => a as = undefined infer = undefined -- | Evaluates an expression, given a witness for its monomorphic type. interpret :: (MonadInterpreter m, Typeable a) => String -> a -> m a interpret expr wit = unsafeInterpret expr (show $ Data.Typeable.typeOf wit) 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) -- | @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 let show_expr = unwords [in_scope_show, parens expr] unsafeInterpret show_expr in_scope_String -- | 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 hint-0.4.2.3/src/Hint/Extension.hs0000644000000000000000000001362112527106264015017 0ustar0000000000000000-- this module was automatically generated. do not edit! -- edit util/mk_extensions_mod.hs instead module Hint.Extension (Extension(..), knownExtensions, availableExtensions, asExtension) where import Hint.Compat as Compat -- | List of the extensions known by the interpreter. availableExtensions :: [Extension] availableExtensions = map asExtension Compat.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 | NoMonomorphismRestriction | FunctionalDependencies | Rank2Types | RankNTypes | PolymorphicComponents | ExistentialQuantification | ScopedTypeVariables | ImplicitParams | FlexibleContexts | FlexibleInstances | EmptyDataDecls | CPP | KindSignatures | BangPatterns | TypeSynonymInstances | TemplateHaskell | ForeignFunctionInterface | Arrows | Generics | NoImplicitPrelude | NamedFieldPuns | PatternGuards | GeneralizedNewtypeDeriving | ExtensibleRecords | RestrictedTypeSynonyms | HereDocuments | MagicHash | TypeFamilies | StandaloneDeriving | UnicodeSyntax | PatternSignatures | UnliftedFFITypes | LiberalTypeSynonyms | TypeOperators | RecordWildCards | RecordPuns | DisambiguateRecordFields | OverloadedStrings | GADTs | NoMonoPatBinds | RelaxedPolyRec | ExtendedDefaultRules | UnboxedTuples | DeriveDataTypeable | ConstrainedClassMethods | PackageImports | ImpredicativeTypes | NewQualifiedOperators | PostfixOperators | QuasiQuotes | TransformListComp | ViewPatterns | XmlSyntax | RegularPatterns | TupleSections | GHCForeignImportPrim | NPlusKPatterns | DoAndIfThenElse | RebindableSyntax | ExplicitForAll | DatatypeContexts | MonoLocalBinds | DeriveFunctor | DeriveTraversable | DeriveFoldable | UnknownExtension String deriving (Eq, Show, Read) knownExtensions :: [Extension] knownExtensions = [OverlappingInstances, UndecidableInstances, IncoherentInstances, DoRec, RecursiveDo, ParallelListComp, MultiParamTypeClasses, NoMonomorphismRestriction, FunctionalDependencies, Rank2Types, RankNTypes, PolymorphicComponents, ExistentialQuantification, ScopedTypeVariables, ImplicitParams, FlexibleContexts, FlexibleInstances, EmptyDataDecls, CPP, KindSignatures, BangPatterns, TypeSynonymInstances, TemplateHaskell, ForeignFunctionInterface, Arrows, Generics, NoImplicitPrelude, NamedFieldPuns, PatternGuards, GeneralizedNewtypeDeriving, ExtensibleRecords, RestrictedTypeSynonyms, HereDocuments, MagicHash, TypeFamilies, StandaloneDeriving, UnicodeSyntax, PatternSignatures, UnliftedFFITypes, LiberalTypeSynonyms, TypeOperators, RecordWildCards, RecordPuns, DisambiguateRecordFields, OverloadedStrings, GADTs, NoMonoPatBinds, RelaxedPolyRec, ExtendedDefaultRules, UnboxedTuples, DeriveDataTypeable, ConstrainedClassMethods, PackageImports, ImpredicativeTypes, NewQualifiedOperators, PostfixOperators, QuasiQuotes, TransformListComp, ViewPatterns, XmlSyntax, RegularPatterns, TupleSections, GHCForeignImportPrim, NPlusKPatterns, DoAndIfThenElse, RebindableSyntax, ExplicitForAll, DatatypeContexts, MonoLocalBinds, DeriveFunctor, DeriveTraversable, DeriveFoldable ] hint-0.4.2.3/src/Hint/GHC.hs0000644000000000000000000000417312527106264013446 0ustar0000000000000000module Hint.GHC ( module GHC, module Outputable, module ErrUtils, Message, module Pretty, module DriverPhases, module StringBuffer, module Lexer, module Parser, module DynFlags, module FastString, #if __GLASGOW_HASKELL__ >= 610 module Control.Monad.Ghc, module HscTypes, module Bag, #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 #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 Pretty ( Doc ) import DriverPhases ( Phase(Cpp), HscSource(HsSrcFile) ) import StringBuffer ( stringToStringBuffer ) import Lexer ( P(..), ParseResult(..), mkPState ) import Parser ( parseStmt, parseType ) import FastString ( fsLit ) #if __GLASGOW_HASKELL__ >= 710 import DynFlags ( supportedLanguagesAndExtensions, xFlags, xopt, FlagSpec(..) ) #elif __GLASGOW_HASKELL__ >= 700 import DynFlags ( supportedLanguagesAndExtensions, xFlags, xopt ) #else import DynFlags ( supportedLanguages ) #endif #if __GLASGOW_HASKELL__ >=704 import DynFlags ( 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 hint-0.4.2.3/src/Hint/InterpreterT.hs0000644000000000000000000002232612527106264015474 0ustar0000000000000000module Hint.InterpreterT ( InterpreterT, Interpreter, runInterpreter, runInterpreterWithArgs, MultipleInstancesNotAllowed(..) ) where import Prelude import Hint.Base import Hint.Context import Hint.Configuration import Hint.Extension import Control.Applicative 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.List import Data.Maybe #if __GLASGOW_HASKELL__ < 610 import Data.Dynamic #endif import qualified GHC.Paths import qualified Hint.GHC as GHC import qualified Hint.Compat as Compat type Interpreter = InterpreterT IO #if __GLASGOW_HASKELL__ < 610 newtype InterpreterT m a = InterpreterT{ unInterpreterT :: ReaderT InterpreterSession (ErrorT InterpreterError m) a} deriving (Functor, Monad, MonadIO, MonadThrow,MonadCatch,MonadMask) execute :: (MonadIO m, MonadMask m, Functor m) => InterpreterSession -> InterpreterT m a -> m (Either InterpreterError a) execute s = runErrorT . flip runReaderT s . unInterpreterT instance MonadTrans InterpreterT where lift = InterpreterT . lift . lift runGhc_impl :: (MonadIO m, MonadThrow m, MonadMask m, Functor m) => RunGhc (InterpreterT m) a runGhc_impl f = do s <- fromSession versionSpecific -- i.e. the ghc session r <- liftIO $ f' s either throwError return r where f' = tryJust (fmap (GhcException . showGhcEx) . ghcExceptions) . f ghcExceptions (DynException e) = fromDynamic e ghcExceptions _ = Nothing #else -- ghc >= 6.10 newtype InterpreterT m a = InterpreterT{ unInterpreterT :: ReaderT InterpreterSession (GHC.GhcT m) a} deriving (Functor, Monad, MonadIO, MonadThrow, MonadCatch, MonadMask) execute :: (MonadIO m, MonadMask m, Functor m) => InterpreterSession -> InterpreterT m a -> m (Either InterpreterError a) execute s = try . GHC.runGhcT (Just GHC.Paths.libdir) . flip runReaderT s . unInterpreterT instance MonadTrans InterpreterT where lift = InterpreterT . lift . lift runGhc_impl :: (MonadIO m, MonadThrow m, MonadMask m, Functor m) => RunGhc (InterpreterT m) a runGhc_impl a = 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 #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 "" -- ================= 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 = Compat.configureDynFlags df0 (df2, extra) <- runGhc2 Compat.parseDynamicFlags df1 args when (not . null $ extra) $ throwM $ UnknownError (concat [ "flags: '" , intercalate " " 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 -- (SIGINT, SIGHUP, SIGTERM, SIGQUIT on Posix systems, Ctrl-C handler on Windows). -- In future versions of hint, this might be controlled by the user. runInterpreter :: (MonadIO m, MonadMask m, Functor m) => 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, Functor m) => [String] -> InterpreterT m a -> m (Either InterpreterError a) 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 () 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 {active_phantoms = [], zombie_phantoms = [], hint_support_module = error "No support module loaded!", import_qual_hack_mod = Nothing, qual_imports = [], defaultExts = error "defaultExts missing!", configuration = defaultConf} 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 = #if __GLASGOW_HASKELL__ < 706 \_ src style msg -> let renderErrMsg = Compat.showSDoc () #else \df _ src style msg -> let renderErrMsg = Compat.showSDoc df #endif errorEntry = mkGhcError renderErrMsg src style msg in modifyIORef r (errorEntry :) mkGhcError :: (GHC.SDoc -> String) -> GHC.SrcSpan -> GHC.PprStyle -> GHC.Message -> GhcError mkGhcError render src_span style msg = GhcError{errMsg = niceErrMsg} where niceErrMsg = render . GHC.withPprStyle style $ Compat.mkLocMessage src_span msg -- The MonadInterpreter instance instance (MonadIO m, MonadMask m, Functor m) => MonadInterpreter (InterpreterT m) where fromSession f = InterpreterT $ fmap f ask -- modifySessionRef target f = do ref <- fromSession target old_val <- liftIO $ atomicModifyIORef ref (\a -> (f a, a)) return old_val -- runGhc a = runGhc_impl a instance (Monad m, Applicative m) => Applicative (InterpreterT m) where pure = return (<*>) = ap hint-0.4.2.3/src/Hint/Parsers.hs0000644000000000000000000000466512527106264014472 0ustar0000000000000000module Hint.Parsers where import Prelude hiding(span) import Hint.Base import qualified Hint.Compat as Compat 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 <- Compat.stringToStringBuffer expr -- -- ghc >= 7 panics if noSrcLoc is given let srcLoc = Compat.mkSrcLoc (GHC.fsLit "") 1 1 let parse_res = GHC.unP parser (Compat.mkPState dyn_fl buf srcLoc) -- case parse_res of GHC.POk{} -> return ParseOk -- GHC.PFailed span err -> 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 #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 err -- -- behave like the rest of the GHC API functions -- do on error... return Nothing hint-0.4.2.3/src/Hint/Reflection.hs0000644000000000000000000000635512527106264015143 0ustar0000000000000000module Hint.Reflection ( ModuleElem(..), Id, name, children, getModuleExports, ) 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 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) = ( #if __GLASGOW_HASKELL__ < 704 [asModElem df c | c@GHC.AClass{} <- xs], [asModElem df t | t@GHC.ATyCon{} <- xs], #else [asModElem df c | c@(GHC.ATyCon c') <- xs, GHC.isClassTyCon c'], [asModElem df t | t@(GHC.ATyCon c') <- xs, (not . GHC.isClassTyCon) c'], #endif #if __GLASGOW_HASKELL__ < 708 [asModElem df d | d@GHC.ADataCon{} <- xs], #else [asModElem df d | d@(GHC.AConLike (GHC.RealDataCon{})) <- xs], #endif [asModElem df f | f@GHC.AnId{} <- xs] ) cs' = [Class n $ filter (alsoIn fs) ms | Class n ms <- cs] ts' = [Data t $ filter (alsoIn ds) dcs | Data t dcs <- ts] alsoIn es = (`elem` (map name es)) asModElem :: GHC.DynFlags -> GHC.TyThing -> ModuleElem asModElem df (GHC.AnId f) = Fun $ getUnqualName df f #if __GLASGOW_HASKELL__ < 708 asModElem df (GHC.ADataCon dc) = Fun $ getUnqualName df dc #else asModElem df (GHC.AConLike (GHC.RealDataCon dc)) = Fun $ getUnqualName df dc #endif #if __GLASGOW_HASKELL__ < 704 asModElem df(GHC.ATyCon tc) = Data (getUnqualName df tc) (map (getUnqualName df) $ GHC.tyConDataCons tc) asModElem df (GHC.AClass c) = Class (getUnqualName df c) (map (getUnqualName df) $ GHC.classMethods c) #else asModElem df (GHC.ATyCon tc) = if GHC.isClassTyCon tc then Class (getUnqualName df tc) (map (getUnqualName df) $ (GHC.classMethods . fromJust . GHC.tyConClass_maybe) tc) else Data (getUnqualName df tc) (map (getUnqualName df) $ GHC.tyConDataCons tc) asModElem _ _ = error "asModElem: can't happen!" #endif getUnqualName :: GHC.NamedThing a => GHC.DynFlags -> a -> String getUnqualName dfs = Compat.showSDocUnqual dfs . GHC.pprParenSymName hint-0.4.2.3/src/Hint/Sandbox.hs0000644000000000000000000000712112527106264014437 0ustar0000000000000000module 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 hint-0.4.2.3/src/Hint/SignalHandlers.hs0000644000000000000000000000200112527106264015727 0ustar0000000000000000module 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 hint-0.4.2.3/src/Hint/Typecheck.hs0000644000000000000000000000403412527106264014760 0ustar0000000000000000module Hint.Typecheck ( typeOf, typeChecks, kindOf, typeOf_unsandboxed, typeChecks_unsandboxed ) 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 = do -- First, make sure the expression has no syntax errors, -- for this is the only way we have to "intercept" this -- kind of errors failOnParseError parseExpr expr -- ty <- mayFail $ runGhc1 Compat.exprType expr -- typeToString ty -- | 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) `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) onCompilationError :: MonadInterpreter m => ([GhcError] -> m a) -> (InterpreterError -> m a) onCompilationError recover = \interp_error -> case interp_error of WontCompile errs -> recover errs otherErr -> throwM otherErr hint-0.4.2.3/src/Hint/Typecheck.hs-boot0000644000000000000000000000020312527106264015713 0ustar0000000000000000module Hint.Typecheck where import Hint.Base (MonadInterpreter) typeChecks_unsandboxed :: MonadInterpreter m => String -> m Bool hint-0.4.2.3/src/Hint/Util.hs0000644000000000000000000000205112527106264013753 0ustar0000000000000000module 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 xs = foldr (select prop) ([],[]) xs 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) infixr 1 >=> (>=>) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c) f >=> g = \x -> f x >>= g quote :: String -> String quote s = concat ["'", s, "'"] hint-0.4.2.3/src/Language/0000755000000000000000000000000012527106264013325 5ustar0000000000000000hint-0.4.2.3/src/Language/Haskell/0000755000000000000000000000000012527106264014710 5ustar0000000000000000hint-0.4.2.3/src/Language/Haskell/Interpreter.hs0000644000000000000000000000376612527106264017563 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.Interpreter -- License : BSD-style -- -- Maintainer : jcpetruzza@gmail.com -- 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, glasgowExtensions, Extension(..), installedModulesInScope, searchPath, setUseLanguageExtensions, setInstalledModsAreInScopeQualified, -- ** Context handling ModuleName, isModuleInterpreted, loadModules, getLoadedModules, setTopLevelModules, setImports, setImportsQ, reset, -- ** Module querying ModuleElem(..), Id, name, children, getModuleExports, #if __GLASGOW_HASKELL__ >= 611 -- ** Anotations -- | Please note below that annotations are an experimental -- feature in GHC HEAD. -- 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 interpret, as, infer, eval, -- * Error handling InterpreterError(..), GhcError(..), MultipleInstancesNotAllowed(..), -- * Miscellaneous ghcVersion,parens, 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 import Hint.Reflection import Hint.Typecheck import Hint.Eval import Control.Monad.Trans hint-0.4.2.3/src/Language/Haskell/Interpreter/0000755000000000000000000000000012527106264017213 5ustar0000000000000000hint-0.4.2.3/src/Language/Haskell/Interpreter/Extension.hs0000644000000000000000000000014612527106264021524 0ustar0000000000000000module Language.Haskell.Interpreter.Extension ( module Hint.Extension ) where import Hint.Extension hint-0.4.2.3/src/Language/Haskell/Interpreter/GHC.hs0000644000000000000000000000064512527106264020155 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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 hint-0.4.2.3/src/Language/Haskell/Interpreter/Unsafe.hs0000644000000000000000000000206412527106264020772 0ustar0000000000000000module Language.Haskell.Interpreter.Unsafe ( unsafeSetGhcOption, unsafeRunInterpreterWithArgs ) where import Control.Monad.Trans import Control.Monad.Catch import Hint.Base 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, Functor m) => [String] -> InterpreterT m a -> m (Either InterpreterError a) unsafeRunInterpreterWithArgs = runInterpreterWithArgs hint-0.4.2.3/src/Language/Haskell/Interpreter/GHC/0000755000000000000000000000000012527106264017614 5ustar0000000000000000hint-0.4.2.3/src/Language/Haskell/Interpreter/GHC/Unsafe.hs0000644000000000000000000000070112527106264021367 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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 hint-0.4.2.3/unit-tests/0000755000000000000000000000000012527106264013132 5ustar0000000000000000hint-0.4.2.3/unit-tests/run-unit-tests.hs0000644000000000000000000002642412527106264016417 0ustar0000000000000000module Main ( main ) where import Prelude hiding ( catch ) import Control.Exception.Extensible ( ArithException(..) ) import Control.Monad.Catch as MC import Control.Monad ( liftM, when ) import Control.Concurrent ( forkIO ) import Control.Concurrent.MVar import System.IO import System.FilePath import System.Directory import System.Exit 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] r <- interpret "f" (as :: Int -> Int) return r 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 "f $ 1 == 2" infer @@?= 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 expr (as :: Int) 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" return () test_basic_eval :: TestCase test_basic_eval = TestCase "basic_eval" [] $ do eval "()" @@?= "()" test_eval_layout :: TestCase test_eval_layout = TestCase "eval_layout" [] $ do eval layout_expr @@?= "10" where layout_expr = unlines $ ["let x = let y = 10", " in y", "in x"] test_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" [] $ do liftIO $ do r <- newEmptyMVar let concurrent = runInterpreter (liftIO $ putMVar r False) `catch` \MultipleInstancesNotAllowed -> do liftIO $ putMVar r True return $ Right () _ <- forkIO $ concurrent >> return () readMVar r @? "concurrent instance did not fail" tests :: [TestCase] tests = [test_reload_modified ,test_lang_exts ,test_work_in_main ,test_comments_in_expr ,test_qual_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 ] main :: IO () main = do -- run the tests... c <- runTests False tests -- then run again, but with sandboxing on... c' <- runTests True tests -- let failures = HUnit.errors c + HUnit.failures c + HUnit.errors c' + HUnit.failures c' exit_code | failures > 0 = ExitFailure failures | otherwise = ExitSuccess exitWith exit_code -- `catch` (\_ -> exitWith (ExitFailure $ -1)) printInterpreterError :: InterpreterError -> IO () printInterpreterError = hPutStrLn stderr . show setSandbox :: Interpreter () setSandbox = set [installedModulesInScope := False] (>=>) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c) f >=> g = \a -> f a >>= g (@@?) :: (HUnit.AssertionPredicable p, MonadIO m) => m p -> String -> m () p @@? msg = do b <- p; liftIO (b @? msg) (@@?=) :: (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 TestCase = TestCase String [FilePath] (Interpreter ()) runTests :: Bool -> [TestCase] -> IO HUnit.Counts runTests sandboxed = HUnit.runTestTT . HUnit.TestList . map build where build (TestCase title tmps test) = HUnit.TestLabel title $ HUnit.TestCase test_case where test_case = go `finally` clean_up clean_up = mapM_ removeIfExists tmps go = do r <- runInterpreter (when sandboxed setSandbox >> test) either (printInterpreterError >=> (fail . show)) return r removeIfExists f = do existsF <- doesFileExist f if existsF then removeFile f else do existsD <- doesDirectoryExist f when existsD $ removeDirectory f