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
import Data.Dynamic
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 :: forall m . MonadException m => TermOps -> String -> InputT m (Maybe String)
getInputCmdLine tops prefix = do
emode <- asks (\prefs -> case editMode prefs of
Vi -> viActions
Emacs -> emacsCommands)
settings :: Settings m <- ask
result <- runInputCmdT tops $ flip (runTerm tops) (handleSigINT settings)
$ \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
repeatTillFinish :: forall m s d
. (MonadTrans d, Term (d m), MonadIO 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 <- getEvent
case event of
SigInt -> do
moveToNextLine s
throwInterrupt
WindowResize newLayout ->
withReposition newLayout (loop s processor)
KeyInput k -> case lookupKM processor k of
Nothing -> actBell >> loop s processor
Just g -> case g s of
Left r -> moveToNextLine 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)
data Interrupt = Interrupt
deriving (Show,Typeable,Eq)
handleInterrupt :: MonadException m => m a
-> m a
-> m a
handleInterrupt f = handle (const f)
throwInterrupt :: MonadIO m => m a
throwInterrupt = throwDynIO Interrupt
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) = drawLineDiff prefix s t
drawEffect prefix s (PrintLines ls t) = do
if isTemporary s
then clearLine prefix s
else moveToNextLine s
printLines ls
drawLine prefix t
drawEffect prefix s (RingBell t) = drawLineDiff prefix s t >> actBell
drawLine :: (LineState s, Term m) => String -> s -> m ()
drawLine prefix s = drawLineDiff prefix Cleared s
clearLine :: (LineState s, Term m) => String -> s -> m ()
clearLine prefix s = drawLineDiff 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