module Mueval.Interpreter where
import qualified Control.Exception.Extensible as E (evaluate,catch,SomeException(..))
import Control.Monad (forM_,guard,mplus,unless,when)
import Control.Monad.Trans (MonadIO)
import Control.Monad.Writer (Any(..),runWriterT,tell)
import Data.Char (isDigit)
import System.Directory
import System.Exit (exitFailure)
import System.FilePath.Posix (takeBaseName)
import System.IO (openTempFile)
import Data.List
import Language.Haskell.Interpreter (eval, set, reset, setImportsQ, loadModules, liftIO,
installedModulesInScope, languageExtensions, availableExtensions,
typeOf, setTopLevelModules, runInterpreter,
OptionVal(..), Interpreter,
InterpreterError(..),GhcError(..),
Extension(UnknownExtension))
import Language.Haskell.Interpreter.Unsafe (unsafeSetGhcOption)
import Mueval.ArgsParse (Options(..))
import qualified Mueval.Resources as MR (limitResources)
import qualified Mueval.Context as MC (qualifiedModules)
readExt :: String -> Extension
readExt s = case reads s of
[(e,[])] -> e
_ -> UnknownExtension s
interpreter :: Options -> Interpreter (String,String,String)
interpreter Options { extensions = exts, namedExtensions = nexts,
rLimits = rlimits,
typeOnly = noEval,
loadFile = load, expression = expr,
packageTrust = trust,
trustedPackages = trustPkgs,
modules = m } = do
let lexts = (guard exts >> glasgowExtensions) ++ map readExt nexts
unless (null lexts) $ set [languageExtensions := (UnknownExtension "ImplicitPrelude" : lexts)]
when trust $ do
unsafeSetGhcOption "-fpackage-trust"
forM_ (trustPkgs >>= words) $ \pkg ->
unsafeSetGhcOption ("-trust " ++ pkg)
reset
set [installedModulesInScope := False]
lfl' <- if (load /= "") then (do { lfl <- liftIO (cpload load);
loadModules [lfl];
setTopLevelModules [takeBaseName load];
return lfl }) else (return "")
liftIO $ MR.limitResources rlimits
case m of
Nothing -> return ()
Just ms -> do let unqualModules = zip ms (repeat Nothing)
setImportsQ (unqualModules ++ MC.qualifiedModules)
when (load /= "") $ liftIO (removeFile lfl')
etype <- typeOf expr
result <- if noEval
then return ""
else 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) -> do when (printType opts)
(sayIO e >> sayIOOneLine et)
sayIO val
where sayIOOneLine = sayIO . unwords . words
cpload :: FilePath -> IO FilePath
cpload definitions = do
tmpdir <- getTemporaryDirectory
(tempfile,_) <- System.IO.openTempFile tmpdir "mueval.hs"
liftIO $ copyFile definitions tempfile
setCurrentDirectory tmpdir
return tempfile
sayIO :: String -> IO ()
sayIO str = do (out,b) <- render 1024 str
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, Functor 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)
glasgowExtensions :: [Extension]
glasgowExtensions = intersect availableExtensions exts612
where exts612 = map readExt ["PrintExplicitForalls",
"ForeignFunctionInterface",
"UnliftedFFITypes",
"GADTs",
"ImplicitParams",
"ScopedTypeVariables",
"UnboxedTuples",
"TypeSynonymInstances",
"StandaloneDeriving",
"DeriveDataTypeable",
"FlexibleContexts",
"FlexibleInstances",
"ConstrainedClassMethods",
"MultiParamTypeClasses",
"FunctionalDependencies",
"MagicHash",
"PolymorphicComponents",
"ExistentialQuantification",
"UnicodeSyntax",
"PostfixOperators",
"PatternGuards",
"LiberalTypeSynonyms",
"ExplicitForAll",
"RankNTypes",
"ImpredicativeTypes",
"TypeOperators",
"RecursiveDo",
"DoRec",
"ParallelListComp",
"EmptyDataDecls",
"KindSignatures",
"GeneralizedNewtypeDeriving",
"TypeFamilies" ]