module Mueval.Interpreter where
import Control.Monad (when)
import qualified Control.Exception as E (bracket,catchDyn)
import Control.Monad.Trans (liftIO)
import System.Directory (copyFile, makeRelativeToCurrentDirectory, removeFile)
import System.FilePath.Posix (takeFileName)
import System.Exit (exitFailure)
import Language.Haskell.Interpreter.GHC (eval, newSession, reset, setImports, loadModules,
setOptimizations, setUseLanguageExtensions, setInstalledModsAreInScopeQualified,
typeOf, withSession, setTopLevelModules,
Interpreter, InterpreterError(..),GhcError(..), ModuleName, Optimizations(All))
import qualified Codec.Binary.UTF8.String as Codec (decodeString)
import qualified System.IO.UTF8 as UTF (putStrLn)
import qualified Mueval.Resources (limitResources)
say :: String -> Interpreter ()
say = liftIO . sayIO
sayIO :: String -> IO ()
sayIO = UTF.putStrLn . Codec.decodeString . take 1024
printInterpreterError :: InterpreterError -> IO ()
printInterpreterError (WontCompile errors) =
do sayIO $ concatMap (dropLinePosition . errMsg) errors
exitFailure
where
dropLinePosition = unlines . tail . lines
printInterpreterError other = error (show other)
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
when prt $ say =<< typeOf expr
result <- eval expr
say $ result
interpreterSession :: Bool
-> Bool
-> Maybe [ModuleName]
-> String
-> String
-> IO ()
interpreterSession prt exts mds lfl expr = E.bracket newSession cleanTmpFile $ \session ->
withSession session (interpreter prt exts mds lfl expr)
`E.catchDyn` printInterpreterError
where
cleanTmpFile _ = case lfl of
"" -> return ()
l -> do canonfile <- makeRelativeToCurrentDirectory l
removeFile $ "/tmp/" ++ takeFileName canonfile
mvload :: FilePath -> IO ()
mvload lfl = do canonfile <- (makeRelativeToCurrentDirectory lfl)
liftIO $ copyFile canonfile ("/tmp/" ++ (takeFileName canonfile))