{-# LANGUAGE OverloadedStrings #-}
module Koneko.Repl (repl, repl', promptText, errorText) where
import Control.Monad (unless)
import Data.String (IsString)
import Data.Text (Text)
import System.IO (hPutStrLn, stderr)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Koneko.Data (Context, Stack)
import Koneko.Eval (evalText, tryK)
import Koneko.Misc (prompt)
import Koneko.Prim (replDef)
repl :: Context -> Stack -> IO ()
repl :: Context -> Stack -> IO ()
repl Context
c Stack
s = () () -> IO Stack -> IO ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Text -> Context -> Stack -> IO Stack
repl' Bool
False Text
forall s. IsString s => s
promptText Context
c Stack
s
repl' :: Bool -> Text -> Context -> Stack -> IO Stack
repl' :: Bool -> Text -> Context -> Stack -> IO Stack
repl' Bool
breakOnError Text
pr Context
ctx Stack
st = Context -> IO ()
replDef Context
ctx IO () -> IO Stack -> IO Stack
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Context -> Stack -> IO Stack
loop Context
ctx Stack
st
where
loop :: Context -> Stack -> IO Stack
loop :: Context -> Stack -> IO Stack
loop Context
c Stack
s = Maybe Text -> IO (Maybe Text)
prompt (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
pr) IO (Maybe Text) -> (Maybe Text -> IO Stack) -> IO Stack
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO Stack -> (Text -> IO Stack) -> Maybe Text -> IO Stack
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Stack
s Stack -> IO () -> IO Stack
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> IO ()
T.putStrLn Text
"") Text -> IO Stack
f
where
f :: Text -> IO Stack
f Text
line = if Text -> Bool
T.null Text
line then Context -> Stack -> IO Stack
loop Context
c Stack
s else do
Either KException Stack
r <- IO Stack -> IO (Either KException Stack)
forall a. IO a -> IO (Either KException a)
tryK (IO Stack -> IO (Either KException Stack))
-> IO Stack -> IO (Either KException Stack)
forall a b. (a -> b) -> a -> b
$ Text -> Context -> Stack -> IO Stack
et Text
line Context
c Stack
s IO Stack -> (Stack -> IO Stack) -> IO Stack
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Context -> Text -> Stack -> IO Stack
showTop Context
c Text
line
let err :: a -> IO Stack
err a
e = do Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
forall s. IsString s => s
errorText String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
e
if Bool
breakOnError then Stack -> IO Stack
forall (m :: * -> *) a. Monad m => a -> m a
return Stack
s else Context -> Stack -> IO Stack
loop Context
c Stack
s
(KException -> IO Stack)
-> (Stack -> IO Stack) -> Either KException Stack -> IO Stack
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either KException -> IO Stack
forall a. Show a => a -> IO Stack
err (Context -> Stack -> IO Stack
loop Context
c) Either KException Stack
r
showTop :: Context -> Text -> Stack -> IO Stack
showTop Context
c Text
line Stack
s = Stack
s Stack -> IO () -> IO Stack
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Stack -> Text -> Bool
shouldSkip Stack
s Text
line)
(() () -> IO Stack -> IO ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Context -> Stack -> IO Stack
et Text
"__prld__.show __prld__.say!" Context
c (Int -> Stack -> Stack
forall a. Int -> [a] -> [a]
take Int
1 Stack
s))
et :: Text -> Context -> Stack -> IO Stack
et = String -> Text -> Context -> Stack -> IO Stack
evalText String
"(repl)"
shouldSkip :: Stack -> Text -> Bool
shouldSkip :: Stack -> Text -> Bool
shouldSkip Stack
s Text
line = Stack -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Stack
s Bool -> Bool -> Bool
|| Text -> Char
T.head Text
line Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
',',Char
';']
promptText, errorText :: IsString s => s
promptText :: s
promptText = s
">>> "
errorText :: s
errorText = s
"*** ERROR: "