{-# OPTIONS_GHC -cpp #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  System.Console.SimpleLineEditor
-- Copyright   :  (c) 2000,2003, Malcolm Wallace
-- License     :  GPL (if it depends on readline, which is GPL)
--                BSD (otherwise)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  non-portable (unix-specific at the moment)
--
-- A simple line editor, using the GNU readline library if available,
-- or a small emulation otherwise.
--
-----------------------------------------------------------------------------

module System.Console.SimpleLineEditor
  ( initialise		--	:: IO ()
  , restore		--	:: IO ()
  , getLineEdited	--	:: String -> IO (Maybe String)
  , delChars		--	:: String -> IO ()
  ) 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

-- | Set up the environment so that the terminal passes characters directly
--   into the Haskell program, for immediate interpretation by the line editor.
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
    -- The following call is probably non-portable.  Better suggestions?
    -- Note, we turn OFF terminal echoing of input characters
    String -> IO ExitCode
system(String
"stty -icanon min 1 -echo")
    () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#endif

-- | Restore the environment so that the terminal is usable in normal
--   mode once again.
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
    -- The following call is probably non-portable.  Better suggestions?
    -- We assume the terminal should echo input characters after restoration
    String -> IO ExitCode
system(String
"stty icanon echo")
    () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#endif

-- | Remove the given string from immediately behind (to the left of) the
--   current cursor position.
delChars :: String -> IO ()
delChars :: String -> IO ()
delChars []     = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
delChars (Char
_:String
xs) = do String -> IO ()
putStr String
"\BS \BS"
                     String -> IO ()
delChars String
xs

-- | 'getLineEdited p' uses the string @p@ as a prompt, and returns a line
--   of input from the user.  The user can edit the line in-place before
--   completion, using common readline-like command keys.  (The real readline
--   is used when available, or otherwise a simplified emulation.)

#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 :: 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 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 String
"" Int
0 ([],[String]
previous)
    case Maybe String
ms of 
      Maybe String
Nothing -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
ms
      Just 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 String
s Int
0 ([String], [String])
hist = do	-- s is accumulated line (in reverse)
			-- 0 is cursor position FROM THE END of the string
      LineCmd
cmd <- IO LineCmd
lineCmd
      case LineCmd
cmd of
        Char 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) Int
0 ([String], [String])
hist
        LineCmd
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))
        LineCmd
Cancel   -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
        Delete Cursor
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 Int
0 ([String], [String])
hist
                    else String -> IO ()
delChars String
"_" 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) Int
0 ([String], [String])
hist
        Delete Cursor
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 String
"" Int
0 ([String], [String])
hist
        Move Cursor
L   -> if Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s) then String -> IO ()
putStr (String
"\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 Int
1 ([String], [String])
hist
                    else String -> Int -> ([String], [String]) -> IO (Maybe String)
gl String
s Int
0 ([String], [String])
hist
        LineCmd
History  -> case ([String], [String])
hist of
                      ([String]
_fut, [])    -> String -> Int -> ([String], [String]) -> IO (Maybe String)
gl String
s Int
0 ([String], [String])
hist
                      ([String]
fut, String
p:[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 Int
0 (String
sString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
fut, [String]
past)
        LineCmd
Future   -> case ([String], [String])
hist of
                      ([], [String]
_past)   -> String -> Int -> ([String], [String]) -> IO (Maybe String)
gl String
s Int
0 ([String], [String])
hist
                      (String
f:[String]
fut, [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 Int
0 ([String]
fut, String
sString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
past)
        LineCmd
_        -> String -> Int -> ([String], [String]) -> IO (Maybe String)
gl String
s Int
0 ([String], [String])
hist

    gl String
s Int
n ([String], [String])
hist = do	-- s is accumulated line, n(/=0) is cursor position
      LineCmd
cmd <- IO LineCmd
lineCmd
      case LineCmd
cmd of
        Char 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 Char
'\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
        LineCmd
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))
        LineCmd
Cancel   -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
        Move Cursor
R   -> do let n1 :: Int
n1 = Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
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
" ")
                       String -> IO ()
putStr (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
'\BS')
                       String -> Int -> ([String], [String]) -> IO (Maybe String)
gl String
s Int
n1 ([String], [String])
hist
        Delete Cursor
R -> do let n1 :: Int
n1 = Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
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
" ")
                       String -> IO ()
putStr (Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
n1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Char
'\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 Cursor
L   -> do let n1 :: Int
n1 = Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
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 (Char
'\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 Char
'\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
" ")
                           String -> IO ()
putStr (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n1 Char
'\BS')
                           String -> Int -> ([String], [String]) -> IO (Maybe String)
gl String
s Int
n ([String], [String])
hist
        Delete Cursor
L -> do let n1 :: Int
n1 = Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
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 (Char
'\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
" ")
                           String -> IO ()
putStr (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n1 Char
'\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
" ")
                           String -> IO ()
putStr (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n1 Char
'\BS')
                           String -> Int -> ([String], [String]) -> IO (Maybe String)
gl String
s Int
n ([String], [String])
hist
        LineCmd
History  -> case ([String], [String])
hist of
                      ([String]
_fut, [])    -> String -> Int -> ([String], [String]) -> IO (Maybe String)
gl String
s Int
n ([String], [String])
hist
                      ([String]
fut, String
p:[String]
past) -> do String -> IO ()
putStr (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
' ')
                                          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 Int
0 (String
sString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
fut, [String]
past)
        LineCmd
Future   -> case ([String], [String])
hist of
                      ([], [String]
_past)   -> String -> Int -> ([String], [String]) -> IO (Maybe String)
gl String
s Int
n ([String], [String])
hist
                      (String
f:[String]
fut, [String]
past) -> do String -> IO ()
putStr (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
' ')
                                          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 Int
0 ([String]
fut, String
sString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
past)
        LineCmd
_        -> String -> Int -> ([String], [String]) -> IO (Maybe String)
gl String
s Int
n ([String], [String])
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 | Begin | End -- not implemented yet: | WordL | WordR

-- 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 :: IO LineCmd
lineCmd = do
    Char
c1 <- Handle -> IO Char
hGetChar Handle
stdin
    case Char
c1 of
      Char
'\n'   -> Char -> IO ()
putChar Char
'\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
      Char
'\^K'  -> Char -> IO ()
putChar Char
'\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
      Char
'\DEL' -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return (Cursor -> LineCmd
Delete Cursor
L)
      Char
'\BS'  -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return (Cursor -> LineCmd
Delete Cursor
L)
      Char
'\^L'  -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return (Cursor -> LineCmd
Move Cursor
R)
      Char
'\^[' -> do
        Char
c2 <- Handle -> IO Char
hGetChar Handle
stdin
        case Char
c2 of
          Char
'k' -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return LineCmd
History
          Char
'j' -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return LineCmd
Future
          Char
'[' -> do
              Char
c3 <- Handle -> IO Char
hGetChar Handle
stdin
              case Char
c3 of
                Char
'D' -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return (Cursor -> LineCmd
Move Cursor
L)
                Char
'C' -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return (Cursor -> LineCmd
Move Cursor
R)
                Char
'A' -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return LineCmd
History
                Char
'B' -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return LineCmd
Future
                Char
'3' -> do Char
c <- Handle -> IO Char
hGetChar Handle
stdin
                          case Char
c of
                            Char
'~' -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return (Cursor -> LineCmd
Delete Cursor
R)
                            Char
_   -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return LineCmd
NoOp
                Char
'4' -> do Char
c <- Handle -> IO Char
hGetChar Handle
stdin
                          case Char
c of
                            Char
'~' -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return (Cursor -> LineCmd
Move Cursor
End)
                            Char
_   -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return LineCmd
NoOp
                Char
'1' -> do Char
c <- Handle -> IO Char
hGetChar Handle
stdin
                          case Char
c of
                            Char
'~' -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return (Cursor -> LineCmd
Move Cursor
Begin)
                            Char
_   -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return LineCmd
NoOp
                Char
_   -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return LineCmd
NoOp
          Char
'O' -> do
              Char
c3 <- Handle -> IO Char
hGetChar Handle
stdin
              case Char
c3 of
                Char
'D' -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return (Cursor -> LineCmd
Move Cursor
L)
                Char
'C' -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return (Cursor -> LineCmd
Move Cursor
R)
                Char
'A' -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return LineCmd
History
                Char
'B' -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return LineCmd
Future
                Char
_   -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return LineCmd
NoOp
          Char
_   -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return LineCmd
NoOp
      Char
_ -> LineCmd -> IO LineCmd
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> LineCmd
Char Char
c1)

#endif /* USE_READLINE */

{-
-- | A simple interactive test for the line-editing functionality.

-- (This illustrates the necessary use of 'initialise' and 'restore'
--  as brackets around the editing loop.)
testIt :: IO ()
testIt = initialise >> loop >> restore
  where loop = do l <- getLineEdited "prompt> "
                  when (isJust l) (putStrLn (fromJust l))
                  when (l/=Just "quit") loop
-}