{-# OPTIONS_GHC -cpp #-}
module System.Console.SimpleLineEditor
( initialise
, restore
, getLineEdited
, delChars
) where
import System.IO (stdin, stdout, BufferMode(..), hSetBuffering)
import Control.Monad (when)
import Data.Char (isSpace)
import Data.Maybe (isJust, fromJust)
#if USE_READLINE
import System.Console.Readline
#else
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import System.Cmd (system)
import System.IO (hGetChar)
import System.IO.Unsafe (unsafePerformIO)
#endif
initialise :: IO ()
initialise :: IO ()
initialise = do
Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdout BufferMode
NoBuffering
Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdin BufferMode
NoBuffering
#if USE_READLINE
initialize
#else
String -> IO ExitCode
system("stty -icanon min 1 -echo")
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#endif
restore :: IO ()
restore :: IO ()
restore = do
Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdout BufferMode
LineBuffering
Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdin BufferMode
LineBuffering
#if ! USE_READLINE
String -> IO ExitCode
system("stty icanon echo")
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#endif
delChars :: String -> IO ()
delChars :: String -> IO ()
delChars [] = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
delChars (_:xs :: String
xs) = do String -> IO ()
putStr "\BS \BS"
String -> IO ()
delChars String
xs
#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
history :: IORef [String]
history :: IORef [String]
history = IO (IORef [String]) -> IORef [String]
forall a. IO a -> a
unsafePerformIO ([String] -> IO (IORef [String])
forall a. a -> IO (IORef a)
newIORef [])
getLineEdited :: String -> IO (Maybe String)
getLineEdited :: String -> IO (Maybe String)
getLineEdited prompt :: String
prompt = do
String -> IO ()
putStr String
prompt
[String]
previous <- IORef [String] -> IO [String]
forall a. IORef a -> IO a
readIORef IORef [String]
history
Maybe String
ms <- String -> Int -> ([String], [String]) -> IO (Maybe String)
gl "" 0 ([],[String]
previous)
case Maybe String
ms of
Nothing -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
ms
Just s :: String
s -> do Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ((Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
s))
(IORef [String] -> [String] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [String]
history (String -> String
forall a. [a] -> [a]
reverse String
sString -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
previous))
Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
ms
where
gl :: String -> Int -> ([String], [String]) -> IO (Maybe String)
gl s :: String
s 0 hist :: ([String], [String])
hist = do
LineCmd
cmd <- IO LineCmd
lineCmd
case LineCmd
cmd of
Char c :: Char
c -> Char -> IO ()
putChar Char
c IO () -> IO (Maybe String) -> IO (Maybe String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Int -> ([String], [String]) -> IO (Maybe String)
gl (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
s) 0 ([String], [String])
hist
Accept -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just (String -> String
forall a. [a] -> [a]
reverse String
s))
Cancel -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
Delete L -> if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s then String -> Int -> ([String], [String]) -> IO (Maybe String)
gl String
s 0 ([String], [String])
hist
else String -> IO ()
delChars "_" IO () -> IO (Maybe String) -> IO (Maybe String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Int -> ([String], [String]) -> IO (Maybe String)
gl (String -> String
forall a. [a] -> [a]
tail String
s) 0 ([String], [String])
hist
Delete Begin -> String -> IO ()
delChars String
s IO () -> IO (Maybe String) -> IO (Maybe String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Int -> ([String], [String]) -> IO (Maybe String)
gl "" 0 ([String], [String])
hist
Move L -> if Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s) then String -> IO ()
putStr ("\BS") IO () -> IO (Maybe String) -> IO (Maybe String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Int -> ([String], [String]) -> IO (Maybe String)
gl String
s 1 ([String], [String])
hist
else String -> Int -> ([String], [String]) -> IO (Maybe String)
gl String
s 0 ([String], [String])
hist
History -> case ([String], [String])
hist of
(_fut :: [String]
_fut, []) -> String -> Int -> ([String], [String]) -> IO (Maybe String)
gl String
s 0 ([String], [String])
hist
(fut :: [String]
fut, p :: String
p:past :: [String]
past) -> do String -> IO ()
delChars String
s
String -> IO ()
putStr (String -> String
forall a. [a] -> [a]
reverse String
p)
String -> Int -> ([String], [String]) -> IO (Maybe String)
gl String
p 0 (String
sString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
fut, [String]
past)
Future -> case ([String], [String])
hist of
([], _past :: [String]
_past) -> String -> Int -> ([String], [String]) -> IO (Maybe String)
gl String
s 0 ([String], [String])
hist
(f :: String
f:fut :: [String]
fut, past :: [String]
past) -> do String -> IO ()
delChars String
s
String -> IO ()
putStr (String -> String
forall a. [a] -> [a]
reverse String
f)
String -> Int -> ([String], [String]) -> IO (Maybe String)
gl String
f 0 ([String]
fut, String
sString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
past)
_ -> String -> Int -> ([String], [String]) -> IO (Maybe String)
gl String
s 0 ([String], [String])
hist
gl s :: String
s n :: Int
n hist :: ([String], [String])
hist = do
LineCmd
cmd <- IO LineCmd
lineCmd
case LineCmd
cmd of
Char c :: Char
c -> do String -> IO ()
putStr (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
: String -> String
forall a. [a] -> [a]
reverse (Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
n String
s))
String -> IO ()
putStr (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n '\BS')
String -> Int -> ([String], [String]) -> IO (Maybe String)
gl (Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
n String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
cChar -> String -> String
forall a. a -> [a] -> [a]
: Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
n String
s) Int
n ([String], [String])
hist
Accept -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just (String -> String
forall a. [a] -> [a]
reverse String
s))
Cancel -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
Move R -> do let n1 :: Int
n1 = Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-1
String -> IO ()
putStr (String -> String
forall a. [a] -> [a]
reverse (Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
n String
s)String -> String -> String
forall a. [a] -> [a] -> [a]
++" ")
String -> IO ()
putStr (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n '\BS')
String -> Int -> ([String], [String]) -> IO (Maybe String)
gl String
s Int
n1 ([String], [String])
hist
Delete R -> do let n1 :: Int
n1 = Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-1
String -> IO ()
putStr (String -> String
forall a. [a] -> [a]
reverse (Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
n1 String
s) String -> String -> String
forall a. [a] -> [a] -> [a]
++ " ")
String -> IO ()
putStr (Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
n1Int -> Int -> Int
forall a. Num a => a -> a -> a
+1) '\BS')
String -> Int -> ([String], [String]) -> IO (Maybe String)
gl (Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
n1 String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
n String
s) Int
n1 ([String], [String])
hist
Move L -> do let n1 :: Int
n1 = Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1
if Int
n1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s then do
String -> IO ()
putStr ('\BS'Char -> String -> String
forall a. a -> [a] -> [a]
:String -> String
forall a. [a] -> [a]
reverse (Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
n1 String
s))
String -> IO ()
putStr (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n1 '\BS')
String -> Int -> ([String], [String]) -> IO (Maybe String)
gl String
s Int
n1 ([String], [String])
hist
else do
String -> IO ()
putStr (String -> String
forall a. [a] -> [a]
reverse String
sString -> String -> String
forall a. [a] -> [a] -> [a]
++" ")
String -> IO ()
putStr (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n1 '\BS')
String -> Int -> ([String], [String]) -> IO (Maybe String)
gl String
s Int
n ([String], [String])
hist
Delete L -> do let n1 :: Int
n1 = Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1
if Int
n1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s then do
String -> IO ()
putStr ('\BS'Char -> String -> String
forall a. a -> [a] -> [a]
:String -> String
forall a. [a] -> [a]
reverse (Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
n String
s)String -> String -> String
forall a. [a] -> [a] -> [a]
++" ")
String -> IO ()
putStr (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n1 '\BS')
String -> Int -> ([String], [String]) -> IO (Maybe String)
gl (Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
n String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
n1 String
s) Int
n ([String], [String])
hist
else do
String -> IO ()
putStr (String -> String
forall a. [a] -> [a]
reverse String
sString -> String -> String
forall a. [a] -> [a] -> [a]
++" ")
String -> IO ()
putStr (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n1 '\BS')
String -> Int -> ([String], [String]) -> IO (Maybe String)
gl String
s Int
n ([String], [String])
hist
History -> case ([String], [String])
hist of
(_fut :: [String]
_fut, []) -> String -> Int -> ([String], [String]) -> IO (Maybe String)
gl String
s Int
n ([String], [String])
hist
(fut :: [String]
fut, p :: String
p:past :: [String]
past) -> do String -> IO ()
putStr (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n ' ')
String -> IO ()
delChars String
s
String -> IO ()
putStr (String -> String
forall a. [a] -> [a]
reverse String
p)
String -> Int -> ([String], [String]) -> IO (Maybe String)
gl String
p 0 (String
sString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
fut, [String]
past)
Future -> case ([String], [String])
hist of
([], _past :: [String]
_past) -> String -> Int -> ([String], [String]) -> IO (Maybe String)
gl String
s Int
n ([String], [String])
hist
(f :: String
f:fut :: [String]
fut, past :: [String]
past) -> do String -> IO ()
putStr (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n ' ')
String -> IO ()
delChars String
s
String -> IO ()
putStr (String -> String
forall a. [a] -> [a]
reverse String
f)
String -> Int -> ([String], [String]) -> IO (Maybe String)
gl String
f 0 ([String]
fut, String
sString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
past)
_ -> String -> Int -> ([String], [String]) -> IO (Maybe String)
gl String
s Int
n ([String], [String])
hist
data LineCmd = Char Char | Move Cursor | Delete Cursor
| Accept | Cancel | History | Future | NoOp
data Cursor = L | R | Begin | End
lineCmd :: IO LineCmd
lineCmd :: IO LineCmd
lineCmd = do
Char
c1 <- Handle -> IO Char
hGetChar Handle
stdin
case Char
c1 of
'\n' -> Char -> IO ()
putChar '\n' IO () -> IO LineCmd -> IO LineCmd
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return LineCmd
Accept
'\^K' -> Char -> IO ()
putChar '\n' IO () -> IO LineCmd -> IO LineCmd
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return LineCmd
Cancel
'\DEL' -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return (Cursor -> LineCmd
Delete Cursor
L)
'\BS' -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return (Cursor -> LineCmd
Delete Cursor
L)
'\^L' -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return (Cursor -> LineCmd
Move Cursor
R)
'\^[' -> do
Char
c2 <- Handle -> IO Char
hGetChar Handle
stdin
case Char
c2 of
'k' -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return LineCmd
History
'j' -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return LineCmd
Future
'[' -> do
Char
c3 <- Handle -> IO Char
hGetChar Handle
stdin
case Char
c3 of
'D' -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return (Cursor -> LineCmd
Move Cursor
L)
'C' -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return (Cursor -> LineCmd
Move Cursor
R)
'A' -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return LineCmd
History
'B' -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return LineCmd
Future
'3' -> do Char
c <- Handle -> IO Char
hGetChar Handle
stdin
case Char
c of
'~' -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return (Cursor -> LineCmd
Delete Cursor
R)
_ -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return LineCmd
NoOp
'4' -> do Char
c <- Handle -> IO Char
hGetChar Handle
stdin
case Char
c of
'~' -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return (Cursor -> LineCmd
Move Cursor
End)
_ -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return LineCmd
NoOp
'1' -> do Char
c <- Handle -> IO Char
hGetChar Handle
stdin
case Char
c of
'~' -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return (Cursor -> LineCmd
Move Cursor
Begin)
_ -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return LineCmd
NoOp
_ -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return LineCmd
NoOp
'O' -> do
Char
c3 <- Handle -> IO Char
hGetChar Handle
stdin
case Char
c3 of
'D' -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return (Cursor -> LineCmd
Move Cursor
L)
'C' -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return (Cursor -> LineCmd
Move Cursor
R)
'A' -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return LineCmd
History
'B' -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return LineCmd
Future
_ -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return LineCmd
NoOp
_ -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return LineCmd
NoOp
_ -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> LineCmd
Char Char
c1)
#endif /* USE_READLINE */