diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -3,14 +3,15 @@ module Main where import Climb +import Control.Concurrent (forkIO, threadDelay) import Control.Exception (Exception) +import Control.Monad (void) import Control.Monad.Catch (MonadCatch, MonadThrow (..)) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.IO.Unlift (MonadUnliftIO (..)) import Control.Monad.Reader (MonadReader (..), ReaderT (..), asks) import qualified Data.Map.Strict as Map import qualified Data.Text as T -import qualified Data.Text.IO as TIO import Text.Read (readMaybe) newtype BadGuessErr = BadGuessErr (Maybe Int) @@ -29,37 +30,49 @@ runReplM :: ReplM a -> ReplEnv -> IO a runReplM = runReaderT . unReplM -guessCommand :: Command ReplM -guessCommand input = do +guessCommand :: TerminalWrite ReplM -> Command ReplM +guessCommand write input = do num <- asks reMagicNumber let mayGuess = readMaybe (T.unpack input) if readMaybe (T.unpack input) == Just num - then ReplContinue <$ liftIO (putStrLn "You guessed it!") + then ReplContinue <$ write "You guessed it!\n" else throwM (BadGuessErr mayGuess) -options :: OptionCommands ReplM -options = Map.fromList [("guess", ("guess a number", guessCommand))] +delayCommand :: TerminalWrite ReplM -> Command ReplM +delayCommand write _ = do + env <- ask + liftIO $ void $ forkIO $ do + threadDelay 2000000 + runReplM (write "delayed log\n") env + write "scheduled delayed log\n" + pure ReplContinue -exec :: Command ReplM -exec input = liftIO $ do - putStr "You said: " - TIO.putStrLn input +options :: TerminalWrite ReplM -> OptionCommands ReplM +options write = + Map.fromList + [ ("guess", ("guess a number", guessCommand write)) + , ("delay", ("log after 2 seconds", delayCommand write)) + ] + +exec :: TerminalWrite ReplM -> Command ReplM +exec write input = do + write ("You said: " <> input <> "\n") pure ReplContinue completion :: Completion ReplM completion _ = pure [] -replDef :: ReplDef ReplM -replDef = +replDef :: TerminalWrite ReplM -> ReplDef ReplM +replDef write = ReplDef { rdOnInterrupt = pure ReplContinue , rdOnEof = pure ReplQuit , rdGreeting = "Hello, REPL!" , rdPrompt = "> " - , rdOptionCommands = options - , rdExecCommand = exec + , rdOptionCommands = options write + , rdExecCommand = exec write , rdCompletion = completion } main :: IO () -main = runReplM (runReplDef replDef) (ReplEnv 42) +main = runReplM (runReplDefWithOutput replDef) (ReplEnv 42) diff --git a/climb.cabal b/climb.cabal --- a/climb.cabal +++ b/climb.cabal @@ -3,11 +3,9 @@ -- This file has been generated from package.yaml by hpack version 0.39.1. -- -- see: https://github.com/sol/hpack --- --- hash: b29667bdc4492f0f51fe1df41c406056b9bbde355adb6a41eb975a30c7e7af10 name: climb -version: 0.7.0 +version: 0.8.0 synopsis: Building blocks for a GHCi-like REPL with colon-commands description: Please see the README on GitHub at category: User Interfaces @@ -42,7 +40,7 @@ , bytestring >=0.10 && <1 , containers >=0.6 && <1 , exceptions >=0.10 && <1 - , linenoise >=0.6.0 && <1 + , linenoise >=0.7.0 && <1 , mtl >=2.2 && <3 , text >=1.2 && <3 , unliftio-core >=0.1 && <1 @@ -64,7 +62,7 @@ , climb , containers >=0.6 && <1 , exceptions >=0.10 && <1 - , linenoise >=0.6.0 && <1 + , linenoise >=0.7.0 && <1 , mtl >=2.2 && <3 , text >=1.2 && <3 , unliftio-core >=0.1 && <1 diff --git a/src/Climb.hs b/src/Climb.hs --- a/src/Climb.hs +++ b/src/Climb.hs @@ -8,27 +8,34 @@ , OptionCommands , ReplDef (..) , ReplDirective (..) + , TerminalWrite , bareCommand , noOptionCommands , noCompletion , runReplDef + , runReplDefWithOutput , stepReplDef ) where +import Control.Concurrent.MVar (MVar, newMVar, withMVar) import Control.Exception (Exception (..), SomeAsyncException (..), SomeException) +import qualified Control.Exception as Exception import Control.Monad (unless) import Control.Monad.Catch (MonadCatch, MonadThrow (..), catchIf) import Control.Monad.Fix (fix) import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.IO.Unlift (MonadUnliftIO) +import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO) import Data.Foldable (for_) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.IO as TIO -import Linenoise.Repl (ReplDirective (..), replM) +import Linenoise.Repl (ReplDirective (..)) +import qualified Linenoise.Unlift as Linenoise +import System.IO (hFlush, stdout) -- | A 'Command' takes some input, performs some effect, and returns a directive (continue or quit). type Command m = Text -> m ReplDirective @@ -39,6 +46,14 @@ -- | A 'Completion' takes some input and returns potential matches. type Completion m = Text -> m [Text] +-- | A prompt-safe terminal writer. +-- +-- Text written through this function is serialized with other writes. If a +-- linenoise prompt is active, the prompt and edit buffer are hidden before the +-- text is written and redrawn afterward. Include @"\n"@ when line-oriented +-- output is desired. +type TerminalWrite m = Text -> m () + -- | Sometimes things go wrong... data CommandErr = -- | An option 'Command' got input when it expected None @@ -52,17 +67,26 @@ -- | Defines a REPL with commands, options, and completion. data ReplDef m = ReplDef { rdOnInterrupt :: !(m ReplDirective) + -- ^ Action to run when the user interrupts the current prompt. , rdOnEof :: !(m ReplDirective) + -- ^ Action to run when the user sends EOF. , rdGreeting :: !Text + -- ^ Greeting printed before the first prompt. , rdPrompt :: !Text + -- ^ Prompt text shown for each input line. , rdOptionCommands :: !(OptionCommands m) + -- ^ Colon-prefixed option commands, keyed without the leading colon. , rdExecCommand :: !(Command m) + -- ^ Command to run for non-option input. , rdCompletion :: !(Completion m) + -- ^ Completion function for the current input line. } +-- | Empty option-command map. noOptionCommands :: OptionCommands m noOptionCommands = Map.empty +-- | Completion function that never returns candidates. noCompletion :: (Applicative m) => Completion m noCompletion = const (pure []) @@ -76,17 +100,17 @@ quitCommand :: (MonadThrow m) => Command m quitCommand = bareCommand (pure ReplQuit) -helpCommand :: (MonadThrow m, MonadIO m) => OptionCommands m -> Command m -helpCommand opts = bareCommand $ do - liftIO (TIO.putStrLn "Available commands:") - for_ (Map.toList opts) $ \(name, (desc, _)) -> liftIO (TIO.putStrLn (":" <> name <> "\t" <> desc)) +helpCommand :: (MonadThrow m) => TerminalWrite m -> OptionCommands m -> Command m +helpCommand write opts = bareCommand $ do + writeLine write "Available commands:" + for_ (Map.toList opts) $ \(name, (desc, _)) -> writeLine write (":" <> name <> "\t" <> desc) pure ReplContinue -defaultOptions :: (MonadThrow m, MonadIO m) => OptionCommands m -> OptionCommands m -defaultOptions opts = +defaultOptions :: (MonadThrow m) => TerminalWrite m -> OptionCommands m -> OptionCommands m +defaultOptions write opts = Map.fromList [ ("quit", ("quit", quitCommand)) - , ("help", ("describe all commands", helpCommand opts)) + , ("help", ("describe all commands", helpCommand write opts)) ] outerCommand :: (MonadThrow m) => OptionCommands m -> Command m -> Command m @@ -108,21 +132,87 @@ catchUserErr :: (MonadCatch m) => m a -> (SomeException -> m a) -> m a catchUserErr = catchIf isUserErr -handleUserErr :: (MonadCatch m, MonadIO m) => Command m -> Command m -handleUserErr action input = catchUserErr (action input) $ \err -> do - liftIO (TIO.putStr "Caught error: ") - liftIO (print err) +handleUserErr :: (MonadCatch m) => TerminalWrite m -> Command m -> Command m +handleUserErr write action input = catchUserErr (action input) $ \err -> do + writeLine write ("Caught error: " <> Text.pack (show err)) pure ReplContinue -- | Runs a REPL as defined. +-- +-- Use 'runReplDefWithOutput' when commands or background threads need a +-- prompt-safe 'TerminalWrite'. runReplDef :: (MonadCatch m, MonadUnliftIO m) => ReplDef m -> m () -runReplDef (ReplDef onInterrupt onEof greeting prompt opts exec comp) = do - let allOpts = fix (\c -> defaultOptions c <> opts) +runReplDef def = runReplDefWithOutput (const def) + +-- | Runs a REPL built with prompt-safe terminal writers. +-- +-- The builder receives a 'TerminalWrite' that can be captured by commands or +-- forked threads. All uses of that writer are serialized and integrated with +-- the active linenoise prompt so asynchronous output does not corrupt the +-- line the user is editing. +runReplDefWithOutput :: (MonadCatch m, MonadUnliftIO m) => (TerminalWrite m -> ReplDef m) -> m () +runReplDefWithOutput buildDef = do + currentSession <- liftIO (newIORef Nothing) + outputLock <- liftIO (newMVar ()) + let write = writeText currentSession outputLock + ReplDef onInterrupt onEof greeting prompt opts exec comp = buildDef write + allOpts = fix (\c -> defaultOptions write c <> opts) action = outerCommand allOpts exec - handledAction = handleUserErr action - liftIO (TIO.putStrLn greeting) - liftIO (TIO.putStrLn "Enter `:quit` to exit or `:help` to see all commands.") - replM onInterrupt onEof prompt handledAction comp + handledAction = handleUserErr write action + writeLine write greeting + writeLine write "Enter `:quit` to exit or `:help` to see all commands." + Linenoise.setCompletion comp + loop currentSession prompt onInterrupt onEof handledAction + +loop + :: (MonadUnliftIO m) + => IORef (Maybe Linenoise.EditSession) + -> Text + -> m ReplDirective + -> m ReplDirective + -> Command m + -> m () +loop currentSession prompt onInterrupt onEof action = do + res <- readLine currentSession prompt + directive <- case res of + Linenoise.InterruptResult -> onInterrupt + Linenoise.EofResult -> onEof + Linenoise.LineResult line -> do + directive <- action line + Linenoise.addHistory line + pure directive + case directive of + ReplContinue -> loop currentSession prompt onInterrupt onEof action + ReplQuit -> pure () + +readLine :: (MonadUnliftIO m) => IORef (Maybe Linenoise.EditSession) -> Text -> m (Linenoise.InputResult Text) +readLine currentSession prompt = + withRunInIO $ \runInIO -> + Linenoise.withEditSession prompt $ \session -> do + writeIORef currentSession (Just session) + runInIO (feed session) `Exception.finally` writeIORef currentSession Nothing + +feed :: (MonadIO m) => Linenoise.EditSession -> m (Linenoise.InputResult Text) +feed session = do + res <- Linenoise.feedEditSession session + case res of + Linenoise.MoreResult -> feed session + Linenoise.DoneResult input -> pure input + +writeText :: (MonadIO m) => IORef (Maybe Linenoise.EditSession) -> MVar () -> TerminalWrite m +writeText currentSession outputLock text = + liftIO (writeSafely currentSession outputLock (TIO.putStr text >> hFlush stdout)) + +writeLine :: TerminalWrite m -> Text -> m () +writeLine write text = write (text <> "\n") + +writeSafely :: IORef (Maybe Linenoise.EditSession) -> MVar () -> IO () -> IO () +writeSafely currentSession outputLock action = + withMVar outputLock $ \_ -> do + session <- readIORef currentSession + case session of + Nothing -> action + Just session' -> Linenoise.withHiddenEditSession session' action -- | Processes a single line of input. Useful for testing. -- (Note that this does not handle default option commands.)