hint-0.6.0/0000755000000000000000000000000012725023006010642 5ustar0000000000000000hint-0.6.0/LICENSE0000644000000000000000000000272212725023006011652 0ustar0000000000000000Copyright (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. hint-0.6.0/Setup.hs0000644000000000000000000000005612725023006012277 0ustar0000000000000000import Distribution.Simple main = defaultMain hint-0.6.0/hint.cabal0000644000000000000000000000511312725023006012570 0ustar0000000000000000name: hint version: 0.6.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: mvdan@mvdan.cc homepage: https://github.com/mvdan/hint cabal-version: >= 1.9.2 build-type: Simple extra-source-files: README.md AUTHORS CHANGELOG.md examples/example.hs examples/SomeModule.hs source-repository head type: git location: https://github.com/mvdan/hint Test-Suite unit-tests type: exitcode-stdio-1.0 hs-source-dirs: unit-tests main-is: run-unit-tests.hs build-depends: base == 4.*, hint, HUnit, directory, filepath, extensible-exceptions, exceptions Library build-depends: base == 4.*, ghc >= 7.6 && < 8.2, ghc-paths, mtl, filepath, exceptions, random, directory if !os(windows) { build-depends: unix >= 2.2.0.0 } exposed-modules: Language.Haskell.Interpreter Language.Haskell.Interpreter.Extension Language.Haskell.Interpreter.Unsafe other-modules: Hint.GHC Hint.Base Hint.InterpreterT Hint.Compat Hint.CompatPlatform Hint.Configuration Hint.Extension Hint.Context Hint.Conversions Hint.Eval Hint.Parsers Hint.Reflection Hint.Typecheck Hint.Util Hint.Annotations Control.Monad.Ghc hs-source-dirs: src ghc-options: -Wall extensions: CPP GeneralizedNewtypeDeriving DeriveDataTypeable MagicHash FunctionalDependencies Rank2Types ScopedTypeVariables ExistentialQuantification hint-0.6.0/README.md0000644000000000000000000000127412725023006012125 0ustar0000000000000000# hint [![Build Status](https://travis-ci.org/mvdan/hint.svg?branch=master)](https://travis-ci.org/mvdan/hint) [![Hackage](https://img.shields.io/hackage/v/hint.svg)](https://hackage.haskell.org/package/hint) This library defines an Interpreter monad. It allows to load Haskell modules, browse them, type-check and evaluate strings with Haskell expressions and even coerce them into values. The library is thread-safe and type-safe (even the coercion of expressions to values). It is, essentially, a huge subset of the GHC API wrapped in a simpler API. ### Example Check [example.hs](examples/example.hs) to see a simple but comprehensive example (it must be run from the `examples` directory). hint-0.6.0/AUTHORS0000644000000000000000000000062112725023006011711 0ustar0000000000000000# Please keep the list sorted. Austin Seipp Bertram Felgenhauer Bryan O'Sullivan Carl Howells Conrad Parker Corentin Dupont Daniel Gorin Daniel Martí Daniel Wagner Evan Laforge Fernando Benavides Gwern Branwen Jean Philippe Bernardy Jens Petersen Mark Wright Nathaniel W. Filardo Pasqualino Titto Assini Rob Zinkov Samuel Gélineau Sid Kapur hint-0.6.0/CHANGELOG.md0000644000000000000000000001040612725023006012454 0ustar0000000000000000### 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 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.6.0/src/0000755000000000000000000000000012725023006011431 5ustar0000000000000000hint-0.6.0/src/Language/0000755000000000000000000000000012725023006013154 5ustar0000000000000000hint-0.6.0/src/Language/Haskell/0000755000000000000000000000000012725023006014537 5ustar0000000000000000hint-0.6.0/src/Language/Haskell/Interpreter.hs0000644000000000000000000000335612725023006017405 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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, loadModules, getLoadedModules, setTopLevelModules, setImports, setImportsQ, 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 typeOf, typeChecks, kindOf, -- ** Evaluation interpret, as, infer, eval, -- * 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 hint-0.6.0/src/Language/Haskell/Interpreter/0000755000000000000000000000000012725023006017042 5ustar0000000000000000hint-0.6.0/src/Language/Haskell/Interpreter/Extension.hs0000644000000000000000000000015312725023006021351 0ustar0000000000000000module Language.Haskell.Interpreter.Extension ( module Hint.Extension ) where import Hint.Extension hint-0.6.0/src/Language/Haskell/Interpreter/Unsafe.hs0000644000000000000000000000365512725023006020630 0ustar0000000000000000module 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 #if __GLASGOW_HASKELL__ < 800 , Functor m #endif ) => [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 would be "/opt/ghc/7.10.3/lib/ghc-7.10.3". unsafeRunInterpreterWithArgsLibdir :: (MonadIO m, MonadMask m #if __GLASGOW_HASKELL__ < 800 , Functor m #endif ) => [String] -> String -> InterpreterT m a -> m (Either InterpreterError a) unsafeRunInterpreterWithArgsLibdir = runInterpreterWithArgsLibdir hint-0.6.0/src/Hint/0000755000000000000000000000000012725023006012333 5ustar0000000000000000hint-0.6.0/src/Hint/GHC.hs0000644000000000000000000000204212725023006013266 0ustar0000000000000000module Hint.GHC ( Message, module X ) where import GHC as X hiding (Phase, GhcT, runGhcT) import Control.Monad.Ghc as X (GhcT, runGhcT) import HscTypes as X (SourceError, srcErrorMessages, GhcApiError) 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) #if __GLASGOW_HASKELL__ >= 710 import DynFlags as X (xFlags, xopt, LogAction, FlagSpec(..)) #else import DynFlags as X (xFlags, xopt, LogAction) #endif import PprTyThing as X (pprTypeForUser) import SrcLoc as X (mkRealSrcLoc) #if __GLASGOW_HASKELL__ >= 708 import ConLike as X (ConLike(RealDataCon)) #endif type Message = MsgDoc hint-0.6.0/src/Hint/Base.hs0000644000000000000000000001534712725023006013553 0ustar0000000000000000module Hint.Base ( MonadInterpreter(..), RunGhc, GhcError(..), InterpreterError(..), mayFail, catchIE, InterpreterSession, SessionData(..), GhcErrLogger, InterpreterState(..), fromState, onState, InterpreterConfiguration(..), 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 Hint.GHC as GHC #if MIN_VERSION_base(4,8,0) import qualified Data.List #endif import Hint.Extension -- | Version of the underlying ghc api. Values are: -- -- * @708@ for GHC 7.8.x -- -- * @710@ for GHC 7.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 { activePhantoms :: [PhantomModule], zombiePhantoms :: [PhantomModule], hintSupportModule :: PhantomModule, importQualHackMod :: Maybe PhantomModule, qualImports :: [(ModuleName, String)], defaultExts :: [(Extension, Bool)], -- R/O configuration :: InterpreterConfiguration } data InterpreterConfiguration = Conf { searchFilePath :: [FilePath], languageExts :: [Extension], allModsInScope :: Bool } type InterpreterSession = SessionData () instance Exception InterpreterError #if MIN_VERSION_base(4,8,0) 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 #endif type RunGhc m a = #if __GLASGOW_HASKELL__ >= 800 (forall n.(MonadIO n, MonadMask n) => GHC.GhcT n a) #else (forall n.(MonadIO n, MonadMask n, Functor n) => GHC.GhcT n a) #endif -> m a type RunGhc1 m a b = #if __GLASGOW_HASKELL__ >= 800 (forall n.(MonadIO n, MonadMask n) => a -> GHC.GhcT n b) #else (forall n.(MonadIO n, MonadMask n, Functor n) => a -> GHC.GhcT n b) #endif -> (a -> m b) type RunGhc2 m a b c = #if __GLASGOW_HASKELL__ >= 800 (forall n.(MonadIO n, MonadMask n) => a -> b -> GHC.GhcT n c) #else (forall n.(MonadIO n, MonadMask n, Functor n) => a -> b -> GHC.GhcT n c) #endif -> (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 _ -> throwM e) withDynFlags :: MonadInterpreter m => (GHC.DynFlags -> m a) -> m a withDynFlags action = do df <- runGhc GHC.getSessionDynFlags action df hint-0.6.0/src/Hint/InterpreterT.hs0000644000000000000000000002014512725023006015320 0ustar0000000000000000module 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 import qualified Hint.Compat as Compat 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 #if __GLASGOW_HASKELL__ < 800 , Functor m #endif ) => 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 #if __GLASGOW_HASKELL__ < 800 , MonadThrow m, Functor m #endif ) => 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 = Compat.configureDynFlags df0 (df2, extra) <- runGhc2 Compat.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} #if __GLASGOW_HASKELL__ >= 710 let extMap = map (\fs -> (GHC.flagSpecName fs, GHC.flagSpecFlag fs)) GHC.xFlags #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 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 #if __GLASGOW_HASKELL__ < 800 , Functor m #endif ) => 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 #if __GLASGOW_HASKELL__ < 800 , Functor m #endif ) => [String] -> InterpreterT m a -> m (Either InterpreterError a) runInterpreterWithArgs args = runInterpreterWithArgsLibdir args GHC.Paths.libdir runInterpreterWithArgsLibdir :: (MonadIO m, MonadMask m #if __GLASGOW_HASKELL__ < 800 , Functor m #endif ) => [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 #if __GLASGOW_HASKELL__ < 800 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 { activePhantoms = [], zombiePhantoms = [], 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 #if __GLASGOW_HASKELL__ >= 800 mkLogHandler r df _ _ src style msg = #else mkLogHandler r df _ src style msg = #endif 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 #if __GLASGOW_HASKELL__ >= 800 instance (Monad m) => Applicative (InterpreterT m) where #else instance (Monad m, Applicative m) => Applicative (InterpreterT m) where #endif pure = return (<*>) = ap hint-0.6.0/src/Hint/Compat.hs0000644000000000000000000000215112725023006014111 0ustar0000000000000000module Hint.Compat where 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 supportedExtensions :: [String] supportedExtensions = map f GHC.xFlags where #if (__GLASGOW_HASKELL__ >= 710) f = GHC.flagSpecName #else f (e,_,_) = e #endif 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) pprType :: GHC.Type -> GHC.SDoc #if __GLASGOW_HASKELL__ < 708 pprType = GHC.pprTypeForUser False -- False means drop explicit foralls #else pprType = GHC.pprTypeForUser #endif hint-0.6.0/src/Hint/CompatPlatform.hs0000644000000000000000000000143312725023006015620 0ustar0000000000000000#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 hint-0.6.0/src/Hint/Configuration.hs0000644000000000000000000001077012725023006015503 0ustar0000000000000000module Hint.Configuration ( setGhcOption, setGhcOptions, defaultConf, get, set, Option, OptionVal(..), languageExtensions, availableExtensions, Extension(..), installedModulesInScope, searchPath ) where import Control.Monad import Control.Monad.Catch import Data.Char import Data.List (intercalate) import qualified Hint.GHC as GHC import qualified Hint.Compat as Compat import Hint.Base import Hint.Util (quote) import Hint.Extension setGhcOptions :: MonadInterpreter m => [String] -> m () setGhcOptions opts = do old_flags <- runGhc GHC.getSessionDynFlags (new_flags,not_parsed) <- runGhc2 Compat.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 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)} hint-0.6.0/src/Hint/Extension.hs0000644000000000000000000004241212725023006014646 0ustar0000000000000000-- this module was automatically generated. do not edit! -- edit util/mk_extensions_mod.hs instead module Hint.Extension ( Extension(..), 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 | 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 | 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 | 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, 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 ] hint-0.6.0/src/Hint/Context.hs0000644000000000000000000004047412725023006014324 0ustar0000000000000000module Hint.Context ( isModuleInterpreted, loadModules, getLoadedModules, setTopLevelModules, setImports, setImportsQ, reset, PhantomModule(..), cleanPhantomModules, supportString, supportShow ) where import Prelude hiding (mod) import Data.Char 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.Util as Util 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{pmName = mod_name, pmFile = tmp_dir nums} allModulesInContext :: MonadInterpreter m => m ([ModuleName], [ModuleName]) allModulesInContext = runGhc getContextNames 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 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.RdrName] -> 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 () 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) 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' 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 importQualHackMod maybe (return ()) removePhantomModule old_qual_hack_mod -- new_pm <- if not $ null quals then do new_pm <- addPhantomModule $ \mod_name -> unlines $ ("module " ++ mod_name ++ " where ") : ["import qualified " ++ m ++ " as " ++ n | (m,n) <- quals] onState (\s -> s{importQualHackMod = Just new_pm}) return $ Just new_pm else return Nothing -- 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 unqual_mods -- onState (\s ->s{qualImports = 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 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) -- | 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 () hint-0.6.0/src/Hint/Conversions.hs0000644000000000000000000000175612725023006015210 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 $ GHC.showSDocForUser df unqual (Compat.pprType t) kindToString :: MonadInterpreter m => Compat.Kind -> m String kindToString (Compat.Kind k) = withDynFlags $ \df -> return $ GHC.showSDoc df (Compat.pprType 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.6.0/src/Hint/Eval.hs0000644000000000000000000000507112725023006013561 0ustar0000000000000000module Hint.Eval ( interpret, as, infer, unsafeInterpret, 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.Util import qualified Hint.GHC as GHC -- | 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 = 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 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.6.0/src/Hint/Parsers.hs0000644000000000000000000000471112725023006014311 0ustar0000000000000000module Hint.Parsers where import Prelude hiding (span) import Hint.Base import Control.Monad.Trans (liftIO) import qualified Hint.GHC as GHC #if __GLASGOW_HASKELL__ >= 800 import qualified DynFlags as GHC #endif 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 "") 1 1 let parse_res = GHC.unP parser (GHC.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 dflags <- runGhc GHC.getSessionDynFlags let logger' = logger dflags errStyle = GHC.defaultErrStyle dflags liftIO $ logger' #if __GLASGOW_HASKELL__ >= 800 GHC.NoReason #endif GHC.SevError span errStyle err -- -- behave like the rest of the GHC API functions -- do on error... return Nothing hint-0.6.0/src/Hint/Reflection.hs0000644000000000000000000000531012725023006014760 0ustar0000000000000000module 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'], #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 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 hint-0.6.0/src/Hint/Typecheck.hs0000644000000000000000000000363312725023006014613 0ustar0000000000000000module Hint.Typecheck ( typeOf, typeChecks, kindOf, ) where import Control.Monad.Catch import Hint.Base import Hint.Parsers import Hint.Conversions import qualified Hint.Compat as Compat import qualified Hint.GHC as GHC -- | Returns a string representation of the type of the expression. typeOf :: MonadInterpreter m => String -> m String typeOf 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. typeChecks :: MonadInterpreter m => String -> m Bool typeChecks expr = (typeOf expr >> return True) `catchIE` onCompilationError (\_ -> return False) -- | Returns a string representation of the kind of the type expression. kindOf :: MonadInterpreter m => String -> m String kindOf 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 (Compat.Kind kind) -- 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 typeKind :: GHC.GhcMonad m => String -> m (Maybe GHC.Kind) typeKind = fmap (Just . snd) . 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 hint-0.6.0/src/Hint/Util.hs0000644000000000000000000000167712725023006013617 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 = 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, "'"] hint-0.6.0/src/Hint/Annotations.hs0000644000000000000000000000176112725023006015171 0ustar0000000000000000module Hint.Annotations ( getModuleAnnotations, getValAnnotations ) 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. 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. 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.6.0/src/Control/0000755000000000000000000000000012725023006013051 5ustar0000000000000000hint-0.6.0/src/Control/Monad/0000755000000000000000000000000012725023006014107 5ustar0000000000000000hint-0.6.0/src/Control/Monad/Ghc.hs0000644000000000000000000000505612725023006015152 0ustar0000000000000000module Control.Monad.Ghc ( GhcT, runGhcT ) where import Control.Applicative import Prelude import Control.Monad import Control.Monad.Trans import qualified Control.Monad.Trans as MTL import Control.Monad.Catch import qualified GHC (runGhcT) import qualified MonadUtils as GHC import qualified Exception as GHC import qualified GhcMonad as GHC import qualified DynFlags as GHC newtype GhcT m a = GhcT { unGhcT :: GHC.GhcT (MTLAdapter m) a } deriving (Functor, Monad, GHC.HasDynFlags) instance (Functor m, Monad m) => Applicative (GhcT m) where pure = return (<*>) = ap #if __GLASGOW_HASKELL__ >= 800 runGhcT :: (MonadIO m, MonadMask m) => Maybe FilePath -> GhcT m a -> m a #else runGhcT :: (Functor m, MonadIO m, MonadCatch m, MonadMask m) => Maybe FilePath -> GhcT m a -> m a #endif runGhcT f = unMTLA . GHC.runGhcT f . unGhcT instance MTL.MonadTrans GhcT where lift = GhcT . GHC.liftGhcT . MTLAdapter instance MTL.MonadIO m => MTL.MonadIO (GhcT m) where liftIO = GhcT . GHC.liftIO #if __GLASGOW_HASKELL__ < 708 -- ghc started using transformers at some point instance MTL.MonadIO m => GHC.MonadIO (GhcT m) where liftIO = MTL.liftIO #endif instance MonadCatch m => MonadThrow (GhcT m) where throwM = lift . throwM instance (MonadIO m, MonadCatch m, MonadMask m) => MonadCatch (GhcT m) where m `catch` f = GhcT (unGhcT m `GHC.gcatch` (unGhcT . f)) instance (MonadIO m, MonadMask m) => MonadMask (GhcT m) where mask f = wrap $ \s -> mask $ \io_restore -> unwrap (f $ \m -> (wrap $ \s' -> io_restore (unwrap m s'))) s where wrap g = GhcT $ GHC.GhcT $ \s -> MTLAdapter (g s) unwrap m = unMTLA . GHC.unGhcT (unGhcT m) uninterruptibleMask = mask instance (MonadIO m, MonadCatch m, MonadMask m) => GHC.ExceptionMonad (GhcT m) where gcatch = catch gmask f = mask (\x -> f x) instance (Functor m, MonadIO m, MonadCatch m, MonadMask m) => GHC.GhcMonad (GhcT m) where getSession = GhcT GHC.getSession setSession = GhcT . GHC.setSession -- | We use the 'MTLAdapter' to convert between similar classes -- like 'MTL'''s 'MonadIO' and 'GHC'''s 'MonadIO'. newtype MTLAdapter m a = MTLAdapter {unMTLA :: m a} deriving (Functor, Applicative, Monad) instance MTL.MonadIO m => GHC.MonadIO (MTLAdapter m) where liftIO = MTLAdapter . MTL.liftIO instance (MonadIO m, MonadCatch m, MonadMask m) => GHC.ExceptionMonad (MTLAdapter m) where m `gcatch` f = MTLAdapter $ unMTLA m `catch` (unMTLA . f) gmask io = MTLAdapter $ mask (\f -> unMTLA $ io (MTLAdapter . f . unMTLA)) hint-0.6.0/unit-tests/0000755000000000000000000000000012725023006012761 5ustar0000000000000000hint-0.6.0/unit-tests/run-unit-tests.hs0000644000000000000000000002603012725023006016237 0ustar0000000000000000module Main (main) where import Prelude hiding (catch) import Control.Exception.Extensible (ArithException(..)) import Control.Monad.Catch as MC import Control.Monad (liftM, when, void, (>=>)) 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] interpret "f" (as :: Int -> Int) test_lang_exts :: TestCase test_lang_exts = TestCase "lang_exts" [mod_file] $ do liftIO $ writeFile mod_file "data T where T :: T" 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" 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" 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 = 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 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 hint-0.6.0/examples/0000755000000000000000000000000012725023006012460 5ustar0000000000000000hint-0.6.0/examples/example.hs0000644000000000000000000000470412725023006014454 0ustar0000000000000000import 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 hint-0.6.0/examples/SomeModule.hs0000644000000000000000000000007112725023006015063 0ustar0000000000000000module SomeModule(g, h) where f = head g = f [f] h = f