ghc/lib/ghc/Readline.lhs

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