module System.Console.Haskeline(
InputT,
runInputT,
runInputTWithPrefs,
getInputLine,
outputStr,
outputStrLn,
Settings(..),
defaultSettings,
setComplete,
Interrupt(..),
handleInterrupt,
module System.Console.Haskeline.Completion,
module System.Console.Haskeline.Prefs,
module System.Console.Haskeline.MonadException)
where
import System.Console.Haskeline.LineState
import System.Console.Haskeline.Command
import System.Console.Haskeline.Command.History
import System.Console.Haskeline.Vi
import System.Console.Haskeline.Emacs
import System.Console.Haskeline.Prefs
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.IO
import qualified System.IO.UTF8 as UTF8
import Data.Char (isSpace)
import Control.Monad
defaultSettings :: MonadIO m => Settings m
defaultSettings = Settings {complete = completeFilename,
historyFile = Nothing,
handleSigINT = False}
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
case termOps rterm of
Nothing -> simpleFileLoop prefix rterm
Just tops -> getInputCmdLine tops prefix
getInputCmdLine :: MonadException m => TermOps -> String -> InputT m (Maybe String)
getInputCmdLine tops prefix = do
emode <- asks (\prefs -> case editMode prefs of
Vi -> viActions
Emacs -> emacsCommands)
wrapper <- sigINTWrapper
result <- runInputCmdT tops $ wrapper $ runTerm tops
$ \getEvent -> do
let ls = emptyIM
drawLine prefix ls
repeatTillFinish getEvent prefix ls emode
case result of
Just line | not (all isSpace line) -> addHistory line
_ -> return ()
return result
sigINTWrapper :: forall m n a . (Monad m, MonadException n) => InputT m (n a -> n a)
sigINTWrapper = do
settings :: Settings m <- ask
rterm <- ask
return $ if handleSigINT settings
then wrapInterrupt rterm
else id
repeatTillFinish :: forall m s d
. (MonadTrans d, Term (d m), LineState s, MonadReader Prefs m)
=> d m Event -> String -> s -> KeyMap m s
-> d m (Maybe String)
repeatTillFinish getEvent prefix = loop
where
loop :: forall t . LineState t => t -> KeyMap m t -> d m (Maybe String)
loop s processor = do
event <- handle (\e -> movePast prefix s >> throwIO e) getEvent
case event of
WindowResize newLayout -> do
oldLayout <- ask
local newLayout $ do
reposition oldLayout (lineChars prefix s)
loop s processor
KeyInput k -> 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 (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
l <- UTF8.getLine
putStrOut rterm (l++"\n")
return (Just l)
handleInterrupt :: MonadException m => m a
-> m a
-> m a
handleInterrupt f = handle (const f)
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)