module System.Console.Haskeline(
InputT,
runInputT,
runInputTWithPrefs,
getInputLine,
outputStr,
outputStrLn,
Settings(..),
defaultSettings,
setComplete,
Interrupt(..),
withInterrupt,
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}
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
case result of
Just line | not (all isSpace line) -> addHistory line
_ -> return ()
return result
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 => 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
WindowResize -> do
oldLayout <- ask
newLayout <- liftIO $ getLayout tops
if oldLayout == newLayout
then loop s processor
else 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 liftM Just UTF8.getLine
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)
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