hint 0.2.4.1 → 0.3.0.0
raw patch · 24 files changed
+1339/−675 lines, 24 filesdep +Cabaldep +MonadCatchIO-mtldep +ghc-mtldep ~basedep ~ghc
Dependencies added: Cabal, MonadCatchIO-mtl, ghc-mtl
Dependency ranges changed: base, ghc
Files
- Changes +13/−0
- README +1/−1
- examples/example.hs +10/−11
- hint.cabal +41/−23
- src/Hint/Base.hs +164/−170
- src/Hint/Compat.hs +85/−29
- src/Hint/Compat/Exceptions.hs +27/−0
- src/Hint/Configuration.hs +138/−23
- src/Hint/Context.hs +282/−79
- src/Hint/Conversions.hs +6/−10
- src/Hint/Eval.hs +19/−27
- src/Hint/GHC.hs +49/−0
- src/Hint/InterpreterT.hs +168/−0
- src/Hint/Parsers.hs +46/−24
- src/Hint/Reflection.hs +8/−16
- src/Hint/Sandbox.hs +37/−101
- src/Hint/Typecheck.hs +18/−24
- src/Hint/Typecheck.hs-boot +2/−2
- src/Hint/Util.hs +24/−0
- src/Language/Haskell/Interpreter.hs +53/−0
- src/Language/Haskell/Interpreter/GHC.hs +7/−40
- src/Language/Haskell/Interpreter/GHC/Unsafe.hs +10/−10
- src/Language/Haskell/Interpreter/Unsafe.hs +13/−0
- unit-tests/run-unit-tests.hs +118/−85
Changes view
@@ -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
README view
@@ -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
examples/example.hs view
@@ -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 --
hint.cabal view
@@ -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
src/Hint/Base.hs view
@@ -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)
src/Hint/Compat.hs view
@@ -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
+ src/Hint/Compat/Exceptions.hs view
@@ -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
src/Hint/Configuration.hs view
@@ -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]
src/Hint/Context.hs view
@@ -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 ()
src/Hint/Conversions.hs view
@@ -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 --------------------------
src/Hint/Eval.hs view
@@ -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
+ src/Hint/GHC.hs view
@@ -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
+ src/Hint/InterpreterT.hs view
@@ -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)
src/Hint/Parsers.hs view
@@ -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
src/Hint/Reflection.hs view
@@ -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
src/Hint/Sandbox.hs view
@@ -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)
src/Hint/Typecheck.hs view
@@ -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
src/Hint/Typecheck.hs-boot view
@@ -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
+ src/Hint/Util.hs view
@@ -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+
+ src/Language/Haskell/Interpreter.hs view
@@ -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
src/Language/Haskell/Interpreter/GHC.hs view
@@ -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
src/Language/Haskell/Interpreter/GHC/Unsafe.hs view
@@ -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
+ src/Language/Haskell/Interpreter/Unsafe.hs view
@@ -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
unit-tests/run-unit-tests.hs view
@@ -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