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.
  10
  11
  12 \begin{code}
  13 {-# OPTIONS -#include "cbits/ghcReadline.h" #-}
  14
  15 module Readline (
  16     rlInitialize,
  17     readline, addHistory,
  18
  19     rlBindKey, rlAddDefun,
  20     RlCallbackFunction,
  21
  22     rlGetLineBuffer, rlSetLineBuffer,
  23     rlGetPoint, rlSetPoint,
  24     rlGetEnd, rlSetEnd,
  25     rlGetMark, rlSetMark,
  26     rlSetDone,
  27     rlPendingInput,
  28
  29     rlPrompt, rlTerminalName, rlSetReadlineName, rlGetReadlineName
  30
  31     ) where
  32 import GlaExts
  33
  34 import CString  ( unpackCStringIO )
  35 import Foreign
  36
  37 import System
  38
  39 --#include <readline/readline.h>
  40
  41 type KeyCode = Int
  42
  43 type RlCallbackFunction =
  44     (Int ->                     -- Numeric Argument
  45      KeyCode ->                 -- KeyCode of pressed Key
  46      IO Int)
  47 \end{code}
  48
  49 %***************************************************************************
  50 %*                                                                         *
  51 \subsection[Readline-Functions]{Main Readline Functions}
  52 %*                                                                         *
  53 %***************************************************************************
  54 \begin{code}
  55
  56 readline :: String                      -- Prompt String
  57          -> IO String                   -- Returned line
  58 readline prompt =  do
  59 --ToDo: Get the "Live register in _casm_GC_ " bug fixed
  60 --      this stops us passing the prompt string to readline directly :-(
  61 --    litstr <- _casm_GC_ ``%r = readline(%0);'' prompt
  62     _casm_ ``rl_prompt_hack = (char*)realloc(rl_prompt_hack, %1);
  63              strcpy (rl_prompt_hack,%0);''
  64                 prompt  (length prompt)
  65     litstr <- _casm_GC_ ``%r = readline (rl_prompt_hack);''
  66     if (litstr == ``NULL'')
  67      then fail (userError "Readline has read EOF")
  68      else do
  69         str <- unpackCStringIO litstr
  70         _ccall_ free litstr
  71         return str
  72
  73 addHistory :: String            -- String to enter in history
  74            -> IO ()
  75 addHistory str = _ccall_ add_history str
  76
  77
  78 rlBindKey :: KeyCode                -- Key to Bind to
  79           -> RlCallbackFunction     -- Function to exec on execution
  80           -> IO ()
  81 rlBindKey key cback =
  82     if (0 > key) || (key > 255) then
  83         fail (userError "Invalid ASCII Key Code, must be in range 0.255")
  84     else  do
  85         addCbackEntry (key,cback)
  86         _casm_ `` rl_bind_key((KeyCode)%0,&genericRlCback); '' key
  87
  88 \end{code}
  89
  90 i.e. add the (KeyCode,RlCallbackFunction) key to the assoc. list and register
  91 the generic callback for this KeyCode.
  92
  93 The entry point that $genericRlCback$ calls would then read the
  94 global variables $current\_i$ and $current\_kc$ and do a lookup:
  95
  96 \begin{code}
  97 rlAddDefun :: String ->                 -- Function Name
  98               RlCallbackFunction ->     -- Function to call
  99               KeyCode ->                -- Key to bind to, or -1 for no bind
 100               IO ()
 101 rlAddDefun name cback key =
 102     if (0 > key) || (key > 255) then
 103         fail (userError "Invalid ASCII Key Code, must be in range 0..255")
 104     else do
 105         addCbackEntry (key, cback)
 106         _casm_ ``rl_add_defun (%0, &genericRlCback, (KeyCode)%1);'' name key
 107
 108 \end{code}
 109
 110
 111 The C function $genericRlCallback$ puts the callback arguments into
 112 global variables and enters the Haskell world through the
 113 $haskellRlEntry$ function. Before exiting, the Haskell function will
 114 deposit its result in the global varariable $rl\_return$.
 115
 116 In the Haskell action that is invoked via $enterStablePtr$, a match
 117 between the Keycode in $current\_kc$ and the Haskell callback needs to
 118 be made. To essentially keep the same assoc. list of (KeyCode,cback
 119 function) as Readline does, we make use of yet another global variable
 120 $cbackList$:
 121
 122 \begin{code}
 123
 124 createCbackList :: [(KeyCode,RlCallbackFunction)] -> PrimIO ()
 125 createCbackList ls =
 126 #ifndef __PARALLEL_HASKELL__
 127     makeStablePtr ls  >>= \ stable_ls ->
 128     _casm_ `` cbackList=(StgStablePtr)%0; '' stable_ls
 129 #else
 130     error "createCbackList: not available for Parallel Haskell"
 131 #endif
 132
 133 getCbackList :: PrimIO [(KeyCode,RlCallbackFunction)]
 134 getCbackList =
 135 #ifndef __PARALLEL_HASKELL__
 136     _casm_ `` %r=(StgStablePtr)cbackList; '' >>= \ stable_ls ->
 137     deRefStablePtr stable_ls
 138 #else
 139     error "getCbackList: not available for Parallel Haskell"
 140 #endif
 141
 142 setCbackList :: [(KeyCode,RlCallbackFunction)] -> PrimIO ()
 143 setCbackList ls =
 144 #ifndef __PARALLEL_HASKELL__
 145     _casm_ `` %r=(StgStablePtr)cbackList; '' >>= \ old_stable_ls ->
 146     freeStablePtr old_stable_ls              >>
 147     createCbackList ls
 148 #else
 149     error "setCbackList: not available for Parallel Haskell"
 150 #endif
 151
 152 addCbackEntry :: (KeyCode,RlCallbackFunction) -> IO ()
 153 addCbackEntry entry = do
 154     ls <- getCbackList
 155     setCbackList (entry:ls)
 156 \end{code}
 157
 158 The above functions allows us to query and augment the assoc. list in
 159 Haskell.
 160
 161 \begin{code}
 162
 163 invokeRlCback :: IO ()
 164 invokeRlCback = do
 165     kc    <- _casm_ `` %r=(KeyCode)current_kc; ''
 166     narg  <- _casm_ `` %r=(int)current_narg; ''
 167     ls    <- getCbackList
 168     ret_val <-
 169       (case (dropWhile (\ (key,_) -> kc/=key) ls) of
 170          [] -> return (-1)
 171          ((_,cback):_) -> cback narg kc
 172       )
 173     _casm_ `` rl_return=(int)%0; '' ret_val
 174
 175 \end{code}
 176
 177 Finally, we need to initialise this whole, ugly machinery:
 178
 179 \begin{code}
 180 initRlCbacks :: PrimIO ()
 181
 182 initRlCbacks =
 183 #ifndef __PARALLEL_HASKELL__
 184     createCbackList []             >>
 185     makeStablePtr (invokeRlCback)  >>= \ stable_f ->
 186     _casm_ `` haskellRlEntry=(StgStablePtr)%0; '' stable_f >>= \ () ->
 187     return ()
 188 #else
 189     error "initRlCbacks: not available for Parallel Haskell"
 190 #endif
 191 \end{code}
 192
 193
 194 %***************************************************************************
 195 %*                                                                         *
 196 \subsection[Readline-Globals]{Global Readline Variables}
 197 %*                                                                         *
 198 %***************************************************************************
 199
 200 These are the global variables required by the readline lib. Need to
 201 find a way of making these read/write from the Haskell side.  Should
 202 they be in the IO Monad, should they be Mutable Variables?
 203
 204 \begin{code}
 205
 206 rlGetLineBuffer :: IO String
 207 rlGetLineBuffer = do
 208     litstr <- _casm_ ``%r = rl_line_buffer;''
 209     unpackCStringIO litstr
 210
 211 rlSetLineBuffer :: String -> IO ()
 212 rlSetLineBuffer str = _casm_ ``rl_line_buffer = %0;'' str
 213
 214
 215 rlGetPoint :: IO Int
 216 rlGetPoint = _casm_ ``%r = rl_point;''
 217
 218 rlSetPoint :: Int -> IO ()
 219 rlSetPoint point = _casm_ ``rl_point = %0;'' point
 220
 221 rlGetEnd :: IO Int
 222 rlGetEnd = _casm_ ``%r = rl_end;''
 223
 224 rlSetEnd :: Int -> IO ()
 225 rlSetEnd end = _casm_ ``rl_end = %0;'' end
 226
 227 rlGetMark :: IO Int
 228 rlGetMark = _casm_ ``%r = rl_mark;''
 229
 230 rlSetMark :: Int -> IO ()
 231 rlSetMark mark = _casm_ ``rl_mark = %0;'' mark
 232
 233 rlSetDone :: Bool -> IO ()
 234 rlSetDone True  = _casm_ ``rl_done = %0;'' 1
 235 rlSetDone False = _casm_ ``rl_done = %0;'' 0
 236
 237 rlPendingInput :: KeyCode -> IO ()
 238 rlPendingInput key = primIOToIO (_casm_ ``rl_pending_input = %0;'' key)
 239
 240 rlPrompt :: IO String
 241 rlPrompt = do
 242     litstr <- _casm_ ``%r = rl_readline_name;''
 243     unpackCStringIO litstr
 244
 245 rlTerminalName :: IO String
 246 rlTerminalName = do
 247     litstr <- _casm_ ``%r = rl_terminal_name;''
 248     unpackCStringIO litstr
 249
 250
 251 rlGetReadlineName :: IO String
 252 rlGetReadlineName = do
 253     litstr <- _casm_ ``%r = rl_readline_name;''
 254     unpackCStringIO litstr
 255
 256 rlSetReadlineName :: String -> IO ()
 257 rlSetReadlineName str = _casm_ ``rl_readline_name = %0;'' str
 258 \end{code}
 259
 260 \begin{verbatim}
 261 --
 262 -- The following two were taken from PreludeStdIO stdin/stdout
 263 --
 264 rlInStream :: Handle
 265 rlInStream = unsafePerformPrimIO (
 266     newMVar                                             >>= \ handle ->
 267     _ccall_ getLock (``rl_instream''::Addr) 0           >>= \ rc ->
 268     (case rc of
 269        0 -> putMVar handle ClosedHandle
 270        1 -> putMVar handle (ReadHandle ``rl_instream'' Nothing False)
 271        _ -> constructError                              >>= \ ioError ->
 272             putMVar handle (ErrorHandle ioError)
 273     )                                                   >>
 274     returnPrimIO handle
 275   )
 276
 277
 278 rlOutStream :: Handle
 279 rlOutStream = unsafePerformPrimIO (
 280     newMVar                                             >>= \ handle ->
 281     _ccall_ getLock (``rl_outstream''::Addr) 1          >>= \ rc ->
 282     (case rc of
 283        0 -> putMVar handle ClosedHandle
 284        1 -> putMVar handle (WriteHandle ``rl_outstream'' Nothing False)
 285        _ -> constructError                              >>= \ ioError ->
 286             putMVar handle (ErrorHandle ioError)
 287     )                                                   >>
 288     returnPrimIO handle
 289   )
 290
 291 \end{verbatim}
 292
 293
 294 \begin{code}
 295
 296 -- rlStartupHook :: RlCallBackFunction -> IO ()
 297
 298 rlInitialize :: IO ()
 299 rlInitialize = do
 300     pname <- getProgName
 301     rlSetReadlineName pname
 302     _casm_ ``rl_prompt_hack = (char*)malloc(1);''
 303     initRlCbacks
 304
 305 \end{code}