diff --git a/Changes b/Changes --- a/Changes +++ b/Changes @@ -1,3 +1,16 @@ +- ver 0.3.0.0 + * Updated API: + + InterpreterT monad transformer (Interpreter = InterpreterT IO) + + No more Sessions, use runInterpreter only once + + New options handling functions + - but observe that there is no setOptimizations equivalent; + since GHC does no optimization on interpreted code, this was actually + doing nothing + * Works with GHC 6.10 and 6.8 (untested with 6.6) + +- ver 0.2.5 + * setImportsQ added (modules can be imported both qualified and unqualified) + - ver 0.2.4.1 * BUGFIX: No longer fails on expressions ending in a -- comment diff --git a/README b/README --- a/README +++ b/README @@ -20,5 +20,5 @@ To get a copy of the darcs repository: -darcs get http://www.glyc.dc.uba.ar/daniel/repos/hint +darcs get http://code.haskell.org/~jcpetruzza/hint diff --git a/examples/example.hs b/examples/example.hs --- a/examples/example.hs +++ b/examples/example.hs @@ -1,27 +1,26 @@ import Control.Monad -import Control.Monad.Trans ( liftIO ) -import Language.Haskell.Interpreter.GHC - -import Control.Exception ( catchDyn ) +import Language.Haskell.Interpreter main :: IO () -main = do s <- newSession - withSession s testHint - putStrLn "that's all folks" - `catchDyn` printInterpreterError +main = do r <- runInterpreter testHint + case r of + Left err -> printInterpreterError err + Right () -> putStrLn "that's all folks" +-- observe that Interpreter () is an alias for InterpreterT IO () testHint :: Interpreter () testHint = do say "Load SomeModule.hs" loadModules ["SomeModule.hs"] -- - say "Put the Prelude and *SomeModule in scope" + say "Put the Prelude, Data.Map and *SomeModule in scope" + say "Data.Map is qualified as M!" setTopLevelModules ["SomeModule"] - setImports ["Prelude"] + setImportsQ [("Prelude", Nothing), ("Data.Map", Just "M")] -- say "Now we can query the type of an expression" - let expr1 = "(f, g, h, 42)" + let expr1 = "M.singleton (f, g, h, 42)" say $ "e.g. typeOf " ++ expr1 say =<< typeOf expr1 -- diff --git a/hint.cabal b/hint.cabal --- a/hint.cabal +++ b/hint.cabal @@ -1,5 +1,5 @@ name: hint -version: 0.2.4.1 +version: 0.3.0.0 description: This library defines an @Interpreter@ monad. It allows to load Haskell modules, browse them, type-check and evaluate strings with Haskell @@ -8,17 +8,19 @@ 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. + API. Works with GHC 6.10.x and 6.8.x + (this version was not tested with GHC 6.6). synopsis: Runtime Haskell interpreter (GHC API wrapper) category: Language, Compilers/Interpreters license: BSD3 license-file: LICENSE author: Daniel Gorin maintainer: jcpetruzza@gmail.com +homepage: http://code.haskell.org/~jcpetruzza/hint -cabal-version: >= 1.2 +cabal-version: >= 1.2.3 build-type: Simple -tested-with: GHC==6.6.1, GHC==6.8.2 +tested-with: GHC==6.8.3, GHC==6.10 extra-source-files: README AUTHORS @@ -28,30 +30,38 @@ unit-tests/run-unit-tests.hs Library + build-depends: haskell-src, + ghc > 6.6, + ghc-paths, + mtl, + filepath, + utf8-string, + Cabal >= 1.4, + MonadCatchIO-mtl 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 + build-depends: random, + directory + + if impl(ghc >= 6.10) { + build-depends: base >= 4, base < 5, + ghc-mtl + } else { + build-depends: base >= 3, base < 4 + } } + else { -- ghc < 6.8 + build-depends: utf8-string < 0.3 + } - exposed-modules: Language.Haskell.Interpreter.GHC + exposed-modules: Language.Haskell.Interpreter + Language.Haskell.Interpreter.Unsafe + Language.Haskell.Interpreter.GHC Language.Haskell.Interpreter.GHC.Unsafe - other-modules: Hint.Base + other-modules: Hint.GHC + Hint.Base + Hint.InterpreterT Hint.Compat + Hint.Compat.Exceptions Hint.Configuration Hint.Context Hint.Conversions @@ -60,6 +70,7 @@ Hint.Reflection Hint.Typecheck Hint.Sandbox + Hint.Util hs-source-dirs: src @@ -71,3 +82,10 @@ MagicHash TypeSynonymInstances FlexibleInstances + FlexibleContexts + FunctionalDependencies + KindSignatures + Rank2Types + ScopedTypeVariables + ExistentialQuantification + PatternGuards diff --git a/src/Hint/Base.hs b/src/Hint/Base.hs --- a/src/Hint/Base.hs +++ b/src/Hint/Base.hs @@ -1,193 +1,211 @@ -module Hint.Base +module Hint.Base ( + MonadInterpreter(..), RunGhc, + -- + GhcError(..), InterpreterError(..), finally, mayFail, + -- + InterpreterSession, SessionData(..), GhcErrLogger, + InterpreterState(..), fromState, onState, + InterpreterConfiguration(..), + -- + runGhc1, runGhc2, runGhc3, runGhc4, runGhc5, + -- + ModuleName, PhantomModule(..), + findModule, moduleIsLoaded, + -- + ghcVersion +) 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.GHC as GHC +import Hint.Compat.Exceptions -import qualified Hint.Compat as Compat -import Hint.Parsers +import Language.Haskell.Extension -newtype Interpreter a = - Interpreter{unInterpreter :: ReaderT SessionState - (ErrorT InterpreterError - IO) a} - deriving (Typeable, Functor, Monad, MonadIO) +-- | Version of the underlying ghc api. Values are: +-- +-- * @606@ for GHC 6.6.x +-- +-- * @608@ for GHC 6.8.x +-- +-- * @610@ for GHC 6.10.x +-- +-- * etc... +ghcVersion :: Int +ghcVersion = __GLASGOW_HASKELL__ +-- this requires FlexibleContexts +class (MonadCatchIO m,MonadError InterpreterError m) => MonadInterpreter m where + fromSession :: FromSession m a + modifySessionRef :: ModifySessionRef m a + runGhc :: RunGhc m a -instance MonadError InterpreterError Interpreter where - throwError = Interpreter . throwError - catchError (Interpreter m) catchE = Interpreter $ m `catchError` (\e -> - unInterpreter $ catchE e) +-- this is for hiding the actual types in haddock +type FromSession m a = (InterpreterSession -> a) -> m a +type ModifySessionRef m a = (InterpreterSession -> IORef a) -> (a -> a) -> m a + data InterpreterError = UnknownError String | WontCompile [GhcError] | NotAllowed String -- | GhcExceptions from the underlying GHC API are caught -- and rethrown as this. - | GhcException GHC.GhcException + | GhcException String deriving (Show, Typeable) instance Error InterpreterError where noMsg = UnknownError "" strMsg = UnknownError -data InterpreterConf = Conf{all_mods_in_scope :: Bool} +data InterpreterState = St{active_phantoms :: [PhantomModule], + zombie_phantoms :: [PhantomModule], + hint_support_module :: PhantomModule, + import_qual_hack_mod :: Maybe PhantomModule, + qual_imports :: [(ModuleName, String)], + configuration :: InterpreterConfiguration} -defaultConf :: InterpreterConf -defaultConf = Conf {all_mods_in_scope = True} +data InterpreterConfiguration = Conf { + language_exts :: [Extension], + all_mods_in_scope :: Bool + } --- 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} +#if __GLASGOW_HASKELL__ < 610 +type InterpreterSession = SessionData GHC.Session -data SessionState = SessionState{configuration :: IORef InterpreterConf, - ghcSession :: GHC.Session, - ghcErrListRef :: IORef [GhcError], - ghcErrLogger :: GhcErrLogger} +adjust :: (a -> b -> c) -> (b -> a -> c) +adjust f = flip f --- 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 +type RunGhc m a = (GHC.Session -> IO a) + -> m a +type RunGhc1 m a b = (GHC.Session -> a -> IO b) + -> (a -> m b) +type RunGhc2 m a b c = (GHC.Session -> a -> b -> IO c) + -> (a -> b -> m c) +type RunGhc3 m a b c d = (GHC.Session -> a -> b -> c -> IO d) + -> (a -> b -> c -> m d) + +type RunGhc4 m a b c d e = (GHC.Session -> a -> b -> c -> d -> IO e) + -> (a -> b -> c -> d -> m e) + +type RunGhc5 m a b c d e f = (GHC.Session -> a -> b -> c -> d -> e -> IO f) + -> (a -> b -> c -> d -> e -> m f) + +#else + -- ghc >= 6.10 +type InterpreterSession = SessionData () + +instance Exception InterpreterError + +adjust :: (a -> b) -> (a -> b) +adjust = id + +type RunGhc m a = + (forall n.(MonadCatchIO n,Functor n) => GHC.GhcT n a) + -> m a + +type RunGhc1 m a b = + (forall n.(MonadCatchIO n, Functor n) => a -> GHC.GhcT n b) + -> (a -> m b) + +type RunGhc2 m a b c = + (forall n.(MonadCatchIO n, Functor n) => a -> b -> GHC.GhcT n c) + -> (a -> b -> m c) + +type RunGhc3 m a b c d = + (forall n.(MonadCatchIO n, Functor n) => a -> b -> c -> GHC.GhcT n d) + -> (a -> b -> c -> m d) + +type RunGhc4 m a b c d e = + (forall n.(MonadCatchIO n, Functor n) => a -> b -> c -> d -> GHC.GhcT n e) + -> (a -> b -> c -> d -> m e) + +type RunGhc5 m a b c d e f = + (forall n.(MonadCatchIO n, Functor n) => a->b->c->d->e->GHC.GhcT n f) + -> (a -> b -> c -> d -> e -> m f) +#endif + +data SessionData a = SessionData { + internalState :: IORef InterpreterState, + versionSpecific :: a, + ghcErrListRef :: IORef [GhcError], + ghcErrLogger :: GhcErrLogger + } + +-- When intercepting errors reported by GHC, we only get a ErrUtils.Message +-- and a SrcLoc.SrcSpan. The latter holds the file name and the location -- of the error. However, SrcSpan is abstract and it doesn't provide -- functions to retrieve the line and column of the error... we can only -- generate a string with this information. Maybe I can parse this string -- later.... (sigh) -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 +newtype GhcError = GhcError{errMsg :: String} deriving Show -mapGhcExceptions :: (String -> InterpreterError) -> IO a -> Interpreter a +mapGhcExceptions :: MonadInterpreter m + => (String -> InterpreterError) + -> m a + -> m 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 - + do action + `catchError` (\err -> case err of + GhcException s -> throwError (buildEx s) + _ -> throwError err) type GhcErrLogger = GHC.Severity - -> GHC.S.SrcSpan - -> GHC.O.PprStyle - -> GHC.E.Message + -> GHC.SrcSpan + -> GHC.PprStyle + -> GHC.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 - +runGhc1 :: MonadInterpreter m => RunGhc1 m a b +runGhc1 f a = runGhc (adjust f a) --- ================= Executing the interpreter ================== +runGhc2 :: MonadInterpreter m => RunGhc2 m a b c +runGhc2 f a = runGhc1 (adjust f a) --- | 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 +runGhc3 :: MonadInterpreter m => RunGhc3 m a b c d +runGhc3 f a = runGhc2 (adjust f a) -rethrowGhcException :: GHC.GhcException -> IO a -rethrowGhcException = throwDyn . GhcException +runGhc4 :: MonadInterpreter m => RunGhc4 m a b c d e +runGhc4 f a = runGhc3 (adjust f a) +runGhc5 :: MonadInterpreter m => RunGhc5 m a b c d e f +runGhc5 f a = runGhc4 (adjust f a) -- ================ Handling the interpreter state ================= -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 +fromState :: MonadInterpreter m => (InterpreterState -> a) -> m a +fromState f = do ref_st <- fromSession internalState + liftIO $ f `fmap` readIORef ref_st -onConf :: (InterpreterConf -> InterpreterConf) -> Interpreter () -onConf f = modifySessionStateRef configuration f >> return () +onState :: MonadInterpreter m => (InterpreterState -> InterpreterState) -> m () +onState f = modifySessionRef internalState f >> return () -- =============== Error handling ============================== -mayFail :: IO (Maybe a) -> Interpreter a -mayFail ghc_action = +mayFail :: MonadInterpreter m => m (Maybe a) -> m a +mayFail action = do - maybe_res <- liftIO ghc_action + maybe_res <- action -- - es <- modifySessionStateRef ghcErrListRef (const []) + es <- modifySessionRef 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!" + case (maybe_res, null es) of + (Nothing,True) -> throwError $ UnknownError "Got no error message" + (Nothing,False) -> throwError $ WontCompile (reverse es) + (Just a, True) -> return a + (Just _, False) -> fail $ "GHC returned a result but said: " ++ + show es -finally :: Interpreter a -> Interpreter () -> Interpreter a +finally :: MonadInterpreter m => m a -> m () -> m a finally action clean_up = do r <- protected_action clean_up return r @@ -198,42 +216,18 @@ -- ================ 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 +-- this type ought to go in Hint.Context, but ghc dislikes cyclic imports... +data PhantomModule = PhantomModule{pm_name :: ModuleName, pm_file :: FilePath} + deriving (Eq, Show) -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) +findModule :: MonadInterpreter m => ModuleName -> m GHC.Module +findModule mn = mapGhcExceptions NotAllowed $ + runGhc2 GHC.findModule mod_name Nothing + where mod_name = GHC.mkModuleName mn + + +moduleIsLoaded :: MonadInterpreter m => ModuleName -> m Bool +moduleIsLoaded mn = (findModule mn >> return True) + `catchError` (\e -> case e of + NotAllowed{} -> return False + _ -> throwError e) diff --git a/src/Hint/Compat.hs b/src/Hint/Compat.hs --- a/src/Hint/Compat.hs +++ b/src/Hint/Compat.hs @@ -2,51 +2,107 @@ where -import qualified GHC -import qualified Pretty -import qualified Outputable - -#if __GLASGOW_HASKELL__ >= 608 - -import qualified PprTyThing - -#endif +import qualified Hint.GHC as GHC -- Kinds became a synonym for Type in GHC 6.8. We define this wrapper -- to be able to define a FromGhcRep instance for both versions newtype Kind = Kind GHC.Kind -#if __GLASGOW_HASKELL__ >= 608 +#if __GLASGOW_HASKELL__ >= 610 +configureDynFlags :: GHC.DynFlags -> GHC.DynFlags +configureDynFlags dflags = dflags{GHC.ghcMode = GHC.CompManager, + GHC.hscTarget = GHC.HscInterpreted, + GHC.ghcLink = GHC.LinkInMemory, + GHC.verbosity = 0} +parseDynamicFlags :: GHC.GhcMonad m + => GHC.DynFlags -> [String] -> m (GHC.DynFlags, [String]) +parseDynamicFlags d = fmap firstTwo . GHC.parseDynamicFlags d . map GHC.noLoc + where firstTwo (a,b,_) = (a, map GHC.unLoc b) + +fileTarget :: FilePath -> GHC.Target +fileTarget f = GHC.Target (GHC.TargetFile f $ Just next_phase) True Nothing + where next_phase = GHC.Cpp GHC.HsSrcFile + +targetId :: GHC.Target -> GHC.TargetId +targetId = GHC.targetId + +guessTarget :: GHC.GhcMonad m => String -> Maybe GHC.Phase -> m GHC.Target +guessTarget = GHC.guessTarget + +-- add a bogus Maybe, in order to use it with mayFail +compileExpr :: GHC.GhcMonad m => String -> m (Maybe GHC.HValue) +compileExpr = fmap Just . GHC.compileExpr + +-- add a bogus Maybe, in order to use it with mayFail +exprType :: GHC.GhcMonad m => String -> m (Maybe GHC.Type) +exprType = fmap Just . GHC.exprType + +-- add a bogus Maybe, in order to use it with mayFail +typeKind :: GHC.GhcMonad m => String -> m (Maybe GHC.Kind) +typeKind = fmap Just . GHC.typeKind +#else +-- add a bogus session parameter, in order to use it with runGhc2 +parseDynamicFlags :: GHC.Session + -> GHC.DynFlags + -> [String] -> IO (GHC.DynFlags, [String]) +parseDynamicFlags = const GHC.parseDynamicFlags + +fileTarget :: FilePath -> GHC.Target +fileTarget f = GHC.Target (GHC.TargetFile f $ Just next_phase) Nothing + where next_phase = GHC.Cpp GHC.HsSrcFile + +targetId :: GHC.Target -> GHC.TargetId +targetId (GHC.Target _id _) = _id + +-- add a bogus session parameter, in order to use it with runGhc2 +guessTarget :: GHC.Session -> String -> Maybe GHC.Phase -> IO GHC.Target +guessTarget = const GHC.guessTarget + +compileExpr :: GHC.Session -> String -> IO (Maybe GHC.HValue) +compileExpr = GHC.compileExpr + +exprType :: GHC.Session -> String -> IO (Maybe GHC.Type) +exprType = GHC.exprType + +typeKind :: GHC.Session -> String -> IO (Maybe GHC.Kind) +typeKind = GHC.typeKind + +#endif + +#if __GLASGOW_HASKELL__ >= 608 +#if __GLASGOW_HASKELL__ < 610 + -- 6.08 only newSession :: FilePath -> IO GHC.Session -newSession ghc_root = - 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 +newSession ghc_root = GHC.newSession (Just ghc_root) -pprType :: GHC.Type -> (Outputable.PprStyle -> Pretty.Doc) -pprType = PprTyThing.pprTypeForUser False -- False means drop explicit foralls +configureDynFlags :: GHC.DynFlags -> GHC.DynFlags +configureDynFlags dflags = dflags{GHC.ghcMode = GHC.CompManager, + GHC.hscTarget = GHC.HscInterpreted, + GHC.ghcLink = GHC.LinkInMemory} +#endif -pprKind :: GHC.Kind -> (Outputable.PprStyle -> Pretty.Doc) + -- 6.08 and above +pprType :: GHC.Type -> (GHC.PprStyle -> GHC.Doc) +pprType = GHC.pprTypeForUser False -- False means drop explicit foralls + +pprKind :: GHC.Kind -> (GHC.PprStyle -> GHC.Doc) pprKind = pprType #elif __GLASGOW_HASKELL__ >= 606 + -- 6.6 only 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 +newSession ghc_root = GHC.newSession GHC.Interactive (Just ghc_root) -pprType :: GHC.Type -> (Outputable.PprStyle -> Pretty.Doc) -pprType = Outputable.ppr . GHC.dropForAlls +configureDynFlags :: GHC.DynFlags -> GHC.DynFlags +configureDynFlags dflags = dflags{GHC.hscTarget = GHC.HscInterpreted} -pprKind :: GHC.Kind -> (Outputable.PprStyle -> Pretty.Doc) -pprKind = Outputable.ppr +pprType :: GHC.Type -> (GHC.PprStyle -> GHC.Doc) +pprType = GHC.ppr . GHC.dropForAlls + +pprKind :: GHC.Kind -> (GHC.PprStyle -> GHC.Doc) +pprKind = GHC.ppr #endif diff --git a/src/Hint/Compat/Exceptions.hs b/src/Hint/Compat/Exceptions.hs new file mode 100644 --- /dev/null +++ b/src/Hint/Compat/Exceptions.hs @@ -0,0 +1,27 @@ +module Hint.Compat.Exceptions ( +#if __GLASGOW_HASKELL__ >= 610 + module Control.Monad.CatchIO +#else + throw, catch, + module Control.Monad.CatchIO.Old +#endif + +) + +where + +import Prelude hiding ( catch ) + +#if __GLASGOW_HASKELL__ >= 610 +import Control.Monad.CatchIO +#else +import Data.Dynamic + +import Control.Monad.CatchIO.Old hiding ( throw, catch ) + +throw :: Typeable e => e -> a +throw = throwDyn + +catch :: (Typeable e, MonadCatchIO m) => m a -> (e -> m a) -> m a +catch = catchDyn +#endif diff --git a/src/Hint/Configuration.hs b/src/Hint/Configuration.hs --- a/src/Hint/Configuration.hs +++ b/src/Hint/Configuration.hs @@ -2,52 +2,167 @@ setGhcOption, setGhcOptions, + defaultConf, fromConf, onConf, + + get, set, Option, OptionVal(..), + + languageExtensions, availableExtensions, glasgowExtensions, Extension(..), + installedModulesInScope, + setUseLanguageExtensions, - Optimizations(..), setOptimizations, setInstalledModsAreInScopeQualified ) where import Control.Monad.Error -import qualified GHC +import Data.Char +import Data.List ( intersect ) + +import qualified Hint.GHC as GHC +import qualified Hint.Compat as Compat import Hint.Base +import Hint.Util ( partition ) -setGhcOptions :: [String] -> Interpreter () +import Language.Haskell.Extension + +setGhcOptions :: MonadInterpreter m => [String] -> m () setGhcOptions opts = - do ghc_session <- fromSessionState ghcSession - old_flags <- liftIO $ GHC.getSessionDynFlags ghc_session - (new_flags, not_parsed) <- liftIO $ GHC.parseDynamicFlags old_flags opts + do old_flags <- runGhc GHC.getSessionDynFlags + (new_flags,not_parsed) <- runGhc2 Compat.parseDynamicFlags old_flags opts when (not . null $ not_parsed) $ throwError $ UnknownError (concat ["flag: '", unwords opts, "' not recognized"]) - liftIO $ GHC.setSessionDynFlags ghc_session new_flags + runGhc1 GHC.setSessionDynFlags new_flags return () -setGhcOption :: String -> Interpreter () +setGhcOption :: MonadInterpreter m => String -> m () 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" +defaultConf :: InterpreterConfiguration +defaultConf = Conf { + language_exts = [], + all_mods_in_scope = False + } -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" +-- | Available options are: +-- +-- * 'languageExtensions' +-- +-- * 'installedModulesInScope' +data Option m a = Option{_set :: MonadInterpreter m => a -> m (), + _get :: MonadInterpreter m => m a} +data OptionVal m = forall a . (Option m a) := a + +-- | Use this function to set or modify the value of any option. It is +-- invoked like this: +-- +-- @set [opt1 := val1, opt2 := val2,... optk := valk]@ +set :: MonadInterpreter m => [OptionVal m] -> m () +set = mapM_ $ \(opt := val) -> _set opt val + +-- | Retrieves the value of an option. +get :: MonadInterpreter m => Option m a -> m a +get = _get + +-- | Language extensions in use by the interpreter. +-- +-- Default is: @[]@ (i.e. none, pure Haskell 98) +languageExtensions :: MonadInterpreter m => Option m [Extension] +languageExtensions = Option setter getter + where setter es = do setGhcOptions $ map (mkFlag False) availableExtensions + setGhcOptions $ map (mkFlag True) es + onConf $ \c -> c{language_exts = es} + -- + getter = fromConf language_exts + -- + mkFlag b (UnknownExtension o) = "-X" ++ concat ["No"|not b] ++ o + mkFlag b o + | ('N':'o':c:_) <- show o, + isUpper c = if b + then "-X" ++ show o + else "-X" ++ (drop 2 $ show o) + | otherwise = "-X" ++ concat ["No"|not b] ++ show o + +-- | List of the extensions known by the interpreter. +availableExtensions :: [Extension] +availableExtensions = asExtensionList GHC.supportedLanguages + +asExtensionList :: [String] -> [Extension] +asExtensionList exts = map read knownPos ++ + map read (map ("No" ++) knownNegs) ++ + map UnknownExtension unknown + where (knownPos, unknownPos) = partition isKnown exts + (knownNegs,unknown) = partition (isKnown . ("No" ++)) unknownPos + isKnown e = e `elem` map show knownExtensions + + +-- | List of extensions turned on when the @-fglasgow-exts@ flag is used +glasgowExtensions :: [Extension] +glasgowExtensions = intersect availableExtensions exts610 -- works also for 608 + where exts610 = asExtensionList ["ForeignFunctionInterface", + "UnliftedFFITypes", + "GADTs", + "ImplicitParams", + "ScopedTypeVariables", + "UnboxedTuples", + "TypeSynonymInstances", + "StandaloneDeriving", + "DeriveDataTypeable", + "FlexibleContexts", + "FlexibleInstances", + "ConstrainedClassMethods", + "MultiParamTypeClasses", + "FunctionalDependencies", + "MagicHash", + "PolymorphicComponents", + "ExistentialQuantification", + "UnicodeSyntax", + "PostfixOperators", + "PatternGuards", + "LiberalTypeSynonyms", + "RankNTypes", + "ImpredicativeTypes", + "TypeOperators", + "RecursiveDo", + "ParallelListComp", + "EmptyDataDecls", + "KindSignatures", + "GeneralizedNewtypeDeriving", + "TypeFamilies" ] + -- | When set to @True@, every module in every available package is implicitly -- imported qualified. This is very convenient for interactive -- evaluation, but can be a problem in sandboxed environments --- (e.g. 'System.Unsafe.unsafePerformIO' is in scope'). +-- (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} +installedModulesInScope :: MonadInterpreter m => Option m Bool +installedModulesInScope = Option setter getter + where getter = fromConf all_mods_in_scope + setter b = do onConf $ \c -> c{all_mods_in_scope = b} + when ( ghcVersion >= 610 ) $ + setGhcOption $ "-f" ++ + concat ["no-" | not b] ++ + "implicit-import-qualified" + +fromConf :: MonadInterpreter m => (InterpreterConfiguration -> a) -> m a +fromConf f = fromState (f . configuration) + +onConf :: MonadInterpreter m + => (InterpreterConfiguration -> InterpreterConfiguration) + -> m () +onConf f = onState $ \st -> st{configuration = f (configuration st)} + +{-# DEPRECATED setUseLanguageExtensions "Use set [languageExtensions := (ExtendedDefaultRules:glasgowExtensions)] instead." #-} +setUseLanguageExtensions :: MonadInterpreter m => Bool -> m () +setUseLanguageExtensions False = set [languageExtensions := []] +setUseLanguageExtensions True = set [languageExtensions := exts] + where exts = ExtendedDefaultRules : glasgowExtensions + +{-# DEPRECATED setInstalledModsAreInScopeQualified "Use set [installedModulesInScope := b] instead." #-} +setInstalledModsAreInScopeQualified :: MonadInterpreter m => Bool -> m () +setInstalledModsAreInScopeQualified b = set [installedModulesInScope := b] diff --git a/src/Hint/Context.hs b/src/Hint/Context.hs --- a/src/Hint/Context.hs +++ b/src/Hint/Context.hs @@ -2,124 +2,327 @@ ModuleName, loadModules, getLoadedModules, setTopLevelModules, - setImports, - reset + setImports, setImportsQ, + reset, + PhantomModule(..), ModuleText, + addPhantomModule, removePhantomModule, getPhantomModules, + + allModulesInContext, onAnEmptyContext, + + support_String, support_show ) where +import Prelude hiding ( mod ) + +import Data.Char import Data.List +import Data.Maybe -import Control.Monad.Error +import Control.Monad ( liftM, filterM, when, guard ) +import Control.Monad.Error ( catchError, throwError, liftIO ) import Hint.Base +import Hint.Util ( (>=>) ) -- compat version import Hint.Conversions +import qualified Hint.Util as Util +import qualified Hint.Compat as Compat -import qualified GHC +import qualified Hint.GHC as GHC +import System.Random +import System.FilePath +import System.Directory +import qualified System.IO.UTF8 as UTF8 (writeFile) + +type ModuleText = String + +-- When creating a phantom module we have a situation similar to that of +-- @Hint.Util.safeBndFor@: we want to avoid picking a module name that is +-- already in-scope. Additionally, since this may be used with sandboxing in +-- mind we want to avoid easy-to-guess names. Thus, we do a trick similar +-- to the one in safeBndFor, but including a random number instead of an +-- additional digit +newPhantomModule :: MonadInterpreter m => m PhantomModule +newPhantomModule = + do n <- liftIO randomIO + (ls,is) <- allModulesInContext + let nums = concat [show (abs n::Int), filter isDigit $ concat (ls ++ is)] + let mod_name = 'M':nums + -- + tmp_dir <- liftIO getTemporaryDirectory + -- + return PhantomModule{pm_name = mod_name, pm_file = tmp_dir nums} + +allModulesInContext :: MonadInterpreter m => m ([ModuleName], [ModuleName]) +allModulesInContext = + do (l, i) <- runGhc GHC.getContext + return (map fromGhcRep_ l, map fromGhcRep_ i) + +addPhantomModule :: MonadInterpreter m + => (ModuleName -> ModuleText) + -> m PhantomModule +addPhantomModule mod_text = + do pm <- newPhantomModule + let t = Compat.fileTarget (pm_file pm) + m = GHC.mkModuleName (pm_name pm) + -- + liftIO $ UTF8.writeFile (pm_file pm) (mod_text $ pm_name pm) + -- + onState (\s -> s{active_phantoms = pm:active_phantoms s}) + mayFail (do -- GHC.load will remove all the modules from scope, so first + -- we save the context... + (old_top, old_imps) <- runGhc GHC.getContext + -- + runGhc1 GHC.addTarget t + res <- runGhc1 GHC.load (GHC.LoadUpTo m) + -- + if isSucceeded res + then do runGhc2 GHC.setContext old_top old_imps + return $ Just () + else return Nothing) + `catchError` (\err -> case err of + WontCompile _ -> do removePhantomModule pm + throwError err + _ -> throwError err) + -- + return pm + +removePhantomModule :: MonadInterpreter m => PhantomModule -> m () +removePhantomModule pm = + do -- We don't want to actually unload this module, because that + -- would mean that all the real modules might get reloaded and the + -- user didn't require that (they may be in a non-compiling state!). + -- However, this means that we can't actually delete the file, because + -- it is an active target. Therefore, we simply take it out of scope + -- and mark it as "delete me when possible" (i.e., next time the + -- @loadModules@ function is called). + -- + isLoaded <- moduleIsLoaded $ pm_name pm + safeToRemove <- + if isLoaded + then do -- take it out of scope + mod <- findModule (pm_name pm) + (mods, imps) <- runGhc GHC.getContext + let mods' = filter (mod /=) mods + runGhc2 GHC.setContext mods' imps + -- + let isNotPhantom = isPhantomModule . fromGhcRep_ >=> + return . not + null `liftM` filterM isNotPhantom mods' + else return True + -- + let file_name = pm_file pm + runGhc1 GHC.removeTarget (Compat.targetId $ Compat.fileTarget file_name) + -- + onState (\s -> s{active_phantoms = filter (pm /=) $ active_phantoms s}) + -- + if safeToRemove + then do mayFail $ do res <- runGhc1 GHC.load GHC.LoadAllTargets + return $ guard (isSucceeded res) >> Just () + liftIO $ removeFile (pm_file pm) + else do onState (\s -> s{zombie_phantoms = pm:zombie_phantoms s}) + return () + +-- Returns a tuple with the active and zombie phantom modules respectively +getPhantomModules :: MonadInterpreter m => m ([PhantomModule], [PhantomModule]) +getPhantomModules = do active <- fromState active_phantoms + zombie <- fromState zombie_phantoms + return (active, zombie) + +isPhantomModule :: MonadInterpreter m => ModuleName -> m Bool +isPhantomModule mn = do (as,zs) <- getPhantomModules + return $ mn `elem` (map pm_name $ as ++ zs) + -- | Tries to load all the requested modules from their source file. -- Modules my be indicated by their ModuleName (e.g. \"My.Module\") or -- by the full path to its source file. -- -- The interpreter is 'reset' both before loading the modules and in the event -- of an error. -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 () +loadModules :: MonadInterpreter m => [String] -> m () +loadModules fs = do -- first, unload everything, and do some clean-up + reset + doLoad fs `catchError` (\e -> reset >> throwError e) +doLoad :: MonadInterpreter m => [String] -> m () +doLoad fs = do mayFail $ do + targets <- mapM (\f->runGhc2 Compat.guessTarget f Nothing) fs + -- + runGhc1 GHC.setTargets targets + res <- runGhc1 GHC.load GHC.LoadAllTargets + -- loading the targets removes the support module + reinstallSupportModule + return $ guard (isSucceeded res) >> Just () + -- | Returns the list of modules loaded with 'loadModules'. -getLoadedModules :: Interpreter [ModuleName] -getLoadedModules = liftM (map modNameFromSummary) getLoadedModSummaries +getLoadedModules :: MonadInterpreter m => m [ModuleName] +getLoadedModules = do (active_pms, zombie_pms) <- getPhantomModules + ms <- map modNameFromSummary `liftM` getLoadedModSummaries + return $ ms \\ (map pm_name $ active_pms ++ zombie_pms) modNameFromSummary :: GHC.ModSummary -> ModuleName modNameFromSummary = fromGhcRep_ . GHC.ms_mod -getLoadedModSummaries :: Interpreter [GHC.ModSummary] +getLoadedModSummaries :: MonadInterpreter m => m [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 + do all_mod_summ <- runGhc GHC.getModuleGraph + filterM (runGhc1 GHC.isLoaded . GHC.ms_mod_name) all_mod_summ -- | Sets the modules whose context is used during evaluation. All bindings -- of these modules are in scope, not only those exported. -- -- Modules must be interpreted to use this function. -setTopLevelModules :: [ModuleName] -> Interpreter () +setTopLevelModules :: MonadInterpreter m => [ModuleName] -> m () 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 + do 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) + -- + active_pms <- fromState active_phantoms + ms_mods <- mapM findModule (nub $ ms ++ map pm_name active_pms) + -- + let mod_is_interpr = runGhc1 GHC.moduleIsInterpreted + not_interpreted <- filterM (liftM not . mod_is_interpr) ms_mods + when (not . null $ not_interpreted) $ + throwError $ NotAllowed ("These modules are not interpreted:\n" ++ + unlines (map fromGhcRep_ not_interpreted)) + -- + (_, old_imports) <- runGhc GHC.getContext + runGhc2 GHC.setContext ms_mods old_imports +onAnEmptyContext :: MonadInterpreter m => m a -> m a +onAnEmptyContext action = + do (old_mods, old_imps) <- runGhc GHC.getContext + runGhc2 GHC.setContext [] [] + let restore = runGhc2 GHC.setContext old_mods old_imps + a <- action `catchError` (\e -> do restore; throwError e) + restore + return a + -- | 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 +-- +-- Warning: 'setImports' and 'setImportsQ' are mutually exclusive. +-- If you have a list of modules to be used qualified and another list +-- unqualified, then you need to do something like +-- +-- > setImportsQ ((zip unqualified $ repeat Nothing) ++ qualifieds) +setImports :: MonadInterpreter m => [ModuleName] -> m () +setImports ms = setImportsQ $ zip ms (repeat Nothing) +-- | Sets the modules whose exports must be in context; some +-- of them may be qualified. E.g.: +-- +-- @setImports [("Prelude", Nothing), ("Data.Map", Just "M")]@. +-- +-- Here, "map" will refer to Prelude.map and "M.map" to Data.Map.map. +setImportsQ :: MonadInterpreter m => [(ModuleName, Maybe String)] -> m () +setImportsQ ms = + do let (q, u) = Util.partition (isJust . snd) ms + (quals, unquals) = (map (\(a, Just b) -> (a,b)) q, map fst u) + -- + unqual_mods <- mapM findModule unquals + mapM_ (findModule . fst) quals -- just to be sure they exist + -- + old_qual_hack_mod <- fromState import_qual_hack_mod + maybe (return ()) removePhantomModule old_qual_hack_mod + -- + new_pm <- if ( not $ null quals ) + then do + new_pm <- addPhantomModule $ \mod_name -> unlines $ + ("module " ++ mod_name ++ " where ") : + ["import qualified " ++ m ++ " as " ++ n | + (m,n) <- quals] + onState (\s -> s{import_qual_hack_mod = Just new_pm}) + return $ Just new_pm + else return Nothing + -- + pm <- maybe (return []) (findModule . pm_name >=> return . return) new_pm + (old_top_level, _) <- runGhc GHC.getContext + let new_top_level = pm ++ old_top_level + runGhc2 GHC.setContext new_top_level unqual_mods + -- + onState (\s ->s{qual_imports = quals}) + -- | 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 :: MonadInterpreter m => m () 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 () + do -- Remove all modules from context + runGhc2 GHC.setContext [] [] + -- + -- Unload all previously loaded modules + runGhc1 GHC.setTargets [] + runGhc1 GHC.load GHC.LoadAllTargets + -- + -- At this point, GHCi would call rts_revertCAFs and + -- reset the buffering of stdin, stdout and stderr. + -- Should we do any of these? + -- + -- liftIO $ rts_revertCAFs + -- + -- We now remove every phantom module and forget about qual imports + old_active <- fromState active_phantoms + old_zombie <- fromState zombie_phantoms + onState (\s -> s{active_phantoms = [], + zombie_phantoms = [], + import_qual_hack_mod = Nothing, + qual_imports = []}) + liftIO $ mapM_ (removeFile . pm_file) (old_active ++ old_zombie) + -- + -- Now, install a support module + installSupportModule + +-- Load a phantom module with all the symbols from the prelude we need +installSupportModule :: MonadInterpreter m => m () +installSupportModule = do mod <- addPhantomModule support_module + onState (\st -> st{hint_support_module = mod}) + mod' <- findModule (pm_name mod) + runGhc2 GHC.setContext [mod'] [] + -- + where support_module m = unlines [ + "module " ++ m ++ "( ", + " " ++ _String ++ ",", + " " ++ _show ++ ")", + "where", + "", + "import qualified Prelude as P", + "", + "type " ++ _String ++ " = P.String", + "", + _show ++ " :: P.Show a => a -> P.String", + _show ++ " = P.show" + ] + where _String = altStringName m + _show = altShowName m + +-- Call it when the support module is an active phantom module but has been +-- unloaded as a side effect by GHC (e.g. by calling GHC.loadTargets) +reinstallSupportModule :: MonadInterpreter m => m () +reinstallSupportModule = do pm <- fromState hint_support_module + removePhantomModule pm + installSupportModule + +altStringName :: ModuleName -> String +altStringName mod_name = "String_" ++ mod_name + +altShowName :: ModuleName -> String +altShowName mod_name = "show_" ++ mod_name + +support_String :: MonadInterpreter m => m String +support_String = do mod_name <- fromState (pm_name . hint_support_module) + return $ concat [mod_name, ".", altStringName mod_name] + +support_show :: MonadInterpreter m => m String +support_show = do mod_name <- fromState (pm_name . hint_support_module) + return $ concat [mod_name, ".", altShowName mod_name] -- SHOULD WE CALL THIS WHEN MODULES ARE LOADED / UNLOADED? -- foreign import ccall "revertCAFs" rts_revertCAFs :: IO () diff --git a/src/Hint/Conversions.hs b/src/Hint/Conversions.hs --- a/src/Hint/Conversions.hs +++ b/src/Hint/Conversions.hs @@ -2,10 +2,7 @@ where -import Control.Monad.Trans ( liftIO ) - -import qualified GHC as GHC -import qualified Outputable as GHC.O +import qualified Hint.GHC as GHC import Hint.Base import qualified Hint.Compat as Compat @@ -15,7 +12,7 @@ -- | Conversions from GHC representation to standard representations class FromGhcRep ghc target where - fromGhcRep :: ghc -> Interpreter target + fromGhcRep :: MonadInterpreter m => ghc -> m target class FromGhcRep_ ghc target where fromGhcRep_ :: ghc -> target @@ -35,11 +32,10 @@ instance FromGhcRep GHC.Type String where - fromGhcRep t = do ghc_session <- fromSessionState ghcSession - -- Unqualify necessary types + fromGhcRep t = do -- Unqualify necessary types -- (i.e., do not expose internals) - unqual <- liftIO $ GHC.getPrintUnqual ghc_session - return $ GHC.O.showSDocForUser unqual (Compat.pprType t) + unqual <- runGhc GHC.getPrintUnqual + return $ GHC.showSDocForUser unqual (Compat.pprType t) parseModule' :: String -> HsModule parseModule' s = case parseModule s of @@ -49,7 +45,7 @@ show failed] instance FromGhcRep_ Compat.Kind String where - fromGhcRep_ (Compat.Kind k) = GHC.O.showSDoc (Compat.pprKind k) + fromGhcRep_ (Compat.Kind k) = GHC.showSDoc (Compat.pprKind k) -- ---------------- Modules -------------------------- diff --git a/src/Hint/Eval.hs b/src/Hint/Eval.hs --- a/src/Hint/Eval.hs +++ b/src/Hint/Eval.hs @@ -5,19 +5,20 @@ where -import qualified GHC import qualified GHC.Exts ( unsafeCoerce# ) import Data.Typeable hiding ( typeOf ) import qualified Data.Typeable ( typeOf ) -import Data.Char - import Hint.Base +import Hint.Context import Hint.Parsers import Hint.Sandbox +import Hint.Util +import qualified Hint.Compat as Compat + -- | Convenience functions to be used with @interpret@ to provide witnesses. -- Example: -- @@ -29,39 +30,31 @@ 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 +interpret :: (MonadInterpreter m, Typeable a) => String -> a -> m a +interpret expr wit = unsafeInterpret expr (show $ Data.Typeable.typeOf wit) + + +unsafeInterpret :: (MonadInterpreter m) => String -> String -> m a +unsafeInterpret expr type_str = sandboxed go expr where go e = - do ghc_session <- fromSessionState ghcSession - -- - -- First, make sure the expression has no syntax errors, + do -- First, make sure the expression has no syntax errors, -- for this is the only way we have to "intercept" this -- kind of errors failOnParseError parseExpr e -- - let expr_typesig = concat [parens e," :: ",show $ myTypeOf witness] - expr_val <- mayFail $ GHC.compileExpr ghc_session expr_typesig + let expr_typesig = concat [parens e, " :: ", type_str] + expr_val <- mayFail $ runGhc1 Compat.compileExpr 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 = "Prelude.show" ++ (parens expr) - +eval :: MonadInterpreter m => String -> m String +eval expr = do in_scope_show <- support_show + in_scope_String <- support_String + let show_expr = unwords [in_scope_show, parens expr] + unsafeInterpret show_expr in_scope_String -- Conceptually, @parens s = "(" ++ s ++ ")"@, where s is some valid haskell -- expression. In practice, it is harder than this. @@ -75,5 +68,4 @@ parens :: String -> String parens s = concat ["(let {", foo, " = ", s, "\n", " ;} in ", foo, ")"] - where foo = "foo_1" ++ filter isDigit s - -- same trick as in Sandbox.safeBndFor + where foo = safeBndFor s diff --git a/src/Hint/GHC.hs b/src/Hint/GHC.hs new file mode 100644 --- /dev/null +++ b/src/Hint/GHC.hs @@ -0,0 +1,49 @@ +module Hint.GHC ( + module GHC, + module Outputable, + module ErrUtils, + module Pretty, + module DriverPhases, + module StringBuffer, + module Lexer, + module Parser, + module DynFlags, +#if __GLASGOW_HASKELL__ >= 610 + module Control.Monad.Ghc, + module HscTypes, + module Bag, +#endif +#if __GLASGOW_HASKELL__ >= 608 + module PprTyThing, +#elif __GLASGOW_HASKELL__ < 608 + module SrcLoc, +#endif +) + +where +#if __GLASGOW_HASKELL__ >= 610 +import GHC hiding ( Phase, GhcT, runGhcT ) +import Control.Monad.Ghc ( GhcT, runGhcT ) + +import HscTypes ( SourceError, srcErrorMessages, GhcApiError ) +import Bag ( bagToList ) +#else +import GHC hiding ( Phase ) +#endif + +import Outputable ( PprStyle, ppr, + showSDoc, showSDocForUser, showSDocUnqual, + withPprStyle, defaultErrStyle ) +import ErrUtils ( Message, mkLocMessage ) +import Pretty ( Doc ) +import DriverPhases ( Phase(Cpp), HscSource(HsSrcFile) ) +import StringBuffer ( stringToStringBuffer ) +import Lexer ( P(..), ParseResult(..), mkPState ) +import Parser ( parseStmt, parseType ) +import DynFlags ( supportedLanguages ) + +#if __GLASGOW_HASKELL__ >= 608 +import PprTyThing ( pprTypeForUser ) +#elif __GLASGOW_HASKELL__ < 608 +import SrcLoc ( SrcSpan, noSrcLoc ) +#endif diff --git a/src/Hint/InterpreterT.hs b/src/Hint/InterpreterT.hs new file mode 100644 --- /dev/null +++ b/src/Hint/InterpreterT.hs @@ -0,0 +1,168 @@ +module Hint.InterpreterT ( + InterpreterT, Interpreter, runInterpreter, +) + +where + +import Prelude hiding ( catch ) + +import Hint.Base +import Hint.Context +import Hint.Configuration + +import Control.Monad.Reader +import Control.Monad.Error + +import Data.IORef +#if __GLASGOW_HASKELL__ < 610 +import Data.Dynamic +#endif + +import qualified GHC.Paths + +import qualified Hint.GHC as GHC +import qualified Hint.Compat as Compat +import Hint.Compat.Exceptions + +type Interpreter = InterpreterT IO + +#if __GLASGOW_HASKELL__ < 610 + +newtype InterpreterT m a = InterpreterT{ + unInterpreterT :: ReaderT InterpreterSession + (ErrorT InterpreterError m) a} + deriving (Functor, Monad, MonadIO, MonadCatchIO) + +execute :: (MonadCatchIO m, Functor m) + => InterpreterSession + -> InterpreterT m a + -> m (Either InterpreterError a) +execute s = runErrorT . flip runReaderT s . unInterpreterT + +instance MonadTrans InterpreterT where + lift = InterpreterT . lift . lift + +runGhc_impl :: (MonadCatchIO m, Functor m) => RunGhc (InterpreterT m) a +runGhc_impl f = do s <- fromSession versionSpecific -- i.e. the ghc session + r <- liftIO $ f' s + either throwError return r + where f' = tryJust (fmap (GhcException . showGhcEx) . ghcExceptions) . f + ghcExceptions (DynException e) = fromDynamic e + ghcExceptions _ = Nothing + +#else + -- ghc >= 6.10 +newtype InterpreterT m a = InterpreterT{ + unInterpreterT :: ReaderT InterpreterSession + (ErrorT InterpreterError + (GHC.GhcT m)) a} + deriving (Functor, Monad, MonadIO, MonadCatchIO) + +execute :: (MonadCatchIO m, Functor m) + => InterpreterSession + -> InterpreterT m a + -> m (Either InterpreterError a) +execute s = GHC.runGhcT (Just GHC.Paths.libdir) + . runErrorT + . flip runReaderT s + . unInterpreterT + +instance MonadTrans InterpreterT where + lift = InterpreterT . lift . lift . lift + +runGhc_impl :: (MonadCatchIO m, Functor m) => RunGhc (InterpreterT m) a +runGhc_impl a = InterpreterT (lift (lift a)) + `catches` + [Handler (\(e :: GHC.SourceError) -> rethrowWC e), + Handler (\(e :: GHC.GhcApiError) -> rethrowGE $ show e), + Handler (\(e :: GHC.GhcException) -> rethrowGE $ showGhcEx e)] + where rethrowGE = throwError . GhcException + rethrowWC = throwError + . WontCompile + . map (GhcError . show) + . GHC.bagToList + . GHC.srcErrorMessages +#endif + +showGhcEx :: GHC.GhcException -> String +showGhcEx = flip GHC.showGhcException "" + +-- ================= Executing the interpreter ================== + +initialize :: (MonadCatchIO m, Functor m) => InterpreterT m () +initialize = + do log_handler <- fromSession ghcErrLogger + -- + -- Set a custom log handler, to intercept error messages :S + -- Observe that, setSessionDynFlags loads info on packages + -- available; calling this function once is mandatory! + dflags <- runGhc GHC.getSessionDynFlags + let dflags' = Compat.configureDynFlags dflags + runGhc1 GHC.setSessionDynFlags dflags'{GHC.log_action = log_handler} + -- + reset + +-- | Executes the interpreter. Returns @Left InterpreterError@ in case of error. +-- +runInterpreter :: (MonadCatchIO m, Functor m) + => InterpreterT m a + -> m (Either InterpreterError a) +runInterpreter action = + do s <- newInterpreterSession `catch` rethrowGhcException + execute s (initialize >> action) + where rethrowGhcException = throw . GhcException . showGhcEx +#if __GLASGOW_HASKELL__ < 610 + newInterpreterSession = do s <- liftIO $ + Compat.newSession GHC.Paths.libdir + newSessionData s +#else + -- GHC >= 610 + newInterpreterSession = newSessionData () +#endif + +initialState :: InterpreterState +initialState = St {active_phantoms = [], + zombie_phantoms = [], + hint_support_module = error "No support module loaded!", + import_qual_hack_mod = Nothing, + qual_imports = [], + configuration = defaultConf} + + +newSessionData :: MonadIO m => a -> m (SessionData a) +newSessionData a = do initial_state <- liftIO $ newIORef initialState + ghc_err_list_ref <- liftIO $ newIORef [] + return SessionData{ + internalState = initial_state, + versionSpecific = a, + ghcErrListRef = ghc_err_list_ref, + ghcErrLogger = mkLogHandler ghc_err_list_ref + } + +mkLogHandler :: IORef [GhcError] -> GhcErrLogger +mkLogHandler r _ src style msg = modifyIORef r (errorEntry :) + where errorEntry = mkGhcError src style msg + +mkGhcError :: GHC.SrcSpan -> GHC.PprStyle -> GHC.Message -> GhcError +mkGhcError src_span style msg = GhcError{errMsg = niceErrMsg} + where niceErrMsg = GHC.showSDoc . GHC.withPprStyle style $ + GHC.mkLocMessage src_span msg + + +-- The MonadInterpreter instance + +instance (MonadCatchIO m, Functor m) => MonadInterpreter (InterpreterT m) where + fromSession f = InterpreterT $ fmap f ask + -- + modifySessionRef target f = + do ref <- fromSession target + old_val <- liftIO $ atomicModifyIORef ref (\a -> (f a, a)) + return old_val + -- + runGhc a = runGhc_impl a + +instance Monad m => MonadError InterpreterError (InterpreterT m) where + throwError = InterpreterT . throwError + catchError (InterpreterT m) catchE = InterpreterT $ + m `catchError` + (\e -> unInterpreterT $ catchE e) diff --git a/src/Hint/Parsers.hs b/src/Hint/Parsers.hs --- a/src/Hint/Parsers.hs +++ b/src/Hint/Parsers.hs @@ -4,32 +4,54 @@ import Prelude hiding(span) -import qualified GHC(Session, getSessionDynFlags) +import Hint.Base -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) +import Control.Monad.Trans ( liftIO ) -data ParseResult = ParseOk | ParseError GHC.S.SrcSpan GHC.E.Message +import qualified Hint.GHC as GHC -parseExpr :: GHC.Session -> String -> IO ParseResult -parseExpr = runParser GHC.P.parseStmt +data ParseResult = ParseOk | ParseError GHC.SrcSpan GHC.Message -parseType :: GHC.Session -> String -> IO ParseResult -parseType = runParser GHC.P.parseType +parseExpr :: MonadInterpreter m => String -> m ParseResult +parseExpr = runParser GHC.parseStmt -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) +parseType :: MonadInterpreter m => String -> m ParseResult +parseType = runParser GHC.parseType + +runParser :: MonadInterpreter m => GHC.P a -> String -> m ParseResult +runParser parser expr = + do dyn_fl <- runGhc GHC.getSessionDynFlags + -- + buf <- liftIO $ GHC.stringToStringBuffer expr + -- + let parse_res = GHC.unP parser (GHC.mkPState buf GHC.noSrcLoc dyn_fl) + -- + case parse_res of + GHC.POk{} -> return ParseOk + -- + GHC.PFailed span err -> return (ParseError span err) + +failOnParseError :: MonadInterpreter m + => (String -> m ParseResult) + -> String + -> m () +failOnParseError parser expr = mayFail go + where go = do parsed <- parser expr + -- + -- If there was a parsing error, + -- do the "standard" error reporting + case parsed of + ParseOk -> return (Just ()) + -- + ParseError span err -> + do -- parsing failed, so we report it just as all + -- other errors get reported.... + logger <- fromSession ghcErrLogger + liftIO $ logger GHC.SevError + span + GHC.defaultErrStyle + err + -- + -- behave like the rest of the GHC API functions + -- do on error... + return Nothing diff --git a/src/Hint/Reflection.hs b/src/Hint/Reflection.hs --- a/src/Hint/Reflection.hs +++ b/src/Hint/Reflection.hs @@ -10,12 +10,8 @@ import Data.List import Data.Maybe -import Control.Monad.Trans - import Hint.Base - -import qualified GHC -import qualified Outputable as GHC.O +import qualified Hint.GHC as GHC -- | An Id for a class, a type constructor, a data constructor, a binding, etc type Id = String @@ -36,17 +32,13 @@ -- | 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 :: MonadInterpreter m => ModuleName -> m [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) + do module_ <- findModule mn + mod_info <- mayFail $ runGhc1 GHC.getModuleInfo module_ + exports <- mapM (runGhc1 GHC.lookupName) (GHC.modInfoExports mod_info) + -- + return (asModElemList $ catMaybes exports) asModElemList :: [GHC.TyThing] -> [ModuleElem] asModElemList xs = concat [cs', @@ -71,4 +63,4 @@ (map getUnqualName $ GHC.classMethods c) getUnqualName :: GHC.NamedThing a => a -> String -getUnqualName = GHC.O.showSDocUnqual . GHC.pprParenSymName +getUnqualName = GHC.showSDocUnqual . GHC.pprParenSymName diff --git a/src/Hint/Sandbox.hs b/src/Hint/Sandbox.hs --- a/src/Hint/Sandbox.hs +++ b/src/Hint/Sandbox.hs @@ -1,35 +1,26 @@ module Hint.Sandbox ( sandboxed ) where import Hint.Base -import Hint.Conversions import Hint.Context +import Hint.Configuration +import Hint.Util import {-# SOURCE #-} Hint.Typecheck ( typeChecks_unsandboxed ) -import qualified GHC -import qualified DriverPhases as DP - -import Data.Char - +import Data.List 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 :: MonadInterpreter m => (Expr -> m a) -> (Expr -> m a) +sandboxed = if ghcVersion >= 610 then id else old_sandboxed -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 +old_sandboxed :: MonadInterpreter m => (Expr -> m a) -> (Expr -> m a) +old_sandboxed do_stuff = \expr -> do no_sandbox <- fromConf all_mods_in_scope + if no_sandbox + then do_stuff expr + else usingAModule do_stuff expr -usingAModule :: (Expr -> Interpreter a) -> (Expr -> Interpreter a) +usingAModule :: MonadInterpreter m => (Expr -> m a) -> (Expr -> m 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 @@ -38,102 +29,47 @@ -- 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 + do type_checks <- typeChecks_unsandboxed expr case type_checks of False -> do_stuff_on expr -- fail as you wish... True -> - do (loaded, imports) <- modulesInContext + do (loaded, imports) <- allModulesInContext + zombies <- fromState zombie_phantoms + quals <- fromState qual_imports -- 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 + let mod_text no_prel mod_name = textify [ + ["{-# LANGUAGE NoMonomorphismRestriction #-}"], + ["{-# LANGUAGE NoImplicitPrelude #-}" | no_prel], + ["module " ++ mod_name], + ["where"], + ["import " ++ m | m <- loaded ++ imports, + not $ m `elem` (map pm_name zombies)], + ["import qualified " ++ m ++ " as " ++ q | (m,q) <- quals], + [e ++ " = " ++ expr] ] -- - setTopLevelModules [] - setImports [] - let go = do addTarget t - setTopLevelModules [mod_name] - do_stuff_on e - write_mod True + let go no_prel = do pm <- addPhantomModule (mod_text no_prel) + setTopLevelModules [pm_name pm] + r <- do_stuff_on e + `catchError` (\err -> + case err of + WontCompile _ -> + do removePhantomModule pm + throwError err + _ -> throwError err) + removePhantomModule pm + return r -- If the Prelude was not explicitly imported but implicitly -- imported in some interpreted module, then the user may -- get very unintuitive errors when turning sandboxing on. Thus -- we will import the Prelude if the operation fails... -- I guess this may lead to even more obscure errors, but -- hopefully in much less frequent situations... - r <- go + r <- onAnEmptyContext $ go True `catchError` (\err -> case err of - WontCompile _ -> do removeTarget t - write_mod False - go + WontCompile _ -> go False _ -> 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 --- a/src/Hint/Typecheck.hs +++ b/src/Hint/Typecheck.hs @@ -17,52 +17,46 @@ import qualified Hint.Compat as Compat -import qualified GHC - -- | Returns a string representation of the type of the expression. -typeOf :: String -> Interpreter String +typeOf :: MonadInterpreter m => String -> m String typeOf = sandboxed typeOf_unsandboxed -typeOf_unsandboxed :: String -> Interpreter String +typeOf_unsandboxed :: MonadInterpreter m => String -> m 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 + do -- First, make sure the expression has no syntax errors, + -- for this is the only way we have to "intercept" this + -- kind of errors + failOnParseError parseExpr expr + -- + ty <- mayFail $ runGhc1 Compat.exprType expr + -- + fromGhcRep ty -- | Tests if the expression type checks. -typeChecks :: String -> Interpreter Bool +typeChecks :: MonadInterpreter m => String -> m Bool typeChecks = sandboxed typeChecks_unsandboxed -typeChecks_unsandboxed :: String -> Interpreter Bool +typeChecks_unsandboxed :: MonadInterpreter m => String -> m 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 :: MonadInterpreter m => String -> m String kindOf = sandboxed go where go type_expr = - do ghc_session <- fromSessionState ghcSession - -- - -- First, make sure the expression has no syntax errors, + do -- First, make sure the expression has no syntax errors, -- for this is the only way we have to "intercept" this -- kind of errors failOnParseError parseType type_expr -- - kind <- mayFail $ GHC.typeKind ghc_session type_expr + kind <- mayFail $ runGhc1 Compat.typeKind type_expr -- return $ fromGhcRep_ (Compat.Kind kind) -onCompilationError :: ([GhcError] -> Interpreter a) - -> (InterpreterError -> Interpreter a) +onCompilationError :: MonadInterpreter m + => ([GhcError] -> m a) + -> (InterpreterError -> m a) onCompilationError recover = \interp_error -> case interp_error of WontCompile errs -> recover errs diff --git a/src/Hint/Typecheck.hs-boot b/src/Hint/Typecheck.hs-boot --- a/src/Hint/Typecheck.hs-boot +++ b/src/Hint/Typecheck.hs-boot @@ -1,5 +1,5 @@ module Hint.Typecheck where -import Hint.Base (Interpreter) +import Hint.Base (MonadInterpreter) -typeChecks_unsandboxed :: String -> Interpreter Bool +typeChecks_unsandboxed :: MonadInterpreter m => String -> m Bool diff --git a/src/Hint/Util.hs b/src/Hint/Util.hs new file mode 100644 --- /dev/null +++ b/src/Hint/Util.hs @@ -0,0 +1,24 @@ +module Hint.Util where + +import Data.Char + +type Expr = String + +-- @safeBndFor expr@ generates a name @e@ such that it does not +-- occur free in @expr@ and, thus, it is safe to write something +-- like @e = expr@ (otherwise, it will get accidentally bound). +-- This ought to do the trick: observe that @safeBndFor expr@ +-- contains more digits than @expr@ and, thus, cannot occur inside +-- @expr@. +safeBndFor :: Expr -> String +safeBndFor expr = "e_1" ++ filter isDigit expr + +partition :: (a -> Bool) -> [a] -> ([a], [a]) +partition prop xs = foldr (select prop) ([],[]) xs + where select p x ~(ts,fs) | p x = (x:ts,fs) + | otherwise = (ts, x:fs) + +infixr 1 >=> +(>=>) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c) +f >=> g = \x -> f x >>= g + diff --git a/src/Language/Haskell/Interpreter.hs b/src/Language/Haskell/Interpreter.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Interpreter.hs @@ -0,0 +1,53 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Language.Haskell.Interpreter +-- License : BSD-style +-- +-- Maintainer : jcpetruzza@gmail.com +-- Stability : experimental +-- Portability : non-portable (GHC API) +-- +-- A Haskell interpreter built on top of the GHC API +----------------------------------------------------------------------------- +module Language.Haskell.Interpreter( + -- * The interpreter monad transformer + MonadInterpreter(..), InterpreterT, Interpreter, + -- ** Running the interpreter + runInterpreter, + -- ** Interpreter options + Option, OptionVal((:=)), + get, set, + languageExtensions, availableExtensions, glasgowExtensions, Extension(..), + installedModulesInScope, + + setUseLanguageExtensions, + setInstalledModsAreInScopeQualified, + -- ** Context handling + ModuleName, + loadModules, getLoadedModules, setTopLevelModules, + setImports, setImportsQ, + reset, + -- ** Module querying + ModuleElem(..), Id, name, children, + getModuleExports, + -- ** Type inference + typeOf, typeChecks, kindOf, + -- ** Evaluation + interpret, as, infer, eval, + -- * Error handling + InterpreterError(..), GhcError(..), + -- * Miscellaneous + ghcVersion, + module Control.Monad.Trans) + +where + +import Hint.Base +import Hint.InterpreterT +import Hint.Configuration +import Hint.Context +import Hint.Reflection +import Hint.Typecheck +import Hint.Eval + +import Control.Monad.Trans 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 @@ -1,46 +1,13 @@ ----------------------------------------------------------------------------- -- | --- Module : Language.Haskell.Interpreter.GHC --- License : BSD-style --- --- Maintainer : jcpetruzza@gmail.com --- Stability : experimental --- Portability : non-portable (GHC API) --- --- A Haskell interpreter built on top of the GHC API +-- DEPRECATED: use @Language.Haskell.Interpreter.Unsafe@ instead. ----------------------------------------------------------------------------- -module Language.Haskell.Interpreter.GHC( - -- * Session handling - InterpreterSession, newSession, newSessionUsing, - -- * Error handling - InterpreterError(..), GhcError(..), - -- * The interpreter type - Interpreter, - -- ** Running the interpreter - withSession, - -- ** Interpreter options - setUseLanguageExtensions, - Optimizations(..), setOptimizations, - setInstalledModsAreInScopeQualified, - -- ** Context handling - ModuleName, - loadModules, getLoadedModules, setTopLevelModules, - setImports, - reset, - -- ** Module querying - ModuleElem(..), Id, name, children, - getModuleExports, - -- ** Type inference - typeOf, typeChecks, kindOf, - -- ** Evaluation - interpret, as, infer, - eval) +module Language.Haskell.Interpreter.GHC +{-# DEPRECATED "Import Language.Haskell.Interpreter instead." #-} +( + module Language.Haskell.Interpreter +) where -import Hint.Base -import Hint.Configuration -import Hint.Context -import Hint.Reflection -import Hint.Typecheck -import Hint.Eval +import Language.Haskell.Interpreter 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 @@ -1,13 +1,13 @@ -module Language.Haskell.Interpreter.GHC.Unsafe ( unsafeSetGhcOption ) +----------------------------------------------------------------------------- +-- | +-- DEPRECATED: use @Language.Haskell.Interpreter.Unsafe@ instead. +----------------------------------------------------------------------------- +module Language.Haskell.Interpreter.GHC.Unsafe +{-# DEPRECATED "Import Language.Haskell.Interpreter.Unsafe instead." #-} +( + module Language.Haskell.Interpreter.Unsafe +) where -import Hint.Base -import Hint.Configuration - --- | Set a GHC option for the current session, --- eg. @unsafeSetGhcOption \"-fno-monomorphism-restriction\"@. --- --- Warning: Some options may interact badly with the Interpreter. -unsafeSetGhcOption :: String -> Interpreter () -unsafeSetGhcOption = setGhcOption +import Language.Haskell.Interpreter.Unsafe diff --git a/src/Language/Haskell/Interpreter/Unsafe.hs b/src/Language/Haskell/Interpreter/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Interpreter/Unsafe.hs @@ -0,0 +1,13 @@ +module Language.Haskell.Interpreter.Unsafe ( unsafeSetGhcOption ) + +where + +import Hint.Base +import Hint.Configuration + +-- | Set a GHC option for the current session, +-- eg. @unsafeSetGhcOption \"-XNoMonomorphismRestriction\"@. +-- +-- Warning: Some options may interact badly with the Interpreter. +unsafeSetGhcOption :: MonadInterpreter m => String -> m () +unsafeSetGhcOption = setGhcOption 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,10 +1,11 @@ module Main ( main ) where +import Prelude hiding (catch) + import Control.Exception import Control.Monad ( liftM, when ) -import Control.Monad.Trans ( MonadIO(liftIO) ) -import Control.Monad.Error ( catchError ) +import Control.Monad.Error ( Error, MonadError(catchError) ) import System.IO import System.Directory @@ -14,17 +15,17 @@ import Test.HUnit ( (@?=), (@?) ) import qualified Test.HUnit as HUnit -import qualified Language.Haskell.Interpreter.GHC as H +import Language.Haskell.Interpreter -test_reload_modified :: H.InterpreterSession -> HUnit.Test -test_reload_modified s = testCase "reload_modified" [mod_file] $ do - writeFile mod_file mod_v1 - f_v1 <- H.withSession s get_f +test_reload_modified :: TestCase +test_reload_modified = TestCase "reload_modified" [mod_file] $ do + liftIO $ writeFile mod_file mod_v1 + f_v1 <- get_f -- - writeFile mod_file mod_v2 - f_v2 <- H.withSession s get_f + liftIO $ writeFile mod_file mod_v2 + f_v2 <- get_f -- - (f_v1 5, f_v2 5) @?= (5, 6) + liftIO $ (f_v1 5, f_v2 5) @?= (5, 6) -- where mod_name = "TEST_ReloadModified" mod_file = mod_name ++ ".hs" @@ -38,86 +39,104 @@ "f :: Int -> Int", "f = (1 +)"] -- - get_f = do H.loadModules [mod_file] - H.setTopLevelModules [mod_name] - H.interpret "f" (H.as :: Int -> Int) + get_f = do loadModules [mod_file] + setTopLevelModules [mod_name] + interpret "f" (as :: Int -> Int) -test_lang_exts :: H.InterpreterSession -> HUnit.Test -test_lang_exts s = testCase "lang_exts" [mod_file] $ do - writeFile mod_file "data T where T :: T" - H.withSession s $ do - loadFails @@? "first time, it shouldn't load" - -- - H.setUseLanguageExtensions True - loadSucceeds @@? "now, it should load" - -- - H.setUseLanguageExtensions False - loadFails @@? "it shouldn't load, again" +test_lang_exts :: TestCase +test_lang_exts = TestCase "lang_exts" [mod_file] $ do + liftIO $ writeFile mod_file "data T where T :: T" + fails do_load @@? "first time, it shouldn't load" + -- + set [languageExtensions := glasgowExtensions] + succeeds do_load @@? "now, it should load" + -- + set [languageExtensions := []] + fails do_load @@? "it shouldn't load, again" -- - where mod_name = "TEST_LangExts" - mod_file = mod_name ++ ".hs" + where mod_name = "TEST_LangExts" + mod_file = mod_name ++ ".hs" -- - loadFails = not `liftM` loadSucceeds - loadSucceeds = do H.loadModules [mod_name] - return True - `catchError` (\_ -> return False) + do_load = loadModules [mod_name] -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 +test_work_in_main :: TestCase +test_work_in_main = TestCase "work_in_main" [mod_file] $ do + liftIO $ writeFile mod_file "f = id" + loadModules [mod_file] + setTopLevelModules ["Main"] + setImportsQ [("Prelude",Nothing), + ("Data.Maybe", Just "Mb")] + -- + typeOf "f $ 1+1" @@?= "(Num a) => a" + eval "f . Mb.fromJust $ Just [1,2]" @@?= "[1,2]" + interpret "f $ 1 == 2" infer @@?= False -- where mod_file = "TEST_WorkInMain.hs" -test_priv_syms_in_scope :: 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" +test_priv_syms_in_scope :: TestCase +test_priv_syms_in_scope = TestCase "private_syms_in_scope" [mod_file] $ do + -- must set to True, otherwise won't work with + -- ghc 6.8 + set [installedModulesInScope := True] + liftIO $ writeFile mod_file mod_text + loadModules [mod_file] + setTopLevelModules ["T"] + typeChecks "g" @@? "g is hidden" where mod_text = unlines ["module T(f) where", "f = g", "g = id"] mod_file = "TEST_PrivateSymbolsInScope.hs" -test_comments_in_expr :: H.InterpreterSession -> HUnit.Test -test_comments_in_expr s = testCase "comments_in_expr" [] $ do - H.withSession s $ do - H.reset - H.setImports ["Prelude"] - let expr = "length $ concat [[1,2],[3]] -- bla" - H.typeChecks expr @@? "comment on expression" - H.eval expr - H.interpret expr (H.as :: Int) - return () +test_comments_in_expr :: TestCase +test_comments_in_expr = TestCase "comments_in_expr" [] $ do + setImports ["Prelude"] + let expr = "length $ concat [[1,2],[3]] -- bla" + typeChecks expr @@? "comment on expression" + eval expr + interpret expr (as :: Int) + return () -common_tests :: H.InterpreterSession -> [HUnit.Test] -common_tests s = [test_reload_modified s, - test_lang_exts s, - test_work_in_main s, - test_comments_in_expr s] +test_qual_import :: TestCase +test_qual_import = TestCase "qual_import" [] $ do + setImportsQ [("Prelude", Nothing), + ("Data.Map", Just "M")] + typeChecks "null []" @@? "Unqual null" + typeChecks "M.null M.empty" @@? "Qual null" + return () +test_basic_eval :: TestCase +test_basic_eval = TestCase "basic_eval" [] $ do + eval "()" @@?= "()" -non_sb_tests :: H.InterpreterSession -> HUnit.Test -non_sb_tests s = HUnit.TestList $ common_tests s ++ [test_priv_syms_in_scope s] +test_show_in_scope :: TestCase +test_show_in_scope = TestCase "show_in_scope" [] $ do + setImports ["Prelude"] + eval "show ([] :: String)" @@?= show (show "") -sb_tests :: H.InterpreterSession -> HUnit.Test -sb_tests s = HUnit.TestList $ common_tests s +test_installed_not_in_scope :: TestCase +test_installed_not_in_scope = TestCase "installed_not_in_scope" [] $ do + b <- get installedModulesInScope + succeeds action @@?= b + set [installedModulesInScope := False] + fails action @@? "now must be out of scope" + set [installedModulesInScope := True] + succeeds action @@? "must be in scope again" + where action = typeOf "Data.Map.singleton" +tests :: [TestCase] +tests = [test_reload_modified, + test_lang_exts, + test_work_in_main, + test_comments_in_expr, + test_qual_import, + test_basic_eval, + test_show_in_scope, + test_installed_not_in_scope, + test_priv_syms_in_scope] + main :: IO () -main = do s <- H.newSession - -- - -- run the tests... - c <- HUnit.runTestTT $ non_sb_tests s +main = do -- run the tests... + c <- runTests False tests -- then run again, but with sandboxing on... - setSandbox s - c' <- HUnit.runTestTT $ sb_tests s + c' <- runTests True tests -- let failures = HUnit.errors c + HUnit.failures c + HUnit.errors c' + HUnit.failures c' @@ -125,13 +144,13 @@ | failures > 0 = ExitFailure failures | otherwise = ExitSuccess exitWith exit_code - `catchDyn` (printInterpreterError >=> \_ -> exitWith (ExitFailure $ -1)) + -- `catch` (\_ -> exitWith (ExitFailure $ -1)) -printInterpreterError :: H.InterpreterError -> IO () +printInterpreterError :: InterpreterError -> IO () printInterpreterError = hPutStrLn stderr . show -setSandbox :: H.InterpreterSession -> IO () -setSandbox s = H.withSession s $ H.setInstalledModsAreInScopeQualified False +setSandbox :: Interpreter () +setSandbox = set [installedModulesInScope := False] (>=>) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c) f >=> g = \a -> f a >>= g @@ -142,11 +161,25 @@ (@@?=) :: (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 test' = test `catchDyn` (printInterpreterError >=> throwDyn) - clean_up = mapM_ removeIfExists tmps - removeIfExists f = do exists <- doesFileExist f - when exists $ - removeFile f +fails :: (Error e, MonadError e m, MonadIO m) => m a -> m Bool +fails action = (action >> return False) `catchError` (\_ -> return True) + +succeeds :: (Error e, MonadError e m, MonadIO m) => m a -> m Bool +succeeds = liftM not . fails + + +data TestCase = TestCase String [FilePath] (Interpreter ()) + +runTests :: Bool -> [TestCase] -> IO HUnit.Counts +runTests sandboxed = HUnit.runTestTT . HUnit.TestList . map build + where build (TestCase title tmps test) = HUnit.TestLabel title $ + HUnit.TestCase test_case + where test_case = go `finally` clean_up + clean_up = mapM_ removeIfExists tmps + go = do r <- runInterpreter + (when sandboxed setSandbox >> test) + either (printInterpreterError >=> (fail . show)) + return r + removeIfExists f = do exists <- doesFileExist f + when exists $ + removeFile f