module System.Console.Readline (
readline,
addHistory,
getLineBuffer,
setLineBuffer,
getPoint,
setPoint,
getEnd,
setEnd,
getMark,
setMark,
setDone,
setPendingInput,
setEraseEmptyLine,
getPrompt,
setAlreadyPrompted,
getLibraryVersion,
getTerminalName,
setReadlineName,
getInStream,
getOutStream,
setStartupHook,
setPreInputHook,
setEventHook,
setRedisplayFunction,
Keymap,
newBareKeymap,
copyKeymap,
newKeymap,
freeKeymap,
getKeymap,
setKeymap,
getKeymapByName,
getKeymapName,
getExecutingKeymap,
getBindingKeymap,
Callback,
addDefun,
bindKey,
bindKeyInMap,
unbindKey,
unbindKeyInMap,
unbindCommandInMap,
Entry(..),
genericBind,
parseAndBind,
readInitFile,
namedFunction,
functionOfKeyseq,
functionDumper,
listFunmapNames,
funmapNames,
beginUndoGroup, endUndoGroup,
UndoCode(..),
addUndo,
freeUndoList,
doUndo,
modifying,
redisplay,
forcedUpdateDisplay,
onNewLine,
onNewLineWithPrompt,
resetLineState,
message,
clearMessage,
savePrompt,
restorePrompt,
insertText,
deleteText,
copyText,
killText,
readKey,
stuffChar,
initialize,
resetTerminal,
ding,
displayMatchList,
callbackHandlerInstall,
callbackReadChar,
setCatchSignals,
getCatchSignals,
setCatchSigwinch,
getCatchSigwinch,
cleanupAfterSignal,
freeLineState,
resetAfterSignal,
resizeTerminal,
setSignals,
clearSignals,
completeInternal,
complete,
possibleCompletions,
insertCompletions,
completionMatches,
filenameCompletionFunction,
usernameCompletionFunction,
setCompletionEntryFunction,
setAttemptedCompletionFunction,
setFilenameQuotingFunction,
quoteFilename,
setFilenameDequotingFunction,
setCharIsQuotedP,
getCompletionQueryItems,
setCompletionQueryItems,
getBasicWordBreakCharacters,
setBasicWordBreakCharacters,
getBasicQuoteCharacters,
setBasicQuoteCharacters,
getCompleterWordBreakCharacters,
setCompleterWordBreakCharacters,
getCompleterQuoteCharacters,
setCompleterQuoteCharacters,
getFilenameQuoteCharacters,
setFilenameQuoteCharacters,
getSpecialPrefixes,
setSpecialPrefixes,
getCompletionAppendCharacter,
setCompletionAppendCharacter,
setIgnoreCompletionDuplicates,
getIgnoreCompletionDuplicates,
setFilenameCompletionDesired,
getFilenameCompletionDesired,
setFilenameQuotingDesired,
getFilenameQuotingDesired,
setInhibitCompletion,
getInhibitCompletion,
setAttemptedCompletionOver,
getAttemptedCompletionOver,
setIgnoreSomeCompletionsFunction,
setDirectoryCompletionHook
,
setCompletionWordBreakHook
,
setCompletionDisplayMatchesHook
)
where
import Control.Monad ( liftM, when, unless )
import Data.Char ( chr, ord )
import Data.Maybe ( fromMaybe )
import System.IO ( Handle )
import System.IO.Unsafe ( unsafePerformIO )
import Data.IORef ( newIORef, readIORef, writeIORef )
import Foreign.Ptr ( Ptr, nullPtr, castPtr, castFunPtrToPtr,
FunPtr, nullFunPtr, freeHaskellFunPtr )
import Foreign.Storable ( Storable(..) )
import Foreign.Marshal.Utils ( maybePeek, maybeWith, withMany )
import Foreign.Marshal.Alloc ( alloca, free )
import Foreign.Marshal.Array ( mallocArray, peekArray0, pokeArray0, withArray0 )
import Foreign.C.Types ( CInt, CChar, CFile )
import Foreign.C.String ( newCString, peekCString, withCString,
castCharToCChar, castCCharToChar )
import GHC.Handle ( fdToHandle )
readline :: String
-> IO (Maybe String)
readline prompt = do
ptr <- withCString prompt readlineC
flip maybePeek ptr $ \ptr' -> do
line <- peekCString ptr'
free ptr'
return line
foreign import ccall "readline" readlineC :: Ptr CChar -> IO (Ptr CChar)
addHistory :: String -> IO ()
addHistory line = withCString line add_history
foreign import ccall unsafe add_history :: Ptr CChar -> IO ()
getLineBuffer :: IO String
getLineBuffer = peek rl_line_buffer >>= peekCString
setLineBuffer :: String -> IO ()
setLineBuffer line = do
let lineC = map castCharToCChar line
rl_extend_line_buffer (fromIntegral (length lineC))
ptr <- peek rl_line_buffer
pokeArray0 0 (castPtr ptr) lineC
foreign import ccall "&"
rl_line_buffer :: Ptr (Ptr CChar)
foreign import ccall unsafe rl_extend_line_buffer :: CInt -> IO ()
getPoint :: IO Int
getPoint = liftM fromIntegral (peek rl_point)
setPoint :: Int -> IO ()
setPoint p = poke rl_point (fromIntegral p)
foreign import ccall "&" rl_point :: Ptr CInt
getEnd :: IO Int
getEnd = liftM fromIntegral (peek rl_end)
setEnd :: Int -> IO ()
setEnd p = poke rl_end (fromIntegral p)
foreign import ccall "&" rl_end :: Ptr CInt
getMark :: IO Int
getMark = liftM fromIntegral (peek rl_mark)
setMark :: Int -> IO ()
setMark p = poke rl_mark (fromIntegral p)
foreign import ccall "&" rl_mark :: Ptr CInt
setDone :: Bool -> IO ()
setDone done = poke rl_done (if done then 1 else 0)
foreign import ccall "&" rl_done :: Ptr CInt
setPendingInput :: Char -> IO ()
setPendingInput key = poke rl_pending_input (fromIntegral (ord key))
foreign import ccall "&" rl_pending_input :: Ptr CInt
setEraseEmptyLine :: Bool -> IO ()
setEraseEmptyLine erase = poke rl_erase_empty_line (if erase then 1 else 0)
foreign import ccall "&" rl_erase_empty_line :: Ptr CInt
getPrompt :: IO String
getPrompt = peek rl_prompt >>= peekCString
foreign import ccall "&" rl_prompt :: Ptr (Ptr CChar)
setAlreadyPrompted :: Bool -> IO ()
setAlreadyPrompted pr = poke rl_already_prompted (if pr then 1 else 0)
foreign import ccall "&" rl_already_prompted :: Ptr CInt
getLibraryVersion :: IO String
getLibraryVersion = peek rl_library_version >>= peekCString
foreign import ccall "&" rl_library_version :: Ptr (Ptr CChar)
getTerminalName :: IO String
getTerminalName = peek rl_terminal_name >>= peekCString
foreign import ccall "&" rl_terminal_name :: Ptr (Ptr CChar)
setReadlineName :: String -> IO ()
setReadlineName name = newCString name >>= poke rl_readline_name
foreign import ccall "&" rl_readline_name :: Ptr (Ptr CChar)
getInStream :: IO Handle
getInStream = peek rl_instream >>= hs_fileno >>= fdToHandle . fromIntegral
foreign import ccall "&" rl_instream :: Ptr (Ptr CFile)
getOutStream :: IO Handle
getOutStream = peek rl_outstream >>= hs_fileno >>= fdToHandle . fromIntegral
foreign import ccall "&" rl_outstream :: Ptr (Ptr CFile)
foreign import ccall unsafe "__hscore_hs_fileno"
hs_fileno :: Ptr CFile -> IO CInt
setStartupHook :: Maybe (IO ()) -> IO ()
setStartupHook hook = setFunPtr rl_startup_hook hook exportHookInt
foreign import ccall "&" rl_startup_hook :: Ptr (FunPtr (IO CInt))
setPreInputHook :: Maybe (IO ()) -> IO ()
setPreInputHook hook = setFunPtr rl_pre_input_hook hook exportHookInt
foreign import ccall "&" rl_pre_input_hook :: Ptr (FunPtr (IO CInt))
setEventHook :: Maybe (IO ()) -> IO ()
setEventHook hook = setFunPtr rl_event_hook hook exportHookInt
foreign import ccall "&" rl_event_hook :: Ptr (FunPtr (IO CInt))
setRedisplayFunction :: Maybe (IO ()) -> IO ()
setRedisplayFunction fun = do
oldPtr <- peek rl_redisplay_function
when (oldPtr /= nullFunPtr && oldPtr /= rl_redisplay) $
freeHaskellFunPtr oldPtr
newPtr <- case fun of
Nothing -> return rl_redisplay
Just f -> exportHookVoid f
poke rl_redisplay_function newPtr
foreign import ccall "&" rl_redisplay_function :: Ptr (FunPtr (IO ()))
foreign import ccall "&" rl_redisplay :: FunPtr (IO ())
exportHookInt :: IO () -> IO (FunPtr (IO CInt))
exportHookInt hook = exportHookIntC (hook >> return 0)
foreign import ccall "wrapper"
exportHookIntC :: IO CInt -> IO (FunPtr (IO CInt))
foreign import ccall "wrapper"
exportHookVoid :: IO () -> IO (FunPtr (IO ()))
setFunPtr_freeIf :: (FunPtr a -> Bool)
-> Ptr (FunPtr a)
-> Maybe b
-> (b -> IO (FunPtr a))
-> IO ()
setFunPtr_freeIf pred variable newFun makeNewFun = do
oldPtr <- peek variable
when (pred oldPtr) $ freeHaskellFunPtr oldPtr
newPtr <- case newFun of
Nothing -> return nullFunPtr
Just f -> makeNewFun f
poke variable newPtr
setFunPtr :: Ptr (FunPtr a)
-> Maybe b
-> (b -> IO (FunPtr a))
-> IO ()
setFunPtr = setFunPtr_freeIf (/= nullFunPtr)
data KeymapTag = KeymapTag
newtype Keymap = MkKeymap (Ptr KeymapTag)
foreign import ccall unsafe "rl_make_bare_keymap" newBareKeymap :: IO Keymap
foreign import ccall unsafe "rl_copy_keymap" copyKeymap :: Keymap -> IO Keymap
foreign import ccall unsafe "rl_make_keymap" newKeymap :: IO Keymap
freeKeymap :: Keymap -> IO ()
freeKeymap k@(MkKeymap km) = do
rl_discard_keymap k
free km
foreign import ccall unsafe "rl_discard_keymap"
rl_discard_keymap :: Keymap -> IO ()
foreign import ccall unsafe "rl_get_keymap"
getKeymap :: IO Keymap
foreign import ccall unsafe "rl_set_keymap"
setKeymap :: Keymap -> IO ()
getKeymapByName :: String -> IO Keymap
getKeymapByName name = withCString name rl_get_keymap_by_name
foreign import ccall unsafe
rl_get_keymap_by_name :: Ptr CChar -> IO Keymap
getKeymapName :: Keymap -> IO (Maybe String)
getKeymapName km = do
ptr <- rl_get_keymap_name km
maybePeek peekCString ptr
foreign import ccall unsafe "rl_get_keymap_name"
rl_get_keymap_name :: Keymap -> IO (Ptr CChar)
getExecutingKeymap :: IO Keymap
getExecutingKeymap = liftM MkKeymap $ peek rl_executing_keymap
foreign import ccall "&" rl_executing_keymap :: Ptr (Ptr KeymapTag)
getBindingKeymap :: IO Keymap
getBindingKeymap = liftM MkKeymap $ peek rl_binding_keymap
foreign import ccall "&" rl_binding_keymap :: Ptr (Ptr KeymapTag)
type Callback = Int -> Char -> IO Int
type CallbackC = CInt -> CInt -> IO CInt
addDefun :: String -> Callback -> Maybe Char -> IO ()
addDefun name cb key = do
namePtr <- newCString name
cbPtr <- exportCallback cb
rl_add_defun namePtr cbPtr (maybe (1) (fromIntegral . ord) key)
return ()
foreign import ccall unsafe "rl_add_defun"
rl_add_defun :: Ptr CChar -> FunPtr CallbackC -> CInt -> IO CInt
bindKey :: Char -> Callback -> IO ()
bindKey key cb = do
cbPtr <- exportCallback cb
rl_bind_key (fromIntegral (ord key)) cbPtr
return ()
foreign import ccall unsafe "rl_bind_key"
rl_bind_key :: CInt -> FunPtr CallbackC -> IO CInt
bindKeyInMap :: Char -> Callback -> Keymap -> IO ()
bindKeyInMap key cb km = do
cbPtr <- exportCallback cb
rl_bind_key_in_map (fromIntegral (ord key)) cbPtr km
return ()
foreign import ccall unsafe "rl_bind_key_in_map"
rl_bind_key_in_map :: CInt -> FunPtr CallbackC -> Keymap -> IO CInt
unbindKey :: Char -> IO ()
unbindKey key = do
rl_unbind_key (fromIntegral (ord key))
return ()
foreign import ccall unsafe rl_unbind_key :: CInt -> IO CInt
unbindKeyInMap :: Char -> Keymap -> IO ()
unbindKeyInMap key km = do
rl_unbind_key_in_map (fromIntegral (ord key)) km
return ()
foreign import ccall unsafe "rl_unbind_key_in_map"
rl_unbind_key_in_map :: CInt -> Keymap -> IO CInt
unbindCommandInMap :: String -> Keymap -> IO ()
unbindCommandInMap comm km = do
withCString comm $ \commPtr -> rl_unbind_command_in_map commPtr km
return ()
foreign import ccall unsafe "rl_unbind_command_in_map"
rl_unbind_command_in_map :: Ptr CChar -> Keymap -> IO CInt
data Entry
= Function Callback
| Macro String
| Keymap Keymap
genericBind :: String -> Entry -> Keymap -> IO ()
genericBind keys (Function cb) km = do
cbPtr <- exportCallback cb
genericBind' (0) keys (castFunPtrToPtr cbPtr) km
genericBind keys (Macro s) km =
withCString s $ \ptr -> genericBind' (2) keys ptr km
genericBind keys (Keymap (MkKeymap km')) km =
genericBind' (1) keys (castPtr km') km
genericBind' :: CInt -> String -> Ptr CChar -> Keymap -> IO ()
genericBind' typ keys dat km = do
withCString keys $ \keysPtr -> rl_generic_bind typ keysPtr dat km
return ()
foreign import ccall unsafe "rl_generic_bind"
rl_generic_bind :: CInt -> Ptr CChar -> Ptr CChar -> Keymap -> IO CInt
parseAndBind :: String -> IO ()
parseAndBind s = do
ok <- withCString s rl_parse_and_bind
unless (ok == 0) $ ioError (userError "Parse error")
foreign import ccall unsafe "rl_parse_and_bind"
rl_parse_and_bind :: Ptr CChar -> IO CInt
readInitFile :: String -> IO ()
readInitFile name = do
ok <- withCString name rl_read_init_file
unless (ok == 0) $ ioError (userError "Can't read file")
foreign import ccall unsafe "rl_read_init_file"
rl_read_init_file :: Ptr CChar -> IO CInt
namedFunction :: String -> IO (Maybe Callback)
namedFunction name = do
ptr <- withCString name rl_named_function
return $ if ptr == nullFunPtr then Nothing else Just (importCallback ptr)
foreign import ccall unsafe "rl_named_function"
rl_named_function :: Ptr CChar -> IO (FunPtr CallbackC)
functionOfKeyseq :: String -> Maybe Keymap -> IO Entry
functionOfKeyseq keys km =
withCString keys $ \keysPtr -> alloca $ \typPtr -> do
dat <- rl_function_of_keyseq keysPtr (fromMaybe (MkKeymap nullPtr) km) typPtr
typ <- peek typPtr
case typ of
(0) ->
return (Function (importCallback dat))
(2) ->
liftM Macro (peekCString (castFunPtrToPtr dat))
(1) ->
return (Keymap (MkKeymap (castFunPtrToPtr dat)))
_ -> error "functionOfKeyseq: unknown type"
foreign import ccall unsafe "rl_function_of_keyseq"
rl_function_of_keyseq :: Ptr CChar -> Keymap -> Ptr CInt -> IO (FunPtr CallbackC)
functionDumper :: Bool -> IO ()
functionDumper readable = rl_function_dumper (if readable then 1 else 0)
foreign import ccall unsafe "rl_function_dumper"
rl_function_dumper :: CInt -> IO ()
foreign import ccall unsafe "rl_list_funmap_names" listFunmapNames :: IO ()
funmapNames :: IO [String]
funmapNames = do
namesPtr <- rl_funmap_names
namePtrs <- peekArray0 nullPtr namesPtr
free namesPtr
mapM peekCString namePtrs
foreign import ccall unsafe "rl_funmap_names"
rl_funmap_names :: IO (Ptr (Ptr CChar))
exportCallback :: Callback -> IO (FunPtr CallbackC)
exportCallback cb =
exportCallbackC $ \n key ->
liftM fromIntegral (cb (fromIntegral n) (chr (fromIntegral key)))
foreign import ccall "wrapper"
exportCallbackC :: CallbackC -> IO (FunPtr CallbackC)
importCallback :: FunPtr CallbackC -> Callback
importCallback ptr n key =
liftM fromIntegral $
importCallbackC ptr (fromIntegral n) (fromIntegral (ord key))
foreign import ccall "dynamic"
importCallbackC :: FunPtr CallbackC -> CallbackC
beginUndoGroup :: IO ()
beginUndoGroup = do rl_begin_undo_group; return ()
foreign import ccall unsafe "rl_begin_undo_group"
rl_begin_undo_group :: IO CInt
endUndoGroup :: IO ()
endUndoGroup = do rl_end_undo_group; return ()
foreign import ccall unsafe "rl_end_undo_group"
rl_end_undo_group :: IO CInt
data UndoCode = UndoDelete | UndoInsert | UndoBegin | UndoEnd
addUndo :: UndoCode -> Int -> Int -> String -> IO ()
addUndo uc start end text =
withCString text $ \textPtr ->
rl_add_undo uc' (fromIntegral start) (fromIntegral end) textPtr
where
uc' = case uc of
UndoDelete -> 0
UndoInsert -> 1
UndoBegin -> 2
UndoEnd -> 3
foreign import ccall unsafe
rl_add_undo :: CInt -> CInt -> CInt -> Ptr CChar -> IO ()
foreign import ccall unsafe "rl_free_undo_list" freeUndoList :: IO ()
doUndo :: IO Bool
doUndo = liftM (/= 0) rl_do_undo
foreign import ccall unsafe "rl_do_undo"
rl_do_undo :: IO CInt
modifying :: Int -> Int -> IO ()
modifying start end = do
rl_modifying (fromIntegral start) (fromIntegral end)
return ()
foreign import ccall unsafe "rl_modifying"
rl_modifying :: CInt -> CInt -> IO CInt
foreign import ccall unsafe "rl_redisplay" redisplay :: IO ()
forcedUpdateDisplay :: IO ()
forcedUpdateDisplay = do rl_forced_update_display; return ()
foreign import ccall unsafe "rl_forced_update_display"
rl_forced_update_display :: IO CInt
onNewLine :: IO ()
onNewLine = do rl_on_new_line; return ()
foreign import ccall unsafe "rl_on_new_line"
rl_on_new_line :: IO CInt
onNewLineWithPrompt :: IO ()
onNewLineWithPrompt = do rl_on_new_line_with_prompt; return ()
foreign import ccall unsafe "rl_on_new_line_with_prompt"
rl_on_new_line_with_prompt :: IO CInt
resetLineState :: IO ()
resetLineState = do rl_reset_line_state; return ()
foreign import ccall unsafe "rl_reset_line_state"
rl_reset_line_state :: IO CInt
message :: String -> IO ()
message s = withCString s hs_rl_message
foreign import ccall unsafe "hs_rl_message"
hs_rl_message :: Ptr CChar -> IO ()
clearMessage :: IO ()
clearMessage = do rl_clear_message; return ()
foreign import ccall unsafe "rl_clear_message"
rl_clear_message :: IO CInt
foreign import ccall unsafe "rl_save_prompt" savePrompt :: IO ()
foreign import ccall unsafe "rl_restore_prompt" restorePrompt :: IO ()
insertText :: String -> IO ()
insertText s = do withCString s rl_insert_text; return ()
foreign import ccall unsafe "rl_insert_text"
rl_insert_text :: Ptr CChar -> IO CInt
deleteText :: Int -> Int -> IO ()
deleteText start end = do
rl_delete_text (fromIntegral start) (fromIntegral end)
return ()
foreign import ccall unsafe "rl_delete_text"
rl_delete_text :: CInt -> CInt -> IO CInt
copyText :: Int -> Int -> IO String
copyText start end = do
ptr <- rl_copy_text (fromIntegral start) (fromIntegral end)
text <- peekCString ptr
free ptr
return text
foreign import ccall unsafe "rl_copy_text"
rl_copy_text :: CInt -> CInt -> IO (Ptr CChar)
killText :: Int -> Int -> IO ()
killText start end = do
rl_kill_text (fromIntegral start) (fromIntegral end)
return ()
foreign import ccall unsafe "rl_kill_text"
rl_kill_text :: CInt -> CInt -> IO CInt
readKey :: IO Char
readKey = liftM (chr . fromIntegral) rl_read_key
foreign import ccall unsafe "rl_read_key"
rl_read_key :: IO CInt
stuffChar :: Char -> IO Bool
stuffChar key = liftM (/= 0) (rl_stuff_char (fromIntegral (ord key)))
foreign import ccall unsafe "rl_stuff_char"
rl_stuff_char :: CInt -> IO CInt
initialize :: IO ()
initialize = do rl_initialize; return ()
foreign import ccall unsafe "rl_initialize"
rl_initialize :: IO CInt
resetTerminal :: Maybe String -> IO ()
resetTerminal name = do
maybeWith withCString name rl_reset_terminal
return ()
foreign import ccall unsafe "rl_reset_terminal"
rl_reset_terminal :: Ptr CChar -> IO CInt
ding :: IO Bool
ding = liftM (== 0) rl_ding
foreign import ccall unsafe "rl_ding" rl_ding :: IO CInt
displayMatchList :: [String] -> IO ()
displayMatchList matches =
withMany withCString matches $ \matchPtrs ->
withArray0 nullPtr (nullPtr:matchPtrs) $ \matchesPtr ->
rl_display_match_list
matchesPtr
(fromIntegral (length matches))
(fromIntegral (maximum (map length matches)))
foreign import ccall unsafe "rl_display_match_list"
rl_display_match_list :: Ptr (Ptr CChar) -> CInt -> CInt -> IO ()
type Handler = Ptr CChar -> IO ()
callbackHandlerInstall :: String -> (String -> IO ()) -> IO (IO ())
callbackHandlerInstall prompt lhandler = do
lhandlerPtr <- exportHandler $ \linePtr -> peekCString linePtr >>= lhandler
withCString prompt $ \promptPtr -> do
rl_callback_handler_install promptPtr lhandlerPtr
return (do rl_callback_handler_remove; freeHaskellFunPtr lhandlerPtr)
foreign import ccall "wrapper"
exportHandler :: Handler -> IO (FunPtr Handler)
foreign import ccall unsafe "rl_callback_handler_install"
rl_callback_handler_install :: Ptr CChar -> FunPtr Handler -> IO ()
foreign import ccall unsafe "rl_callback_handler_remove"
rl_callback_handler_remove :: IO ()
foreign import ccall "rl_callback_read_char"
callbackReadChar :: IO ()
setCatchSignals :: Bool -> IO ()
setCatchSignals cat = poke rl_catch_signals (if cat then 1 else 0)
getCatchSignals :: IO Bool
getCatchSignals = liftM (/= 0) (peek rl_catch_signals)
foreign import ccall "&" rl_catch_signals :: Ptr CInt
setCatchSigwinch :: Bool -> IO ()
setCatchSigwinch cat = poke rl_catch_sigwinch (if cat then 1 else 0)
getCatchSigwinch :: IO Bool
getCatchSigwinch = liftM (/= 0) (peek rl_catch_sigwinch)
foreign import ccall "&" rl_catch_sigwinch :: Ptr CInt
foreign import ccall unsafe "rl_cleanup_after_signal" cleanupAfterSignal :: IO ()
foreign import ccall unsafe "rl_free_line_state" freeLineState :: IO ()
foreign import ccall unsafe "rl_reset_after_signal" resetAfterSignal :: IO ()
foreign import ccall unsafe "rl_resize_terminal" resizeTerminal :: IO ()
setSignals :: IO ()
setSignals = do rl_set_signals; return ()
foreign import ccall unsafe "rl_set_signals"
rl_set_signals :: IO CInt
clearSignals :: IO ()
clearSignals = do rl_clear_signals; return ()
foreign import ccall unsafe "rl_clear_signals"
rl_clear_signals :: IO CInt
completeInternal :: Char -> IO ()
completeInternal what = do
rl_complete_internal (fromIntegral (ord what))
return ()
foreign import ccall "rl_complete_internal"
rl_complete_internal :: CInt -> IO CInt
complete :: Int -> Char -> IO Int
complete n key =
liftM fromIntegral $
rl_complete (fromIntegral n) (fromIntegral (ord key))
foreign import ccall "rl_complete"
rl_complete :: CInt -> CInt -> IO CInt
possibleCompletions :: Int -> Char -> IO Int
possibleCompletions n key =
liftM fromIntegral $
rl_possible_completions (fromIntegral n) (fromIntegral (ord key))
foreign import ccall "rl_possible_completions"
rl_possible_completions :: CInt -> CInt -> IO CInt
insertCompletions :: Int -> Char -> IO Int
insertCompletions n key =
liftM fromIntegral $
rl_insert_completions (fromIntegral n) (fromIntegral (ord key))
foreign import ccall "rl_insert_completions"
rl_insert_completions :: CInt -> CInt -> IO CInt
type Generator = Ptr CChar -> CInt -> IO (Ptr CChar)
singleToWhole :: Generator -> String -> IO [String]
singleToWhole f text =
withCString text $ \textPtr -> let
loop n = do
ptr <- f textPtr n
if ptr == nullPtr
then return []
else do
str <- peekCString ptr
free ptr
rest <- loop (n+1)
return (str:rest)
in loop 0
wholeToSingle :: (String -> IO [String]) -> IO Generator
wholeToSingle f = do
ref <- newIORef []
return $ \textPtr state -> do
when (state == 0) $ peekCString textPtr >>= f >>= writeIORef ref
next <- readIORef ref
case next of
[] -> return nullPtr
x:xs -> do
writeIORef ref xs
newCString x
completionMatches
:: String -> (String -> IO [String]) -> IO (Maybe (String, [String]))
completionMatches text entry =
withCString text $ \textPtr -> do
entryPtr <- wholeToSingle entry >>= exportGenerator
matchesPtr <- rl_completion_matches textPtr entryPtr
freeHaskellFunPtr entryPtr
if matchesPtr == nullPtr then return Nothing else do
matchPtrs <- peekArray0 nullPtr matchesPtr
(text':matches) <- mapM peekCString matchPtrs
mapM_ free matchPtrs
free matchesPtr
return (Just (text', matches))
foreign import ccall "rl_completion_matches"
rl_completion_matches :: Ptr CChar -> FunPtr Generator -> IO (Ptr (Ptr CChar))
filenameCompletionFunction :: String -> IO [String]
filenameCompletionFunction = singleToWhole rl_filename_completion_function
foreign import ccall unsafe "rl_filename_completion_function"
rl_filename_completion_function :: Generator
usernameCompletionFunction :: String -> IO [String]
usernameCompletionFunction = singleToWhole rl_username_completion_function
foreign import ccall unsafe "rl_username_completion_function"
rl_username_completion_function :: Generator
setCompletionEntryFunction :: Maybe (String -> IO [String]) -> IO ()
setCompletionEntryFunction fun =
setFunPtr rl_completion_entry_function fun $ \f ->
wholeToSingle f >>= exportGenerator
foreign import ccall "&" rl_completion_entry_function :: Ptr (FunPtr Generator)
foreign import ccall "wrapper"
exportGenerator :: Generator -> IO (FunPtr Generator)
type Completer = Ptr CChar -> CInt -> CInt -> IO (Ptr (Ptr CChar))
setAttemptedCompletionFunction
:: Maybe (String -> Int -> Int -> IO (Maybe (String, [String]))) -> IO ()
setAttemptedCompletionFunction fun =
setFunPtr rl_attempted_completion_function fun $ \f ->
exportCompleter $ \textPtr start end -> do
text <- peekCString textPtr
found <- f text (fromIntegral start) (fromIntegral end)
case found of
Nothing -> return nullPtr
Just (text', matches) -> do
matchPtrs <- mapM newCString (text':matches)
matchesPtr <- mallocArray (length matchPtrs + 1)
pokeArray0 nullPtr matchesPtr matchPtrs
return matchesPtr
foreign import ccall "&" rl_attempted_completion_function :: Ptr (FunPtr Completer)
foreign import ccall "wrapper"
exportCompleter :: Completer -> IO (FunPtr Completer)
type StringFunc = IO (Ptr CChar)
foreign import ccall "&" rl_completion_word_break_hook
:: Ptr (FunPtr StringFunc)
foreign import ccall "wrapper"
exportStringFunc :: StringFunc -> IO (FunPtr StringFunc)
setCompletionWordBreakHook
:: Maybe (IO (Maybe String)) -> IO ()
setCompletionWordBreakHook fun =
setFunPtr rl_completion_word_break_hook fun $ \f ->
exportStringFunc $ do
wordBreaks <- f
case wordBreaks of
Nothing -> return nullPtr
Just wordBreaksString -> newCString wordBreaksString
type Quoter = Ptr CChar -> CInt -> Ptr CChar -> IO (Ptr CChar)
setFilenameQuotingFunction
:: Maybe (String -> Bool -> Ptr CChar -> IO String) -> IO ()
setFilenameQuotingFunction fun =
setFunPtr_freeIf
(\oldPtr -> oldPtr /= nullFunPtr && oldPtr /= rl_quote_filename)
rl_filename_quoting_function fun $ \f ->
exportQuoter $ \textPtr typ qp -> do
text <- peekCString textPtr
s <- f text (typ == (2)) qp
newCString s
foreign import ccall "&" rl_filename_quoting_function :: Ptr (FunPtr Quoter)
foreign import ccall "wrapper"
exportQuoter :: Quoter -> IO (FunPtr Quoter)
rl_quote_filename :: FunPtr Quoter
rl_quote_filename = unsafePerformIO $ peek rl_filename_quoting_function
quoteFilename :: String -> Bool -> Ptr CChar -> IO String
quoteFilename text typ qp = do
ptr <- withCString text $ \textPtr ->
importQuoter rl_quote_filename
textPtr
(if typ then (1) else (2))
qp
s <- peekCString ptr
free ptr
return s
foreign import ccall "dynamic" importQuoter :: FunPtr Quoter -> Quoter
type Dequoter = Ptr CChar -> CInt -> IO (Ptr CChar)
setFilenameDequotingFunction :: Maybe (String -> Maybe Char -> IO String) -> IO ()
setFilenameDequotingFunction fun =
setFunPtr rl_filename_dequoting_function fun $ \f ->
exportDequoter $ \textPtr qc -> do
text <- peekCString textPtr
s <- f text (if qc==0 then Nothing else Just (chr (fromIntegral qc)))
newCString s
foreign import ccall "&"rl_filename_dequoting_function :: Ptr (FunPtr Dequoter)
foreign import ccall "wrapper"
exportDequoter :: Dequoter -> IO (FunPtr Dequoter)
type IsQuoted = Ptr CChar -> CInt -> IO CInt
setCharIsQuotedP :: Maybe (String -> Int -> IO Bool) -> IO ()
setCharIsQuotedP fun =
setFunPtr rl_char_is_quoted_p fun $ \f ->
exportIsQuoted $ \textPtr index -> do
text <- peekCString textPtr
quoted <- f text (fromIntegral index)
return (if quoted then 1 else 0)
foreign import ccall "&" rl_char_is_quoted_p :: Ptr (FunPtr IsQuoted)
foreign import ccall "wrapper"
exportIsQuoted :: IsQuoted -> IO (FunPtr IsQuoted)
getCompletionQueryItems :: IO Int
getCompletionQueryItems =
liftM fromIntegral (peek rl_completion_query_items)
setCompletionQueryItems :: Int -> IO ()
setCompletionQueryItems items =
poke rl_completion_query_items (fromIntegral items)
foreign import ccall "&" rl_completion_query_items :: Ptr CInt
getBasicWordBreakCharacters :: IO String
getBasicWordBreakCharacters = getCharacters rl_basic_word_break_characters
setBasicWordBreakCharacters :: String -> IO ()
setBasicWordBreakCharacters =
setCharacters_freeIf
(/= orig_rl_basic_word_break_characters)
rl_basic_word_break_characters
foreign import ccall "&" rl_basic_word_break_characters :: Ptr (Ptr CChar)
orig_rl_basic_word_break_characters :: Ptr CChar
orig_rl_basic_word_break_characters = unsafePerformIO $
peek rl_basic_word_break_characters
getBasicQuoteCharacters :: IO String
getBasicQuoteCharacters = getCharacters rl_basic_quote_characters
setBasicQuoteCharacters :: String -> IO ()
setBasicQuoteCharacters =
setCharacters_freeIf
(/= orig_rl_basic_quote_characters)
rl_basic_quote_characters
foreign import ccall "&" rl_basic_quote_characters :: Ptr (Ptr CChar)
orig_rl_basic_quote_characters :: Ptr CChar
orig_rl_basic_quote_characters = unsafePerformIO $
peek rl_basic_quote_characters
getCompleterWordBreakCharacters :: IO String
getCompleterWordBreakCharacters = getCharacters rl_completer_word_break_characters
setCompleterWordBreakCharacters :: String -> IO ()
setCompleterWordBreakCharacters =
setCharacters_freeIf
(\oldPtr -> oldPtr /= nullPtr &&
oldPtr /= orig_rl_basic_word_break_characters)
rl_completer_word_break_characters
foreign import ccall "&" rl_completer_word_break_characters :: Ptr (Ptr CChar)
getCompleterQuoteCharacters :: IO String
getCompleterQuoteCharacters = getCharacters rl_completer_quote_characters
setCompleterQuoteCharacters :: String -> IO ()
setCompleterQuoteCharacters cs = do
oldPtr <- peek rl_completer_quote_characters
when (oldPtr /= nullPtr) $ free oldPtr
newPtr <- if null cs
then return nullPtr
else do
ptr <- mallocArray (length cs + 1)
pokeArray0 0 ptr (map castCharToCChar cs)
return ptr
poke rl_completer_quote_characters newPtr
foreign import ccall "&" rl_completer_quote_characters :: Ptr (Ptr CChar)
getFilenameQuoteCharacters :: IO String
getFilenameQuoteCharacters = getCharacters rl_filename_quote_characters
setFilenameQuoteCharacters :: String -> IO ()
setFilenameQuoteCharacters = setCharacters rl_filename_quote_characters
foreign import ccall "&" rl_filename_quote_characters :: Ptr (Ptr CChar)
getSpecialPrefixes :: IO String
getSpecialPrefixes = getCharacters rl_special_prefixes
setSpecialPrefixes :: String -> IO ()
setSpecialPrefixes = setCharacters rl_special_prefixes
foreign import ccall "&" rl_special_prefixes :: Ptr (Ptr CChar)
getCompletionAppendCharacter :: IO (Maybe Char)
getCompletionAppendCharacter = do
ch <- peek rl_completion_append_character
return $ if ch == 0 then Nothing else Just (chr (fromIntegral ch))
setCompletionAppendCharacter :: Maybe Char -> IO ()
setCompletionAppendCharacter ch =
poke rl_completion_append_character (maybe 0 (fromIntegral . ord) ch)
foreign import ccall "&" rl_completion_append_character :: Ptr CInt
setIgnoreCompletionDuplicates :: Bool -> IO ()
setIgnoreCompletionDuplicates ign =
poke rl_ignore_completion_duplicates (if ign then 1 else 0)
getIgnoreCompletionDuplicates :: IO Bool
getIgnoreCompletionDuplicates =
liftM (/= 0) (peek rl_ignore_completion_duplicates)
foreign import ccall "&" rl_ignore_completion_duplicates :: Ptr CInt
setFilenameCompletionDesired :: Bool -> IO ()
setFilenameCompletionDesired comp =
poke rl_filename_completion_desired (if comp then 1 else 0)
getFilenameCompletionDesired :: IO Bool
getFilenameCompletionDesired =
liftM (/= 0) (peek rl_filename_completion_desired)
foreign import ccall "&" rl_filename_completion_desired :: Ptr CInt
setFilenameQuotingDesired :: Bool -> IO ()
setFilenameQuotingDesired quot =
poke rl_filename_quoting_desired (if quot then 1 else 0)
getFilenameQuotingDesired :: IO Bool
getFilenameQuotingDesired =
liftM (/= 0) (peek rl_filename_quoting_desired)
foreign import ccall "&" rl_filename_quoting_desired :: Ptr CInt
setInhibitCompletion :: Bool -> IO ()
setInhibitCompletion inh = poke rl_inhibit_completion (if inh then 1 else 0)
getInhibitCompletion :: IO Bool
getInhibitCompletion = liftM (/= 0) (peek rl_inhibit_completion)
foreign import ccall "&" rl_attempted_completion_over :: Ptr CInt
getAttemptedCompletionOver :: IO Bool
getAttemptedCompletionOver =
liftM (/=0) (peek rl_attempted_completion_over)
setAttemptedCompletionOver :: Bool -> IO ()
setAttemptedCompletionOver over =
poke rl_attempted_completion_over (if over then 1 else 0)
foreign import ccall "&" rl_inhibit_completion :: Ptr CInt
type Ignorer = Ptr (Ptr CChar) -> IO CInt
setIgnoreSomeCompletionsFunction :: Maybe ([String] -> IO [String]) -> IO ()
setIgnoreSomeCompletionsFunction fun =
setFunPtr rl_ignore_some_completions_function fun $ \f ->
exportIgnorer $ \matchesPtr -> do
matchPtrs <- peekArray0 nullPtr matchesPtr
matches <- mapM peekCString matchPtrs
mapM_ free matchPtrs
f matches >>= mapM newCString >>= pokeArray0 nullPtr matchesPtr
return 0
foreign import ccall "&" rl_ignore_some_completions_function :: Ptr (FunPtr Ignorer)
foreign import ccall "wrapper"
exportIgnorer :: Ignorer -> IO (FunPtr Ignorer)
type DirCompleter = Ptr (Ptr CChar) -> IO CInt
setDirectoryCompletionHook :: Maybe (String -> IO String) -> IO ()
setDirectoryCompletionHook fun =
setFunPtr rl_directory_completion_hook fun $ \f ->
exportDirCompleter $ \dirPtrPtr -> do
oldDirPtr <- peek dirPtrPtr
oldDir <- peekCString oldDirPtr
free oldDirPtr
newDirPtr <- f oldDir >>= newCString
poke dirPtrPtr newDirPtr
return 0
foreign import ccall "&" rl_directory_completion_hook :: Ptr (FunPtr DirCompleter)
foreign import ccall "wrapper"
exportDirCompleter :: DirCompleter -> IO (FunPtr DirCompleter)
type Displayer = Ptr (Ptr CChar) -> CInt -> CInt -> IO ()
setCompletionDisplayMatchesHook :: Maybe ([String] -> IO ()) -> IO ()
setCompletionDisplayMatchesHook fun =
setFunPtr rl_completion_display_matches_hook fun $ \f ->
exportDisplayHook $ \matchesPtr _ _ ->
peekArray0 nullPtr matchesPtr >>= mapM peekCString >>= f
foreign import ccall "&" rl_completion_display_matches_hook :: Ptr (FunPtr Displayer)
foreign import ccall "wrapper"
exportDisplayHook :: Displayer -> IO (FunPtr Displayer)
setCharacters_freeIf :: (Ptr CChar -> Bool) -> Ptr (Ptr CChar) -> String -> IO ()
setCharacters_freeIf pred variable chars = do
oldPtr <- peek variable
when (pred oldPtr) $ free oldPtr
newPtr <- mallocArray (length chars + 1)
pokeArray0 0 newPtr (map castCharToCChar chars)
poke variable newPtr
setCharacters :: Ptr (Ptr CChar) -> String -> IO ()
setCharacters = setCharacters_freeIf (/= nullPtr)
getCharacters :: Ptr (Ptr CChar) -> IO String
getCharacters variable = do
ptr <- peek variable
if ptr == nullPtr then return "" else do
cs <- peekArray0 0 ptr
return (map castCCharToChar cs)