module Mueval.Interpreter where
import Control.Monad (guard,mplus,unless,when)
import Control.Monad.Trans (MonadIO)
import Control.Monad.Writer (Any(..),runWriterT,tell)
import Data.Char (isDigit)
import Data.List (stripPrefix)
import System.Directory (copyFile, makeRelativeToCurrentDirectory, setCurrentDirectory)
import System.Exit (exitFailure)
import System.FilePath.Posix (takeFileName)
import qualified Control.Exception.Extensible as E (evaluate,catch,SomeException(..))
import qualified System.IO.UTF8 as UTF (putStrLn)
import Language.Haskell.Interpreter (eval, set, reset, setImportsQ, loadModules, liftIO,
installedModulesInScope, languageExtensions,
typeOf, setTopLevelModules, runInterpreter, glasgowExtensions,
OptionVal(..), Interpreter,
InterpreterError(..),GhcError(..))
import Mueval.ArgsParse (Options(..))
import qualified Mueval.Resources as MR (limitResources)
import qualified Mueval.Context as MC (qualifiedModules)
interpreter :: Options -> Interpreter (String,String,String)
interpreter Options { extensions = exts, namedExtensions = nexts,
rLimits = rlimits,
loadFile = load, expression = expr,
modules = m } = do
let lexts = (guard exts >> glasgowExtensions) ++ map read nexts
unless (null lexts) $ set [languageExtensions := lexts]
reset
set [installedModulesInScope := False]
when (load /= "") $ do liftIO (mvload load)
let lfl' = takeFileName load
loadModules [lfl']
setTopLevelModules [takeWhile (/='.') lfl']
liftIO $ MR.limitResources rlimits
case m of
Nothing -> return ()
Just ms -> do let unqualModules = zip ms (repeat Nothing)
setImportsQ (unqualModules ++ MC.qualifiedModules)
etype <- typeOf expr
result <- eval expr
return (expr, etype, result)
interpreterSession :: Options -> IO ()
interpreterSession opts = do r <- runInterpreter (interpreter opts)
case r of
Left err -> printInterpreterError err
Right (e,et,val) -> when (printType opts) (sayIO e >> sayIO et) >> sayIO val
mvload :: FilePath -> IO ()
mvload lfl = do canonfile <- makeRelativeToCurrentDirectory lfl
liftIO $ copyFile canonfile $ "/tmp/" ++ takeFileName canonfile
setCurrentDirectory "/tmp"
sayIO :: String -> IO ()
sayIO str = do (out,b) <- render 1024 str
UTF.putStrLn out
when b exitFailure
printInterpreterError :: InterpreterError -> IO ()
printInterpreterError (WontCompile errors) =
do sayIO $ concatMap (dropLinePosition . errMsg) errors
exitFailure
where
dropLinePosition e
| Just s <- parseErr e = s
| otherwise = e
parseErr e = do s <- stripPrefix "<interactive>:" e
skipSpaces =<< (skipNumber =<< skipNumber s)
skip x (y:xs) | x == y = Just xs
| otherwise = Nothing
skip _ _ = Nothing
skipNumber = skip ':' . dropWhile isDigit
skipSpaces xs = let xs' = dropWhile (==' ') xs
in skip '\n' xs' `mplus` return xs'
printInterpreterError other = error (show other)
exceptionMsg :: String
exceptionMsg = "*Exception: "
render :: (Control.Monad.Trans.MonadIO m)
=> Int
-> String
-> m (String, Bool)
render i xs =
do (out,Any b) <- runWriterT $ render' i (toStream xs)
return (out,b)
where
render' n _ | n <= 0 = return ""
render' n s = render'' n =<< liftIO s
render'' _ End = return ""
render'' n (Cons x s) = fmap (x:) $ render' (n1) s
render'' n (Exception s) = do
tell (Any True)
fmap (take n exceptionMsg ++) $ render' (n length exceptionMsg) s
data Stream = Cons Char (IO Stream) | Exception (IO Stream) | End
toStream :: String -> IO Stream
toStream str = E.evaluate (uncons str) `E.catch`
\(E.SomeException e) -> return . Exception . toStream . show $ e
where uncons [] = End
uncons (x:xs) = x `seq` Cons x (toStream xs)