{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE FlexibleContexts #-}
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 :: String -> Extension
readExt s :: String
s = case ReadS Extension
forall a. Read a => ReadS a
reads String
s of
[(e :: Extension
e,[])] -> Extension
e
_ -> String -> Extension
UnknownExtension String
s
interpreter :: Options -> Interpreter (String,String,String)
interpreter :: Options -> Interpreter (String, String, String)
interpreter Options { extensions :: Options -> Bool
extensions = Bool
exts, namedExtensions :: Options -> [String]
namedExtensions = [String]
nexts,
rLimits :: Options -> Bool
rLimits = Bool
rlimits,
typeOnly :: Options -> Bool
typeOnly = Bool
noEval,
loadFile :: Options -> String
loadFile = String
load, expression :: Options -> String
expression = String
expr,
packageTrust :: Options -> Bool
packageTrust = Bool
trust,
trustedPackages :: Options -> [String]
trustedPackages = [String]
trustPkgs,
modules :: Options -> Maybe [String]
modules = Maybe [String]
m } = do
let lexts :: [Extension]
lexts = (Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
exts [()] -> [Extension] -> [Extension]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Extension]
glasgowExtensions) [Extension] -> [Extension] -> [Extension]
forall a. [a] -> [a] -> [a]
++ (String -> Extension) -> [String] -> [Extension]
forall a b. (a -> b) -> [a] -> [b]
map String -> Extension
readExt [String]
nexts
Bool -> InterpreterT IO () -> InterpreterT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Extension] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Extension]
lexts) (InterpreterT IO () -> InterpreterT IO ())
-> InterpreterT IO () -> InterpreterT IO ()
forall a b. (a -> b) -> a -> b
$ [OptionVal (InterpreterT IO)] -> InterpreterT IO ()
forall (m :: * -> *). MonadInterpreter m => [OptionVal m] -> m ()
set [Option (InterpreterT IO) [Extension]
forall (m :: * -> *). MonadInterpreter m => Option m [Extension]
languageExtensions Option (InterpreterT IO) [Extension]
-> [Extension] -> OptionVal (InterpreterT IO)
forall (m :: * -> *) a. Option m a -> a -> OptionVal m
:= (String -> Extension
UnknownExtension "ImplicitPrelude" Extension -> [Extension] -> [Extension]
forall a. a -> [a] -> [a]
: [Extension]
lexts)]
Bool -> InterpreterT IO () -> InterpreterT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
trust (InterpreterT IO () -> InterpreterT IO ())
-> InterpreterT IO () -> InterpreterT IO ()
forall a b. (a -> b) -> a -> b
$ do
String -> InterpreterT IO ()
forall (m :: * -> *). MonadInterpreter m => String -> m ()
unsafeSetGhcOption "-fpackage-trust"
[String] -> (String -> InterpreterT IO ()) -> InterpreterT IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([String]
trustPkgs [String] -> (String -> [String]) -> [String]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> [String]
words) ((String -> InterpreterT IO ()) -> InterpreterT IO ())
-> (String -> InterpreterT IO ()) -> InterpreterT IO ()
forall a b. (a -> b) -> a -> b
$ \pkg :: String
pkg ->
String -> InterpreterT IO ()
forall (m :: * -> *). MonadInterpreter m => String -> m ()
unsafeSetGhcOption ("-trust " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pkg)
InterpreterT IO ()
forall (m :: * -> *). MonadInterpreter m => m ()
reset
[OptionVal (InterpreterT IO)] -> InterpreterT IO ()
forall (m :: * -> *). MonadInterpreter m => [OptionVal m] -> m ()
set [Option (InterpreterT IO) Bool
forall (m :: * -> *). MonadInterpreter m => Option m Bool
installedModulesInScope Option (InterpreterT IO) Bool
-> Bool -> OptionVal (InterpreterT IO)
forall (m :: * -> *) a. Option m a -> a -> OptionVal m
:= Bool
False]
String
lfl' <- if (String
load String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= "") then (do { String
lfl <- IO String -> InterpreterT IO String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO String
cpload String
load);
[String] -> InterpreterT IO ()
forall (m :: * -> *). MonadInterpreter m => [String] -> m ()
loadModules [String
lfl];
[String] -> InterpreterT IO ()
forall (m :: * -> *). MonadInterpreter m => [String] -> m ()
setTopLevelModules [String -> String
takeBaseName String
load];
String -> InterpreterT IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
lfl }) else (String -> InterpreterT IO String
forall (m :: * -> *) a. Monad m => a -> m a
return "")
IO () -> InterpreterT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> InterpreterT IO ()) -> IO () -> InterpreterT IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> IO ()
MR.limitResources Bool
rlimits
case Maybe [String]
m of
Nothing -> () -> InterpreterT IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just ms :: [String]
ms -> do let unqualModules :: [(String, Maybe a)]
unqualModules = [String] -> [Maybe a] -> [(String, Maybe a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
ms (Maybe a -> [Maybe a]
forall a. a -> [a]
repeat Maybe a
forall a. Maybe a
Nothing)
[(String, Maybe String)] -> InterpreterT IO ()
forall (m :: * -> *).
MonadInterpreter m =>
[(String, Maybe String)] -> m ()
setImportsQ ([(String, Maybe String)]
forall a. [(String, Maybe a)]
unqualModules [(String, Maybe String)]
-> [(String, Maybe String)] -> [(String, Maybe String)]
forall a. [a] -> [a] -> [a]
++ [(String, Maybe String)]
MC.qualifiedModules)
Bool -> InterpreterT IO () -> InterpreterT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
load String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= "") (InterpreterT IO () -> InterpreterT IO ())
-> InterpreterT IO () -> InterpreterT IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> InterpreterT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ()
removeFile String
lfl')
String
etype <- String -> InterpreterT IO String
forall (m :: * -> *). MonadInterpreter m => String -> m String
typeOf String
expr
String
result <- if Bool
noEval
then String -> InterpreterT IO String
forall (m :: * -> *) a. Monad m => a -> m a
return ""
else String -> InterpreterT IO String
forall (m :: * -> *). MonadInterpreter m => String -> m String
eval String
expr
(String, String, String) -> Interpreter (String, String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
expr, String
etype, String
result)
interpreterSession :: Options -> IO ()
interpreterSession :: Options -> IO ()
interpreterSession opts :: Options
opts = do Either InterpreterError (String, String, String)
r <- Interpreter (String, String, String)
-> IO (Either InterpreterError (String, String, String))
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
InterpreterT m a -> m (Either InterpreterError a)
runInterpreter (Options -> Interpreter (String, String, String)
interpreter Options
opts)
case Either InterpreterError (String, String, String)
r of
Left err :: InterpreterError
err -> InterpreterError -> IO ()
printInterpreterError InterpreterError
err
Right (e :: String
e,et :: String
et,val :: String
val) -> do Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Bool
printType Options
opts)
(String -> IO ()
sayIO String
e IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
sayIOOneLine String
et)
String -> IO ()
sayIO String
val
where sayIOOneLine :: String -> IO ()
sayIOOneLine = String -> IO ()
sayIO (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unwords ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words
cpload :: FilePath -> IO FilePath
cpload :: String -> IO String
cpload definitions :: String
definitions = do
String
tmpdir <- IO String
getTemporaryDirectory
(tempfile :: String
tempfile,_) <- String -> String -> IO (String, Handle)
System.IO.openTempFile String
tmpdir "mueval.hs"
IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
copyFile String
definitions String
tempfile
String -> IO ()
setCurrentDirectory String
tmpdir
String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
tempfile
sayIO :: String -> IO ()
sayIO :: String -> IO ()
sayIO str :: String
str = do (out :: String
out,b :: Bool
b) <- Int -> String -> IO (String, Bool)
forall (m :: * -> *).
(MonadIO m, Functor m) =>
Int -> String -> m (String, Bool)
render 1024 String
str
String -> IO ()
putStrLn String
out
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b IO ()
forall a. IO a
exitFailure
printInterpreterError :: InterpreterError -> IO ()
printInterpreterError :: InterpreterError -> IO ()
printInterpreterError (WontCompile errors :: [GhcError]
errors) =
do String -> IO ()
sayIO (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ (GhcError -> String) -> [GhcError] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String -> String
dropLinePosition (String -> String) -> (GhcError -> String) -> GhcError -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhcError -> String
errMsg) [GhcError]
errors
IO ()
forall a. IO a
exitFailure
where
dropLinePosition :: String -> String
dropLinePosition e :: String
e
| Just s :: String
s <- String -> Maybe String
parseErr String
e = String
s
| Bool
otherwise = String
e
parseErr :: String -> Maybe String
parseErr e :: String
e = do String
s <- String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix "<interactive>:" String
e
String -> Maybe String
skipSpaces (String -> Maybe String) -> Maybe String -> Maybe String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (String -> Maybe String
skipNumber (String -> Maybe String) -> Maybe String -> Maybe String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Maybe String
skipNumber String
s)
skip :: a -> [a] -> Maybe [a]
skip x :: a
x (y :: a
y:xs :: [a]
xs) | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y = [a] -> Maybe [a]
forall a. a -> Maybe a
Just [a]
xs
| Bool
otherwise = Maybe [a]
forall a. Maybe a
Nothing
skip _ _ = Maybe [a]
forall a. Maybe a
Nothing
skipNumber :: String -> Maybe String
skipNumber = Char -> String -> Maybe String
forall a. Eq a => a -> [a] -> Maybe [a]
skip ':' (String -> Maybe String)
-> (String -> String) -> String -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isDigit
skipSpaces :: String -> Maybe String
skipSpaces xs :: String
xs = let xs' :: String
xs' = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==' ') String
xs
in Char -> String -> Maybe String
forall a. Eq a => a -> [a] -> Maybe [a]
skip '\n' String
xs' Maybe String -> Maybe String -> Maybe String
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` String -> Maybe String
forall (m :: * -> *) a. Monad m => a -> m a
return String
xs'
printInterpreterError other :: InterpreterError
other = String -> IO ()
forall a. HasCallStack => String -> a
error (InterpreterError -> String
forall a. Show a => a -> String
show InterpreterError
other)
exceptionMsg :: String
exceptionMsg :: String
exceptionMsg = "*Exception: "
render :: (Control.Monad.Trans.MonadIO m, Functor m)
=> Int
-> String
-> m (String, Bool)
render :: Int -> String -> m (String, Bool)
render i :: Int
i xs :: String
xs =
do (out :: String
out,Any b :: Bool
b) <- WriterT Any m String -> m (String, Any)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT Any m String -> m (String, Any))
-> WriterT Any m String -> m (String, Any)
forall a b. (a -> b) -> a -> b
$ Int -> IO Stream -> WriterT Any m String
forall (f :: * -> *).
(MonadIO f, MonadWriter Any f) =>
Int -> IO Stream -> f String
render' Int
i (String -> IO Stream
toStream String
xs)
(String, Bool) -> m (String, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
out,Bool
b)
where
render' :: Int -> IO Stream -> f String
render' n :: Int
n _ | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0 = String -> f String
forall (m :: * -> *) a. Monad m => a -> m a
return ""
render' n :: Int
n s :: IO Stream
s = Int -> Stream -> f String
render'' Int
n (Stream -> f String) -> f Stream -> f String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Stream -> f Stream
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Stream
s
render'' :: Int -> Stream -> f String
render'' _ End = String -> f String
forall (m :: * -> *) a. Monad m => a -> m a
return ""
render'' n :: Int
n (Cons x :: Char
x s :: IO Stream
s) = (String -> String) -> f String -> f String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:) (f String -> f String) -> f String -> f String
forall a b. (a -> b) -> a -> b
$ Int -> IO Stream -> f String
render' (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) IO Stream
s
render'' n :: Int
n (Exception s :: IO Stream
s) = do
Any -> f ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Bool -> Any
Any Bool
True)
(String -> String) -> f String -> f String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
n String
exceptionMsg String -> String -> String
forall a. [a] -> [a] -> [a]
++) (f String -> f String) -> f String -> f String
forall a b. (a -> b) -> a -> b
$ Int -> IO Stream -> f String
render' (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
exceptionMsg) IO Stream
s
data Stream = Cons Char (IO Stream) | Exception (IO Stream) | End
toStream :: String -> IO Stream
toStream :: String -> IO Stream
toStream str :: String
str = Stream -> IO Stream
forall a. a -> IO a
E.evaluate (String -> Stream
uncons String
str) IO Stream -> (SomeException -> IO Stream) -> IO Stream
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch`
\(E.SomeException e :: e
e) -> Stream -> IO Stream
forall (m :: * -> *) a. Monad m => a -> m a
return (Stream -> IO Stream) -> (e -> Stream) -> e -> IO Stream
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO Stream -> Stream
Exception (IO Stream -> Stream) -> (e -> IO Stream) -> e -> Stream
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO Stream
toStream (String -> IO Stream) -> (e -> String) -> e -> IO Stream
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> String
forall a. Show a => a -> String
show (e -> IO Stream) -> e -> IO Stream
forall a b. (a -> b) -> a -> b
$ e
e
where uncons :: String -> Stream
uncons [] = Stream
End
uncons (x :: Char
x:xs :: String
xs) = Char
x Char -> Stream -> Stream
forall a b. a -> b -> b
`seq` Char -> IO Stream -> Stream
Cons Char
x (String -> IO Stream
toStream String
xs)
glasgowExtensions :: [Extension]
glasgowExtensions :: [Extension]
glasgowExtensions = [Extension] -> [Extension] -> [Extension]
forall a. Eq a => [a] -> [a] -> [a]
intersect [Extension]
availableExtensions [Extension]
exts612
where exts612 :: [Extension]
exts612 = (String -> Extension) -> [String] -> [Extension]
forall a b. (a -> b) -> [a] -> [b]
map String -> Extension
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" ]