hint 0.1 → 0.2
raw patch · 12 files changed
+474/−271 lines, 12 filessetup-changed
Files
- Changes +6/−0
- README +19/−1
- Setup.lhs +45/−41
- examples/example.hs +64/−0
- examples/example1.hs +0/−55
- hint.cabal +42/−18
- src/Language/Haskell/Interpreter/GHC.hs +72/−136
- src/Language/Haskell/Interpreter/GHC/Base.hs +144/−0
- src/Language/Haskell/Interpreter/GHC/Compat.hs +42/−0
- src/Language/Haskell/Interpreter/GHC/Conversions.hs +32/−20
- src/Language/Haskell/Interpreter/GHC/LibDir.hs +7/−0
- src/Language/Haskell/Interpreter/GHC/Parsers.hs +1/−0
+ Changes view
@@ -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
README view
@@ -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+
Setup.lhs view
@@ -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
+ examples/example.hs view
@@ -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)+
− examples/example1.hs
@@ -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
hint.cabal view
@@ -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
src/Language/Haskell/Interpreter/GHC.hs view
@@ -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.
+ src/Language/Haskell/Interpreter/GHC/Base.hs view
@@ -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
+ src/Language/Haskell/Interpreter/GHC/Compat.hs view
@@ -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+
src/Language/Haskell/Interpreter/GHC/Conversions.hs view
@@ -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)
+ src/Language/Haskell/Interpreter/GHC/LibDir.hs view
@@ -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"
src/Language/Haskell/Interpreter/GHC/Parsers.hs view
@@ -33,3 +33,4 @@ GHC.L.POk{} -> return ParseOk -- GHC.L.PFailed span err -> return (ParseError span err)+