Better handling of interrupts in REPL

This commit is contained in:
James Eversole 2025-01-27 16:46:41 -06:00 committed by James Eversole
parent c6a7835a6f
commit 09eedfb609
4 changed files with 30 additions and 23 deletions

View File

@ -15,7 +15,7 @@ evalSingle env term
Just existingValue Just existingValue
| existingValue == evalAST env body -> env | existingValue == evalAST env body -> env
| otherwise -> errorWithoutStackTrace $ | otherwise -> errorWithoutStackTrace $
"Unable to rebind immutable identifier: '" ++ name "Unable to rebind immutable identifier: " ++ name
Nothing -> Nothing ->
let res = evalAST env body let res = evalAST env body
in Map.insert "!result" res (Map.insert name res env) in Map.insert "!result" res (Map.insert name res env)

View File

@ -59,7 +59,7 @@ main = do
case args of case args of
Repl -> do Repl -> do
putStrLn "Welcome to the tricu REPL" putStrLn "Welcome to the tricu REPL"
putStrLn "You can exit with `CTRL+D` or the `:_exit` command.`" putStrLn "You can exit with `CTRL+D` or the `!exit` command.`"
repl Map.empty repl Map.empty
Evaluate { file = filePaths, form = form } -> do Evaluate { file = filePaths, form = form } -> do
result <- case filePaths of result <- case filePaths of

View File

@ -8,6 +8,7 @@ import Research
import Control.Exception (SomeException, catch) import Control.Exception (SomeException, catch)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Monad.Catch (handle, MonadCatch)
import Data.Char (isSpace) import Data.Char (isSpace)
import Data.List (dropWhile, dropWhileEnd, intercalate) import Data.List (dropWhile, dropWhileEnd, intercalate)
import System.Console.Haskeline import System.Console.Haskeline
@ -15,33 +16,37 @@ import System.Console.Haskeline
import qualified Data.Map as Map import qualified Data.Map as Map
repl :: Env -> IO () repl :: Env -> IO ()
repl env = runInputT defaultSettings (loop env) repl env = runInputT defaultSettings (withInterrupt (loop env))
where where
loop :: Env -> InputT IO () loop :: Env -> InputT IO ()
loop env = do loop env = handle (interruptHandler env) $ do
minput <- getInputLine "tricu < " minput <- getInputLine "tricu < "
if case minput of
| Nothing <- minput -> outputStrLn "Exiting tricu" Nothing -> outputStrLn "Exiting tricu"
| Just s <- minput, strip s == "!exit" -> outputStrLn "Exiting tricu" Just s
| Just s <- minput, strip s == "" -> do | strip s == "!exit" -> outputStrLn "Exiting tricu"
outputStrLn "" | strip s == "" -> loop env
loop env | strip s == "!import" -> do
| Just s <- minput, strip s == "!import" -> do path <- getInputLine "File path to load < "
path <- getInputLine "File path to load < " case path of
if Nothing -> do
| Nothing <- path -> do outputStrLn "No input received; stopping import."
outputStrLn "No input received; stopping import." loop env
loop env Just p -> do
| Just p <- path -> do loadedEnv <- liftIO $ evaluateFileWithContext env
loadedEnv <- liftIO $ evaluateFileWithContext env (strip p) `catch` \e -> errorHandler env e (strip p) `catch` \e -> errorHandler env e
loop $ Map.delete "!result" (Map.union loadedEnv env) loop $ Map.delete "!result" (Map.union loadedEnv env)
| Just s <- minput -> do | take 2 s == "--" -> loop env
if | otherwise -> do
| take 2 s == "--" -> loop env
| otherwise -> do
newEnv <- liftIO $ processInput env s `catch` errorHandler env newEnv <- liftIO $ processInput env s `catch` errorHandler env
loop newEnv loop newEnv
interruptHandler :: Env -> Interrupt -> InputT IO ()
interruptHandler env _ = do
outputStrLn "Interrupted with CTRL+C\n\
\You can use the !exit command or CTRL+D to exit"
loop env
processInput :: Env -> String -> IO Env processInput :: Env -> String -> IO Env
processInput env input = do processInput env input = do
let asts = parseTricu input let asts = parseTricu input

View File

@ -26,6 +26,7 @@ executable tricu
base >=4.7 base >=4.7
, cmdargs , cmdargs
, containers , containers
, exceptions
, haskeline , haskeline
, megaparsec , megaparsec
, mtl , mtl
@ -52,6 +53,7 @@ test-suite tricu-tests
base base
, cmdargs , cmdargs
, containers , containers
, exceptions
, haskeline , haskeline
, megaparsec , megaparsec
, mtl , mtl