module Mueval.Interpreter where
import Control.Monad (when,mplus)
import System.Directory (copyFile, makeRelativeToCurrentDirectory)
import System.Exit (exitFailure)
import System.FilePath.Posix (takeFileName)
import qualified Control.OldException as E (evaluate,catch)
import Language.Haskell.Interpreter (eval, set, reset, setImportsQ, loadModules, liftIO,
installedModulesInScope, languageExtensions,
typeOf, setTopLevelModules, runInterpreter, glasgowExtensions,
OptionVal(..), Extension(ExtendedDefaultRules),
Interpreter, InterpreterError(..),GhcError(..), ModuleName)
import qualified Mueval.Resources (limitResources)
import qualified Mueval.Context (qualifiedModules)
import qualified System.IO.UTF8 as UTF (putStrLn)
import Control.Monad.Writer (Any(..),runWriterT,tell)
import Data.List (stripPrefix)
import Data.Char (isDigit)
import Control.Monad.Trans
interpreter :: Bool -> Bool -> Maybe [ModuleName] -> String -> String -> Interpreter (String,String,String)
interpreter exts rlimits modules lfl expr = do
when exts $ set [languageExtensions := (ExtendedDefaultRules:glasgowExtensions)]
reset
set [installedModulesInScope := False]
let doload = lfl /= ""
when doload $ liftIO (mvload lfl)
liftIO $ Mueval.Resources.limitResources rlimits
when doload $ do let lfl' = takeFileName lfl
loadModules [lfl']
setTopLevelModules [(takeWhile (/='.') lfl')]
case modules of
Nothing -> return ()
Just ms -> do let unqualModules = zip ms (repeat Nothing)
setImportsQ (unqualModules ++ Mueval.Context.qualifiedModules)
etype <- typeOf expr
result <- eval expr
return (expr, etype, result)
interpreterSession :: Bool
-> Bool
-> Bool
-> Maybe [ModuleName]
-> String
-> String
-> IO ()
interpreterSession prt exts rls mds lfl expr = do r <- runInterpreter (interpreter exts rls mds lfl expr)
case r of
Left err -> printInterpreterError err
Right (e,et,val) -> do when prt $ (sayIO e >> sayIO et)
sayIO val
mvload :: FilePath -> IO ()
mvload lfl = do canonfile <- makeRelativeToCurrentDirectory lfl
liftIO $ copyFile canonfile $ "/tmp/" ++ takeFileName canonfile
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 -> return $ Exception $ toStream (show e)
where uncons [] = End
uncons (x:xs) = x `seq` Cons x (toStream xs)