ref: 41c2cd888668f697dbcae2b031c7afacde168987
dir: /lib/System/Console/SimpleReadline.hs/
-- Copyright 2023 Lennart Augustsson
-- See LICENSE file for full license.
--
-- Simple readline with line editing and history.
-- Only assumes the terminal is capable of (sane) backspace.
module System.Console.SimpleReadline(
getInputLine,
getInputLineHist
) where
import Prelude
import Control.Monad
import Data.Char
import System.IO
foreign import ccall "GETRAW" c_getRaw :: IO Int
-- Get an input line with editing.
-- Return Nothing if the input is ^D, otherwise the typed string.
getInputLine :: String -> IO (Maybe String)
getInputLine prompt = do
(_, r) <- loop ([],[]) "" ""
return r
-- Get an input line with editing.
-- Return Nothing if the input is ^D, otherwise the typed string.
-- The FilePath gives the name of a file that stores the history.
getInputLineHist :: FilePath -> String -> IO (Maybe String)
getInputLineHist hfn prompt = do
mhdl <- openFileM hfn ReadMode
hist <-
case mhdl of
Nothing -> return []
Just hdl -> do
file <- hGetContents hdl
let h = lines file
seq (length h) (return h) -- force file to be read
putStr prompt
(hist', r) <- loop (reverse hist, []) "" ""
-- putStrLn $ "done: " ++ hfn ++ "\n" ++ unlines hist'
writeFile hfn $ unlines hist'
return r -- XXX no type error
getRaw :: IO Int
getRaw = do
i <- c_getRaw
when (i < 0) $
error "getRaw failed"
return i
type Hist = ([String], [String])
loop :: Hist -> String -> String -> IO ([String], Maybe String)
loop hist before after = do
hFlush stdout
i <- chr <$> getRaw
let
cur = reverse before ++ after
back n = putStr (replicate n '\b')
bsSpBs n = concat $ replicate n "\b \b"
add c = do
putChar c
putStr after
back (length after)
loop hist (c:before) after
backward =
case before of
[] -> noop
c:cs -> do
back 1
loop hist cs (c:after)
forward =
case after of
[] -> noop
c:cs -> do
putChar c
loop hist (c:before) cs
bol = do
back (length before)
loop hist [] cur
eol = do
putStr after
loop hist (reverse after ++ before) []
bs = do
case before of
[] -> noop
_:cs -> do
back 1
putStr after
putChar ' '
back (length after + 1)
loop hist cs after
del = do
case after of
[] -> noop
_:cs -> do
putStr cs
putChar ' '
back (length cs + 1)
loop hist before cs
send =
ret (Just cur)
ret ms = do
putChar '\n'
hFlush stdout
let
o = reverse (fst hist) ++ snd hist
l =
case ms of
Nothing -> []
Just [] -> []
Just s | not (null o) && s == last o -> []
| otherwise -> [s]
h = o ++ l
return (h, ms)
erase = do
eraseLine
loop hist [] []
noop = loop hist before after
kill = do
putStr after
putStr $ bsSpBs $ length after
loop hist before []
next =
case hist of
(_, []) -> noop
(p, l:n) -> setLine (l:p, n) l
previous =
case hist of
([], _) -> noop
(l:p, n) -> setLine (p, l:n) l
setLine h s = do
eraseLine
putStr s
loop h (reverse s) ""
eraseLine = do
putStr after
putStr $ bsSpBs $ length before + length after
case i of
'\^D' -> -- CTL-D, EOF
if null before && null after then
ret Nothing
else
del
'\^B' -> backward -- CTL-B, backwards
'\^F' -> forward -- CTL-F, forwards
'\^A' -> bol -- CTL-A, beginning of line
'\^E' -> eol -- CTL-E, end of line
'\^H' -> bs -- BS, backspace
'\DEL' -> bs -- DEL, backspace
'\^M' -> send -- CR, return
'\^J' -> send -- LF, return
'\^N' -> next -- CTL-N, next line
'\^P' -> previous -- CTL-P, previous line
'\^U' -> erase -- CTL-U, erase line
'\^K' -> kill -- CTL-K, kill to eol
'\ESC' -> do -- ESC
b <- chr <$> getRaw
if b /= '[' then
noop
else do
c <- chr <$> getRaw
case c of
'A' -> previous
'B' -> next
'C' -> forward
'D' -> backward
_ -> noop
_ -> if i >= ' ' && i < '\DEL' then add i else noop