hint (empty) → 0.1
raw patch · 9 files changed
+730/−0 lines, 9 filesdep +basedep +ghcdep +haskell-srcbuild-type:Customsetup-changed
Dependencies added: base, ghc, haskell-src, mtl
Files
- LICENSE +27/−0
- README +6/−0
- Setup.lhs +60/−0
- examples/SomeModule.hs +7/−0
- examples/example1.hs +55/−0
- hint.cabal +22/−0
- src/Language/Haskell/Interpreter/GHC.hs +480/−0
- src/Language/Haskell/Interpreter/GHC/Conversions.hs +38/−0
- src/Language/Haskell/Interpreter/GHC/Parsers.hs +35/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright 2007, Daniel Gorin. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of its contributors may be+ used to endorse or promote products derived from this software without+ specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ README view
@@ -0,0 +1,6 @@+To install locally:++> runhaskell Setup.lhs configure --prefix=$USER --user+> runhaskell Setup.lhs build+> runhaskell Setup.lhs haddock+> runhaskell Setup.lhs install
+ Setup.lhs view
@@ -0,0 +1,60 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), autogenModulesDir )+> import Distribution.Simple.Utils ( warn, die )++> import System.IO ( readFile, writeFile )++> import System.Cmd ( system )+> import System.Exit ( ExitCode(..) )++> import System.FilePath ( (</>) )+> import System.Directory ( doesDirectoryExist, createDirectoryIfMissing, removeFile )++> import Control.Monad ( when, liftM )++> main = defaultMainWithHooks myHooks+> where myHooks = let h = defaultUserHooks in h{postConf = myPostConf (postConf h)}+> myPostConf oldHook = \a f p lbi -> (saveGhcLibdir lbi >> oldHook a f p lbi)++> saveGhcLibdir :: LocalBuildInfo -> IO ()+> saveGhcLibdir lbi = do+> let libdir_file = ".ghc-libdir"+> let cmd = unwords [compilerPath . compiler $ lbi, "--print-libdir", ">", libdir_file]+> result <- system cmd+> --+> case result of+> ExitFailure _ -> die "Could not determine ghc's libdir!"+> ExitSuccess ->+> do+> libdir <- removeTrailingEOL `liftM` readFile libdir_file+> --+> isOk <- doesDirectoryExist libdir+> if not isOk+> then warn $ "Suspicious ghc libdir: '" ++ libdir ++ "'"+> else message $ "Using ghc libdir: '" ++ libdir ++ "'"+> --+> let mod_dir = "Language" </> "Haskell" </> "Interpreter" </> "GHC"+> let ghc_libdir_module_file = "src" </> mod_dir </> "LibDir.hs"+> writeFile ghc_libdir_module_file $ mkGhcLibdirModule libdir+> --+> removeFile libdir_file+++> mkGhcLibdirModule :: FilePath -> String+> mkGhcLibdirModule libdir = unlines ["-- Autogenerated by Cabal script... DO NOT MODIFY!",+> "module Language.Haskell.Interpreter.GHC.LibDir ( ghc_libdir )",+> "",+> "where",+> "",+> "ghc_libdir :: FilePath",+> "ghc_libdir = " ++ show libdir]++> removeTrailingEOL :: String -> String+> removeTrailingEOL [] = []+> removeTrailingEOL ['\n'] = []+> removeTrailingEOL (x:xs) = x : removeTrailingEOL xs++> message :: String -> IO ()+> message s = putStrLn $ "configure: " ++ s
+ examples/SomeModule.hs view
@@ -0,0 +1,7 @@+module SomeModule(g, h) where++f = head++g = f [f]++h = f
+ examples/example1.hs view
@@ -0,0 +1,55 @@+import Control.Monad+import Control.Monad.Trans ( liftIO )+import Language.Haskell.Interpreter.GHC++main :: IO ()+main = do s <- newSession+ r <- withSession s testHint+ --+ case r of+ Left err -> putStrLn $ "Ups: " ++ show err+ Right () -> putStrLn "that's all folks"+ ++testHint :: Interpreter () +testHint =+ do+ say "Load SomeModule.hs" + loadModules ["SomeModule.hs"]+ --+ say "Put the Prelude and *SomeModule in scope"+ setTopLevelModules ["SomeModule"]+ setImports ["Prelude"]+ --+ say "Now we can query the type of an expression"+ let expr1 = "(f, g, h, 42)"+ say $ "e.g. typeOf " ++ expr1+ say =<< typeOf expr1+ say "Observe that f, g and h are defined in SomeModule.hs, but f is not exported"+ --+ say "We can also evaluate an expression; the result will be a string"+ let expr2 = "length $ concat [[f,g],[h]]"+ say $ concat ["e.g. eval ", show expr1]+ a <- eval expr2+ say (show a)+ --+ say "Or we can interpret it as a proper, say, int value!"+ a_int <- interpret expr2 (as :: Int)+ say (show a_int)+ --+ say "This works for any monomorphic type, even for function types"+ let expr3 = "\\(Just x) -> succ x"+ say $ "e.g. we interpret " ++ expr3 ++ " with type Maybe Int -> Int and apply it on Just 7"+ fun <- interpret expr3 (as :: Maybe Int -> Int)+ say . show $ fun (Just 7)+ --+ say "And sometimes we can even use the type system to infer the expected type (eg Maybe Bool -> Bool)!"+ bool_val <- (interpret expr3 infer `ap` (return $ Just False))+ say (show $ not bool_val)+ --+ say "Here we evaluate an expression of type string, that when evaluated (again) leads to a string"+ res <- interpret "head $ map show [\"Worked!\", \"Didn't work\"]" infer >>= flip interpret infer+ say res++say :: String -> Interpreter ()+say = liftIO . putStrLn
+ hint.cabal view
@@ -0,0 +1,22 @@+Name: hint+Version: 0.1+Description:+ This library defines an @Interpreter@ monad, inside which modules can be+ loaded, and strings with Haskell expressions can be evaluated, coerced+ into values, or type-checked. The library is thread-safe and all+ operations (even the coertion of expressions to values) are type-safe.+ It is, esentially, a huge subset of the GHC API wrapped in a simpler+ API. Tested with GHC 6.6.1.+Synopsis: Runtime Haskell interpreter (GHC API wrapper)+Category: Language, Compilers/Interpreters+License: BSD3+License-file: LICENSE+Author: Daniel Gorin+Maintainer: jcpetruzza@gmail.com+Build-Depends: base, haskell-src, ghc, mtl+Exposed-modules: Language.Haskell.Interpreter.GHC+Other-modules: Language.Haskell.Interpreter.GHC.Conversions+ Language.Haskell.Interpreter.GHC.Parsers+ Language.Haskell.Interpreter.GHC.LibDir+ghc-options: -Wall -O2+hs-source-dirs: src
+ src/Language/Haskell/Interpreter/GHC.hs view
@@ -0,0 +1,480 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+-----------------------------------------------------------------------------+-- |+-- 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+-----------------------------------------------------------------------------+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,+ -- ** Module handling+ ModuleName,+ loadModules, getLoadedModules, setTopLevelModules,+ setImports,+ reset,+ -- ** Type inference+ typeOf, typeChecks, kindOf,+ -- ** Evaluation+ interpret, as, infer,+ eval)++where++import Prelude hiding ( span )++import qualified GHC+import qualified Outputable as GHC.O ( PprStyle, withPprStyle,+ defaultErrStyle, showSDoc )+import qualified SrcLoc as GHC.S ( SrcSpan )+import qualified ErrUtils as GHC.E ( Message, mkLocMessage )++import qualified GHC.Exts ( unsafeCoerce# )++import Control.Monad ( liftM, filterM, guard, when )+import Control.Monad.Trans ( MonadIO(liftIO) )+import Control.Monad.Reader ( ReaderT, ask, runReaderT )+import Control.Monad.Error ( Error(..), MonadError(..), ErrorT, runErrorT )++import Control.Concurrent.MVar ( MVar, newMVar, withMVar )+import Data.IORef ( IORef, newIORef,+ modifyIORef, atomicModifyIORef )++import Control.Exception ( Exception(DynException), tryJust )++import Data.Typeable ( Typeable, TypeRep, mkTyCon,+ mkTyConApp, splitTyConApp )+import qualified Data.Typeable ( typeOf )+import Data.Dynamic ( fromDynamic )++import Data.List ( (\\) )++import Language.Haskell.Interpreter.GHC.Parsers ( ParseResult(..),+ parseExpr, parseType )+import Language.Haskell.Interpreter.GHC.Conversions ( FromGhcRep(..) )++-- autogenerated by Cabal script+import Language.Haskell.Interpreter.GHC.LibDir ( ghc_libdir )++newtype Interpreter a =+ Interpreter{unInterpreter :: ReaderT SessionState+ (ErrorT InterpreterError+ IO) a} deriving(Typeable)++instance Monad Interpreter where+ return = Interpreter . return+ i >>= f = Interpreter (unInterpreter i >>= unInterpreter . f)++instance Functor Interpreter where+ fmap f (Interpreter m) = Interpreter (fmap f m)++instance MonadIO Interpreter where+ liftIO = Interpreter . liftIO++instance MonadError InterpreterError Interpreter where+ throwError = Interpreter . throwError+ catchError (Interpreter m) catchE = Interpreter $ m `catchError` (\e -> + unInterpreter $ catchE e)++-- | 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.+withSession :: InterpreterSession+ -> Interpreter a+ -> IO (Either InterpreterError a)+withSession s i = withMVar (sessionState s) $ \ss ->+ runErrorT . flip runReaderT ss $ unInterpreter i+++data InterpreterError = UnknownError String+ | WontCompile [GhcError]+ | NotAllowed String+ deriving Show++instance Error InterpreterError where+ noMsg = UnknownError ""+ strMsg = UnknownError++-- I'm assuming operations on a ghcSession are not thread-safe. Besides, we need+-- to be sure that messages captured by the log handler correspond to a single+-- operation. Hence, we put the whole state on an MVar, and synchronize on it+newtype InterpreterSession =+ InterpreterSession {sessionState :: MVar SessionState}++data SessionState = SessionState{ghcSession :: GHC.Session,+ ghcErrListRef :: IORef [GhcError],+ ghcErrLogger :: GhcErrLogger}++-- When intercepting errors reported by GHC, we only get a GHC.E.Message+-- and a GHC.S.SrcSpan. The latter holds the file name and the location+-- of the error. However, SrcSpan is abstract and it doesn't provide+-- functions to retrieve the line and column of the error... we can only+-- generate a string with this information. Maybe I can parse this string+-- later.... (sigh)+data GhcError = GhcError{errMsg :: String} deriving Show++mkGhcError :: GHC.S.SrcSpan -> GHC.O.PprStyle -> GHC.E.Message -> GhcError+mkGhcError span style msg = GhcError{errMsg = niceErrMsg}+ where niceErrMsg = GHC.O.showSDoc . GHC.O.withPprStyle style $+ GHC.E.mkLocMessage span msg++type GhcErrLogger = GHC.Severity+ -> GHC.S.SrcSpan+ -> GHC.O.PprStyle+ -> GHC.E.Message+ -> IO ()++-- | Builds a new session using the (hopefully) correct path to the GHC in use.+-- (the path is determined at build time of the package)+newSession :: IO InterpreterSession+newSession = newSessionUsing ghc_libdir++-- | Builds a new session, given the path to a GHC installation+-- (e.g. \/usr\/local\/lib\/ghc-6.6).+newSessionUsing :: FilePath -> IO InterpreterSession+newSessionUsing ghcRoot =+ do+ ghc_session <- GHC.newSession GHC.Interactive $ Just ghcRoot+ --+ ghc_err_list_ref <- newIORef []+ let log_handler = mkLogHandler ghc_err_list_ref+ --+ let session_state = SessionState{ghcSession = ghc_session,+ ghcErrListRef = ghc_err_list_ref,+ ghcErrLogger = log_handler}+ --+ -- set HscTarget to HscInterpreted (default is HsAsm!).+ -- setSessionDynFlags loads info on packages availables; this call+ -- is mandatory!+ -- also set a custom log handler, to intercept error messages :S+ dflags <- GHC.getSessionDynFlags ghc_session+ let myFlags = dflags{GHC.hscTarget = GHC.HscInterpreted,+ GHC.log_action = log_handler}+ GHC.setSessionDynFlags ghc_session myFlags+ --+ return . InterpreterSession =<< newMVar session_state++mkLogHandler :: IORef [GhcError] -> GhcErrLogger+mkLogHandler r _ src style msg = modifyIORef r (errorEntry :)+ where errorEntry = mkGhcError src style msg++fromSessionState :: (SessionState -> a) -> Interpreter a+fromSessionState f = Interpreter $ fmap f ask++-- modifies the session state and returns the old value+modifySessionState :: Show a+ => (SessionState -> IORef a)+ -> (a -> a)+ -> Interpreter a+modifySessionState target f =+ do+ ref <- fromSessionState target+ old_val <- liftIO $ atomicModifyIORef ref (\a -> (f a, a))+ return old_val++-- | Set to true to allow GHC's extensions to Haskell 98.+setUseLanguageExtensions :: Bool -> Interpreter ()+setUseLanguageExtensions val =+ do+ ghc_session <- fromSessionState ghcSession+ --+ let negate_or_not = if val then "" else "no-"+ let flag = concat ["-f", negate_or_not, "glasgow-exts"]+ --+ old_flags <- liftIO $ GHC.getSessionDynFlags ghc_session+ (new_flags, not_parsed) <- liftIO $ GHC.parseDynamicFlags old_flags+ [flag]+ --+ when (not . null $ not_parsed) $+ throwError $ UnknownError (concat ["flag: '", flag,+ "' not recognized"])+ --+ liftIO $ GHC.setSessionDynFlags ghc_session new_flags+ --+ return ()++-- | Module names are _not_ filepaths.+type ModuleName = String++-- | Tries to load all the requested modules from their source file.+-- Modules my be indicated by their ModuleName (e.g. \"My.Module\") or+-- by the full path to its source file.+--+-- The interpreter is 'reset' both before loading the modules and in the event+-- of an error.+loadModules :: [String] -> Interpreter ()+loadModules fs =+ do+ ghc_session <- fromSessionState ghcSession+ --+ -- first, unload everything+ reset+ --+ let doLoad = mayFail $ do+ targets <- mapM (\f -> GHC.guessTarget f Nothing) fs+ --+ GHC.setTargets ghc_session targets+ res <- GHC.load ghc_session GHC.LoadAllTargets+ return $ guard (isSucceeded res) >> Just ()+ --+ doLoad `catchError` (\e -> reset >> throwError e)+ --+ return ()++-- | Returns the list of modules loaded with 'loadModules'.+getLoadedModules :: Interpreter [ModuleName]+getLoadedModules = liftM (map modNameFromSummary) getLoadedModSummaries++modNameFromSummary :: GHC.ModSummary -> ModuleName+modNameFromSummary = modNameFromModule . GHC.ms_mod++modNameFromModule :: GHC.Module -> ModuleName+modNameFromModule = GHC.moduleNameString . GHC.moduleName++getLoadedModSummaries :: Interpreter [GHC.ModSummary]+getLoadedModSummaries =+ do ghc_session <- fromSessionState ghcSession+ --+ all_mod_summ <- liftIO $ GHC.getModuleGraph ghc_session+ filterM (liftIO . GHC.isLoaded ghc_session . GHC.ms_mod_name) all_mod_summ++-- | Sets the modules whose context is used during evaluation. All bindings+-- of these modules are in scope, not only those exported.+--+-- Modules must be interpreted to use this function.+setTopLevelModules :: [ModuleName] -> Interpreter ()+setTopLevelModules ms =+ do+ ghc_session <- fromSessionState ghcSession+ --+ loaded_mods_ghc <- getLoadedModSummaries+ --+ let not_loaded = ms \\ map modNameFromSummary loaded_mods_ghc+ when (not . null $ not_loaded) $+ throwError $ NotAllowed ("These modules have not been loaded:\n" +++ unlines not_loaded)+ --+ ms_mods <- mapM findModule ms+ --+ let mod_is_interpr = GHC.moduleIsInterpreted ghc_session+ not_interpreted <- liftIO $ filterM (liftM not . mod_is_interpr) ms_mods+ when (not . null $ not_interpreted) $+ throwError $ NotAllowed ("These modules are not interpreted:\n" +++ unlines (map modNameFromModule+ not_interpreted))+ --+ liftIO $ do+ (_, old_imports) <- GHC.getContext ghc_session+ GHC.setContext ghc_session ms_mods old_imports++findModule :: ModuleName -> Interpreter GHC.Module+findModule mn =+ do+ ghc_session <- fromSessionState ghcSession+ --+ let mod_name = GHC.mkModuleName mn+ mapGhcExceptions NotAllowed $ GHC.findModule ghc_session+ mod_name+ Nothing++mapGhcExceptions :: (String -> InterpreterError) -> IO a -> Interpreter a+mapGhcExceptions buildEx action =+ do+ r <- liftIO $ tryJust ghcExceptions action+ either (throwError . buildEx . flip GHC.showGhcException []) return r++ghcExceptions :: Exception -> Maybe GHC.GhcException+ghcExceptions (DynException a) = fromDynamic a+ghcExceptions _ = Nothing++-- | Sets the modules whose exports must be in context.+setImports :: [ModuleName] -> Interpreter ()+setImports ms =+ do+ ghc_session <- fromSessionState ghcSession+ --+ ms_mods <- mapM findModule ms+ --+ liftIO $ do+ (old_top_level, _) <- GHC.getContext ghc_session+ GHC.setContext ghc_session old_top_level ms_mods++-- | All imported modules are cleared from the context, and+-- loaded modules are unloaded. It is similar to a @:load@ in+-- GHCi, but observe that not even the Prelude will be in+-- context after a reset.+reset :: Interpreter ()+reset =+ do+ ghc_session <- fromSessionState ghcSession+ --+ -- Remove all modules from context+ liftIO $ GHC.setContext ghc_session [] []+ --+ -- Unload all previously loaded modules+ liftIO $ GHC.setTargets ghc_session []+ liftIO $ GHC.load ghc_session GHC.LoadAllTargets+ --+ -- At this point, GHCi would call rts_revertCAFs and+ -- reset the buffering of stdin, stdout and stderr.+ -- Should we do any of these?+ --+ -- liftIO $ rts_revertCAFs+ --+ return ()+++-- | Returns a string representation of the type of the expression.+typeOf :: String -> Interpreter String+typeOf expr =+ do+ ghc_session <- fromSessionState ghcSession+ --+ -- First, make sure the expression has no syntax errors,+ -- for this is the only way we have to "intercept" this+ -- kind of errors+ failOnParseError parseExpr expr+ --+ ty <- mayFail $ GHC.exprType ghc_session expr+ --+ -- Unqualify necessary types (i.e., do not expose internals)+ unqual <- liftIO $ GHC.getPrintUnqual ghc_session+ return $ fromGhcRep (GHC.dropForAlls ty, unqual)++-- | Tests if the expression type checks.+typeChecks :: String -> Interpreter Bool+typeChecks expr = (typeOf expr >> return True)+ `catchError`+ onCompilationError (\_ -> return False)++-- | Returns a string representation of the kind of the type expression.+kindOf :: String -> Interpreter String+kindOf type_expr =+ do+ ghc_session <- fromSessionState ghcSession+ --+ -- First, make sure the expression has no syntax errors,+ -- for this is the only way we have to "intercept" this+ -- kind of errors+ failOnParseError parseType type_expr++ kind <- mayFail $ GHC.typeKind ghc_session type_expr+ --+ return $ fromGhcRep kind+++-- | Convenience functions to be used with typeCheck to provide witnesses.+-- Example:+--+-- * @interpret \"head [True,False]\" (as :: Bool)@+--+-- * @interpret \"head $ map show [True,False]\" infer >>= flip interpret (as :: Bool)@+as, infer :: Typeable a => a+as = undefined+infer = undefined++-- | Evaluates an expression, given a witness for its monomorphic type.+interpret :: Typeable a => String -> a -> Interpreter a+interpret expr witness =+ do+ ghc_session <- fromSessionState ghcSession+ --+ -- First, make sure the expression has no syntax errors,+ -- for this is the only way we have to "intercept" this+ -- kind of errors+ failOnParseError parseExpr expr+ --+ let expr_typesig = concat ["(", expr, ") :: ", show $ myTypeOf witness]+ expr_val <- mayFail $ GHC.compileExpr ghc_session expr_typesig+ --+ return (GHC.Exts.unsafeCoerce# expr_val :: a)++-- HACK! Allows evaluations even when the Prelude is not in scope+myTypeOf :: Typeable a => a -> TypeRep+myTypeOf a+ | type_of_a == type_of_string = qual_type_of_string+ | otherwise = type_of_a+ where type_of_a = Data.Typeable.typeOf a+ type_of_string = Data.Typeable.typeOf (undefined :: [Char])+ (list_ty_con, _) = splitTyConApp type_of_string+ qual_type_of_string = mkTyConApp list_ty_con+ [mkTyConApp (mkTyCon "Prelude.Char") []]++-- | @eval expr@ will evaluate @show expr@.+-- It will succeed only if @expr@ has type t and there is a 'Show'+-- instance for t.+eval :: String -> Interpreter String+eval expr = interpret show_expr (as :: String)+ where show_expr = unwords ["Prelude.show", "(", expr, ") "]++mayFail :: IO (Maybe a) -> Interpreter a+mayFail ghc_action =+ do+ maybe_res <- liftIO ghc_action+ --+ es <- modifySessionState ghcErrListRef (const [])+ --+ case maybe_res of+ Nothing -> if null es+ then throwError $ UnknownError "Got no error message"+ else throwError $ WontCompile (reverse es)+ Just a -> if null es+ then return a+ else fail "GHC reported errors and also gave a result!"++failOnParseError :: (GHC.Session -> String -> IO ParseResult)+ -> String+ -> Interpreter ()+failOnParseError parser expr =+ do+ ghc_session <- fromSessionState ghcSession+ --+ parsed <- liftIO $ parser ghc_session expr+ --+ -- If there was a parsing error, do the "standard" error reporting+ res <- case parsed of+ ParseOk -> return (Just ())+ --+ ParseError span err ->+ do+ -- parsing failed, so we report it just as all+ -- other errors get reported....+ logger <- fromSessionState ghcErrLogger+ liftIO $ logger GHC.SevError+ span+ GHC.O.defaultErrStyle+ err+ --+ -- behave like the rest of the GHC API functions+ -- do on error...+ return Nothing+ --+ -- "may Have Already Failed", actually :)+ mayFail (return res)++isSucceeded :: GHC.SuccessFlag -> Bool+isSucceeded GHC.Succeeded = True+isSucceeded GHC.Failed = False++onCompilationError :: ([GhcError] -> Interpreter a)+ -> (InterpreterError -> Interpreter a)+onCompilationError recover =+ \interp_error -> case interp_error of+ WontCompile errs -> recover errs+ otherErr -> throwError otherErr++-- SHOULD WE CALL THIS WHEN MODULES ARE LOADED / UNLOADED?+-- foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
+ src/Language/Haskell/Interpreter/GHC/Conversions.hs view
@@ -0,0 +1,38 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+module Language.Haskell.Interpreter.GHC.Conversions(FromGhcRep(..))++where++import qualified GHC as GHC (Type, Kind, PrintUnqualified, alwaysQualify)+import qualified Outputable as GHC.O(Outputable(ppr), showSDoc, showSDocForUser)++import Language.Haskell.Syntax(HsModule(..), HsDecl(..), HsQualType)+import Language.Haskell.Parser(parseModule, ParseResult(ParseOk))++-- | Conversions from GHC representation to standard representations+class FromGhcRep ghc target where+ fromGhcRep :: ghc -> target++-- --------- Types -----------------------+instance FromGhcRep GHC.Type HsQualType where+ fromGhcRep t = fromGhcRep (t, GHC.alwaysQualify)++instance FromGhcRep (GHC.Type, GHC.PrintUnqualified) HsQualType where+ fromGhcRep (t, p) = qualType+ where HsModule _ _ _ _ [decl,_] = parseModule' $ unlines ["f ::" ++ fromGhcRep (t,p),+ "f = undefined"]+ HsTypeSig _ _ qualType = decl++instance FromGhcRep (GHC.Type, GHC.PrintUnqualified) String where+ fromGhcRep (t, p) = GHC.O.showSDocForUser p . GHC.O.ppr $ t++parseModule' :: String -> HsModule+parseModule' s = case parseModule s of+ ParseOk m -> m+ failed -> error $ unlines ["parseModulde' failed?!", s, show failed]+++-- --------------------- Kinds -----------------++instance FromGhcRep GHC.Kind String where+ fromGhcRep k = GHC.O.showSDoc (GHC.O.ppr k)
+ src/Language/Haskell/Interpreter/GHC/Parsers.hs view
@@ -0,0 +1,35 @@+module Language.Haskell.Interpreter.GHC.Parsers++where++import Prelude hiding(span)++import qualified GHC(Session, getSessionDynFlags)++import qualified Lexer as GHC.L (P(..), ParseResult(..), mkPState)+import qualified Parser as GHC.P (parseStmt, parseType)+import qualified StringBuffer as GHC.SB(stringToStringBuffer)+import qualified SrcLoc as GHC.S (SrcSpan, noSrcLoc)+import qualified ErrUtils as GHC.E (Message)++data ParseResult = ParseOk | ParseError GHC.S.SrcSpan GHC.E.Message++parseExpr :: GHC.Session -> String -> IO ParseResult+parseExpr = runParser GHC.P.parseStmt++parseType :: GHC.Session -> String -> IO ParseResult+parseType = runParser GHC.P.parseType++runParser :: GHC.L.P a -> GHC.Session -> String -> IO ParseResult+runParser parser ghc_session expr =+ do+ dyn_fl <- GHC.getSessionDynFlags ghc_session+ --+ buf <- GHC.SB.stringToStringBuffer expr+ --+ let parse_res = GHC.L.unP parser (GHC.L.mkPState buf GHC.S.noSrcLoc dyn_fl)+ --+ case parse_res of+ GHC.L.POk{} -> return ParseOk+ --+ GHC.L.PFailed span err -> return (ParseError span err)