ghc/lib/misc/Readline.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1995-1996
   3 %
   4 \section[Readline]{GNU Readline Library Bindings}
   5
   6 This module attempts to provide a better line based editing facility
   7 for Haskell programmers by providing access to the GNU Readline
   8 library.  Related to this are bindings for the GNU History library
   9 which can be found in History (at some point in the future :-).
  10
  11 Original version by Darren Moffat
  12 Heavily modified in 1999 by Sven Panne <Sven.Panne@informatik.uni-muenchen.de>
  13
  14 Notes:
  15
  16    * This binding is still *very* incomplete...  Volunteers?
  17
  18    * The GHC User's Guide section on Readline is not up-to-date anymore,
  19      the flags you need are: -syslib misc -syslib posix -lreadline -ltermcap
  20      (or -lncurses on some Linux systems)
  21
  22 \begin{code}
  23 {-# OPTIONS -#include <readline/readline.h> -#include <readline/history.h> #-}
  24
  25 module Readline (
  26     rlInitialize,
  27     readline, addHistory,
  28
  29     rlBindKey, rlAddDefun,
  30     RlCallbackFunction,
  31
  32     rlGetLineBuffer, rlSetLineBuffer,
  33     rlGetPoint, rlSetPoint,
  34     rlGetEnd, rlSetEnd,
  35     rlGetMark, rlSetMark,
  36     rlSetDone,
  37     rlPendingInput,
  38
  39     rlPrompt, rlTerminalName,
  40     rlGetReadlineName, rlSetReadlineName,
  41
  42     rlInStream, rlOutStream
  43     ) where
  44
  45 import Addr(Addr)
  46 import ByteArray(ByteArray)
  47 import Char(ord, chr)
  48 import CString(packString, unpackCStringIO)
  49 import IO(Handle)
  50 import IOExts(IORef, newIORef, readIORef, writeIORef, unsafePerformIO, freeHaskellFunctionPtr)
  51 import Maybe(fromMaybe)
  52 import Monad(when)
  53 import Posix(intToFd, fdToHandle)
  54 import System(getProgName)
  55
  56 -- SUP: Haskell has closures and I've got no clue about the return value,
  57 --      so a better type for the callbacks is probably
  58 --      Int {- Numeric Arg -} -> IO ()
  59
  60 type KeyCode = Char
  61
  62 type RlCallbackFunction =
  63     (Int ->                     -- Numeric Argument
  64      KeyCode ->                 -- KeyCode of pressed Key
  65      IO Int)                    -- What's this?
  66 \end{code}
  67
  68 %***************************************************************************
  69 %*                                                                         *
  70 \subsection[Readline-Functions]{Main Readline Functions}
  71 %*                                                                         *
  72 %***************************************************************************
  73 \begin{code}
  74
  75 rlInitialize :: IO ()
  76 rlInitialize = rlSetReadlineName =<< getProgName
  77
  78 foreign import "free"     unsafe free        :: Addr -> IO ()
  79 foreign import "readline" unsafe readlineAux :: ByteArray Int -> IO Addr
  80
  81 readline :: String              -- Prompt String
  82          -> IO (Maybe String)   -- Just returned line or Nothing if EOF
  83 readline prompt =  do
  84    cstr <- readlineAux (packString prompt)
  85    if cstr == ``NULL''
  86       then return Nothing
  87       else do str <- unpackCStringIO cstr
  88               free cstr
  89               return (Just str)
  90
  91 foreign import "add_history" unsafe add_history :: ByteArray Int -> IO ()
  92
  93 addHistory :: String            -- String to enter in history
  94            -> IO ()
  95 addHistory = add_history . packString
  96
  97
  98 foreign export dynamic mkRlCallback :: (Int -> Int -> IO Int) -> IO Addr
  99 foreign import "rl_bind_key" rl_bind_key :: Int -> Addr -> IO Int
 100
 101 rlBindKey :: KeyCode                -- Key to Bind to
 102           -> RlCallbackFunction     -- Function to exec on execution
 103           -> IO ()
 104 rlBindKey key cback = do
 105    cbAddr <- mkRlCallback (\n k -> cback n (chr k))
 106    ok     <- rl_bind_key (ord key) cbAddr
 107    if ok /= 0 then wrongKeyCode else addCbackEntry key cbAddr
 108
 109 foreign import "rl_add_defun" unsafe rl_add_defun :: ByteArray Int -> Addr -> Int -> IO Int
 110
 111 rlAddDefun :: String ->                 -- Function Name
 112               RlCallbackFunction ->     -- Function to call
 113               Maybe KeyCode ->          -- Key to bind to
 114               IO ()
 115 rlAddDefun name cback mbKey = do
 116    cbAddr <- mkRlCallback (\n k -> cback n (chr k))
 117    ok     <- rl_add_defun (packString name) cbAddr (maybe (-1) ord mbKey)
 118    when (ok /= 0) wrongKeyCode
 119
 120 -- Don't know how this should ever happen with KeyCode = Char
 121 wrongKeyCode :: IO ()
 122 wrongKeyCode = ioError (userError "Invalid ASCII Key Code, must be in range 0..255")
 123
 124 -- Global hacking for freeing callbacks
 125
 126 theCbackTable :: IORef [(KeyCode,Addr)]
 127 theCbackTable = unsafePerformIO (newIORef [])
 128
 129 addCbackEntry :: KeyCode -> Addr -> IO ()
 130 addCbackEntry key cbAddr = do
 131    cbackTable <- readIORef theCbackTable
 132    maybe (return ()) freeHaskellFunctionPtr (lookup key cbackTable)
 133    writeIORef theCbackTable
 134               ((key,cbAddr) : [ entry | entry@(k,_) <- cbackTable, k /= key ])
 135
 136 \end{code}
 137
 138
 139 %***************************************************************************
 140 %*                                                                         *
 141 \subsection[Readline-Globals]{Global Readline Variables}
 142 %*                                                                         *
 143 %***************************************************************************
 144
 145 These are the global variables required by the readline lib. Need to
 146 find a way of making these read/write from the Haskell side.  Should
 147 they be in the IO Monad, should they be Mutable Variables?
 148
 149 \begin{code}
 150
 151 rlGetLineBuffer :: IO String
 152 rlGetLineBuffer = unpackCStringIO =<< _casm_ ``%r = rl_line_buffer;''
 153
 154 rlSetLineBuffer :: String -> IO ()
 155 rlSetLineBuffer str = _casm_ ``rl_line_buffer = %0;'' str
 156
 157 rlGetPoint :: IO Int
 158 rlGetPoint = _casm_ ``%r = rl_point;''
 159
 160 rlSetPoint :: Int -> IO ()
 161 rlSetPoint point = _casm_ ``rl_point = %0;'' point
 162
 163 rlGetEnd :: IO Int
 164 rlGetEnd = _casm_ ``%r = rl_end;''
 165
 166 rlSetEnd :: Int -> IO ()
 167 rlSetEnd end = _casm_ ``rl_end = %0;'' end
 168
 169 rlGetMark :: IO Int
 170 rlGetMark = _casm_ ``%r = rl_mark;''
 171
 172 rlSetMark :: Int -> IO ()
 173 rlSetMark mark = _casm_ ``rl_mark = %0;'' mark
 174
 175 rlSetDone :: Bool -> IO ()
 176 rlSetDone False = _casm_ ``rl_done = %0;'' (0::Int)
 177 rlSetDone True  = _casm_ ``rl_done = %0;'' (1::Int)
 178
 179 rlPendingInput :: KeyCode -> IO ()
 180 rlPendingInput key = _casm_ ``rl_pending_input = %0;'' key
 181
 182 rlPrompt :: IO String
 183 rlPrompt = unpackCStringIO =<<  _casm_ ``%r = rl_readline_name;''
 184
 185 rlTerminalName :: IO String
 186 rlTerminalName = unpackCStringIO =<< _casm_ ``%r = rl_terminal_name;''
 187
 188 rlGetReadlineName :: IO String
 189 rlGetReadlineName = unpackCStringIO =<< _casm_ ``%r = rl_readline_name;''
 190
 191 rlSetReadlineName :: String -> IO ()
 192 rlSetReadlineName str = _casm_ ``rl_readline_name = %0;'' str
 193
 194 rlInStream :: Handle
 195 rlInStream  = unsafePerformIO (fdToHandle (intToFd ``fileno(rl_instream)''))
 196
 197 rlOutStream :: Handle
 198 rlOutStream = unsafePerformIO (fdToHandle (intToFd ``fileno(rl_outstream)''))
 199
 200 \end{code}
 201
 202 A simple test:
 203
 204 main :: IO ()
 205 main = do rlInitialize
 206           rlBindKey '\^X' (\nargc kc -> do print (nargc,kc); return 0)
 207           loop
 208    where loop = maybe (putStrLn "Qapla'!")
 209                       (\reply -> do unless (null reply) (addHistory reply)
 210                                     putStrLn (reply ++ "...   pItlh!")
 211                                     loop) =<< readline "nuqneH, ghunwI'? "