module Mueval.Interpreter where
import Control.Monad (when)
import qualified Control.Exception (catch)
import Control.Monad.Trans (liftIO)
import System.Directory (copyFile, makeRelativeToCurrentDirectory, removeFile)
import System.FilePath.Posix (takeFileName)
import Language.Haskell.Interpreter.GHC (eval, newSession, reset, setImports, loadModules,
setOptimizations, setUseLanguageExtensions, setInstalledModsAreInScopeQualified,
typeChecks, typeOf, withSession, setTopLevelModules,
Interpreter, InterpreterError, ModuleName, Optimizations(All))
import qualified Codec.Binary.UTF8.String as Codec (decodeString)
import qualified System.IO.UTF8 as UTF (putStr)
import qualified Mueval.Resources (limitResources)
say :: String -> Interpreter ()
say = liftIO . UTF.putStr . Codec.decodeString . take 1024
printInterpreterError :: InterpreterError -> IO ()
printInterpreterError = error . take 1024 . ("Oops... " ++) . show
interpreter :: Bool -> Bool -> Maybe [ModuleName] -> String -> String -> Interpreter ()
interpreter prt exts modules lfl expr = do
setUseLanguageExtensions exts
setOptimizations All
reset
setInstalledModsAreInScopeQualified False
let doload = if lfl == ""
then False else True
when doload (liftIO $ mvload lfl)
liftIO Mueval.Resources.limitResources
when doload $ do
let lfl' = takeFileName lfl
loadModules [lfl']
setTopLevelModules [(takeWhile (/='.') lfl')]
case modules of
Nothing -> return ()
Just ms -> setImports ms
when prt (say $ expr ++ "\n")
checks <- typeChecks expr
if checks then do
if prt then do say =<< typeOf expr
say "\n"
else return ()
result <- eval expr
say $ result ++ "\n"
else error "Expression did not type check."
interpreterSession :: Bool
-> Bool
-> Maybe [ModuleName]
-> String
-> String
-> IO ()
interpreterSession prt exts mds lfl expr = Control.Exception.catch
(newSession >>= (flip withSession) (interpreter prt exts mds lfl expr))
(\_ -> do case lfl of
"" -> return ()
l -> do canonfile <- (makeRelativeToCurrentDirectory l)
removeFile ("/tmp/" ++ takeFileName canonfile)
error "Expression did not compile.")
mvload :: FilePath -> IO ()
mvload lfl = do canonfile <- (makeRelativeToCurrentDirectory lfl)
liftIO $ copyFile canonfile ("/tmp/" ++ (takeFileName canonfile))