module System.Console.Haskeline(
InputT,
runInputT,
runInputTWithPrefs,
getInputLine,
getInputChar,
outputStr,
outputStrLn,
Settings(..),
defaultSettings,
setComplete,
Prefs(),
readPrefs,
defaultPrefs,
Interrupt(..),
withInterrupt,
handleInterrupt,
module System.Console.Haskeline.Completion,
module System.Console.Haskeline.MonadException)
where
import System.Console.Haskeline.LineState
import System.Console.Haskeline.Command
import System.Console.Haskeline.Vi
import System.Console.Haskeline.Emacs
import System.Console.Haskeline.Prefs
import System.Console.Haskeline.History
import System.Console.Haskeline.Monads
import System.Console.Haskeline.MonadException
import System.Console.Haskeline.InputT
import System.Console.Haskeline.Completion
import System.Console.Haskeline.Term
import System.Console.Haskeline.Key
import System.Console.Haskeline.RunCommand
import System.IO
import Data.Char (isSpace, isPrint)
import Control.Monad
import qualified Data.ByteString.Char8 as B
import System.IO.Error (isEOFError)
defaultSettings :: MonadIO m => Settings m
defaultSettings = Settings {complete = completeFilename,
historyFile = Nothing,
autoAddHistory = True}
outputStr :: MonadIO m => String -> InputT m ()
outputStr xs = do
putter <- asks putStrOut
liftIO $ putter xs
outputStrLn :: MonadIO m => String -> InputT m ()
outputStrLn = outputStr . (++ "\n")
getInputLine :: forall m . MonadException m => String
-> InputT m (Maybe String)
getInputLine prefix = do
liftIO $ hFlush stdout
rterm <- ask
echo <- liftIO $ hGetEcho stdin
case termOps rterm of
Just tops | echo -> getInputCmdLine tops prefix
_ -> simpleFileLoop prefix rterm
getInputCmdLine :: MonadException m => TermOps -> String -> InputT m (Maybe String)
getInputCmdLine tops prefix = do
emode <- asks editMode
result <- runInputCmdT tops $ case emode of
Emacs -> runCommandLoop tops prefix emacsCommands
Vi -> evalStateT' emptyViState $
runCommandLoop tops prefix viKeyCommands
maybeAddHistory result
return result
maybeAddHistory :: forall m . Monad m => Maybe String -> InputT m ()
maybeAddHistory result = do
settings :: Settings m <- ask
histDupes <- asks historyDuplicates
case result of
Just line | autoAddHistory settings && not (all isSpace line)
-> let adder = case histDupes of
AlwaysAdd -> addHistory
IgnoreConsecutive -> addHistoryUnlessConsecutiveDupe
IgnoreAll -> addHistoryRemovingAllDupes
in modify (adder line)
_ -> return ()
simpleFileLoop :: MonadIO m => String -> RunTerm -> m (Maybe String)
simpleFileLoop prefix rterm = liftIO $ do
putStrOut rterm prefix
atEOF <- hIsEOF stdin
if atEOF
then return Nothing
else do
buff <- hGetBuffering stdin
line <- case buff of
NoBuffering -> hWithBinaryMode stdin
$ fmap B.pack System.IO.getLine
_ -> B.getLine
fmap Just $ decodeForTerm rterm line
getInputChar :: MonadException m => String
-> InputT m (Maybe Char)
getInputChar prefix = do
liftIO $ hFlush stdout
rterm <- ask
echo <- liftIO $ hGetEcho stdin
case termOps rterm of
Just tops | echo -> getInputCmdChar tops prefix
_ -> simpleFileChar prefix rterm
simpleFileChar :: MonadIO m => String -> RunTerm -> m (Maybe Char)
simpleFileChar prefix rterm = liftIO $ do
putStrOut rterm prefix
c <- getPrintableChar
maybeReadNewline
return c
where
getPrintableChar = returnOnEOF Nothing $ do
c <- getLocaleChar rterm
if isPrint c
then return (Just c)
else getPrintableChar
maybeReadNewline :: IO ()
maybeReadNewline = returnOnEOF () $ do
ready <- hReady stdin
when ready $ do
c <- hLookAhead stdin
when (c == '\n') $ getChar >> return ()
returnOnEOF :: a -> IO a -> IO a
returnOnEOF x = handle $ \e -> if isEOFError e
then return x
else throwIO e
getInputCmdChar :: MonadException m => TermOps -> String -> InputT m (Maybe Char)
getInputCmdChar tops prefix = runInputCmdT tops
$ runCommandLoop tops prefix acceptOneChar
acceptOneChar :: Monad m => KeyCommand m InsertMode (Maybe Char)
acceptOneChar = choiceCmd [useChar $ \c s -> change (insertChar c) s
>> return (Just c)
, ctrlChar 'l' +> clearScreenCmd >|>
keyCommand acceptOneChar
, ctrlChar 'd' +> failCmd]
withInterrupt :: MonadException m => InputT m a -> InputT m a
withInterrupt f = do
rterm <- ask
wrapInterrupt rterm f
handleInterrupt :: MonadException m => m a
-> m a
-> m a
handleInterrupt f = handleDyn $ \Interrupt -> f