{-# LANGUAGE OverloadedStrings, TypeApplications, PackageImports #-}

module HsDev.Tools.Ghc.Repl (
	importModules, preludeModules,
	evaluate,
	expressionType,

	ReplResult(..),
	tryRepl
	) where

import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Catch
import Data.Aeson
import Data.Dynamic
import Text.Format

import "ghc" GhcMonad
import "ghc" GHC

import HsDev.Error
import HsDev.Tools.Ghc.Base
import qualified HsDev.Tools.Ghc.Compat as C
import HsDev.Util

-- | Import some modules
importModules :: GhcMonad m => [String] -> m ()
importModules :: [String] -> m ()
importModules [String]
mods = (String -> m (ImportDecl GhcPs))
-> [String] -> m [ImportDecl GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> m (ImportDecl GhcPs)
forall (m :: * -> *). GhcMonad m => String -> m (ImportDecl GhcPs)
parseImportDecl [String
"import " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
m | String
m <- [String]
mods] m [ImportDecl GhcPs] -> ([ImportDecl GhcPs] -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [InteractiveImport] -> m ()
forall (m :: * -> *). GhcMonad m => [InteractiveImport] -> m ()
setContext ([InteractiveImport] -> m ())
-> ([ImportDecl GhcPs] -> [InteractiveImport])
-> [ImportDecl GhcPs]
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ImportDecl GhcPs -> InteractiveImport)
-> [ImportDecl GhcPs] -> [InteractiveImport]
forall a b. (a -> b) -> [a] -> [b]
map ImportDecl GhcPs -> InteractiveImport
IIDecl

-- | Default interpreter modules
preludeModules :: [String]
preludeModules :: [String]
preludeModules = [String
"Prelude", String
"Data.List", String
"Control.Monad"]

-- | Evaluate expression
evaluate :: GhcMonad m => String -> m String
evaluate :: String -> m String
evaluate String
expr = do
	Maybe String
v <- (Dynamic -> Maybe String) -> m Dynamic -> m (Maybe String)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Dynamic -> Maybe String
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic (String -> m Dynamic
forall (m :: * -> *). GhcMonad m => String -> m Dynamic
dynCompileExpr (String -> m Dynamic) -> String -> m Dynamic
forall a b. (a -> b) -> a -> b
$ Format
"show ({})" Format -> String -> String
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ String
expr)
	m String -> (String -> m String) -> Maybe String -> m String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ HsDevError -> IO String
forall (m :: * -> *) a. MonadThrow m => HsDevError -> m a
hsdevError (HsDevError -> IO String) -> HsDevError -> IO String
forall a b. (a -> b) -> a -> b
$ String -> HsDevError
OtherError String
"evaluate fail") String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
v

-- | Get expression type as string
expressionType :: GhcMonad m => String -> m String
expressionType :: String -> m String
expressionType String
expr = do
	DynFlags
dflags <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
	Type
ty <- String -> m Type
forall (m :: * -> *). GhcMonad m => String -> m Type
C.exprType String
expr
	String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ DynFlags -> Type -> String
formatType DynFlags
dflags Type
ty

data ReplResult a = ReplError String | ReplOk a deriving (ReplResult a -> ReplResult a -> Bool
(ReplResult a -> ReplResult a -> Bool)
-> (ReplResult a -> ReplResult a -> Bool) -> Eq (ReplResult a)
forall a. Eq a => ReplResult a -> ReplResult a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ReplResult a -> ReplResult a -> Bool
$c/= :: forall a. Eq a => ReplResult a -> ReplResult a -> Bool
== :: ReplResult a -> ReplResult a -> Bool
$c== :: forall a. Eq a => ReplResult a -> ReplResult a -> Bool
Eq, Eq (ReplResult a)
Eq (ReplResult a)
-> (ReplResult a -> ReplResult a -> Ordering)
-> (ReplResult a -> ReplResult a -> Bool)
-> (ReplResult a -> ReplResult a -> Bool)
-> (ReplResult a -> ReplResult a -> Bool)
-> (ReplResult a -> ReplResult a -> Bool)
-> (ReplResult a -> ReplResult a -> ReplResult a)
-> (ReplResult a -> ReplResult a -> ReplResult a)
-> Ord (ReplResult a)
ReplResult a -> ReplResult a -> Bool
ReplResult a -> ReplResult a -> Ordering
ReplResult a -> ReplResult a -> ReplResult a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (ReplResult a)
forall a. Ord a => ReplResult a -> ReplResult a -> Bool
forall a. Ord a => ReplResult a -> ReplResult a -> Ordering
forall a. Ord a => ReplResult a -> ReplResult a -> ReplResult a
min :: ReplResult a -> ReplResult a -> ReplResult a
$cmin :: forall a. Ord a => ReplResult a -> ReplResult a -> ReplResult a
max :: ReplResult a -> ReplResult a -> ReplResult a
$cmax :: forall a. Ord a => ReplResult a -> ReplResult a -> ReplResult a
>= :: ReplResult a -> ReplResult a -> Bool
$c>= :: forall a. Ord a => ReplResult a -> ReplResult a -> Bool
> :: ReplResult a -> ReplResult a -> Bool
$c> :: forall a. Ord a => ReplResult a -> ReplResult a -> Bool
<= :: ReplResult a -> ReplResult a -> Bool
$c<= :: forall a. Ord a => ReplResult a -> ReplResult a -> Bool
< :: ReplResult a -> ReplResult a -> Bool
$c< :: forall a. Ord a => ReplResult a -> ReplResult a -> Bool
compare :: ReplResult a -> ReplResult a -> Ordering
$ccompare :: forall a. Ord a => ReplResult a -> ReplResult a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (ReplResult a)
Ord, ReadPrec [ReplResult a]
ReadPrec (ReplResult a)
Int -> ReadS (ReplResult a)
ReadS [ReplResult a]
(Int -> ReadS (ReplResult a))
-> ReadS [ReplResult a]
-> ReadPrec (ReplResult a)
-> ReadPrec [ReplResult a]
-> Read (ReplResult a)
forall a. Read a => ReadPrec [ReplResult a]
forall a. Read a => ReadPrec (ReplResult a)
forall a. Read a => Int -> ReadS (ReplResult a)
forall a. Read a => ReadS [ReplResult a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ReplResult a]
$creadListPrec :: forall a. Read a => ReadPrec [ReplResult a]
readPrec :: ReadPrec (ReplResult a)
$creadPrec :: forall a. Read a => ReadPrec (ReplResult a)
readList :: ReadS [ReplResult a]
$creadList :: forall a. Read a => ReadS [ReplResult a]
readsPrec :: Int -> ReadS (ReplResult a)
$creadsPrec :: forall a. Read a => Int -> ReadS (ReplResult a)
Read, Int -> ReplResult a -> String -> String
[ReplResult a] -> String -> String
ReplResult a -> String
(Int -> ReplResult a -> String -> String)
-> (ReplResult a -> String)
-> ([ReplResult a] -> String -> String)
-> Show (ReplResult a)
forall a. Show a => Int -> ReplResult a -> String -> String
forall a. Show a => [ReplResult a] -> String -> String
forall a. Show a => ReplResult a -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ReplResult a] -> String -> String
$cshowList :: forall a. Show a => [ReplResult a] -> String -> String
show :: ReplResult a -> String
$cshow :: forall a. Show a => ReplResult a -> String
showsPrec :: Int -> ReplResult a -> String -> String
$cshowsPrec :: forall a. Show a => Int -> ReplResult a -> String -> String
Show)

instance ToJSON a => ToJSON (ReplResult a) where
	toJSON :: ReplResult a -> Value
toJSON (ReplError String
e) = [Pair] -> Value
object [Text
"error" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= String
e]
	toJSON (ReplOk a
v) = [Pair] -> Value
object [Text
"ok" Text -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a
v]

instance FromJSON a => FromJSON (ReplResult a) where
	parseJSON :: Value -> Parser (ReplResult a)
parseJSON = String
-> (Object -> Parser (ReplResult a))
-> Value
-> Parser (ReplResult a)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"repl-result" ((Object -> Parser (ReplResult a))
 -> Value -> Parser (ReplResult a))
-> (Object -> Parser (ReplResult a))
-> Value
-> Parser (ReplResult a)
forall a b. (a -> b) -> a -> b
$ \Object
v -> [Parser (ReplResult a)] -> Parser (ReplResult a)
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [
		String -> ReplResult a
forall a. String -> ReplResult a
ReplError (String -> ReplResult a) -> Parser String -> Parser (ReplResult a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser String
forall a. FromJSON a => Object -> Text -> Parser a
.:: Text
"error",
		a -> ReplResult a
forall a. a -> ReplResult a
ReplOk (a -> ReplResult a) -> Parser a -> Parser (ReplResult a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser a
forall a. FromJSON a => Object -> Text -> Parser a
.:: Text
"ok"]

tryRepl :: (GhcMonad m, MonadCatch m) => m a -> m (ReplResult a)
tryRepl :: m a -> m (ReplResult a)
tryRepl = (Either SomeException a -> ReplResult a)
-> m (Either SomeException a) -> m (ReplResult a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SomeException -> ReplResult a)
-> (a -> ReplResult a) -> Either SomeException a -> ReplResult a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> ReplResult a
forall a. String -> ReplResult a
ReplError (String -> ReplResult a)
-> (SomeException -> String) -> SomeException -> ReplResult a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exception SomeException => SomeException -> String
forall e. Exception e => e -> String
displayException @SomeException) a -> ReplResult a
forall a. a -> ReplResult a
ReplOk) (m (Either SomeException a) -> m (ReplResult a))
-> (m a -> m (Either SomeException a)) -> m a -> m (ReplResult a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> m (Either SomeException a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try