{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PatternGuards #-}

-- TODO: suggest the convenience functions be put into Hint proper?
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

{- | 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 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
        -- 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 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 -- 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
/= 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]
                        -- 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 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)

        -- 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
/= 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')

        -- 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 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)

{- | 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 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

-- | 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 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 -- will at least mess up relative links
    String -> IO String
forall a. a -> IO a
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 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

{- | 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 [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 String
e
        | Just 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 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'

-- other exceptions indicate some problem in Mueval or the environment,
-- so we rethrow them for debugging purposes
printInterpreterError 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 = String
"*Exception: "

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

-- 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
            [ 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"
            ]