ref: c101325aaf8ed0ec3c8c4ff4b7d425bba799825a
dir: /mhs/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,
getInputLineHistComp,
) where
import Prelude(); import MiniPrelude
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 []) ([],[]) "" ""
return r
getInputLineHist :: FilePath -> String -> IO (Maybe String)
getInputLineHist = getInputLineHistComp (\ _ -> return [])
type CompleteFn = (String, String) -> IO [String]
-- 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.
getInputLineHistComp :: CompleteFn -> FilePath -> String -> IO (Maybe String)
getInputLineHistComp comp 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 comp (reverse hist, []) "" ""
-- putStrLn $ "done: " ++ hfn ++ "\n" ++ unlines hist'
writeFile hfn $ unlines hist'
return r -- XXX no type error
getRaw :: IO Char
getRaw = do
i <- c_getRaw
when (i < 0) $
error "getRaw failed"
return (chr i)
type Hist = ([String], [String])
loop :: CompleteFn -> Hist -> String -> String -> IO ([String], Maybe String)
loop comp hist before after = do
hFlush stdout
i <- getRaw
loop' comp hist before after i
loop' :: CompleteFn -> Hist -> String -> String -> Char -> IO ([String], Maybe String)
loop' comp hist before after cmd = do
let
cur = reverse before ++ after
back n = putStr (replicate n '\b')
bsSpBs n = concat $ replicate n "\b \b"
ins c = do
putChar c
putStr after
back (length after)
add c = do
ins c
loop comp hist (c:before) after
backward =
case before of
[] -> noop
c:cs -> do
back 1
loop comp hist cs (c:after)
forward =
case after of
[] -> noop
c:cs -> do
putChar c
loop comp hist (c:before) cs
bol = do
back (length before)
loop comp hist [] cur
eol = do
putStr after
loop comp hist (reverse after ++ before) []
bs = do
case before of
[] -> noop
_:cs -> do
back 1
putStr after
putChar ' '
back (length after + 1)
loop comp hist cs after
del = do
case after of
[] -> noop
_:cs -> do
putStr cs
putChar ' '
back (length cs + 1)
loop comp 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 comp hist [] []
noop = loop comp hist before after
kill = do
putStr after
putStr $ bsSpBs $ length after
loop comp 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 comp h (reverse s) ""
eraseLine = do
putStr after
putStr $ bsSpBs $ length before + length after
complete = do
alts <- comp (before, after)
case alts of
[] -> loop comp hist before after
[s] -> do mapM_ ins s; loop comp hist (reverse s ++ before) after
ss -> tabLoop ss
tabLoop (s:ss) = do
mapM_ ins s -- show first alternative
hFlush stdout
c <- getRaw
if c /= '\t' then
loop' comp hist (reverse s ++ before) after c
else do
let n = length s
back n -- back up this alternative
putStr after -- put back old text
putStr $ replicate n ' ' -- erase extra
back (n + length after) -- put cursor back
tabLoop (ss ++ [s]) -- try next alternative
exec i =
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
'\b' -> bs -- BS, backspace
'\DEL' -> bs -- DEL, backspace
'\r' -> send -- CR, return
'\n' -> 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
'\t' -> complete -- TAB, complete word
'\ESC' -> do -- ESC
b <- getRaw
if b /= '[' then
noop
else do
c <- getRaw
case c of
'A' -> previous
'B' -> next
'C' -> forward
'D' -> backward
_ -> noop
_ -> if i >= ' ' && i < '\DEL' then add i else noop
exec cmd