GHC.hs

{-# 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 ()