diff --git a/Changes b/Changes --- a/Changes +++ b/Changes @@ -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 diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -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 diff --git a/hint.cabal b/hint.cabal --- a/hint.cabal +++ b/hint.cabal @@ -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 diff --git a/src/Hint/Base.hs b/src/Hint/Base.hs new file mode 100644 --- /dev/null +++ b/src/Hint/Base.hs @@ -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) diff --git a/src/Hint/Compat.hs b/src/Hint/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Hint/Compat.hs @@ -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 + diff --git a/src/Hint/Configuration.hs b/src/Hint/Configuration.hs new file mode 100644 --- /dev/null +++ b/src/Hint/Configuration.hs @@ -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} diff --git a/src/Hint/Context.hs b/src/Hint/Context.hs new file mode 100644 --- /dev/null +++ b/src/Hint/Context.hs @@ -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 () diff --git a/src/Hint/Conversions.hs b/src/Hint/Conversions.hs new file mode 100644 --- /dev/null +++ b/src/Hint/Conversions.hs @@ -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 diff --git a/src/Hint/Eval.hs b/src/Hint/Eval.hs new file mode 100644 --- /dev/null +++ b/src/Hint/Eval.hs @@ -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, ") "] diff --git a/src/Hint/Parsers.hs b/src/Hint/Parsers.hs new file mode 100644 --- /dev/null +++ b/src/Hint/Parsers.hs @@ -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) diff --git a/src/Hint/Reflection.hs b/src/Hint/Reflection.hs new file mode 100644 --- /dev/null +++ b/src/Hint/Reflection.hs @@ -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 diff --git a/src/Hint/Sandbox.hs b/src/Hint/Sandbox.hs new file mode 100644 --- /dev/null +++ b/src/Hint/Sandbox.hs @@ -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) diff --git a/src/Hint/Typecheck.hs b/src/Hint/Typecheck.hs new file mode 100644 --- /dev/null +++ b/src/Hint/Typecheck.hs @@ -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 diff --git a/src/Hint/Typecheck.hs-boot b/src/Hint/Typecheck.hs-boot new file mode 100644 --- /dev/null +++ b/src/Hint/Typecheck.hs-boot @@ -0,0 +1,5 @@ +module Hint.Typecheck where + +import Hint.Base (Interpreter) + +typeChecks_unsandboxed :: String -> Interpreter Bool diff --git a/src/Language/Haskell/Interpreter/GHC.hs b/src/Language/Haskell/Interpreter/GHC.hs --- a/src/Language/Haskell/Interpreter/GHC.hs +++ b/src/Language/Haskell/Interpreter/GHC.hs @@ -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 diff --git a/src/Language/Haskell/Interpreter/GHC/Base.hs b/src/Language/Haskell/Interpreter/GHC/Base.hs deleted file mode 100644 --- a/src/Language/Haskell/Interpreter/GHC/Base.hs +++ /dev/null @@ -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] diff --git a/src/Language/Haskell/Interpreter/GHC/Compat.hs b/src/Language/Haskell/Interpreter/GHC/Compat.hs deleted file mode 100644 --- a/src/Language/Haskell/Interpreter/GHC/Compat.hs +++ /dev/null @@ -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 - diff --git a/src/Language/Haskell/Interpreter/GHC/Conversions.hs b/src/Language/Haskell/Interpreter/GHC/Conversions.hs deleted file mode 100644 --- a/src/Language/Haskell/Interpreter/GHC/Conversions.hs +++ /dev/null @@ -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) - diff --git a/src/Language/Haskell/Interpreter/GHC/LibDir.hs b/src/Language/Haskell/Interpreter/GHC/LibDir.hs deleted file mode 100644 --- a/src/Language/Haskell/Interpreter/GHC/LibDir.hs +++ /dev/null @@ -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" diff --git a/src/Language/Haskell/Interpreter/GHC/Parsers.hs b/src/Language/Haskell/Interpreter/GHC/Parsers.hs deleted file mode 100644 --- a/src/Language/Haskell/Interpreter/GHC/Parsers.hs +++ /dev/null @@ -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) - diff --git a/src/Language/Haskell/Interpreter/GHC/Unsafe.hs b/src/Language/Haskell/Interpreter/GHC/Unsafe.hs --- a/src/Language/Haskell/Interpreter/GHC/Unsafe.hs +++ b/src/Language/Haskell/Interpreter/GHC/Unsafe.hs @@ -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\"@. diff --git a/unit-tests/run-unit-tests.hs b/unit-tests/run-unit-tests.hs --- a/unit-tests/run-unit-tests.hs +++ b/unit-tests/run-unit-tests.hs @@ -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