{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE FlexibleContexts #-}
-- TODO: suggest the convenience functions be put into Hint proper?
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

{- | The actual calling of Hint functionality. The heart of this just calls
   'eval', but we do so much more - we disable Haskell extensions,
   hide all packages, make sure one cannot call unimported
   functions, typecheck, set resource limits for this
   thread, and do some error handling. -}
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
                                  -- Explicitly adding ImplicitPrelude because of
                                  -- http://darcsden.com/jcpetruzza/hint/issue/1
                                  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 -- Make sure nothing is available
                                  [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]

                                  -- if we're given a file of definitions, we need to first copy it to a temporary file in /tmp (cpload),
                                  -- then tell Hint to parse/read it, then extract the 'module name' of the file,
                                  -- and tell Hint to expose the module into memory; then we need to store the temporary file's filepath
                                  -- so we can try to clean up after ourselves later.
                                  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];
                                                                     -- We need to mangle the String to
                                                                     -- turn a filename into a module.
                                                                     [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)

                                  -- clean up our tmp file here; must be *after* setImportsQ
                                  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')

                                  -- we don't deliberately don't check if the expression typechecks
                                  -- this way we get an "InterpreterError" we can display
                                  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)

-- | Wrapper around 'interpreter'; supplies a fresh GHC API session and
-- error-handling. The arguments are largely passed on, and the results lightly parsed.
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

-- | Given a filepath (containing function definitions), copy it to a temporary file and change directory to it, returning the new filepath.
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 -- will at least mess up relative links
                String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
tempfile

---------------------------------
-- Handling and outputting results
-- TODO: this whole section is a hack

-- | Print the String (presumably the result
-- of interpreting something), but only print the first 1024 characters to avoid
-- flooding. Lambdabot has a similar limit.
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

-- | Oh no, something has gone wrong. If it's a compilation error pretty print
-- the first 1024 chars of it and throw an "ExitException"
-- otherwise rethrow the exception in String form.
printInterpreterError :: InterpreterError -> IO ()
printInterpreterError :: InterpreterError -> IO ()
printInterpreterError (WontCompile errors :: [GhcError]
errors) =
    -- if we get a compilation error we print it directly to avoid \"mueval: ...\"
    -- maybe it should go to stderr?
    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
      -- each error starts with the line position, which is uninteresting
      dropLinePosition :: String -> String
dropLinePosition e :: String
e
          | Just s :: String
s <- String -> Maybe String
parseErr String
e =  String
s
          | Bool
otherwise = String
e -- if the parse fails we fallback on printing the whole error
      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'

-- other exceptions indicate some problem in Mueval or the environment,
-- so we rethrow them for debugging purposes
printInterpreterError other :: InterpreterError
other = String -> IO ()
forall a. HasCallStack => String -> a
error (InterpreterError -> String
forall a. Show a => a -> String
show InterpreterError
other)

-- Constant
exceptionMsg :: String
exceptionMsg :: String
exceptionMsg = "*Exception: "

-- | Renders the input String including its exceptions using @exceptionMsg@
render :: (Control.Monad.Trans.MonadIO m, Functor m)
          => Int -- ^ max number of characters to include
          -> String -- ^ input
          -> m (String, Bool) -- ^ ( output, @True@ if we found an exception )
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)

-- Copied from old hint, removed from hint since 0.5.0.
glasgowExtensions :: [Extension]
glasgowExtensions :: [Extension]
glasgowExtensions = [Extension] -> [Extension] -> [Extension]
forall a. Eq a => [a] -> [a] -> [a]
intersect [Extension]
availableExtensions [Extension]
exts612 -- works also for 608 and 610
    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" ]