diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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 diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -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 diff --git a/examples/SomeModule.hs b/examples/SomeModule.hs new file mode 100644 --- /dev/null +++ b/examples/SomeModule.hs @@ -0,0 +1,7 @@ +module SomeModule(g, h) where + +f = head + +g = f [f] + +h = f diff --git a/examples/example1.hs b/examples/example1.hs new file mode 100644 --- /dev/null +++ b/examples/example1.hs @@ -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 diff --git a/hint.cabal b/hint.cabal new file mode 100644 --- /dev/null +++ b/hint.cabal @@ -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 diff --git a/src/Language/Haskell/Interpreter/GHC.hs b/src/Language/Haskell/Interpreter/GHC.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Interpreter/GHC.hs @@ -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 () diff --git a/src/Language/Haskell/Interpreter/GHC/Conversions.hs b/src/Language/Haskell/Interpreter/GHC/Conversions.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Interpreter/GHC/Conversions.hs @@ -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) diff --git a/src/Language/Haskell/Interpreter/GHC/Parsers.hs b/src/Language/Haskell/Interpreter/GHC/Parsers.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Interpreter/GHC/Parsers.hs @@ -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)