Alastair Reid <[EMAIL PROTECTED]> writes:
> It would be nice to have those bindings but just having backspace and
> left-right cursors work would already be a huge improvement over nothing.
OK, here is my contribution. The attached module SimpleLineEditor
is API-compatible with readline, and is a slight elaboration of
the line editor currently distributed as part of hmake interactive.
It does the basic stuff like backspace and left and right arrows.
Today's addition was a simple history mechanism using (uggh!) an IORef.
Because of the way I chose to implement a separation of
keystroke-recognition from interpretation of the associated editing
command, it should be reasonably straightforward to extend/change
the keystrokes for different terminal types. It should also be
fairly easy to add more editing commands (e.g. there are commands
for word-movement, and begin/end of line, but no key-binding and no
interpretation yet either.)
Perhaps we should add something like this to the hierarchical libs,
in the readline package? Then we can have some basic line-editing
functionality available in a portable fashion, independent of whether
any particular machine has the real readline library installed.
Regards,
Malcolm
module SimpleLineEditor
( initialise -- :: IO ()
, getLineEdited -- :: String -> IO String
, delChars -- :: String -> IO ()
) where
import IO
import Monad (when)
import Char
import System.IO.Unsafe (unsafePerformIO)
import Data.IORef
import Maybe
import System (system)
#if USE_READLINE
import Readline
#endif
initialise :: IO ()
initialise = do
-- Note, we assume the terminal echos all input characters
system("stty cbreak")
hSetBuffering stdout NoBuffering
hSetBuffering stdin NoBuffering
#if USE_READLINE
Readline.initialize
#endif
delChars :: String -> IO ()
delChars [] = return ()
delChars (_:xs) = do putStr "\BS \BS"
delChars xs
-- getLineEdited relies on having the terminal in non-buffered mode,
-- therefore please ensure that `hSetBuffering NoBuffering' is called
-- before using this.
#if USE_READLINE
getLineEdited :: String -> IO (Maybe String)
getLineEdited prompt = do
ms <- readline prompt
case ms of
Nothing -> return ms
Just s -> when (not (all isSpace s)) (addHistory s) >> return ms
#else
-- nasty imperative state holds the command history
history :: IORef [String]
history = unsafePerformIO (newIORef [])
getLineEdited :: String -> IO (Maybe String)
getLineEdited prompt = do
putStr prompt
previous <- readIORef history
ms <- gl "" 0 ([],previous)
case ms of
Nothing -> return ms
Just s -> do when (not (all isSpace s))
(writeIORef history (reverse s: previous))
return ms
where
gl s 0 hist = do -- s is accumulated line (in reverse)
-- 0 is cursor position FROM THE END of the string
cmd <- lineCmd
case cmd of
Char c -> gl (c:s) 0 hist
Accept -> return (Just (reverse s))
Cancel -> return Nothing
Delete L -> delChars "_" >> gl (if null s then s else tail s) 0 hist
Delete Begin -> delChars s >> gl "" 0 hist
Move L -> if not (null s) then putStr ("\BS") >> gl s 1 hist
else gl s 0 hist
History -> case hist of
(fut, []) -> gl s 0 hist
(fut, p:past) -> do delChars s
putStr (reverse p)
gl p 0 (s:fut, past)
Future -> case hist of
([], past) -> gl s 0 hist
(f:fut, past) -> do delChars s
putStr (reverse f)
gl f 0 (fut, s:past)
_ -> gl s 0 hist
gl s n hist = do -- s is accumulated line, n(/=0) is cursor position
cmd <- lineCmd
case cmd of
Char c -> do putStr (reverse (take n s))
putStr (replicate n '\BS')
gl (take n s ++ c: drop n s) n hist
Accept -> return (Just (reverse s))
Cancel -> return Nothing
Move R -> do let n1 = n-1
putStr (reverse (take n s)++" ")
putStr (replicate n '\BS')
gl s n1 hist
Delete R -> do let n1 = n-1
putStr (reverse (take n1 s) ++ " ")
putStr (replicate (n1+1) '\BS')
gl (take n1 s ++ drop n s) n1 hist
Move L -> do let n1 = n+1
if n1 <= length s then do
putStr ('\BS':reverse (take n1 s))
putStr (replicate n1 '\BS')
gl s n1 hist
else do
putStr (reverse s++" ")
putStr (replicate n1 '\BS')
gl s n hist
Delete L -> do let n1 = n+1
if n1 <= length s then do
putStr ('\BS':reverse (take n s)++" ")
putStr (replicate n1 '\BS')
gl (take n s ++ drop n1 s) n hist
else do
putStr (reverse s++" ")
putStr (replicate n1 '\BS')
gl s n hist
History -> case hist of
(fut, []) -> gl s n hist
(fut, p:past) -> do delChars s
putStr p
gl p 0 (s:fut, past)
Future -> case hist of
([], past) -> gl s n hist
(f:fut, past) -> do delChars s
putStr f
gl f 0 (fut, s:past)
_ -> gl s n hist
-- Define a mini-command language, to separate the lexing of input
-- commands from their interpretation. Note there is room for expansion
-- here, e.g. commands include word-at-a-time movement, but we don't
-- currently have a key binding for that.
data LineCmd = Char Char | Move Cursor | Delete Cursor
| Accept | Cancel | History | Future | NoOp
data Cursor = L | R | WordL | WordR | Begin | End
-- This little lexer for keystrokes does a reasonable job, but there
-- are plenty of problems. E.g. the backspace key might generate a
-- ^H character and not display it, which results in a mismatched cursor
-- position. Behaviour is highly dependent on terminal settings I imagine.
lineCmd :: IO LineCmd
lineCmd = do
c <- hGetChar stdin
case c of
'\n' -> return Accept
'\DEL' -> delChars "\DEL" >> return (Delete L)
'\^H' -> delChars "^H" >> return (Delete L)
'\BS' -> delChars "\BS" >> return (Delete L)
'\^K' -> putChar '\n' >> return Cancel
'\^L' -> delChars "^L" >> return (Move R)
'\^[' -> do
delChars "^["
c <- hGetChar stdin
case c of
'k' -> delChars "k" >> return History
'j' -> delChars "j" >> return Future
'[' -> do
delChars "["
c <- hGetChar stdin
case c of
'D' -> delChars "D" >> return (Move L)
'C' -> delChars "C" >> return (Move R)
'A' -> delChars "A" >> return History
'B' -> delChars "B" >> return Future
'3' -> do delChars "3"
c <- hGetChar stdin
case c of
'~' -> delChars "~" >> return (Delete R)
_ -> delChars "_" >> return NoOp
_ -> delChars "_" >> return NoOp
'O' -> do
delChars "O"
c <- hGetChar stdin
case c of
'D' -> delChars "D" >> return (Move L)
'C' -> delChars "C" >> return (Move R)
'A' -> delChars "A" >> return History
'B' -> delChars "B" >> return Future
_ -> delChars "_" >> return NoOp
_ -> delChars "_" >> return NoOp
_ -> return (Char c)
#endif -- USE_READLINE
module Main where
import SimpleLineEditor
import Monad (when)
import Maybe
main = initialise >> loop
where loop = do l <- getLineEdited "prompt> "
when (isJust l) (putStrLn (fromJust l))
when (l/=Just "quit") loop
return ()
