{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE ScopedTypeVariables        #-}

module Language.Haskell.Interpreter
    ( runghc
    , CompilationError(..)
    , InterpreterError(..)
    , SourceCode(..)
    , avoidUnsafe
    , Warning(..)
    , InterpreterResult(..)
    , parseErrorText
    ) where

import Control.Monad (unless)
import Control.Monad.Catch (MonadCatch, MonadMask)
import Control.Monad.Error.Class (MonadError, throwError)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State (StateT, evalStateT, get, put)
import Control.Newtype.Generics (Newtype)
import Control.Newtype.Generics qualified as Newtype
import Control.Timeout (timeout)
import Data.Aeson (FromJSON, ToJSON)
import Data.Bifunctor (second)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Internal.Search qualified as Text
import Data.Time.Units (TimeUnit)
import GHC.Generics (Generic)
import System.Environment (lookupEnv)
import System.Exit (ExitCode (ExitSuccess))
import System.IO.Error (tryIOError)
import System.Process (readProcessWithExitCode)
import Text.Read (readMaybe)

data CompilationError
    = RawError Text
    | CompilationError { CompilationError -> Text
filename :: !Text
                       , CompilationError -> Int
row      :: !Int
                       , CompilationError -> Int
column   :: !Int
                       , CompilationError -> [Text]
text     :: ![Text] }
    deriving stock (Int -> CompilationError -> ShowS
[CompilationError] -> ShowS
CompilationError -> String
(Int -> CompilationError -> ShowS)
-> (CompilationError -> String)
-> ([CompilationError] -> ShowS)
-> Show CompilationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CompilationError] -> ShowS
$cshowList :: [CompilationError] -> ShowS
show :: CompilationError -> String
$cshow :: CompilationError -> String
showsPrec :: Int -> CompilationError -> ShowS
$cshowsPrec :: Int -> CompilationError -> ShowS
Show, CompilationError -> CompilationError -> Bool
(CompilationError -> CompilationError -> Bool)
-> (CompilationError -> CompilationError -> Bool)
-> Eq CompilationError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CompilationError -> CompilationError -> Bool
$c/= :: CompilationError -> CompilationError -> Bool
== :: CompilationError -> CompilationError -> Bool
$c== :: CompilationError -> CompilationError -> Bool
Eq, (forall x. CompilationError -> Rep CompilationError x)
-> (forall x. Rep CompilationError x -> CompilationError)
-> Generic CompilationError
forall x. Rep CompilationError x -> CompilationError
forall x. CompilationError -> Rep CompilationError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CompilationError x -> CompilationError
$cfrom :: forall x. CompilationError -> Rep CompilationError x
Generic)
    deriving anyclass ([CompilationError] -> Encoding
[CompilationError] -> Value
CompilationError -> Encoding
CompilationError -> Value
(CompilationError -> Value)
-> (CompilationError -> Encoding)
-> ([CompilationError] -> Value)
-> ([CompilationError] -> Encoding)
-> ToJSON CompilationError
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [CompilationError] -> Encoding
$ctoEncodingList :: [CompilationError] -> Encoding
toJSONList :: [CompilationError] -> Value
$ctoJSONList :: [CompilationError] -> Value
toEncoding :: CompilationError -> Encoding
$ctoEncoding :: CompilationError -> Encoding
toJSON :: CompilationError -> Value
$ctoJSON :: CompilationError -> Value
ToJSON, Value -> Parser [CompilationError]
Value -> Parser CompilationError
(Value -> Parser CompilationError)
-> (Value -> Parser [CompilationError])
-> FromJSON CompilationError
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [CompilationError]
$cparseJSONList :: Value -> Parser [CompilationError]
parseJSON :: Value -> Parser CompilationError
$cparseJSON :: Value -> Parser CompilationError
FromJSON)

data InterpreterError
    = CompilationErrors [CompilationError]
    | TimeoutError Text
    deriving stock (Int -> InterpreterError -> ShowS
[InterpreterError] -> ShowS
InterpreterError -> String
(Int -> InterpreterError -> ShowS)
-> (InterpreterError -> String)
-> ([InterpreterError] -> ShowS)
-> Show InterpreterError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InterpreterError] -> ShowS
$cshowList :: [InterpreterError] -> ShowS
show :: InterpreterError -> String
$cshow :: InterpreterError -> String
showsPrec :: Int -> InterpreterError -> ShowS
$cshowsPrec :: Int -> InterpreterError -> ShowS
Show, InterpreterError -> InterpreterError -> Bool
(InterpreterError -> InterpreterError -> Bool)
-> (InterpreterError -> InterpreterError -> Bool)
-> Eq InterpreterError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InterpreterError -> InterpreterError -> Bool
$c/= :: InterpreterError -> InterpreterError -> Bool
== :: InterpreterError -> InterpreterError -> Bool
$c== :: InterpreterError -> InterpreterError -> Bool
Eq, (forall x. InterpreterError -> Rep InterpreterError x)
-> (forall x. Rep InterpreterError x -> InterpreterError)
-> Generic InterpreterError
forall x. Rep InterpreterError x -> InterpreterError
forall x. InterpreterError -> Rep InterpreterError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep InterpreterError x -> InterpreterError
$cfrom :: forall x. InterpreterError -> Rep InterpreterError x
Generic)
    deriving anyclass ([InterpreterError] -> Encoding
[InterpreterError] -> Value
InterpreterError -> Encoding
InterpreterError -> Value
(InterpreterError -> Value)
-> (InterpreterError -> Encoding)
-> ([InterpreterError] -> Value)
-> ([InterpreterError] -> Encoding)
-> ToJSON InterpreterError
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [InterpreterError] -> Encoding
$ctoEncodingList :: [InterpreterError] -> Encoding
toJSONList :: [InterpreterError] -> Value
$ctoJSONList :: [InterpreterError] -> Value
toEncoding :: InterpreterError -> Encoding
$ctoEncoding :: InterpreterError -> Encoding
toJSON :: InterpreterError -> Value
$ctoJSON :: InterpreterError -> Value
ToJSON, Value -> Parser [InterpreterError]
Value -> Parser InterpreterError
(Value -> Parser InterpreterError)
-> (Value -> Parser [InterpreterError])
-> FromJSON InterpreterError
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [InterpreterError]
$cparseJSONList :: Value -> Parser [InterpreterError]
parseJSON :: Value -> Parser InterpreterError
$cparseJSON :: Value -> Parser InterpreterError
FromJSON)

newtype SourceCode = SourceCode Text
   deriving stock (Int -> SourceCode -> ShowS
[SourceCode] -> ShowS
SourceCode -> String
(Int -> SourceCode -> ShowS)
-> (SourceCode -> String)
-> ([SourceCode] -> ShowS)
-> Show SourceCode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SourceCode] -> ShowS
$cshowList :: [SourceCode] -> ShowS
show :: SourceCode -> String
$cshow :: SourceCode -> String
showsPrec :: Int -> SourceCode -> ShowS
$cshowsPrec :: Int -> SourceCode -> ShowS
Show, SourceCode -> SourceCode -> Bool
(SourceCode -> SourceCode -> Bool)
-> (SourceCode -> SourceCode -> Bool) -> Eq SourceCode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SourceCode -> SourceCode -> Bool
$c/= :: SourceCode -> SourceCode -> Bool
== :: SourceCode -> SourceCode -> Bool
$c== :: SourceCode -> SourceCode -> Bool
Eq, (forall x. SourceCode -> Rep SourceCode x)
-> (forall x. Rep SourceCode x -> SourceCode) -> Generic SourceCode
forall x. Rep SourceCode x -> SourceCode
forall x. SourceCode -> Rep SourceCode x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SourceCode x -> SourceCode
$cfrom :: forall x. SourceCode -> Rep SourceCode x
Generic)
   deriving newtype ([SourceCode] -> Encoding
[SourceCode] -> Value
SourceCode -> Encoding
SourceCode -> Value
(SourceCode -> Value)
-> (SourceCode -> Encoding)
-> ([SourceCode] -> Value)
-> ([SourceCode] -> Encoding)
-> ToJSON SourceCode
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [SourceCode] -> Encoding
$ctoEncodingList :: [SourceCode] -> Encoding
toJSONList :: [SourceCode] -> Value
$ctoJSONList :: [SourceCode] -> Value
toEncoding :: SourceCode -> Encoding
$ctoEncoding :: SourceCode -> Encoding
toJSON :: SourceCode -> Value
$ctoJSON :: SourceCode -> Value
ToJSON, Value -> Parser [SourceCode]
Value -> Parser SourceCode
(Value -> Parser SourceCode)
-> (Value -> Parser [SourceCode]) -> FromJSON SourceCode
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [SourceCode]
$cparseJSONList :: Value -> Parser [SourceCode]
parseJSON :: Value -> Parser SourceCode
$cparseJSON :: Value -> Parser SourceCode
FromJSON)
   deriving anyclass (O SourceCode -> SourceCode
SourceCode -> O SourceCode
(O SourceCode -> SourceCode)
-> (SourceCode -> O SourceCode) -> Newtype SourceCode
forall n. (O n -> n) -> (n -> O n) -> Newtype n
unpack :: SourceCode -> O SourceCode
$cunpack :: SourceCode -> O SourceCode
pack :: O SourceCode -> SourceCode
$cpack :: O SourceCode -> SourceCode
Newtype)

newtype Warning = Warning Text
  deriving stock (Warning -> Warning -> Bool
(Warning -> Warning -> Bool)
-> (Warning -> Warning -> Bool) -> Eq Warning
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Warning -> Warning -> Bool
$c/= :: Warning -> Warning -> Bool
== :: Warning -> Warning -> Bool
$c== :: Warning -> Warning -> Bool
Eq, Int -> Warning -> ShowS
[Warning] -> ShowS
Warning -> String
(Int -> Warning -> ShowS)
-> (Warning -> String) -> ([Warning] -> ShowS) -> Show Warning
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Warning] -> ShowS
$cshowList :: [Warning] -> ShowS
show :: Warning -> String
$cshow :: Warning -> String
showsPrec :: Int -> Warning -> ShowS
$cshowsPrec :: Int -> Warning -> ShowS
Show, (forall x. Warning -> Rep Warning x)
-> (forall x. Rep Warning x -> Warning) -> Generic Warning
forall x. Rep Warning x -> Warning
forall x. Warning -> Rep Warning x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Warning x -> Warning
$cfrom :: forall x. Warning -> Rep Warning x
Generic)
  deriving newtype ([Warning] -> Encoding
[Warning] -> Value
Warning -> Encoding
Warning -> Value
(Warning -> Value)
-> (Warning -> Encoding)
-> ([Warning] -> Value)
-> ([Warning] -> Encoding)
-> ToJSON Warning
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Warning] -> Encoding
$ctoEncodingList :: [Warning] -> Encoding
toJSONList :: [Warning] -> Value
$ctoJSONList :: [Warning] -> Value
toEncoding :: Warning -> Encoding
$ctoEncoding :: Warning -> Encoding
toJSON :: Warning -> Value
$ctoJSON :: Warning -> Value
ToJSON, Value -> Parser [Warning]
Value -> Parser Warning
(Value -> Parser Warning)
-> (Value -> Parser [Warning]) -> FromJSON Warning
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Warning]
$cparseJSONList :: Value -> Parser [Warning]
parseJSON :: Value -> Parser Warning
$cparseJSON :: Value -> Parser Warning
FromJSON)

data InterpreterResult a = InterpreterResult { InterpreterResult a -> [Warning]
warnings :: [Warning], InterpreterResult a -> a
result :: a }
  deriving stock (InterpreterResult a -> InterpreterResult a -> Bool
(InterpreterResult a -> InterpreterResult a -> Bool)
-> (InterpreterResult a -> InterpreterResult a -> Bool)
-> Eq (InterpreterResult a)
forall a.
Eq a =>
InterpreterResult a -> InterpreterResult a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InterpreterResult a -> InterpreterResult a -> Bool
$c/= :: forall a.
Eq a =>
InterpreterResult a -> InterpreterResult a -> Bool
== :: InterpreterResult a -> InterpreterResult a -> Bool
$c== :: forall a.
Eq a =>
InterpreterResult a -> InterpreterResult a -> Bool
Eq, Int -> InterpreterResult a -> ShowS
[InterpreterResult a] -> ShowS
InterpreterResult a -> String
(Int -> InterpreterResult a -> ShowS)
-> (InterpreterResult a -> String)
-> ([InterpreterResult a] -> ShowS)
-> Show (InterpreterResult a)
forall a. Show a => Int -> InterpreterResult a -> ShowS
forall a. Show a => [InterpreterResult a] -> ShowS
forall a. Show a => InterpreterResult a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InterpreterResult a] -> ShowS
$cshowList :: forall a. Show a => [InterpreterResult a] -> ShowS
show :: InterpreterResult a -> String
$cshow :: forall a. Show a => InterpreterResult a -> String
showsPrec :: Int -> InterpreterResult a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> InterpreterResult a -> ShowS
Show, (forall x. InterpreterResult a -> Rep (InterpreterResult a) x)
-> (forall x. Rep (InterpreterResult a) x -> InterpreterResult a)
-> Generic (InterpreterResult a)
forall x. Rep (InterpreterResult a) x -> InterpreterResult a
forall x. InterpreterResult a -> Rep (InterpreterResult a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (InterpreterResult a) x -> InterpreterResult a
forall a x. InterpreterResult a -> Rep (InterpreterResult a) x
$cto :: forall a x. Rep (InterpreterResult a) x -> InterpreterResult a
$cfrom :: forall a x. InterpreterResult a -> Rep (InterpreterResult a) x
Generic, a -> InterpreterResult b -> InterpreterResult a
(a -> b) -> InterpreterResult a -> InterpreterResult b
(forall a b.
 (a -> b) -> InterpreterResult a -> InterpreterResult b)
-> (forall a b. a -> InterpreterResult b -> InterpreterResult a)
-> Functor InterpreterResult
forall a b. a -> InterpreterResult b -> InterpreterResult a
forall a b. (a -> b) -> InterpreterResult a -> InterpreterResult b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> InterpreterResult b -> InterpreterResult a
$c<$ :: forall a b. a -> InterpreterResult b -> InterpreterResult a
fmap :: (a -> b) -> InterpreterResult a -> InterpreterResult b
$cfmap :: forall a b. (a -> b) -> InterpreterResult a -> InterpreterResult b
Functor)
  deriving anyclass ([InterpreterResult a] -> Encoding
[InterpreterResult a] -> Value
InterpreterResult a -> Encoding
InterpreterResult a -> Value
(InterpreterResult a -> Value)
-> (InterpreterResult a -> Encoding)
-> ([InterpreterResult a] -> Value)
-> ([InterpreterResult a] -> Encoding)
-> ToJSON (InterpreterResult a)
forall a. ToJSON a => [InterpreterResult a] -> Encoding
forall a. ToJSON a => [InterpreterResult a] -> Value
forall a. ToJSON a => InterpreterResult a -> Encoding
forall a. ToJSON a => InterpreterResult a -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [InterpreterResult a] -> Encoding
$ctoEncodingList :: forall a. ToJSON a => [InterpreterResult a] -> Encoding
toJSONList :: [InterpreterResult a] -> Value
$ctoJSONList :: forall a. ToJSON a => [InterpreterResult a] -> Value
toEncoding :: InterpreterResult a -> Encoding
$ctoEncoding :: forall a. ToJSON a => InterpreterResult a -> Encoding
toJSON :: InterpreterResult a -> Value
$ctoJSON :: forall a. ToJSON a => InterpreterResult a -> Value
ToJSON, Value -> Parser [InterpreterResult a]
Value -> Parser (InterpreterResult a)
(Value -> Parser (InterpreterResult a))
-> (Value -> Parser [InterpreterResult a])
-> FromJSON (InterpreterResult a)
forall a. FromJSON a => Value -> Parser [InterpreterResult a]
forall a. FromJSON a => Value -> Parser (InterpreterResult a)
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [InterpreterResult a]
$cparseJSONList :: forall a. FromJSON a => Value -> Parser [InterpreterResult a]
parseJSON :: Value -> Parser (InterpreterResult a)
$cparseJSON :: forall a. FromJSON a => Value -> Parser (InterpreterResult a)
FromJSON)

-- | spawn an external process to runghc a file
--
--   If you set the environmental varaiable GHC_BIN_DIR
--   then the executable runghc in that path will be used.
--   This is useful if you want to your file to be run with some packages
--   available, you can create a wrapper runghc that includes these
--
--   Any errors are converted to InterpreterError
runghc
    :: (Show t, TimeUnit t, MonadIO m, MonadError InterpreterError m, MonadMask m)
    => t
    -> [String]
    -> FilePath
    -> m (InterpreterResult String)
runghc :: t -> [String] -> String -> m (InterpreterResult String)
runghc t
t [String]
runghcOpts String
file = do
    String
bin <- IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
lookupRunghc
    (ExitCode
exitCode, String
stdout, String
stderr) <- String -> t -> [String] -> String -> m (ExitCode, String, String)
forall t (m :: * -> *).
(Show t, TimeUnit t, MonadIO m, MonadError InterpreterError m,
 MonadMask m) =>
String -> t -> [String] -> String -> m (ExitCode, String, String)
runProcess String
bin t
t [String]
runghcOpts String
file
    case ExitCode
exitCode of
        ExitCode
ExitSuccess -> InterpreterResult String -> m (InterpreterResult String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InterpreterResult String -> m (InterpreterResult String))
-> InterpreterResult String -> m (InterpreterResult String)
forall a b. (a -> b) -> a -> b
$ [Warning] -> String -> InterpreterResult String
forall a. [Warning] -> a -> InterpreterResult a
InterpreterResult [] String
stdout
        ExitCode
_ ->
            InterpreterError -> m (InterpreterResult String)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
                (InterpreterError -> m (InterpreterResult String))
-> (String -> InterpreterError)
-> String
-> m (InterpreterResult String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CompilationError] -> InterpreterError
CompilationErrors
                ([CompilationError] -> InterpreterError)
-> (String -> [CompilationError]) -> String -> InterpreterError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [CompilationError]
parseErrorsText
                (Text -> [CompilationError])
-> (String -> Text) -> String -> [CompilationError]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack
                (String -> m (InterpreterResult String))
-> String -> m (InterpreterResult String)
forall a b. (a -> b) -> a -> b
$ (String
stdout String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
stderr)

runProcess
    :: (Show t, TimeUnit t, MonadIO m, MonadError InterpreterError m, MonadMask m)
    => FilePath
    -> t
    -> [String]
    -> String
    -> m (ExitCode, String, String)
runProcess :: String -> t -> [String] -> String -> m (ExitCode, String, String)
runProcess String
bin t
timeoutValue [String]
runghcOpts String
file = do
    Either IOError (ExitCode, String, String)
result <- m (Either IOError (ExitCode, String, String))
-> m (Either IOError (ExitCode, String, String))
forall (m :: * -> *) a.
(MonadIO m, MonadError InterpreterError m, MonadCatch m) =>
m a -> m a
withTimeout (m (Either IOError (ExitCode, String, String))
 -> m (Either IOError (ExitCode, String, String)))
-> m (Either IOError (ExitCode, String, String))
-> m (Either IOError (ExitCode, String, String))
forall a b. (a -> b) -> a -> b
$ IO (Either IOError (ExitCode, String, String))
-> m (Either IOError (ExitCode, String, String))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOError (ExitCode, String, String))
 -> m (Either IOError (ExitCode, String, String)))
-> IO (Either IOError (ExitCode, String, String))
-> m (Either IOError (ExitCode, String, String))
forall a b. (a -> b) -> a -> b
$ IO (ExitCode, String, String)
-> IO (Either IOError (ExitCode, String, String))
forall a. IO a -> IO (Either IOError a)
tryIOError (IO (ExitCode, String, String)
 -> IO (Either IOError (ExitCode, String, String)))
-> IO (ExitCode, String, String)
-> IO (Either IOError (ExitCode, String, String))
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
bin ([String]
runghcOpts [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String
file]) String
""
    case Either IOError (ExitCode, String, String)
result of
        Left IOError
e  -> InterpreterError -> m (ExitCode, String, String)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (InterpreterError -> m (ExitCode, String, String))
-> (IOError -> InterpreterError)
-> IOError
-> m (ExitCode, String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CompilationError] -> InterpreterError
CompilationErrors ([CompilationError] -> InterpreterError)
-> (IOError -> [CompilationError]) -> IOError -> InterpreterError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompilationError -> [CompilationError]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CompilationError -> [CompilationError])
-> (IOError -> CompilationError) -> IOError -> [CompilationError]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> CompilationError
RawError (Text -> CompilationError)
-> (IOError -> Text) -> IOError -> CompilationError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text) -> (IOError -> String) -> IOError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> String
forall a. Show a => a -> String
show (IOError -> m (ExitCode, String, String))
-> IOError -> m (ExitCode, String, String)
forall a b. (a -> b) -> a -> b
$ IOError
e
        Right (ExitCode, String, String)
v -> (ExitCode, String, String) -> m (ExitCode, String, String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExitCode, String, String)
v
    where
        withTimeout :: (MonadIO m, MonadError InterpreterError m, MonadCatch m) => m a -> m a
        withTimeout :: m a -> m a
withTimeout m a
a = do
            Maybe a
mr <- t -> m a -> m (Maybe a)
forall t (m :: * -> *) a.
(TimeUnit t, MonadIO m, MonadCatch m) =>
t -> m a -> m (Maybe a)
timeout t
timeoutValue m a
a
            case Maybe a
mr of
                Maybe a
Nothing -> InterpreterError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> InterpreterError
TimeoutError (Text -> InterpreterError) -> (t -> Text) -> t -> InterpreterError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text) -> (t -> String) -> t -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> String
forall a. Show a => a -> String
show (t -> InterpreterError) -> t -> InterpreterError
forall a b. (a -> b) -> a -> b
$ t
timeoutValue)
                Just a
r  -> a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
r

avoidUnsafe :: (MonadError InterpreterError m) => SourceCode -> m ()
avoidUnsafe :: SourceCode -> m ()
avoidUnsafe SourceCode
s =
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Int] -> Bool) -> (SourceCode -> [Int]) -> SourceCode -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> [Int]
Text.indices Text
"unsafe" (Text -> [Int]) -> (SourceCode -> Text) -> SourceCode -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceCode -> Text
forall n. Newtype n => n -> O n
Newtype.unpack (SourceCode -> Bool) -> SourceCode -> Bool
forall a b. (a -> b) -> a -> b
$ SourceCode
s)
        (m () -> m ())
-> (CompilationError -> m ()) -> CompilationError -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InterpreterError -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
        (InterpreterError -> m ())
-> (CompilationError -> InterpreterError)
-> CompilationError
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CompilationError] -> InterpreterError
CompilationErrors
        ([CompilationError] -> InterpreterError)
-> (CompilationError -> [CompilationError])
-> CompilationError
-> InterpreterError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompilationError -> [CompilationError]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (CompilationError -> m ()) -> CompilationError -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> CompilationError
RawError Text
"Cannot interpret unsafe functions"

lookupRunghc :: IO String
lookupRunghc :: IO String
lookupRunghc = do
    Maybe String
mBinDir <- IO (Maybe String) -> IO (Maybe String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> IO (Maybe String))
-> IO (Maybe String) -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
lookupEnv String
"GHC_BIN_DIR"
    case Maybe String
mBinDir of
        Maybe String
Nothing  -> String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"runghc"
        Just String
val -> String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
val String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"/runghc"

parseErrorsText :: Text -> [CompilationError]
parseErrorsText :: Text -> [CompilationError]
parseErrorsText Text
input = Text -> CompilationError
parseErrorText (Text -> CompilationError) -> [Text] -> [CompilationError]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> [Text]
Text.splitOn Text
"\n\n" Text
input

parseErrorText :: Text -> CompilationError
parseErrorText :: Text -> CompilationError
parseErrorText Text
input = CompilationError -> Maybe CompilationError -> CompilationError
forall a. a -> Maybe a -> a
fromMaybe (Text -> CompilationError
RawError Text
input) (Maybe CompilationError -> CompilationError)
-> Maybe CompilationError -> CompilationError
forall a b. (a -> b) -> a -> b
$ (StateT Text Maybe CompilationError
 -> Text -> Maybe CompilationError)
-> Text
-> StateT Text Maybe CompilationError
-> Maybe CompilationError
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT Text Maybe CompilationError
-> Text -> Maybe CompilationError
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT Text
input (StateT Text Maybe CompilationError -> Maybe CompilationError)
-> StateT Text Maybe CompilationError -> Maybe CompilationError
forall a b. (a -> b) -> a -> b
$ do
    Text
filename  <- Text -> StateT Text Maybe Text
forall (m :: * -> *). Monad m => Text -> StateT Text m Text
consumeTo Text
":"
    Text
rowStr    <- Text -> StateT Text Maybe Text
forall (m :: * -> *). Monad m => Text -> StateT Text m Text
consumeTo Text
":"
    Text
columnStr <- Text -> StateT Text Maybe Text
forall (m :: * -> *). Monad m => Text -> StateT Text m Text
consumeTo Text
":"
    [Text]
text      <- Text -> [Text]
Text.lines (Text -> [Text])
-> StateT Text Maybe Text -> StateT Text Maybe [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT Text Maybe Text
forall (m :: * -> *) s. (Monad m, Monoid s) => StateT s m s
consume
    Int
row       <- Maybe Int -> StateT Text Maybe Int
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Maybe Int -> StateT Text Maybe Int)
-> Maybe Int -> StateT Text Maybe Int
forall a b. (a -> b) -> a -> b
$ String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int) -> String -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
rowStr
    Int
column    <- Maybe Int -> StateT Text Maybe Int
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Maybe Int -> StateT Text Maybe Int)
-> Maybe Int -> StateT Text Maybe Int
forall a b. (a -> b) -> a -> b
$ String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int) -> String -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
columnStr
    CompilationError -> StateT Text Maybe CompilationError
forall (f :: * -> *) a. Applicative f => a -> f a
pure CompilationError :: Text -> Int -> Int -> [Text] -> CompilationError
CompilationError { Int
[Text]
Text
column :: Int
row :: Int
text :: [Text]
filename :: Text
text :: [Text]
column :: Int
row :: Int
filename :: Text
.. }


consumeTo :: Monad m => Text -> StateT Text m Text
consumeTo :: Text -> StateT Text m Text
consumeTo Text
needle = do
    (Text
before, Text
after) <- Text -> Text -> (Text, Text)
breakWith Text
needle (Text -> (Text, Text))
-> StateT Text m Text -> StateT Text m (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT Text m Text
forall (m :: * -> *) s. Monad m => StateT s m s
get
    Text -> StateT Text m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put Text
after
    Text -> StateT Text m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
before

consume :: (Monad m, Monoid s) => StateT s m s
consume :: StateT s m s
consume = StateT s m s
forall (m :: * -> *) s. Monad m => StateT s m s
get StateT s m s -> StateT s m () -> StateT s m s
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* s -> StateT s m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put s
forall a. Monoid a => a
mempty

-- | Light `Data.Text.breakOn`, but consumes the breakpoint text (the 'needle').
breakWith :: Text -> Text -> (Text, Text)
breakWith :: Text -> Text -> (Text, Text)
breakWith Text
needle = (Text -> Text) -> (Text, Text) -> (Text, Text)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Int -> Text -> Text
Text.drop Int
1) ((Text, Text) -> (Text, Text))
-> (Text -> (Text, Text)) -> Text -> (Text, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> (Text, Text)
Text.breakOn Text
needle