hint 0.2.2 → 0.2.4
raw patch · 22 files changed
+1059/−796 lines, 22 filesdep +directorydep +filepathdep +ghc-pathsdep ~basedep ~ghcsetup-changed
Dependencies added: directory, filepath, ghc-paths, random, utf8-string
Dependency ranges changed: base, ghc
Files
- Changes +4/−0
- Setup.lhs +3/−62
- hint.cabal +61/−39
- src/Hint/Base.hs +239/−0
- src/Hint/Compat.hs +52/−0
- src/Hint/Configuration.hs +53/−0
- src/Hint/Context.hs +125/−0
- src/Hint/Conversions.hs +64/−0
- src/Hint/Eval.hs +62/−0
- src/Hint/Parsers.hs +35/−0
- src/Hint/Reflection.hs +74/−0
- src/Hint/Sandbox.hs +139/−0
- src/Hint/Typecheck.hs +69/−0
- src/Hint/Typecheck.hs-boot +5/−0
- src/Language/Haskell/Interpreter/GHC.hs +7/−370
- src/Language/Haskell/Interpreter/GHC/Base.hs +0/−167
- src/Language/Haskell/Interpreter/GHC/Compat.hs +0/−52
- src/Language/Haskell/Interpreter/GHC/Conversions.hs +0/−50
- src/Language/Haskell/Interpreter/GHC/LibDir.hs +0/−7
- src/Language/Haskell/Interpreter/GHC/Parsers.hs +0/−36
- src/Language/Haskell/Interpreter/GHC/Unsafe.hs +2/−1
- unit-tests/run-unit-tests.hs +65/−12
Changes view
@@ -1,3 +1,7 @@+- ver 0.2.4+ * setInstalledModsAreInScopeQualified added+ * Now depends on ghc-paths (no longer needs a custom cabal script)+ - ver 0.2.2 * setOptimizations added * Module Language.Haskell.Interpreter.GHC.Unsafe added
Setup.lhs view
@@ -1,64 +1,5 @@-#! /usr/bin/env runhaskell-+#!/usr/bin/env runhaskell+> module Main where > import Distribution.Simple-> import Distribution.Simple.Program-> import Distribution.Simple.LocalBuildInfo hiding ( libdir )-> import Distribution.Simple.Setup--> import Distribution.Verbosity-> import Distribution.Simple.Utils ( warn, notice, die )--> import System.IO ( writeFile )--> import System.FilePath ( (</>) )-> import System.Directory ( doesDirectoryExist )--> import Control.Monad ( liftM )- > main :: IO ()-> main = defaultMainWithHooks myHooks-> where myHooks = let h = defaultUserHooks-> in h{postConf = myPostConf (postConf h)}-> myPostConf oldHook = \a f p lbi -> do let verb = configVerbose f-> saveGhcLibdir verb lbi-> oldHook a f p lbi--> saveGhcLibdir :: Verbosity -> LocalBuildInfo -> IO ()-> saveGhcLibdir verbosity lbi =-> do libdir <- removeTrailingEOL `liftM`-> queryGHC verbosity lbi ["--print-libdir"]-> is_ok <- doesDirectoryExist libdir-> if not is_ok-> then warn verbosity $ concat ["Suspicious ghc libdir: '",-> libdir,-> "'"]-> else notice verbosity $ concat ["Using ghc libdir: '",-> libdir,-> "'"]-> ---> let mod_dir = "Language" </> "Haskell" </> "Interpreter" </> "GHC"-> let ghc_libdir_module_file = "src" </> mod_dir </> "LibDir.hs"-> writeFile ghc_libdir_module_file $ mkGhcLibdirModule libdir--> queryGHC :: Verbosity -> LocalBuildInfo -> [String] -> IO String-> queryGHC verbosity lbi args =-> do ghc <- maybe (die "GHC not found")-> return-> (lookupProgram ghcProgram $ withPrograms lbi)-> ---> rawSystemProgramStdout verbosity ghc args--> mkGhcLibdirModule :: FilePath -> String-> mkGhcLibdirModule libdir = unlines m-> where m = ["-- Autogenerated by Cabal script... DO NOT MODIFY!",-> "module Language.Haskell.Interpreter.GHC.LibDir ( ghc_libdir )",-> "",-> "where",-> "",-> "ghc_libdir :: FilePath",-> "ghc_libdir = " ++ show libdir]--> removeTrailingEOL :: String -> String-> removeTrailingEOL [] = []-> removeTrailingEOL ['\n'] = []-> removeTrailingEOL (x:xs) = x : removeTrailingEOL xs+> main = defaultMainWithHooks defaultUserHooks
hint.cabal view
@@ -1,51 +1,73 @@ name: hint-version: 0.2.2+version: 0.2.4 description:- This library defines an @Interpreter@ monad. It allows to load Haskell+ This library defines an @Interpreter@ monad. It allows to load Haskell modules, browse them, type-check and evaluate strings with Haskell expressions and even coerce them into values. The library is- thread-safe and type-safe (even the coertion of expressions to+ thread-safe and type-safe (even the coercion of expressions to values). - It is, esentially, a huge subset of the GHC API wrapped in a simpler- API. Works with GHC 6.6.x and 6.8.x.-synopsis: Runtime Haskell interpreter (GHC API wrapper)-category: Language, Compilers/Interpreters-license: BSD3-license-file: LICENSE-author: Daniel Gorin-maintainer: jcpetruzza@gmail.com+ It is, esentially, a huge subset of the GHC API wrapped in a simpler+ API. Works with GHC 6.6.x and 6.8.x.+synopsis: Runtime Haskell interpreter (GHC API wrapper)+category: Language, Compilers/Interpreters+license: BSD3+license-file: LICENSE+author: Daniel Gorin+maintainer: jcpetruzza@gmail.com --- hackage rejects the correct cabal-version specification--- cabal-version: >= 1.2 && < 1.5-cabal-version: >= 1.2-build-type: Custom-tested-with: GHC==6.6.1, GHC==6.8.2+cabal-version: >= 1.2+build-type: Simple+tested-with: GHC==6.6.1, GHC==6.8.2 +extra-source-files: README+ AUTHORS+ Changes+ examples/example.hs+ examples/SomeModule.hs+ unit-tests/run-unit-tests.hs -build-depends: base, haskell-src, ghc, mtl+Library+ if impl(ghc >= 6.8) {+ build-depends: base >= 3,+ haskell-src,+ ghc,+ ghc-paths,+ mtl,+ random,+ filepath,+ directory,+ utf8-string+ } else {+ build-depends: base < 3,+ haskell-src,+ ghc > 6.6,+ ghc-paths,+ mtl,+ filepath,+ utf8-string < 0.3+ } -exposed-modules: Language.Haskell.Interpreter.GHC- Language.Haskell.Interpreter.GHC.Unsafe-other-modules: Language.Haskell.Interpreter.GHC.Base- Language.Haskell.Interpreter.GHC.Compat- Language.Haskell.Interpreter.GHC.Conversions- Language.Haskell.Interpreter.GHC.Parsers- Language.Haskell.Interpreter.GHC.LibDir+ exposed-modules: Language.Haskell.Interpreter.GHC+ Language.Haskell.Interpreter.GHC.Unsafe+ other-modules: Hint.Base+ Hint.Compat+ Hint.Configuration+ Hint.Context+ Hint.Conversions+ Hint.Eval+ Hint.Parsers+ Hint.Reflection+ Hint.Typecheck+ Hint.Sandbox -hs-source-dirs: src-extra-source-files: README- AUTHORS- Changes- examples/example.hs- examples/SomeModule.hs- unit-tests/run-unit-tests.hs+ hs-source-dirs: src -ghc-options: -Wall -O2-extensions: CPP- GeneralizedNewtypeDeriving- MultiParamTypeClasses- DeriveDataTypeable- MagicHash- TypeSynonymInstances- FlexibleInstances+ ghc-options: -Wall -O2+ extensions: CPP+ GeneralizedNewtypeDeriving+ MultiParamTypeClasses+ DeriveDataTypeable+ MagicHash+ TypeSynonymInstances+ FlexibleInstances
+ src/Hint/Base.hs view
@@ -0,0 +1,239 @@+module Hint.Base++where++import Prelude hiding ( span )++import Control.Monad.Reader+import Control.Monad.Error++import Control.Exception++import Data.IORef+import Control.Concurrent.MVar++import Data.Dynamic++import qualified GHC+import qualified GHC.Paths+import qualified Outputable as GHC.O+import qualified SrcLoc as GHC.S+import qualified ErrUtils as GHC.E+++import qualified Hint.Compat as Compat+import Hint.Parsers++newtype Interpreter a =+ Interpreter{unInterpreter :: ReaderT SessionState+ (ErrorT InterpreterError+ IO) a}+ deriving (Typeable, Functor, Monad, MonadIO)+++instance MonadError InterpreterError Interpreter where+ throwError = Interpreter . throwError+ catchError (Interpreter m) catchE = Interpreter $ m `catchError` (\e ->+ unInterpreter $ catchE e)++data InterpreterError = UnknownError String+ | WontCompile [GhcError]+ | NotAllowed String+ -- | GhcExceptions from the underlying GHC API are caught+ -- and rethrown as this.+ | GhcException GHC.GhcException+ deriving (Show, Typeable)++instance Error InterpreterError where+ noMsg = UnknownError ""+ strMsg = UnknownError++data InterpreterConf = Conf{all_mods_in_scope :: Bool}++defaultConf :: InterpreterConf+defaultConf = Conf {all_mods_in_scope = True}++-- I'm assuming operations on a ghcSession are not thread-safe. Besides, we need+-- to be sure that messages captured by the log handler correspond to a single+-- operation. Hence, we put the whole state on an MVar, and synchronize on it+newtype InterpreterSession =+ InterpreterSession {sessionState :: MVar SessionState}++data SessionState = SessionState{configuration :: IORef InterpreterConf,+ ghcSession :: GHC.Session,+ ghcErrListRef :: IORef [GhcError],+ ghcErrLogger :: GhcErrLogger}++-- When intercepting errors reported by GHC, we only get a GHC.E.Message+-- and a GHC.S.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)+data GhcError = GhcError{errMsg :: String} deriving Show++mkGhcError :: GHC.S.SrcSpan -> GHC.O.PprStyle -> GHC.E.Message -> GhcError+mkGhcError src_span style msg = GhcError{errMsg = niceErrMsg}+ where niceErrMsg = GHC.O.showSDoc . GHC.O.withPprStyle style $+ GHC.E.mkLocMessage src_span msg++mapGhcExceptions :: (String -> InterpreterError) -> IO a -> Interpreter a+mapGhcExceptions buildEx action =+ do r <- liftIO $ tryJust ghcExceptions action+ either (throwError . buildEx . flip GHC.showGhcException []) return r++ghcExceptions :: Exception -> Maybe GHC.GhcException+ghcExceptions (DynException a) = fromDynamic a+ghcExceptions _ = Nothing+++type GhcErrLogger = GHC.Severity+ -> GHC.S.SrcSpan+ -> GHC.O.PprStyle+ -> GHC.E.Message+ -> IO ()++-- | Module names are _not_ filepaths.+type ModuleName = String++-- ================= Creating a session =========================++-- | Builds a new session using the (hopefully) correct path to the GHC in use.+-- (the path is determined at build time of the package)+newSession :: IO InterpreterSession+newSession = newSessionUsing GHC.Paths.libdir++-- | Builds a new session, given the path to a GHC installation+-- (e.g. \/usr\/local\/lib\/ghc-6.6).+newSessionUsing :: FilePath -> IO InterpreterSession+newSessionUsing ghc_root =+ do+ ghc_session <- Compat.newSession ghc_root+ --+ default_conf <- newIORef defaultConf+ ghc_err_list_ref <- newIORef []+ let log_handler = mkLogHandler ghc_err_list_ref+ --+ let session_state = SessionState{configuration = default_conf,+ ghcSession = ghc_session,+ ghcErrListRef = ghc_err_list_ref,+ ghcErrLogger = log_handler}+ --+ -- Set a custom log handler, to intercept error messages :S+ -- Observe that, setSessionDynFlags loads info on packages available;+ -- calling this function once is mandatory! (nevertheless it was most+ -- likely already done in Compat.newSession...)+ dflags <- GHC.getSessionDynFlags ghc_session+ GHC.setSessionDynFlags ghc_session dflags{GHC.log_action = log_handler}+ --+ InterpreterSession `liftM` newMVar session_state++mkLogHandler :: IORef [GhcError] -> GhcErrLogger+mkLogHandler r _ src style msg = modifyIORef r (errorEntry :)+ where errorEntry = mkGhcError src style msg+++-- ================= Executing the interpreter ==================++-- | Executes the interpreter using a given session. This is a thread-safe+-- operation, if the InterpreterSession is in-use, the call will block until+-- the other one finishes.+--+-- In case of error, it will throw a dynamic InterpreterError exception.+withSession :: InterpreterSession -> Interpreter a -> IO a+withSession s i = withMVar (sessionState s) $ \ss ->+ do err_or_res <- runErrorT . flip runReaderT ss $ unInterpreter i+ either throwDyn return err_or_res+ `catchDyn` rethrowGhcException++rethrowGhcException :: GHC.GhcException -> IO a+rethrowGhcException = throwDyn . GhcException++++-- ================ Handling the interpreter state =================++fromSessionState :: (SessionState -> a) -> Interpreter a+fromSessionState f = Interpreter $ fmap f ask++-- modifies a ref in the session state and returns the old value+modifySessionStateRef :: (SessionState -> IORef a) -> (a -> a) -> Interpreter a+modifySessionStateRef target f =+ do ref <- fromSessionState target+ old_val <- liftIO $ atomicModifyIORef ref (\a -> (f a, a))+ return old_val++fromConf :: (InterpreterConf -> a) -> Interpreter a+fromConf f = do ref_conf <- fromSessionState configuration+ liftIO $ f `fmap` readIORef ref_conf++onConf :: (InterpreterConf -> InterpreterConf) -> Interpreter ()+onConf f = modifySessionStateRef configuration f >> return ()++-- =============== Error handling ==============================++mayFail :: IO (Maybe a) -> Interpreter a+mayFail ghc_action =+ do+ maybe_res <- liftIO ghc_action+ --+ es <- modifySessionStateRef ghcErrListRef (const [])+ --+ case maybe_res of+ Nothing -> if null es+ then throwError $ UnknownError "Got no error message"+ else throwError $ WontCompile (reverse es)+ Just a -> if null es+ then return a+ else fail "GHC reported errors and also gave a result!"++finally :: Interpreter a -> Interpreter () -> Interpreter a+finally action clean_up = do r <- protected_action+ clean_up+ return r+ where protected_action = action+ `catchError`+ (\e -> do clean_up `catchError` (\_ -> return ())+ throwError e)++-- ================ Misc ===================================++findModule :: ModuleName -> Interpreter GHC.Module+findModule mn =+ do+ ghc_session <- fromSessionState ghcSession+ --+ let mod_name = GHC.mkModuleName mn+ mapGhcExceptions NotAllowed $ GHC.findModule ghc_session+ mod_name+ Nothing++failOnParseError :: (GHC.Session -> String -> IO ParseResult)+ -> String+ -> Interpreter ()+failOnParseError parser expr =+ do+ ghc_session <- fromSessionState ghcSession+ --+ parsed <- liftIO $ parser ghc_session expr+ --+ -- If there was a parsing error, do the "standard" error reporting+ res <- case parsed of+ ParseOk -> return (Just ())+ --+ ParseError span err ->+ do+ -- parsing failed, so we report it just as all+ -- other errors get reported....+ logger <- fromSessionState ghcErrLogger+ liftIO $ logger GHC.SevError+ span+ GHC.O.defaultErrStyle+ err+ --+ -- behave like the rest of the GHC API functions+ -- do on error...+ return Nothing+ --+ -- "may Have Already Failed", actually :)+ mayFail (return res)
+ src/Hint/Compat.hs view
@@ -0,0 +1,52 @@+module Hint.Compat++where++import qualified GHC+import qualified Pretty+import qualified Outputable++#if __GLASGOW_HASKELL__ >= 608++import qualified PprTyThing++#endif++-- Kinds became a synonym for Type in GHC 6.8. We define this wrapper+-- to be able to define a FromGhcRep instance for both versions+newtype Kind = Kind GHC.Kind++#if __GLASGOW_HASKELL__ >= 608++newSession :: FilePath -> IO GHC.Session+newSession ghc_root =+ do s <- GHC.newSession (Just ghc_root)+ dflags <- GHC.getSessionDynFlags s+ GHC.setSessionDynFlags s dflags{GHC.ghcMode = GHC.CompManager,+ GHC.hscTarget = GHC.HscInterpreted,+ GHC.ghcLink = GHC.LinkInMemory}+ return s++pprType :: GHC.Type -> (Outputable.PprStyle -> Pretty.Doc)+pprType = PprTyThing.pprTypeForUser False -- False means drop explicit foralls++pprKind :: GHC.Kind -> (Outputable.PprStyle -> Pretty.Doc)+pprKind = pprType++#elif __GLASGOW_HASKELL__ >= 606++newSession :: FilePath -> IO GHC.Session+newSession ghc_root =+ do s <- GHC.newSession GHC.Interactive (Just ghc_root)+ dflags <- GHC.getSessionDynFlags s+ GHC.setSessionDynFlags s dflags{GHC.hscTarget = GHC.HscInterpreted}+ return s++pprType :: GHC.Type -> (Outputable.PprStyle -> Pretty.Doc)+pprType = Outputable.ppr . GHC.dropForAlls++pprKind :: GHC.Kind -> (Outputable.PprStyle -> Pretty.Doc)+pprKind = Outputable.ppr++#endif+
+ src/Hint/Configuration.hs view
@@ -0,0 +1,53 @@+module Hint.Configuration (++ setGhcOption, setGhcOptions,++ setUseLanguageExtensions,+ Optimizations(..), setOptimizations,++ setInstalledModsAreInScopeQualified ) where++import Control.Monad.Error+import qualified GHC+import Hint.Base++setGhcOptions :: [String] -> Interpreter ()+setGhcOptions opts =+ do ghc_session <- fromSessionState ghcSession+ old_flags <- liftIO $ GHC.getSessionDynFlags ghc_session+ (new_flags, not_parsed) <- liftIO $ GHC.parseDynamicFlags old_flags opts+ when (not . null $ not_parsed) $+ throwError $ UnknownError (concat ["flag: '", unwords opts,+ "' not recognized"])+ liftIO $ GHC.setSessionDynFlags ghc_session new_flags+ return ()++setGhcOption :: String -> Interpreter ()+setGhcOption opt = setGhcOptions [opt]++-- | Set to true to allow GHC's extensions to Haskell 98.+setUseLanguageExtensions :: Bool -> Interpreter ()+setUseLanguageExtensions True = do setGhcOption "-fglasgow-exts"+ setGhcOption "-fextended-default-rules"+setUseLanguageExtensions False = do setGhcOption "-fno-glasgow-exts"+ setGhcOption "-fno-extended-default-rules"++data Optimizations = None | Some | All deriving (Eq, Read, Show)++-- | Set the optimization level (none, some, all)+setOptimizations :: Optimizations -> Interpreter ()+setOptimizations None = setGhcOption "-O0"+setOptimizations Some = setGhcOption "-O1"+setOptimizations All = setGhcOption "-O2"++-- | 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.+setInstalledModsAreInScopeQualified :: Bool -> Interpreter ()+setInstalledModsAreInScopeQualified b = onConf $ \c -> c{all_mods_in_scope = b}
+ src/Hint/Context.hs view
@@ -0,0 +1,125 @@+module Hint.Context (++ ModuleName,+ loadModules, getLoadedModules, setTopLevelModules,+ setImports,+ reset++)++where++import Data.List++import Control.Monad.Error++import Hint.Base+import Hint.Conversions++import qualified GHC++-- | 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.+loadModules :: [String] -> Interpreter ()+loadModules fs =+ do+ ghc_session <- fromSessionState ghcSession+ --+ -- first, unload everything+ reset+ --+ let doLoad = mayFail $ do+ targets <- mapM (\f -> GHC.guessTarget f Nothing) fs+ --+ GHC.setTargets ghc_session targets+ res <- GHC.load ghc_session GHC.LoadAllTargets+ return $ guard (isSucceeded res) >> Just ()+ --+ doLoad `catchError` (\e -> reset >> throwError e)+ --+ return ()++-- | Returns the list of modules loaded with 'loadModules'.+getLoadedModules :: Interpreter [ModuleName]+getLoadedModules = liftM (map modNameFromSummary) getLoadedModSummaries++modNameFromSummary :: GHC.ModSummary -> ModuleName+modNameFromSummary = fromGhcRep_ . GHC.ms_mod++getLoadedModSummaries :: Interpreter [GHC.ModSummary]+getLoadedModSummaries =+ do ghc_session <- fromSessionState ghcSession+ --+ all_mod_summ <- liftIO $ GHC.getModuleGraph ghc_session+ filterM (liftIO . GHC.isLoaded ghc_session . 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 :: [ModuleName] -> Interpreter ()+setTopLevelModules ms =+ do+ ghc_session <- fromSessionState ghcSession+ --+ loaded_mods_ghc <- getLoadedModSummaries+ --+ let not_loaded = ms \\ map modNameFromSummary loaded_mods_ghc+ when (not . null $ not_loaded) $+ throwError $ NotAllowed ("These modules have not been loaded:\n" +++ unlines not_loaded)+ --+ ms_mods <- mapM findModule ms+ --+ let mod_is_interpr = GHC.moduleIsInterpreted ghc_session+ not_interpreted <- liftIO $ filterM (liftM not . mod_is_interpr) ms_mods+ when (not . null $ not_interpreted) $+ throwError $ NotAllowed ("These modules are not interpreted:\n" +++ unlines (map fromGhcRep_ not_interpreted))+ --+ liftIO $ do+ (_, old_imports) <- GHC.getContext ghc_session+ GHC.setContext ghc_session ms_mods old_imports++-- | Sets the modules whose exports must be in context.+setImports :: [ModuleName] -> Interpreter ()+setImports ms =+ do+ ghc_session <- fromSessionState ghcSession+ --+ ms_mods <- mapM findModule ms+ --+ liftIO $ do+ (old_top_level, _) <- GHC.getContext ghc_session+ GHC.setContext ghc_session old_top_level ms_mods++-- | 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 :: Interpreter ()+reset =+ do+ ghc_session <- fromSessionState ghcSession+ --+ -- Remove all modules from context+ liftIO $ GHC.setContext ghc_session [] []+ --+ -- Unload all previously loaded modules+ liftIO $ GHC.setTargets ghc_session []+ liftIO $ GHC.load ghc_session 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+ --+ return ()++-- SHOULD WE CALL THIS WHEN MODULES ARE LOADED / UNLOADED?+-- foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
+ src/Hint/Conversions.hs view
@@ -0,0 +1,64 @@+module Hint.Conversions( FromGhcRep(..), FromGhcRep_(..), isSucceeded )++where++import Control.Monad.Trans ( liftIO )++import qualified GHC as GHC+import qualified Outputable as GHC.O++import Hint.Base+import qualified Hint.Compat as Compat++import Language.Haskell.Syntax ( HsModule(..), HsDecl(..), HsQualType )+import Language.Haskell.Parser ( parseModule, ParseResult(ParseOk) )++-- | Conversions from GHC representation to standard representations+class FromGhcRep ghc target where+ fromGhcRep :: ghc -> Interpreter target++class FromGhcRep_ ghc target where+ fromGhcRep_ :: ghc -> target++-- --------- Types / Kinds -----------------------++instance FromGhcRep GHC.Type HsQualType where+ fromGhcRep t =+ do t_str <- fromGhcRep t+ --+ let mod_str = unlines ["f ::" ++ t_str,+ "f = undefined"]+ let HsModule _ _ _ _ [decl,_] = parseModule' mod_str+ HsTypeSig _ _ qualType = decl+ --+ return qualType+++instance FromGhcRep GHC.Type String where+ fromGhcRep t = do ghc_session <- fromSessionState ghcSession+ -- Unqualify necessary types+ -- (i.e., do not expose internals)+ unqual <- liftIO $ GHC.getPrintUnqual ghc_session+ return $ GHC.O.showSDocForUser unqual (Compat.pprType t)++parseModule' :: String -> HsModule+parseModule' s = case parseModule s of+ ParseOk m -> m+ failed -> error $ unlines ["parseModulde' failed?!",+ s,+ show failed]++instance FromGhcRep_ Compat.Kind String where+ fromGhcRep_ (Compat.Kind k) = GHC.O.showSDoc (Compat.pprKind k)+++-- ---------------- Modules --------------------------++instance FromGhcRep_ GHC.Module String where+ fromGhcRep_ = GHC.moduleNameString . GHC.moduleName++-- ---------------- Misc -----------------------------++isSucceeded :: GHC.SuccessFlag -> Bool+isSucceeded GHC.Succeeded = True+isSucceeded GHC.Failed = False
+ src/Hint/Eval.hs view
@@ -0,0 +1,62 @@+module Hint.Eval (++ interpret, as, infer,+ eval )++where++import qualified GHC+import qualified GHC.Exts ( unsafeCoerce# )+++import Data.Typeable hiding ( typeOf )+import qualified Data.Typeable ( typeOf )++import Hint.Base+import Hint.Parsers+import Hint.Sandbox+++-- | 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 :: Typeable a => String -> a -> Interpreter a+interpret expr witness = sandboxed go expr+ where go e =+ do ghc_session <- fromSessionState ghcSession+ --+ -- First, make sure the expression has no syntax errors,+ -- for this is the only way we have to "intercept" this+ -- kind of errors+ failOnParseError parseExpr e+ --+ let expr_typesig = concat ["(", e, ") :: ", show $ myTypeOf witness]+ expr_val <- mayFail $ GHC.compileExpr ghc_session expr_typesig+ --+ return (GHC.Exts.unsafeCoerce# expr_val :: a)++-- HACK! Allows evaluations even when the Prelude is not in scope+myTypeOf :: Typeable a => a -> TypeRep+myTypeOf a+ | type_of_a == type_of_string = qual_type_of_string+ | otherwise = type_of_a+ where type_of_a = Data.Typeable.typeOf a+ type_of_string = Data.Typeable.typeOf (undefined :: [Char])+ (list_ty_con, _) = splitTyConApp type_of_string+ qual_type_of_string = mkTyConApp list_ty_con+ [mkTyConApp (mkTyCon "Prelude.Char") []]++-- | @eval expr@ will evaluate @show expr@.+-- It will succeed only if @expr@ has type t and there is a 'Show'+-- instance for t.+eval :: String -> Interpreter String+eval expr = interpret show_expr (as :: String)+ where show_expr = unwords ["Prelude.show", "(", expr, ") "]
+ src/Hint/Parsers.hs view
@@ -0,0 +1,35 @@+module Hint.Parsers++where++import Prelude hiding(span)++import qualified GHC(Session, getSessionDynFlags)++import qualified Lexer as GHC.L (P(..), ParseResult(..), mkPState)+import qualified Parser as GHC.P (parseStmt, parseType)+import qualified StringBuffer as GHC.SB(stringToStringBuffer)+import qualified SrcLoc as GHC.S (SrcSpan, noSrcLoc)+import qualified ErrUtils as GHC.E (Message)++data ParseResult = ParseOk | ParseError GHC.S.SrcSpan GHC.E.Message++parseExpr :: GHC.Session -> String -> IO ParseResult+parseExpr = runParser GHC.P.parseStmt++parseType :: GHC.Session -> String -> IO ParseResult+parseType = runParser GHC.P.parseType++runParser :: GHC.L.P a -> GHC.Session -> String -> IO ParseResult+runParser parser ghc_session expr =+ do+ dyn_fl <- GHC.getSessionDynFlags ghc_session+ --+ buf <- GHC.SB.stringToStringBuffer expr+ --+ let parse_res = GHC.L.unP parser (GHC.L.mkPState buf GHC.S.noSrcLoc dyn_fl)+ --+ case parse_res of+ GHC.L.POk{} -> return ParseOk+ --+ GHC.L.PFailed span err -> return (ParseError span err)
+ src/Hint/Reflection.hs view
@@ -0,0 +1,74 @@+module Hint.Reflection (++ ModuleElem(..), Id, name, children,+ getModuleExports,++)++where++import Data.List+import Data.Maybe++import Control.Monad.Trans++import Hint.Base++import qualified GHC+import qualified Outputable as GHC.O++-- | 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 :: ModuleName -> Interpreter [ModuleElem]+getModuleExports mn =+ do+ ghc_session <- fromSessionState ghcSession+ --+ module_ <- findModule mn+ mod_info <- mayFail $ GHC.getModuleInfo ghc_session module_+ exports <- liftIO $ mapM (GHC.lookupName ghc_session)+ (GHC.modInfoExports mod_info)+ --+ return (asModElemList $ catMaybes exports)++asModElemList :: [GHC.TyThing] -> [ModuleElem]+asModElemList xs = concat [cs',+ ts',+ ds \\ (concatMap (map Fun . children) ts'),+ fs \\ (concatMap (map Fun . children) cs')]+ where (cs,ts,ds,fs) = ([asModElem c | c@GHC.AClass{} <- xs],+ [asModElem t | t@GHC.ATyCon{} <- xs],+ [asModElem d | d@GHC.ADataCon{} <- xs],+ [asModElem 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.TyThing -> ModuleElem+asModElem (GHC.AnId f) = Fun $ getUnqualName f+asModElem (GHC.ADataCon dc) = Fun $ getUnqualName dc+asModElem (GHC.ATyCon tc) = Data (getUnqualName tc)+ (map getUnqualName $ GHC.tyConDataCons tc)+asModElem (GHC.AClass c) = Class (getUnqualName c)+ (map getUnqualName $ GHC.classMethods c)++getUnqualName :: GHC.NamedThing a => a -> String+getUnqualName = GHC.O.showSDocUnqual . GHC.pprParenSymName
+ src/Hint/Sandbox.hs view
@@ -0,0 +1,139 @@+module Hint.Sandbox ( sandboxed ) where++import Hint.Base+import Hint.Conversions+import Hint.Context++import {-# SOURCE #-} Hint.Typecheck ( typeChecks_unsandboxed )++import qualified GHC+import qualified DriverPhases as DP++import Data.Char++import Control.Monad.Error++import System.Directory+import System.FilePath+import System.Random++import qualified System.IO.UTF8 as UTF (writeFile)++type Expr = String++sandboxed :: (Expr -> Interpreter a) -> (Expr -> Interpreter a)+sandboxed do_stuff = \expr -> do dont_need_sandbox <- fromConf all_mods_in_scope+ if dont_need_sandbox+ then do_stuff expr+ else usingAModule do_stuff expr++usingAModule :: (Expr -> Interpreter a) -> (Expr -> Interpreter a)+usingAModule do_stuff_on = \expr ->+ do (mod_name, mod_file) <- mkModName+ --+ -- To avoid defaulting, we will evaluate this expression without the+ -- monomorphism-restriction. This means that expressions that normally+ -- would not typecheck, suddenly will. Thus, we first check if the+ -- expression typechecks as is. If it doesn't, there is no need in+ -- going on (if it does, it may not typecheck once we restrict the+ -- context; that is the whole idea of this!)+ --+ type_checks <- typeChecks_unsandboxed expr+ case type_checks of+ False -> do_stuff_on expr -- fail as you wish...+ True ->+ do (loaded, imports) <- modulesInContext+ --+ let e = safeBndFor expr+ let mod_text no_prel = textify [+ ["{-# OPTIONS_GHC -fno-monomorphism-restriction #-}"],+ ["{-# OPTIONS_GHC -fno-implicit-prelude #-}" | no_prel],+ ["module " ++ mod_name],+ ["where"],+ ["import " ++ m | m <- loaded ++ imports],+ [e ++ " = " ++ expr] ]+ let write_mod = liftIO . UTF.writeFile mod_file . mod_text+ let t = fileTarget mod_file+ --+ setTopLevelModules []+ setImports []+ let go = do addTarget t+ setTopLevelModules [mod_name]+ do_stuff_on e+ write_mod True+ -- If the Prelude was not explicitly imported but implicitly+ -- imported in some interpreted module, then the user may+ -- get very unintuitive errors when turning sandboxing on. Thus+ -- we will import the Prelude if the operation fails...+ -- I guess this may lead to even more obscure errors, but+ -- hopefully in much less frequent situations...+ r <- go+ `catchError` (\err -> case err of+ WontCompile _ -> do removeTarget t+ write_mod False+ go+ _ -> throwError err)+ --+ removeTarget t+ setTopLevelModules loaded+ setImports imports+ --+ return r+ `finally`+ clean_up mod_file+ --+ where textify = unlines . concat+ clean_up f = liftIO $ do exists <- doesFileExist f+ when exists $+ return () -- removeFile f+++addTarget :: GHC.Target -> Interpreter ()+addTarget t = do ghc_session <- fromSessionState ghcSession+ mayFail $ do GHC.addTarget ghc_session t+ res <- GHC.load ghc_session GHC.LoadAllTargets+ return $ guard (isSucceeded res) >> Just ()++removeTarget :: GHC.Target -> Interpreter ()+removeTarget t = do ghc_session <- fromSessionState ghcSession+ mayFail $ do GHC.removeTarget ghc_session (targetId t)+ res <- GHC.load ghc_session GHC.LoadAllTargets+ return $ guard (isSucceeded res) >> Just ()++targetId :: GHC.Target -> GHC.TargetId+targetId (GHC.Target _id _) = _id++fileTarget :: FilePath -> GHC.Target+fileTarget f = GHC.Target (GHC.TargetFile f $ Just next_phase) Nothing+ where next_phase = DP.Cpp DP.HsSrcFile++-- Since instead of working with expr, we will work with+-- e = expr, we must be sure that e does not occur free in 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++-- We have a similar situation with the module name as we have with+-- the binder name (see safeBndFor): we want to avoid a module that is+-- 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+mkModName :: Interpreter (ModuleName, FilePath)+mkModName =+ do n <- liftIO randomIO :: Interpreter Int+ (ls,is) <- modulesInContext+ let nums = concat [show (abs n), filter isDigit $ concat (ls ++ is)]+ let mod_name = 'M':nums+ --+ tmp_dir <- liftIO getTemporaryDirectory+ --+ return (mod_name, tmp_dir </> nums)++modulesInContext :: Interpreter ([ModuleName], [ModuleName])+modulesInContext =+ do ghc_session <- fromSessionState ghcSession+ (l, i) <- liftIO $ GHC.getContext ghc_session+ return (map fromGhcRep_ l, map fromGhcRep_ i)
+ src/Hint/Typecheck.hs view
@@ -0,0 +1,69 @@+module Hint.Typecheck (++ typeOf, typeChecks, kindOf,++ typeOf_unsandboxed, typeChecks_unsandboxed++)++where++import Control.Monad.Error++import Hint.Base+import Hint.Parsers+import Hint.Conversions+import Hint.Sandbox++import qualified Hint.Compat as Compat++import qualified GHC++-- | Returns a string representation of the type of the expression.+typeOf :: String -> Interpreter String+typeOf = sandboxed typeOf_unsandboxed++typeOf_unsandboxed :: String -> Interpreter String+typeOf_unsandboxed expr =+ do+ ghc_session <- fromSessionState ghcSession+ --+ -- 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 $ GHC.exprType ghc_session expr+ --+ fromGhcRep ty++-- | Tests if the expression type checks.+typeChecks :: String -> Interpreter Bool+typeChecks = sandboxed typeChecks_unsandboxed++typeChecks_unsandboxed :: String -> Interpreter Bool+typeChecks_unsandboxed expr = (typeOf_unsandboxed expr >> return True)+ `catchError`+ onCompilationError (\_ -> return False)++-- | Returns a string representation of the kind of the type expression.+kindOf :: String -> Interpreter String+kindOf = sandboxed go+ where go type_expr =+ do ghc_session <- fromSessionState ghcSession+ --+ -- 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 $ GHC.typeKind ghc_session type_expr+ --+ return $ fromGhcRep_ (Compat.Kind kind)++onCompilationError :: ([GhcError] -> Interpreter a)+ -> (InterpreterError -> Interpreter a)+onCompilationError recover =+ \interp_error -> case interp_error of+ WontCompile errs -> recover errs+ otherErr -> throwError otherErr
+ src/Hint/Typecheck.hs-boot view
@@ -0,0 +1,5 @@+module Hint.Typecheck where++import Hint.Base (Interpreter)++typeChecks_unsandboxed :: String -> Interpreter Bool
src/Language/Haskell/Interpreter/GHC.hs view
@@ -21,6 +21,7 @@ -- ** Interpreter options setUseLanguageExtensions, Optimizations(..), setOptimizations,+ setInstalledModsAreInScopeQualified, -- ** Context handling ModuleName, loadModules, getLoadedModules, setTopLevelModules,@@ -37,373 +38,9 @@ where -import Prelude hiding ( span )--import qualified GHC-import qualified Outputable as GHC.O-import qualified ErrUtils as GHC.E-import qualified Name as GHC.N--import qualified GHC.Exts ( unsafeCoerce# )--import Control.Monad ( liftM, filterM, guard, when )-import Control.Monad.Trans ( liftIO )-import Control.Monad.Error ( MonadError(throwError, catchError) )--import Control.Exception ( Exception(DynException), tryJust )--import Data.Typeable ( Typeable, TypeRep, mkTyCon,- mkTyConApp, splitTyConApp )-import qualified Data.Typeable ( typeOf )-import Data.Dynamic ( fromDynamic )--import Data.List ( (\\) )-import Data.Maybe ( catMaybes )--import Language.Haskell.Interpreter.GHC.Base--import Language.Haskell.Interpreter.GHC.Parsers ( ParseResult(..),- parseExpr, parseType )-import Language.Haskell.Interpreter.GHC.Conversions ( FromGhcRep(..) )--import qualified Language.Haskell.Interpreter.GHC.Compat as Compat---- | Set to true to allow GHC's extensions to Haskell 98.-setUseLanguageExtensions :: Bool -> Interpreter ()-setUseLanguageExtensions True = setGhcOption "-fglasgow-exts"-setUseLanguageExtensions False = setGhcOption "-fno-glasgow-exts"--data Optimizations = None | Some | All deriving (Eq, Read, Show)---- | Set the optimization level (none, some, all)-setOptimizations :: Optimizations -> Interpreter ()-setOptimizations None = setGhcOption "-O0"-setOptimizations Some = setGhcOption "-O1"-setOptimizations All = setGhcOption "-O2"---- | Module names are _not_ filepaths.-type ModuleName = String---- | 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---- | 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.-loadModules :: [String] -> Interpreter ()-loadModules fs =- do- ghc_session <- fromSessionState ghcSession- --- -- first, unload everything- reset- --- let doLoad = mayFail $ do- targets <- mapM (\f -> GHC.guessTarget f Nothing) fs- --- GHC.setTargets ghc_session targets- res <- GHC.load ghc_session GHC.LoadAllTargets- return $ guard (isSucceeded res) >> Just ()- --- doLoad `catchError` (\e -> reset >> throwError e)- --- return ()---- | Returns the list of modules loaded with 'loadModules'.-getLoadedModules :: Interpreter [ModuleName]-getLoadedModules = liftM (map modNameFromSummary) getLoadedModSummaries--modNameFromSummary :: GHC.ModSummary -> ModuleName-modNameFromSummary = modNameFromModule . GHC.ms_mod--modNameFromModule :: GHC.Module -> ModuleName-modNameFromModule = GHC.moduleNameString . GHC.moduleName--getLoadedModSummaries :: Interpreter [GHC.ModSummary]-getLoadedModSummaries =- do ghc_session <- fromSessionState ghcSession- --- all_mod_summ <- liftIO $ GHC.getModuleGraph ghc_session- filterM (liftIO . GHC.isLoaded ghc_session . 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 :: [ModuleName] -> Interpreter ()-setTopLevelModules ms =- do- ghc_session <- fromSessionState ghcSession- --- loaded_mods_ghc <- getLoadedModSummaries- --- let not_loaded = ms \\ map modNameFromSummary loaded_mods_ghc- when (not . null $ not_loaded) $- throwError $ NotAllowed ("These modules have not been loaded:\n" ++- unlines not_loaded)- --- ms_mods <- mapM findModule ms- --- let mod_is_interpr = GHC.moduleIsInterpreted ghc_session- not_interpreted <- liftIO $ filterM (liftM not . mod_is_interpr) ms_mods- when (not . null $ not_interpreted) $- throwError $ NotAllowed ("These modules are not interpreted:\n" ++- unlines (map modNameFromModule- not_interpreted))- --- liftIO $ do- (_, old_imports) <- GHC.getContext ghc_session- GHC.setContext ghc_session ms_mods old_imports---- | Gets an abstract representation of all the entities exported by the module.--- It is similar to the @:browse@ command in GHCi.-getModuleExports :: ModuleName -> Interpreter [ModuleElem]-getModuleExports mn =- do- ghc_session <- fromSessionState ghcSession- --- module_ <- findModule mn- mod_info <- mayFail $ GHC.getModuleInfo ghc_session module_- exports <- liftIO $ mapM (GHC.lookupName ghc_session)- (GHC.modInfoExports mod_info)- --- return (asModElemList $ catMaybes exports)--asModElemList :: [GHC.TyThing] -> [ModuleElem]-asModElemList xs = concat [cs',- ts',- ds \\ (concatMap (map Fun . children) ts'),- fs \\ (concatMap (map Fun . children) cs')]- where (cs,ts,ds,fs) = ([asModElem c | c@GHC.AClass{} <- xs],- [asModElem t | t@GHC.ATyCon{} <- xs],- [asModElem d | d@GHC.ADataCon{} <- xs],- [asModElem 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.TyThing -> ModuleElem-asModElem (GHC.AnId f) = Fun $ getUnqualName f-asModElem (GHC.ADataCon dc) = Fun $ getUnqualName dc-asModElem (GHC.ATyCon tc) = Data (getUnqualName tc)- (map getUnqualName $ GHC.tyConDataCons tc)-asModElem (GHC.AClass c) = Class (getUnqualName c)- (map getUnqualName $ GHC.classMethods c)--getUnqualName :: GHC.NamedThing a => a -> String-getUnqualName = GHC.O.showSDocUnqual . GHC.pprParenSymName--findModule :: ModuleName -> Interpreter GHC.Module-findModule mn =- do- ghc_session <- fromSessionState ghcSession- --- let mod_name = GHC.mkModuleName mn- mapGhcExceptions NotAllowed $ GHC.findModule ghc_session- mod_name- Nothing--mapGhcExceptions :: (String -> InterpreterError) -> IO a -> Interpreter a-mapGhcExceptions buildEx action =- do- r <- liftIO $ tryJust ghcExceptions action- either (throwError . buildEx . flip GHC.showGhcException []) return r--ghcExceptions :: Exception -> Maybe GHC.GhcException-ghcExceptions (DynException a) = fromDynamic a-ghcExceptions _ = Nothing---- | Sets the modules whose exports must be in context.-setImports :: [ModuleName] -> Interpreter ()-setImports ms =- do- ghc_session <- fromSessionState ghcSession- --- ms_mods <- mapM findModule ms- --- liftIO $ do- (old_top_level, _) <- GHC.getContext ghc_session- GHC.setContext ghc_session old_top_level ms_mods---- | 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 :: Interpreter ()-reset =- do- ghc_session <- fromSessionState ghcSession- --- -- Remove all modules from context- liftIO $ GHC.setContext ghc_session [] []- --- -- Unload all previously loaded modules- liftIO $ GHC.setTargets ghc_session []- liftIO $ GHC.load ghc_session 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- --- return ()----- | Returns a string representation of the type of the expression.-typeOf :: String -> Interpreter String-typeOf expr =- do- ghc_session <- fromSessionState ghcSession- --- -- 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 $ GHC.exprType ghc_session expr- --- fromGhcRep ty----- | Tests if the expression type checks.-typeChecks :: String -> Interpreter Bool-typeChecks expr = (typeOf expr >> return True)- `catchError`- onCompilationError (\_ -> return False)---- | Returns a string representation of the kind of the type expression.-kindOf :: String -> Interpreter String-kindOf type_expr =- do- ghc_session <- fromSessionState ghcSession- --- -- 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 $ GHC.typeKind ghc_session type_expr- --- fromGhcRep (Compat.Kind kind)----- | Convenience functions to be used with typeCheck 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 :: Typeable a => String -> a -> Interpreter a-interpret expr witness =- do- ghc_session <- fromSessionState ghcSession- --- -- 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 ["(", expr, ") :: ", show $ myTypeOf witness]- expr_val <- mayFail $ GHC.compileExpr ghc_session expr_typesig- --- return (GHC.Exts.unsafeCoerce# expr_val :: a)---- HACK! Allows evaluations even when the Prelude is not in scope-myTypeOf :: Typeable a => a -> TypeRep-myTypeOf a- | type_of_a == type_of_string = qual_type_of_string- | otherwise = type_of_a- where type_of_a = Data.Typeable.typeOf a- type_of_string = Data.Typeable.typeOf (undefined :: [Char])- (list_ty_con, _) = splitTyConApp type_of_string- qual_type_of_string = mkTyConApp list_ty_con- [mkTyConApp (mkTyCon "Prelude.Char") []]---- | @eval expr@ will evaluate @show expr@.--- It will succeed only if @expr@ has type t and there is a 'Show'--- instance for t.-eval :: String -> Interpreter String-eval expr = interpret show_expr (as :: String)- where show_expr = unwords ["Prelude.show", "(", expr, ") "]--mayFail :: IO (Maybe a) -> Interpreter a-mayFail ghc_action =- do- maybe_res <- liftIO ghc_action- --- es <- modifySessionState ghcErrListRef (const [])- --- case maybe_res of- Nothing -> if null es- then throwError $ UnknownError "Got no error message"- else throwError $ WontCompile (reverse es)- Just a -> if null es- then return a- else fail "GHC reported errors and also gave a result!"--failOnParseError :: (GHC.Session -> String -> IO ParseResult)- -> String- -> Interpreter ()-failOnParseError parser expr =- do- ghc_session <- fromSessionState ghcSession- --- parsed <- liftIO $ parser ghc_session expr- --- -- If there was a parsing error, do the "standard" error reporting- res <- case parsed of- ParseOk -> return (Just ())- --- ParseError span err ->- do- -- parsing failed, so we report it just as all- -- other errors get reported....- logger <- fromSessionState ghcErrLogger- liftIO $ logger GHC.SevError- span- GHC.O.defaultErrStyle- err- --- -- behave like the rest of the GHC API functions- -- do on error...- return Nothing- --- -- "may Have Already Failed", actually :)- mayFail (return res)--isSucceeded :: GHC.SuccessFlag -> Bool-isSucceeded GHC.Succeeded = True-isSucceeded GHC.Failed = False--onCompilationError :: ([GhcError] -> Interpreter a)- -> (InterpreterError -> Interpreter a)-onCompilationError recover =- \interp_error -> case interp_error of- WontCompile errs -> recover errs- otherErr -> throwError otherErr---- SHOULD WE CALL THIS WHEN MODULES ARE LOADED / UNLOADED?--- foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()+import Hint.Base+import Hint.Configuration+import Hint.Context+import Hint.Reflection+import Hint.Typecheck+import Hint.Eval
− src/Language/Haskell/Interpreter/GHC/Base.hs
@@ -1,167 +0,0 @@-module Language.Haskell.Interpreter.GHC.Base--where--import Control.Monad ( liftM, when )-import Control.Monad.Trans ( MonadIO(liftIO) )-import Control.Monad.Reader ( ReaderT, ask, runReaderT )-import Control.Monad.Error ( Error(..), MonadError(..), ErrorT, runErrorT )--import Control.Exception ( catchDyn, throwDyn )--import Control.Concurrent.MVar ( MVar, newMVar, withMVar )-import Data.IORef ( IORef, newIORef,- modifyIORef, atomicModifyIORef )--import Data.Typeable ( Typeable )--import qualified GHC-import qualified Outputable as GHC.O-import qualified SrcLoc as GHC.S-import qualified ErrUtils as GHC.E---import qualified Language.Haskell.Interpreter.GHC.Compat as Compat---- autogenerated by Cabal script-import Language.Haskell.Interpreter.GHC.LibDir ( ghc_libdir )---newtype Interpreter a =- Interpreter{unInterpreter :: ReaderT SessionState- (ErrorT InterpreterError- IO) a}- deriving (Typeable, Functor, Monad, MonadIO)---instance MonadError InterpreterError Interpreter where- throwError = Interpreter . throwError- catchError (Interpreter m) catchE = Interpreter $ m `catchError` (\e ->- unInterpreter $ catchE e)--data InterpreterError = UnknownError String- | WontCompile [GhcError]- | NotAllowed String- -- | GhcExceptions from the underlying GHC API are caught- -- and rethrown as this.- | GhcException GHC.GhcException- deriving (Show, Typeable)--instance Error InterpreterError where- noMsg = UnknownError ""- strMsg = UnknownError----- I'm assuming operations on a ghcSession are not thread-safe. Besides, we need--- to be sure that messages captured by the log handler correspond to a single--- operation. Hence, we put the whole state on an MVar, and synchronize on it-newtype InterpreterSession =- InterpreterSession {sessionState :: MVar SessionState}--data SessionState = SessionState{ghcSession :: GHC.Session,- ghcErrListRef :: IORef [GhcError],- ghcErrLogger :: GhcErrLogger}---- When intercepting errors reported by GHC, we only get a GHC.E.Message--- and a GHC.S.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)-data GhcError = GhcError{errMsg :: String} deriving Show--mkGhcError :: GHC.S.SrcSpan -> GHC.O.PprStyle -> GHC.E.Message -> GhcError-mkGhcError src_span style msg = GhcError{errMsg = niceErrMsg}- where niceErrMsg = GHC.O.showSDoc . GHC.O.withPprStyle style $- GHC.E.mkLocMessage src_span msg--type GhcErrLogger = GHC.Severity- -> GHC.S.SrcSpan- -> GHC.O.PprStyle- -> GHC.E.Message- -> IO ()---- ================= Creating a session =========================---- | Builds a new session using the (hopefully) correct path to the GHC in use.--- (the path is determined at build time of the package)-newSession :: IO InterpreterSession-newSession = newSessionUsing ghc_libdir---- | Builds a new session, given the path to a GHC installation--- (e.g. \/usr\/local\/lib\/ghc-6.6).-newSessionUsing :: FilePath -> IO InterpreterSession-newSessionUsing ghc_root =- do- ghc_session <- Compat.newSession ghc_root- --- ghc_err_list_ref <- newIORef []- let log_handler = mkLogHandler ghc_err_list_ref- --- let session_state = SessionState{ghcSession = ghc_session,- ghcErrListRef = ghc_err_list_ref,- ghcErrLogger = log_handler}- --- -- Set a custom log handler, to intercept error messages :S- -- Observe that, setSessionDynFlags loads info on packages available;- -- calling this function once is mandatory! (nevertheless it was most- -- likely already done in Compat.newSession...)- dflags <- GHC.getSessionDynFlags ghc_session- GHC.setSessionDynFlags ghc_session dflags{GHC.log_action = log_handler}- --- InterpreterSession `liftM` newMVar session_state--mkLogHandler :: IORef [GhcError] -> GhcErrLogger-mkLogHandler r _ src style msg = modifyIORef r (errorEntry :)- where errorEntry = mkGhcError src style msg----- ================= Executing the interpreter ==================---- | Executes the interpreter using a given session. This is a thread-safe--- operation, if the InterpreterSession is in-use, the call will block until--- the other one finishes.------ In case of error, it will throw a dynamic InterpreterError exception.-withSession :: InterpreterSession -> Interpreter a -> IO a-withSession s i = withMVar (sessionState s) $ \ss ->- do err_or_res <- runErrorT . flip runReaderT ss $ unInterpreter i- either throwDyn return err_or_res- `catchDyn` rethrowGhcException--rethrowGhcException :: GHC.GhcException -> IO a-rethrowGhcException = throwDyn . GhcException------ ================ Handling the interpreter state =================--fromSessionState :: (SessionState -> a) -> Interpreter a-fromSessionState f = Interpreter $ fmap f ask---- modifies the session state and returns the old value-modifySessionState :: Show a- => (SessionState -> IORef a)- -> (a -> a)- -> Interpreter a-modifySessionState target f =- do- ref <- fromSessionState target- old_val <- liftIO $ atomicModifyIORef ref (\a -> (f a, a))- return old_val---- ================ Interpreter options =====================--setGhcOptions :: [String] -> Interpreter ()-setGhcOptions opts =- do ghc_session <- fromSessionState ghcSession- old_flags <- liftIO $ GHC.getSessionDynFlags ghc_session- (new_flags, not_parsed) <- liftIO $ GHC.parseDynamicFlags old_flags opts- when (not . null $ not_parsed) $- throwError $ UnknownError (concat ["flag: '", unwords opts,- "' not recognized"])- liftIO $ GHC.setSessionDynFlags ghc_session new_flags- return ()--setGhcOption :: String -> Interpreter ()-setGhcOption opt = setGhcOptions [opt]
− src/Language/Haskell/Interpreter/GHC/Compat.hs
@@ -1,52 +0,0 @@-module Language.Haskell.Interpreter.GHC.Compat--where--import qualified GHC-import qualified Pretty-import qualified Outputable--#if __GLASGOW_HASKELL__ >= 608--import qualified PprTyThing--#endif---- Kinds became a synonym for Type in GHC 6.8. We define this wrapper--- to be able to define a FromGhcRep instance for both versions-newtype Kind = Kind GHC.Kind--#if __GLASGOW_HASKELL__ >= 608--newSession :: FilePath -> IO GHC.Session-newSession ghc_root =- do s <- GHC.newSession (Just ghc_root)- dflags <- GHC.getSessionDynFlags s- GHC.setSessionDynFlags s dflags{GHC.ghcMode = GHC.CompManager,- GHC.hscTarget = GHC.HscInterpreted,- GHC.ghcLink = GHC.LinkInMemory}- return s--pprType :: GHC.Type -> (Outputable.PprStyle -> Pretty.Doc)-pprType = PprTyThing.pprTypeForUser False -- False means drop explicit foralls--pprKind :: GHC.Kind -> (Outputable.PprStyle -> Pretty.Doc)-pprKind = pprType--#elif __GLASGOW_HASKELL__ >= 606--newSession :: FilePath -> IO GHC.Session-newSession ghc_root =- do s <- GHC.newSession GHC.Interactive (Just ghc_root)- dflags <- GHC.getSessionDynFlags s- GHC.setSessionDynFlags s dflags{GHC.hscTarget = GHC.HscInterpreted}- return s--pprType :: GHC.Type -> (Outputable.PprStyle -> Pretty.Doc)-pprType = Outputable.ppr . GHC.dropForAlls--pprKind :: GHC.Kind -> (Outputable.PprStyle -> Pretty.Doc)-pprKind = Outputable.ppr--#endif-
− src/Language/Haskell/Interpreter/GHC/Conversions.hs
@@ -1,50 +0,0 @@-module Language.Haskell.Interpreter.GHC.Conversions(FromGhcRep(..))--where--import Control.Monad.Trans ( liftIO )--import qualified GHC as GHC-import qualified Outputable as GHC.O--import Language.Haskell.Interpreter.GHC.Base-import qualified Language.Haskell.Interpreter.GHC.Compat as Compat--import Language.Haskell.Syntax ( HsModule(..), HsDecl(..), HsQualType )-import Language.Haskell.Parser ( parseModule, ParseResult(ParseOk) )---- | Conversions from GHC representation to standard representations-class FromGhcRep ghc target where- fromGhcRep :: ghc -> Interpreter target---- --------- Types / Kinds -------------------------instance FromGhcRep GHC.Type HsQualType where- fromGhcRep t =- do t_str <- fromGhcRep t- --- let mod_str = unlines ["f ::" ++ t_str,- "f = undefined"]- let HsModule _ _ _ _ [decl,_] = parseModule' mod_str- HsTypeSig _ _ qualType = decl- --- return qualType---instance FromGhcRep GHC.Type String where- fromGhcRep t = do ghc_session <- fromSessionState ghcSession- -- Unqualify necessary types- -- (i.e., do not expose internals)- unqual <- liftIO $ GHC.getPrintUnqual ghc_session- return $ GHC.O.showSDocForUser unqual (Compat.pprType t)--parseModule' :: String -> HsModule-parseModule' s = case parseModule s of- ParseOk m -> m- failed -> error $ unlines ["parseModulde' failed?!",- s,- show failed]--instance FromGhcRep Compat.Kind String where- fromGhcRep (Compat.Kind k) = return $ GHC.O.showSDoc (Compat.pprKind k)-
− src/Language/Haskell/Interpreter/GHC/LibDir.hs
@@ -1,7 +0,0 @@--- Autogenerated by Cabal script... DO NOT MODIFY!-module Language.Haskell.Interpreter.GHC.LibDir ( ghc_libdir )--where--ghc_libdir :: FilePath-ghc_libdir = "/opt/local/lib/ghc-6.8.2"
− src/Language/Haskell/Interpreter/GHC/Parsers.hs
@@ -1,36 +0,0 @@-module Language.Haskell.Interpreter.GHC.Parsers--where--import Prelude hiding(span)--import qualified GHC(Session, getSessionDynFlags)--import qualified Lexer as GHC.L (P(..), ParseResult(..), mkPState)-import qualified Parser as GHC.P (parseStmt, parseType)-import qualified StringBuffer as GHC.SB(stringToStringBuffer)-import qualified SrcLoc as GHC.S (SrcSpan, noSrcLoc)-import qualified ErrUtils as GHC.E (Message)--data ParseResult = ParseOk | ParseError GHC.S.SrcSpan GHC.E.Message--parseExpr :: GHC.Session -> String -> IO ParseResult-parseExpr = runParser GHC.P.parseStmt--parseType :: GHC.Session -> String -> IO ParseResult-parseType = runParser GHC.P.parseType--runParser :: GHC.L.P a -> GHC.Session -> String -> IO ParseResult-runParser parser ghc_session expr =- do- dyn_fl <- GHC.getSessionDynFlags ghc_session- --- buf <- GHC.SB.stringToStringBuffer expr- --- let parse_res = GHC.L.unP parser (GHC.L.mkPState buf GHC.S.noSrcLoc dyn_fl)- --- case parse_res of- GHC.L.POk{} -> return ParseOk- --- GHC.L.PFailed span err -> return (ParseError span err)-
src/Language/Haskell/Interpreter/GHC/Unsafe.hs view
@@ -2,7 +2,8 @@ where -import Language.Haskell.Interpreter.GHC.Base ( Interpreter, setGhcOption )+import Hint.Base+import Hint.Configuration -- | Set a GHC option for the current session, -- eg. @unsafeSetGhcOption \"-fno-monomorphism-restriction\"@.
unit-tests/run-unit-tests.hs view
@@ -1,19 +1,23 @@-import Control.Exception ( catchDyn, finally )+module Main ( main ) where +import Control.Exception+ import Control.Monad ( liftM, when ) import Control.Monad.Trans ( MonadIO(liftIO) ) import Control.Monad.Error ( catchError ) -import System.Directory ( doesFileExist, removeFile )+import System.IO+import System.Directory import System.Exit + import Test.HUnit ( (@?=), (@?) ) import qualified Test.HUnit as HUnit import qualified Language.Haskell.Interpreter.GHC as H test_reload_modified :: H.InterpreterSession -> HUnit.Test-test_reload_modified s = testCase "reload_modifie" [mod_file] $ do+test_reload_modified s = testCase "reload_modified" [mod_file] $ do writeFile mod_file mod_v1 f_v1 <- H.withSession s get_f --@@ -58,31 +62,80 @@ return True `catchError` (\_ -> return False) +test_work_in_main :: H.InterpreterSession -> HUnit.Test+test_work_in_main s = testCase "work_in_main" [mod_file] $ do+ writeFile mod_file "f = id"+ H.withSession s $ do+ H.loadModules [mod_file]+ H.setTopLevelModules ["Main"]+ H.setImports ["Prelude"]+ --+ H.typeOf "f $ 1+1" @@?= "(Num a) => a"+ H.eval "f $ filter odd [1,2]" @@?= "[1]"+ H.interpret "f $ 1 == 2" H.infer @@?= False+ --+ where mod_file = "TEST_WorkInMain.hs"++test_priv_syms_in_scope :: H.InterpreterSession -> HUnit.Test+test_priv_syms_in_scope s = testCase "private_syms_in_scope" [mod_file] $ do+ writeFile mod_file mod_text+ H.withSession s $ do+ H.loadModules [mod_file]+ H.setTopLevelModules ["T"]+ H.typeChecks "g" @@? "g is hidden"+ where mod_text = unlines ["module T(f) where", "f = g", "g = id"]+ mod_file = "TEST_PrivateSymbolsInScope.hs"+++common_tests :: H.InterpreterSession -> [HUnit.Test]+common_tests s = [test_reload_modified s,+ test_lang_exts s,+ test_work_in_main s]+++non_sb_tests :: H.InterpreterSession -> HUnit.Test+non_sb_tests s = HUnit.TestList $ common_tests s ++ [test_priv_syms_in_scope s]++sb_tests :: H.InterpreterSession -> HUnit.Test+sb_tests s = HUnit.TestList $ common_tests s+ main :: IO () main = do s <- H.newSession --- c <- HUnit.runTestTT $ HUnit.TestList [- test_reload_modified s,- test_lang_exts s]+ -- run the tests...+ c <- HUnit.runTestTT $ non_sb_tests s+ -- then run again, but with sandboxing on...+ setSandbox s+ c' <- HUnit.runTestTT $ sb_tests s --- let failures = HUnit.errors c + HUnit.failures c+ 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- `catchDyn` printInterpreterError+ `catchDyn` (printInterpreterError >=> \_ -> exitWith (ExitFailure $ -1)) printInterpreterError :: H.InterpreterError -> IO ()-printInterpreterError e = do putStrLn $ "Ups... " ++ (show e)- exitWith (ExitFailure $ -1)+printInterpreterError = hPutStrLn stderr . show +setSandbox :: H.InterpreterSession -> IO ()+setSandbox s = H.withSession s $ H.setInstalledModsAreInScopeQualified False++(>=>) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c)+f >=> g = \a -> f a >>= g+ (@@?) :: (HUnit.AssertionPredicable p, MonadIO m) => m p -> String -> m () p @@? msg = do b <- p; liftIO (b @? msg) +(@@?=) :: (Eq a, Show a, MonadIO m) => m a -> a -> m ()+m_a @@?= b = do a <- m_a; liftIO (a @?= b)+ testCase :: String -> [FilePath] -> HUnit.Assertion -> HUnit.Test testCase title tmps test = HUnit.TestLabel title $- HUnit.TestCase (test `finally` clean_up)- where clean_up = mapM_ removeIfExists tmps+ HUnit.TestCase (test' `finally` clean_up)+ where test' = test `catchDyn` (printInterpreterError >=> throwDyn)+ clean_up = mapM_ removeIfExists tmps removeIfExists f = do exists <- doesFileExist f when exists $ removeFile f