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