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 Data.Char (isSpace)
import Control.Monad
import qualified Control.Exception as Exception
import Data.Dynamic
defaultSettings :: MonadIO m => Settings m
defaultSettings = Settings {complete = completeFilename,
historyFile = Nothing,
handleSigINT = False}
wrapTerminalOps:: MonadException m => m a -> m a
wrapTerminalOps =
bracketSet (hGetBuffering stdin) (hSetBuffering stdin) NoBuffering
. bracketSet (hGetBuffering stdout) (hSetBuffering stdout) LineBuffering
. bracketSet (hGetEcho stdout) (hSetEcho stdout) False
bracketSet :: (Eq a, MonadException m) => IO a -> (a -> IO ()) -> a -> m b -> m b
bracketSet getState set newState f = do
oldState <- liftIO getState
if oldState == newState
then f
else finally (liftIO (set newState) >> f) (liftIO (set oldState))
outputStr :: forall m . MonadIO m => String -> InputT m ()
outputStr xs = do
run :: RunTerm (InputCmdT m) <- ask
liftIO $ putStrTerm run 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
isTerm <- liftIO $ hIsTerminalDevice stdin
if isTerm
then getInputCmdLine prefix
else do
atEOF <- liftIO $ hIsEOF stdin
if atEOF
then return Nothing
else liftM Just $ liftIO $ hGetLine stdin
getInputCmdLine :: forall m . MonadException m => String -> InputT m (Maybe String)
getInputCmdLine prefix = do
emode <- asks (\prefs -> case editMode prefs of
Vi -> viActions
Emacs -> emacsCommands)
settings :: Settings m <- ask
wrapTerminalOps $ do
let ls = emptyIM
RunTerm {withGetEvent = withGetEvent', runTerm=runTerm'} <- ask
result <- runInputCmdT $ runTerm' $ withGetEvent' (handleSigINT settings)
$ \getEvent -> do
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
liftIO $ Exception.evaluate (Exception.throwDyn Interrupt)
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
data Interrupt = Interrupt
deriving (Show,Typeable,Eq)
handleInterrupt :: MonadException m => m a
-> m a
-> m a
handleInterrupt f = handle $ \e -> case Exception.dynExceptions e of
Just dyn | Just Interrupt <- fromDynamic dyn -> f
_ -> throwIO e
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