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.IO
import Data.Char (isSpace)
import Control.Monad
import Data.Char(isPrint)
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 xs = outputStr (xs++"\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 (\prefs -> case editMode prefs of
Vi -> viActions
Emacs -> emacsCommands)
result <- runInputCmdT tops $ runTerm tops
$ \getEvent -> do
let ls = emptyIM
drawLine prefix ls
repeatTillFinish tops getEvent prefix ls emode
maybeAddHistory result
return result
maybeAddHistory :: forall m . Monad m => Maybe String -> InputT m ()
maybeAddHistory result = do
settings :: Settings m <- ask
case result of
Just line | autoAddHistory settings && not (all isSpace line)
-> modify (addHistory line)
_ -> return ()
repeatTillFinish :: forall m s d
. (MonadTrans d, Term (d m), LineState s, MonadReader Prefs m)
=> TermOps -> d m Event -> String -> s -> KeyMap m s
-> d m (Maybe String)
repeatTillFinish tops getEvent prefix = loop []
where
loop :: forall t . LineState t
=> [Key] -> t -> KeyMap m t -> d m (Maybe String)
loop [] s processor = do
event <- handle (\(e::SomeException) -> movePast prefix s >> throwIO e) getEvent
case event of
ErrorEvent e -> movePast prefix s >> throwIO e
WindowResize -> withReposition tops prefix s $ loop [] s processor
KeyInput k -> do
ks <- lift $ asks $ lookupKeyBinding k
loop ks s processor
loop (k:ks) s processor = case lookupKM processor k of
Nothing -> actBell >> loop [] s processor
Just g -> case g s of
Left r -> movePast prefix s >> return r
Right f -> do
KeyAction effect next <- lift f
drawEffect prefix s effect
loop ks (effectState effect) next
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 -> fmap B.pack System.IO.getLine
_ -> B.getLine
fmap Just $ decodeForTerm rterm line
drawEffect :: (LineState s, LineState t, Term (d m),
MonadTrans d, MonadReader Prefs m)
=> String -> s -> Effect t -> d m ()
drawEffect prefix s (Redraw shouldClear t) = if shouldClear
then clearLayout >> drawLine prefix t
else clearLine prefix s >> drawLine prefix t
drawEffect prefix s (Change t) = drawLineStateDiff prefix s t
drawEffect prefix s (PrintLines ls t) = do
if isTemporary s
then clearLine prefix s
else movePast prefix s
printLines ls
drawLine prefix t
drawEffect prefix s (RingBell t) = drawLineStateDiff prefix s t >> actBell
drawLine :: (LineState s, Term m) => String -> s -> m ()
drawLine prefix s = drawLineStateDiff prefix Cleared s
drawLineStateDiff :: (LineState s, LineState t, Term m)
=> String -> s -> t -> m ()
drawLineStateDiff prefix s t = drawLineDiff (lineChars prefix s)
(lineChars prefix t)
clearLine :: (LineState s, Term m) => String -> s -> m ()
clearLine prefix s = drawLineStateDiff prefix s Cleared
actBell :: (Term (d m), MonadTrans d, MonadReader Prefs m) => d m ()
actBell = do
style <- lift (asks bellStyle)
case style of
NoBell -> return ()
VisualBell -> ringBell False
AudibleBell -> ringBell True
movePast :: (LineState s, Term m) => String -> s -> m ()
movePast prefix s = moveToNextLine (lineChars prefix s)
withReposition :: (LineState s, Term m) => TermOps -> String -> s -> m a -> m a
withReposition tops prefix s f = do
oldLayout <- ask
newLayout <- liftIO $ getLayout tops
if oldLayout == newLayout
then f
else local newLayout $ do
reposition oldLayout (lineChars prefix s)
f
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 $ runTerm tops $ \getEvent -> do
drawLine prefix emptyIM
loop getEvent
where
s = emptyIM
loop :: Term m => m Event -> m (Maybe Char)
loop getEvent = do
event <- handle (\(e::SomeException) -> movePast prefix emptyIM >> throwIO e) getEvent
case event of
KeyInput (Key m (KeyChar c))
| m /= noModifier -> loop getEvent
| c == '\EOT' -> movePast prefix s >> return Nothing
| isPrint c -> do
let s' = insertChar c s
drawLineStateDiff prefix s s'
movePast prefix s'
return (Just c)
WindowResize -> withReposition tops prefix emptyIM $ loop getEvent
_ -> loop getEvent
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