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