diff --git a/Changes b/Changes new file mode 100644 --- /dev/null +++ b/Changes @@ -0,0 +1,6 @@ +- ver 0.2 + + * Works also with GHC 6.8 and 6.6 + * Added the getModuleExports function + * withSession function throws a dynamic exception instead of returning Either Error a + * Requires Cabal 1.2.x diff --git a/README b/README --- a/README +++ b/README @@ -1,6 +1,24 @@ +=== Installation === To install locally: -> runhaskell Setup.lhs configure --prefix=$USER --user +> runhaskell Setup.lhs configure --prefix=$HOME --user > runhaskell Setup.lhs build > runhaskell Setup.lhs haddock > runhaskell Setup.lhs install + +=== Documentation === + +The library cames with haddock documentation you can build +(see above). Also, examples/example.hs to see a simple but +comprehensive example (it must be run from the examples +directory, since it expects to find the SomeModule.hs file +located there). + +=== Contact === + +Bug-reports, questions, suggestions and patches are all welcome. + +To get a copy of the darcs repository: + +darcs get http://www.glyc.dc.uba.ar/daniel/repos/hint + diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,60 +1,64 @@ #! /usr/bin/env runhaskell > import Distribution.Simple -> import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), autogenModulesDir ) -> import Distribution.Simple.Utils ( warn, die ) +> import Distribution.Simple.Program +> import Distribution.Simple.LocalBuildInfo hiding ( libdir ) +> import Distribution.Simple.Setup -> import System.IO ( readFile, writeFile ) +> import Distribution.Verbosity +> import Distribution.Simple.Utils ( warn, notice, die ) -> import System.Cmd ( system ) -> import System.Exit ( ExitCode(..) ) +> import System.IO ( writeFile ) > import System.FilePath ( () ) -> import System.Directory ( doesDirectoryExist, createDirectoryIfMissing, removeFile ) +> import System.Directory ( doesDirectoryExist ) -> import Control.Monad ( when, liftM ) +> import Control.Monad ( liftM ) +> main :: IO () > main = defaultMainWithHooks myHooks -> where myHooks = let h = defaultUserHooks in h{postConf = myPostConf (postConf h)} -> myPostConf oldHook = \a f p lbi -> (saveGhcLibdir lbi >> oldHook a f p lbi) +> where myHooks = let h = defaultUserHooks +> in h{postConf = myPostConf (postConf h)} +> myPostConf oldHook = \a f p lbi -> do let verb = configVerbose f +> saveGhcLibdir verb lbi +> oldHook a f p lbi -> saveGhcLibdir :: 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 +> saveGhcLibdir :: Verbosity -> LocalBuildInfo -> IO () +> saveGhcLibdir verbosity lbi = +> do libdir <- removeTrailingEOL `liftM` +> queryGHC verbosity lbi ["--print-libdir"] +> is_ok <- doesDirectoryExist libdir +> if not is_ok +> then warn verbosity $ concat ["Suspicious ghc libdir: '", +> libdir, +> "'"] +> else notice verbosity $ concat ["Using ghc libdir: '", +> libdir, +> "'"] +> -- +> let mod_dir = "Language" "Haskell" "Interpreter" "GHC" +> let ghc_libdir_module_file = "src" mod_dir "LibDir.hs" +> writeFile ghc_libdir_module_file $ mkGhcLibdirModule libdir +> queryGHC :: Verbosity -> LocalBuildInfo -> [String] -> IO String +> queryGHC verbosity lbi args = +> do ghc <- maybe (die "GHC not found") +> return +> (lookupProgram ghcProgram $ withPrograms lbi) +> -- +> rawSystemProgramStdout verbosity ghc args > mkGhcLibdirModule :: FilePath -> String -> mkGhcLibdirModule libdir = unlines ["-- Autogenerated by Cabal script... DO NOT MODIFY!", -> "module Language.Haskell.Interpreter.GHC.LibDir ( ghc_libdir )", -> "", -> "where", -> "", -> "ghc_libdir :: FilePath", -> "ghc_libdir = " ++ show libdir] +> mkGhcLibdirModule libdir = unlines m +> where m = ["-- Autogenerated by Cabal script... DO NOT MODIFY!", +> "module Language.Haskell.Interpreter.GHC.LibDir ( ghc_libdir )", +> "", +> "where", +> "", +> "ghc_libdir :: FilePath", +> "ghc_libdir = " ++ show libdir] > removeTrailingEOL :: String -> String > removeTrailingEOL [] = [] > removeTrailingEOL ['\n'] = [] > removeTrailingEOL (x:xs) = x : removeTrailingEOL xs - -> message :: String -> IO () -> message s = putStrLn $ "configure: " ++ s diff --git a/examples/example.hs b/examples/example.hs new file mode 100644 --- /dev/null +++ b/examples/example.hs @@ -0,0 +1,64 @@ +import Control.Monad +import Control.Monad.Trans ( liftIO ) +import Language.Haskell.Interpreter.GHC + +import Control.Exception ( catchDyn ) + +main :: IO () +main = do s <- newSession + withSession s testHint + putStrLn "that's all folks" + `catchDyn` printInterpreterError + +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. Let's check it..." + exports <- getModuleExports "SomeModule" + say (show exports) + -- + 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 + +printInterpreterError :: InterpreterError -> IO () +printInterpreterError e = putStrLn $ "Ups... " ++ (show e) + diff --git a/examples/example1.hs b/examples/example1.hs deleted file mode 100644 --- a/examples/example1.hs +++ /dev/null @@ -1,55 +0,0 @@ -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 --- a/hint.cabal +++ b/hint.cabal @@ -1,22 +1,46 @@ -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. +name: hint +version: 0.2 +description: + This library defines an @Interpreter@ monad. It allows to load Haskell + modules, browse them, type-check and evaluate strings with Haskell + expressions and even coerce them into values. The library is + thread-safe and type-safe (even the coertion of expressions to + values). + 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 + API. Works with GHC 6.6.x and 6.8.x. +synopsis: Runtime Haskell interpreter (GHC API wrapper) +category: Language, Compilers/Interpreters +license: BSD3 +license-file: LICENSE +author: Daniel Gorin +maintainer: jcpetruzza@gmail.com + +cabal-version: >= 1.2 +build-type: Custom +tested-with: GHC==6.6.1, GHC==6.8.2 + + +build-depends: base, haskell-src, ghc, mtl + +exposed-modules: Language.Haskell.Interpreter.GHC +other-modules: Language.Haskell.Interpreter.GHC.Base + Language.Haskell.Interpreter.GHC.Compat + Language.Haskell.Interpreter.GHC.Conversions Language.Haskell.Interpreter.GHC.Parsers Language.Haskell.Interpreter.GHC.LibDir -ghc-options: -Wall -O2 + hs-source-dirs: src +extra-source-files: README + Changes + examples/example.hs + examples/SomeModule.hs + +ghc-options: -Wall -O2 +extensions: CPP + GeneralizedNewtypeDeriving + MultiParamTypeClasses + DeriveDataTypeable + MagicHash + TypeSynonymInstances + FlexibleInstances diff --git a/src/Language/Haskell/Interpreter/GHC.hs b/src/Language/Haskell/Interpreter/GHC.hs --- a/src/Language/Haskell/Interpreter/GHC.hs +++ b/src/Language/Haskell/Interpreter/GHC.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.Interpreter.GHC @@ -21,11 +20,14 @@ withSession, -- ** Interpreter options setUseLanguageExtensions, - -- ** Module handling + -- ** Context handling ModuleName, loadModules, getLoadedModules, setTopLevelModules, setImports, reset, + -- ** Module querying + ModuleElem(..), Id, name, children, + getModuleExports, -- ** Type inference typeOf, typeChecks, kindOf, -- ** Evaluation @@ -37,21 +39,15 @@ 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 Outputable as GHC.O +import qualified ErrUtils as GHC.E +import qualified Name as GHC.N import qualified GHC.Exts ( unsafeCoerce# ) import Control.Monad ( liftM, filterM, guard, when ) -import Control.Monad.Trans ( 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.Monad.Trans ( liftIO ) +import Control.Monad.Error ( MonadError(throwError, catchError) ) import Control.Exception ( Exception(DynException), tryJust ) @@ -60,130 +56,16 @@ import qualified Data.Typeable ( typeOf ) import Data.Dynamic ( fromDynamic ) -import Data.List ( (\\) ) +import Data.List ( (\\) ) +import Data.Maybe ( catMaybes ) +import Language.Haskell.Interpreter.GHC.Base + import Language.Haskell.Interpreter.GHC.Parsers ( ParseResult(..), parseExpr, parseType ) import Language.Haskell.Interpreter.GHC.Conversions ( FromGhcRep(..) ) --- 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 +import qualified Language.Haskell.Interpreter.GHC.Compat as Compat -- | Set to true to allow GHC's extensions to Haskell 98. setUseLanguageExtensions :: Bool -> Interpreter () @@ -209,6 +91,22 @@ -- | Module names are _not_ filepaths. type ModuleName = String +-- | An Id for a class, a type constructor, a data constructor, a binding, etc +type Id = String + +data ModuleElem = Fun Id | Class Id [Id] | Data Id [Id] + deriving (Read, Show, Eq) + +name :: ModuleElem -> Id +name (Fun f) = f +name (Class c _) = c +name (Data d _) = d + +children :: ModuleElem -> [Id] +children (Fun _) = [] +children (Class _ ms) = ms +children (Data _ dcs) = dcs + -- | Tries to load all the requested modules from their source file. -- Modules my be indicated by their ModuleName (e.g. \"My.Module\") or -- by the full path to its source file. @@ -280,6 +178,45 @@ (_, old_imports) <- GHC.getContext ghc_session GHC.setContext ghc_session ms_mods old_imports +-- | Gets an abstract representation of all the entities exported by the module. +-- It is similar to the @:browse@ command in GHCi. +getModuleExports :: ModuleName -> Interpreter [ModuleElem] +getModuleExports mn = + do + ghc_session <- fromSessionState ghcSession + -- + module_ <- findModule mn + mod_info <- mayFail $ GHC.getModuleInfo ghc_session module_ + exports <- liftIO $ mapM (GHC.lookupName ghc_session) + (GHC.modInfoExports mod_info) + -- + return (asModElemList $ catMaybes exports) + +asModElemList :: [GHC.TyThing] -> [ModuleElem] +asModElemList xs = concat [cs', + ts', + ds \\ (concatMap (map Fun . children) ts'), + fs \\ (concatMap (map Fun . children) cs')] + where (cs,ts,ds,fs) = ([asModElem c | c@GHC.AClass{} <- xs], + [asModElem t | t@GHC.ATyCon{} <- xs], + [asModElem d | d@GHC.ADataCon{} <- xs], + [asModElem f | f@GHC.AnId{} <- xs]) + cs' = [Class n $ filter (alsoIn fs) ms | Class n ms <- cs] + ts' = [Data t $ filter (alsoIn ds) dcs | Data t dcs <- ts] + alsoIn es = (`elem` (map name es)) + + +asModElem :: GHC.TyThing -> ModuleElem +asModElem (GHC.AnId f) = Fun $ getUnqualName f +asModElem (GHC.ADataCon dc) = Fun $ getUnqualName dc +asModElem (GHC.ATyCon tc) = Data (getUnqualName tc) + (map getUnqualName $ GHC.tyConDataCons tc) +asModElem (GHC.AClass c) = Class (getUnqualName c) + (map getUnqualName $ GHC.classMethods c) + +getUnqualName :: GHC.NamedThing a => a -> String +getUnqualName = GHC.O.showSDocUnqual . GHC.pprParenSymName + findModule :: ModuleName -> Interpreter GHC.Module findModule mn = do @@ -350,10 +287,9 @@ -- 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) + fromGhcRep ty + -- | Tests if the expression type checks. typeChecks :: String -> Interpreter Bool typeChecks expr = (typeOf expr >> return True) @@ -373,7 +309,7 @@ kind <- mayFail $ GHC.typeKind ghc_session type_expr -- - return $ fromGhcRep kind + fromGhcRep (Compat.Kind kind) -- | Convenience functions to be used with typeCheck to provide witnesses. diff --git a/src/Language/Haskell/Interpreter/GHC/Base.hs b/src/Language/Haskell/Interpreter/GHC/Base.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Interpreter/GHC/Base.hs @@ -0,0 +1,144 @@ +module Language.Haskell.Interpreter.GHC.Base + +where + +import Control.Monad.Trans ( MonadIO(liftIO) ) +import Control.Monad.Reader ( ReaderT, ask, runReaderT ) +import Control.Monad.Error ( Error(..), MonadError(..), ErrorT, runErrorT ) + +import Control.Exception ( throwDyn ) + +import Control.Concurrent.MVar ( MVar, newMVar, withMVar ) +import Data.IORef ( IORef, newIORef, + modifyIORef, atomicModifyIORef ) + +import Data.Typeable ( Typeable ) + +import qualified GHC +import qualified Outputable as GHC.O +import qualified SrcLoc as GHC.S +import qualified ErrUtils as GHC.E + + +import qualified Language.Haskell.Interpreter.GHC.Compat as Compat + +-- autogenerated by Cabal script +import Language.Haskell.Interpreter.GHC.LibDir ( ghc_libdir ) + + +newtype Interpreter a = + Interpreter{unInterpreter :: ReaderT SessionState + (ErrorT InterpreterError + IO) a} + deriving (Typeable, Functor, Monad, MonadIO) + + +instance MonadError InterpreterError Interpreter where + throwError = Interpreter . throwError + catchError (Interpreter m) catchE = Interpreter $ m `catchError` (\e -> + unInterpreter $ catchE e) + +data InterpreterError = UnknownError String + | WontCompile [GhcError] + | NotAllowed String + deriving (Show, Typeable) + +instance Error InterpreterError where + noMsg = UnknownError "" + strMsg = UnknownError + + +-- I'm assuming operations on a ghcSession are not thread-safe. Besides, we need +-- to be sure that messages captured by the log handler correspond to a single +-- operation. Hence, we put the whole state on an MVar, and synchronize on it +newtype InterpreterSession = + InterpreterSession {sessionState :: MVar SessionState} + +data SessionState = SessionState{ghcSession :: GHC.Session, + ghcErrListRef :: IORef [GhcError], + ghcErrLogger :: GhcErrLogger} + +-- When intercepting errors reported by GHC, we only get a GHC.E.Message +-- and a GHC.S.SrcSpan. The latter holds the file name and the location +-- of the error. However, SrcSpan is abstract and it doesn't provide +-- functions to retrieve the line and column of the error... we can only +-- generate a string with this information. Maybe I can parse this string +-- later.... (sigh) +data GhcError = GhcError{errMsg :: String} deriving Show + +mkGhcError :: GHC.S.SrcSpan -> GHC.O.PprStyle -> GHC.E.Message -> GhcError +mkGhcError src_span style msg = GhcError{errMsg = niceErrMsg} + where niceErrMsg = GHC.O.showSDoc . GHC.O.withPprStyle style $ + GHC.E.mkLocMessage src_span msg + +type GhcErrLogger = GHC.Severity + -> GHC.S.SrcSpan + -> GHC.O.PprStyle + -> GHC.E.Message + -> IO () + +-- ================= Creating a session ========================= + +-- | Builds a new session using the (hopefully) correct path to the GHC in use. +-- (the path is determined at build time of the package) +newSession :: IO InterpreterSession +newSession = newSessionUsing ghc_libdir + +-- | Builds a new session, given the path to a GHC installation +-- (e.g. \/usr\/local\/lib\/ghc-6.6). +newSessionUsing :: FilePath -> IO InterpreterSession +newSessionUsing ghc_root = + do + ghc_session <- Compat.newSession ghc_root + -- + ghc_err_list_ref <- newIORef [] + let log_handler = mkLogHandler ghc_err_list_ref + -- + let session_state = SessionState{ghcSession = ghc_session, + ghcErrListRef = ghc_err_list_ref, + ghcErrLogger = log_handler} + -- + -- set 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 + + +-- ================= Executing the interpreter ================== + +-- | Executes the interpreter using a given session. This is a thread-safe +-- operation, if the InterpreterSession is in-use, the call will block until +-- the other one finishes. +-- +-- In case of error, it will throw a dynamic InterpreterError exception. +withSession :: InterpreterSession -> Interpreter a -> IO a +withSession s i = withMVar (sessionState s) $ \ss -> + do err_or_res <- runErrorT . flip runReaderT ss $ unInterpreter i + either throwDyn return err_or_res + + +-- ================ Handling the interpreter state ================= + +fromSessionState :: (SessionState -> a) -> Interpreter a +fromSessionState f = Interpreter $ fmap f ask + +-- modifies the session state and returns the old value +modifySessionState :: Show a + => (SessionState -> IORef a) + -> (a -> a) + -> Interpreter a +modifySessionState target f = + do + ref <- fromSessionState target + old_val <- liftIO $ atomicModifyIORef ref (\a -> (f a, a)) + return old_val diff --git a/src/Language/Haskell/Interpreter/GHC/Compat.hs b/src/Language/Haskell/Interpreter/GHC/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Interpreter/GHC/Compat.hs @@ -0,0 +1,42 @@ +module Language.Haskell.Interpreter.GHC.Compat + +where + +import qualified GHC +import qualified Pretty +import qualified Outputable + +#if __GLASGOW_HASKELL__ >= 608 + +import qualified PprTyThing + +#endif + +-- Kinds became a synonym for Type in GHC 6.8. We define this wrapper +-- to be able to define a FromGhcRep instance for both versions +newtype Kind = Kind GHC.Kind + +#if __GLASGOW_HASKELL__ >= 608 + +newSession :: FilePath -> IO GHC.Session +newSession ghc_root = GHC.newSession (Just ghc_root) + +pprType :: GHC.Type -> (Outputable.PprStyle -> Pretty.Doc) +pprType = PprTyThing.pprTypeForUser False -- False means drop explicit foralls + +pprKind :: GHC.Kind -> (Outputable.PprStyle -> Pretty.Doc) +pprKind = pprType + +#elif __GLASGOW_HASKELL__ >= 606 + +newSession :: FilePath -> IO GHC.Session +newSession ghc_root = GHC.newSession GHC.Interactive (Just ghc_root) + +pprType :: GHC.Type -> (Outputable.PprStyle -> Pretty.Doc) +pprType = Outputable.ppr . GHC.dropForAlls + +pprKind :: GHC.Kind -> (Outputable.PprStyle -> Pretty.Doc) +pprKind = Outputable.ppr + +#endif + diff --git a/src/Language/Haskell/Interpreter/GHC/Conversions.hs b/src/Language/Haskell/Interpreter/GHC/Conversions.hs --- a/src/Language/Haskell/Interpreter/GHC/Conversions.hs +++ b/src/Language/Haskell/Interpreter/GHC/Conversions.hs @@ -1,38 +1,50 @@ -{-# 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 Control.Monad.Trans ( liftIO ) -import Language.Haskell.Syntax(HsModule(..), HsDecl(..), HsQualType) -import Language.Haskell.Parser(parseModule, ParseResult(ParseOk)) +import qualified GHC as GHC +import qualified Outputable as GHC.O +import Language.Haskell.Interpreter.GHC.Base +import qualified Language.Haskell.Interpreter.GHC.Compat as Compat + +import Language.Haskell.Syntax ( HsModule(..), HsDecl(..), HsQualType ) +import Language.Haskell.Parser ( parseModule, ParseResult(ParseOk) ) + -- | Conversions from GHC representation to standard representations class FromGhcRep ghc target where - fromGhcRep :: ghc -> target + fromGhcRep :: ghc -> Interpreter target --- --------- Types ----------------------- +-- --------- Types / Kinds ----------------------- + instance FromGhcRep GHC.Type HsQualType where - fromGhcRep t = fromGhcRep (t, GHC.alwaysQualify) + fromGhcRep t = + do t_str <- fromGhcRep t + -- + let mod_str = unlines ["f ::" ++ t_str, + "f = undefined"] + let HsModule _ _ _ _ [decl,_] = parseModule' mod_str + HsTypeSig _ _ qualType = decl + -- + return qualType -instance FromGhcRep (GHC.Type, 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 +instance FromGhcRep GHC.Type String where + fromGhcRep t = do ghc_session <- fromSessionState ghcSession + -- Unqualify necessary types + -- (i.e., do not expose internals) + unqual <- liftIO $ GHC.getPrintUnqual ghc_session + return $ GHC.O.showSDocForUser unqual (Compat.pprType t) parseModule' :: String -> HsModule parseModule' s = case parseModule s of ParseOk m -> m - failed -> error $ unlines ["parseModulde' failed?!", s, show failed] - + failed -> error $ unlines ["parseModulde' failed?!", + s, + show failed] --- --------------------- Kinds ----------------- +instance FromGhcRep Compat.Kind String where + fromGhcRep (Compat.Kind k) = return $ GHC.O.showSDoc (Compat.pprKind k) -instance FromGhcRep GHC.Kind String where - fromGhcRep k = GHC.O.showSDoc (GHC.O.ppr k) diff --git a/src/Language/Haskell/Interpreter/GHC/LibDir.hs b/src/Language/Haskell/Interpreter/GHC/LibDir.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Interpreter/GHC/LibDir.hs @@ -0,0 +1,7 @@ +-- Autogenerated by Cabal script... DO NOT MODIFY! +module Language.Haskell.Interpreter.GHC.LibDir ( ghc_libdir ) + +where + +ghc_libdir :: FilePath +ghc_libdir = "/opt/local/lib/ghc-6.8.2" diff --git a/src/Language/Haskell/Interpreter/GHC/Parsers.hs b/src/Language/Haskell/Interpreter/GHC/Parsers.hs --- a/src/Language/Haskell/Interpreter/GHC/Parsers.hs +++ b/src/Language/Haskell/Interpreter/GHC/Parsers.hs @@ -33,3 +33,4 @@ GHC.L.POk{} -> return ParseOk -- GHC.L.PFailed span err -> return (ParseError span err) +