    {-# 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 = do
        hSetBuffering stdout NoBuffering
        hSetBuffering stdin  NoBuffering
    #if USE_READLINE
        initialize
    #else
        -- The following call is probably non-portable.  Better suggestions?
        -- Note, we turn OFF terminal echoing of input characters
        system("stty -icanon min 1 -echo")
        return ()
    #endif

    -- | Restore the environment so that the terminal is usable in normal
    --   mode once again.
    restore :: IO ()
    restore = do
        hSetBuffering stdout LineBuffering
        hSetBuffering stdin  LineBuffering
    #if ! USE_READLINE
        -- The following call is probably non-portable.  Better suggestions?
        -- We assume the terminal should echo input characters after restoration
        system("stty icanon echo")
        return ()
    #endif

    -- | Remove the given string from immediately behind (to the left of) the
    --   current cursor position.
    delChars :: String -> IO ()
    delChars []     = return ()
    delChars (_:xs) = do putStr "\BS \BS"
                         delChars 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 = 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   -> putChar c >> gl (c:s) 0 hist
            Accept   -> return (Just (reverse s))
            Cancel   -> return Nothing
            Delete L -> if null s then gl s 0 hist
                        else delChars "_" >> gl (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 (c: 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 putStr (replicate n ' ')
                                              delChars s
                                              putStr (reverse p)
                                              gl p 0 (s:fut, past)
            Future   -> case hist of
                          ([], _past)   -> gl s n hist
                          (f:fut, past) -> do putStr (replicate n ' ')
                                              delChars s
                                              putStr (reverse 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 | 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 = do
        c1 <- hGetChar stdin
        case c1 of
          '\n'   -> putChar '\n' >> return Accept
          '\^K'  -> putChar '\n' >> return Cancel
          '\DEL' -> return (Delete L)
          '\BS'  -> return (Delete L)
          '\^L'  -> return (Move R)
          '\^[' -> do
            c2 <- hGetChar stdin
            case c2 of
              'k' -> return History
              'j' -> return Future
              '[' -> do
                  c3 <- hGetChar stdin
                  case c3 of
                    'D' -> return (Move L)
                    'C' -> return (Move R)
                    'A' -> return History
                    'B' -> return Future
                    '3' -> do c <- hGetChar stdin
                              case c of
                                '~' -> return (Delete R)
                                _   -> return NoOp
                    '4' -> do c <- hGetChar stdin
                              case c of
                                '~' -> return (Move End)
                                _   -> return NoOp
                    '1' -> do c <- hGetChar stdin
                              case c of
                                '~' -> return (Move Begin)
                                _   -> return NoOp
                    _   -> return NoOp
              'O' -> do
                  c3 <- hGetChar stdin
                  case c3 of
                    'D' -> return (Move L)
                    'C' -> return (Move R)
                    'A' -> return History
                    'B' -> return Future
                    _   -> return NoOp
              _   -> return NoOp
          _ -> return (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
    -}