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