{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PatternGuards #-}
module Mueval.Interpreter where
import qualified Control.Exception.Extensible as E (SomeException (..), catch, evaluate)
import Control.Monad (forM_, guard, mplus, unless, when)
import Control.Monad.Trans (MonadIO)
import Control.Monad.Writer (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 Data.Monoid (Any (..))
import Language.Haskell.Interpreter (
Extension (UnknownExtension),
GhcError (..),
Interpreter,
InterpreterError (..),
OptionVal (..),
availableExtensions,
eval,
installedModulesInScope,
languageExtensions,
liftIO,
loadModules,
reset,
runInterpreter,
set,
setImportsQ,
setTopLevelModules,
typeOf,
)
import Language.Haskell.Interpreter.Unsafe (unsafeSetGhcOption)
import Mueval.ArgsParse (Options (..))
import qualified Mueval.Context as MC (qualifiedModules)
import qualified Mueval.Resources as MR (limitResources)
readExt :: String -> Extension
readExt :: String -> Extension
readExt String
s = case ReadS Extension
forall a. Read a => ReadS a
reads String
s of
[(Extension
e, [])] -> Extension
e
[(Extension, String)]
_ -> 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 a b. [a] -> [b] -> [b]
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 a. [a] -> 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 String
"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 String
"-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 a b. [a] -> (a -> [b]) -> [b]
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
$ \String
pkg ->
String -> InterpreterT IO ()
forall (m :: * -> *). MonadInterpreter m => String -> m ()
unsafeSetGhcOption (String
"-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
/= String
"")
then
( do
String
lfl <- IO String -> InterpreterT IO String
forall a. IO a -> InterpreterT IO a
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 a. a -> InterpreterT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
lfl
)
else (String -> InterpreterT IO String
forall a. a -> InterpreterT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
"")
IO () -> InterpreterT IO ()
forall a. IO a -> InterpreterT IO a
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
Maybe [String]
Nothing -> () -> InterpreterT IO ()
forall a. a -> InterpreterT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just [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
/= String
"") (InterpreterT IO () -> InterpreterT IO ())
-> InterpreterT IO () -> InterpreterT IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> InterpreterT IO ()
forall a. IO a -> InterpreterT IO a
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 a. a -> InterpreterT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
else String -> InterpreterT IO String
forall (m :: * -> *). MonadInterpreter m => String -> m String
eval String
expr
(String, String, String) -> Interpreter (String, String, String)
forall a. a -> InterpreterT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
expr, String
etype, String
result)
interpreterSession :: Options -> IO ()
interpreterSession :: Options -> IO ()
interpreterSession 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 InterpreterError
err -> InterpreterError -> IO ()
printInterpreterError InterpreterError
err
Right (String
e, String
et, 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 a b. IO a -> IO b -> IO b
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 String
definitions = do
String
tmpdir <- IO String
getTemporaryDirectory
(String
tempfile, Handle
_) <- String -> String -> IO (String, Handle)
System.IO.openTempFile String
tmpdir String
"mueval.hs"
IO () -> IO ()
forall a. IO a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
tempfile
sayIO :: String -> IO ()
sayIO :: String -> IO ()
sayIO String
str = do
(String
out, Bool
b) <- Int -> String -> IO (String, Bool)
forall (m :: * -> *).
(MonadIO m, Functor m) =>
Int -> String -> m (String, Bool)
render Int
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 [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 String
e
| Just String
s <- String -> Maybe String
parseErr String
e = String
s
| Bool
otherwise = String
e
parseErr :: String -> Maybe String
parseErr String
e = do
String
s <- String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"<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 a
x (a
y : [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 a
_ [a]
_ = 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 Char
':' (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 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
== Char
' ') String
xs
in Char -> String -> Maybe String
forall {a}. Eq a => a -> [a] -> Maybe [a]
skip Char
'\n' String
xs' Maybe String -> Maybe String -> Maybe String
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` String -> Maybe String
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return String
xs'
printInterpreterError 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 = String
"*Exception: "
render ::
(Control.Monad.Trans.MonadIO m, Functor m) =>
Int ->
String ->
m (String, Bool)
render :: forall (m :: * -> *).
(MonadIO m, Functor m) =>
Int -> String -> m (String, Bool)
render Int
i String
xs =
do
(String
out, Any 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 {m :: * -> *}.
(MonadIO m, MonadWriter Any m) =>
Int -> IO Stream -> m String
render' Int
i (String -> IO Stream
toStream String
xs)
(String, Bool) -> m (String, Bool)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
out, Bool
b)
where
render' :: Int -> IO Stream -> m String
render' Int
n IO Stream
_ | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = String -> m String
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
render' Int
n IO Stream
s = Int -> Stream -> m String
render'' Int
n (Stream -> m String) -> m Stream -> m String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Stream -> m Stream
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Stream
s
render'' :: Int -> Stream -> m String
render'' Int
_ Stream
End = String -> m String
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
render'' Int
n (Cons Char
x IO Stream
s) = (String -> String) -> m String -> m String
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Char
x Char -> String -> String
forall a. a -> [a] -> [a]
:) (m String -> m String) -> m String -> m String
forall a b. (a -> b) -> a -> b
$ Int -> IO Stream -> m String
render' (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) IO Stream
s
render'' Int
n (Exception IO Stream
s) = do
Any -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Bool -> Any
Any Bool
True)
(String -> String) -> m String -> m String
forall a b. (a -> b) -> m a -> m b
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]
++) (m String -> m String) -> m String -> m String
forall a b. (a -> b) -> a -> b
$ Int -> IO Stream -> m String
render' (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> 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 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) -> Stream -> IO Stream
forall a. a -> IO a
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 (Char
x : 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
[ String
"PrintExplicitForalls"
, String
"ForeignFunctionInterface"
, String
"UnliftedFFITypes"
, String
"GADTs"
, String
"ImplicitParams"
, String
"ScopedTypeVariables"
, String
"UnboxedTuples"
, String
"TypeSynonymInstances"
, String
"StandaloneDeriving"
, String
"DeriveDataTypeable"
, String
"FlexibleContexts"
, String
"FlexibleInstances"
, String
"ConstrainedClassMethods"
, String
"MultiParamTypeClasses"
, String
"FunctionalDependencies"
, String
"MagicHash"
, String
"PolymorphicComponents"
, String
"ExistentialQuantification"
, String
"UnicodeSyntax"
, String
"PostfixOperators"
, String
"PatternGuards"
, String
"LiberalTypeSynonyms"
, String
"ExplicitForAll"
, String
"RankNTypes"
, String
"ImpredicativeTypes"
, String
"TypeOperators"
, String
"RecursiveDo"
, String
"DoRec"
, String
"ParallelListComp"
, String
"EmptyDataDecls"
, String
"KindSignatures"
, String
"GeneralizedNewtypeDeriving"
, String
"TypeFamilies"
]