fix completion bug, added namespace-based completion (forgot to commit these files last time)

svn: r6137

collects/readline/mzrl.ss

@@ -5,7 +5,7 @@
          add-history add-history-bytes
          set-completion-function!)
 
-;; libtermcap maybe needed
+;; libtermcap needed on some platforms
 (define libtermcap  (with-handlers ([exn:fail? void]) (ffi-lib "libtermcap")))
 (define libreadline (ffi-lib "libreadline"))
 
@@ -42,25 +42,29 @@
 (define add-history-bytes
   (get-ffi-obj "add_history" libreadline (_fun _bytes -> _void)))
 
-;; Simple completion: use this with a (string -> list-of string) function that
-;; returns the completions for a given string.  (should clean up bytes/string)
+;; Simple completion: use this with a (string -> (list-of string)) function
+;; that returns the completions for a given string (can be used with other
+;; input string types too, depending on the `type' argument).  Use #f to remove
+;; a completion function that was previously set.
 (define set-completion-function!
   (case-lambda
-    [(func) (set-completion-function! _string)]
+    [(func) (set-completion-function! func _string)]
     [(func type)
      (if func
        (set-ffi-obj! "rl_completion_entry_function" libreadline
                      (_fun type _int -> _pointer)
                      (completion-function func))
        (set-ffi-obj! "rl_completion_entry_function" libreadline _pointer #f))]))
+
 (define (completion-function func)
   (let ([cur '()])
     (define (complete str state)
       (if (zero? state)
-        (begin (set! cur (func str)) (complete str 1))
+        (begin (set! cur (func str)) (complete #f 1))
         (and (pair? cur)
-             (begin0 (malloc (add1 (bytes-length (car cur))) (car cur) 'raw)
-               (set! cur (cdr cur))))))
+             (let* ([cur (begin0 (car cur) (set! cur (cdr cur)))]
+                    [cur (if (string? cur) (string->bytes/utf-8 cur) cur)])
+               (malloc (add1 (bytes-length cur)) cur 'raw)))))
     complete))
 
 (set-ffi-obj! "rl_readline_name" libreadline _bytes #"mzscheme")

collects/readline/pread.ss

@@ -1,7 +1,10 @@
 (module pread mzscheme
-  (require (lib "readline.ss" "readline") (lib "file.ss"))
+  (require (lib "readline.ss" "readline") (lib "file.ss")
+           (lib "list.ss") (lib "string.ss"))
+
+  ;; --------------------------------------------------------------------------
+  ;; Configuration
 
-  ;; configuration
   (define current-prompt   (make-parameter #"> "))
   (define show-all-prompts (make-parameter #t))
   (define max-history      (make-parameter 100))
@@ -10,6 +13,40 @@
   (provide current-prompt show-all-prompts
            max-history keep-duplicates keep-blanks)
 
+  ;; --------------------------------------------------------------------------
+  ;; Simple namespace-based completion
+
+  ;; efficiently convert symbols to byte strings
+  (define symbol->bstring
+    (let ([t (make-hash-table 'weak)])
+      (lambda (sym)
+        (or (hash-table-get t sym #f)
+            (let ([bstr (string->bytes/utf-8 (symbol->string sym))])
+              (hash-table-put! t sym bstr)
+              bstr)))))
+
+  ;; get a list of byte strings for current bindings, cache last result
+  (define get-namespace-bstrings
+    (let ([last-syms #f] [last-bstrs #f])
+      (lambda ()
+        (let ([syms (namespace-mapped-symbols)])
+          (unless (equal? syms last-syms)
+            (set! last-syms syms)
+            (set! last-bstrs (sort! (map symbol->bstring syms) bytes<?)))
+          last-bstrs))))
+
+  (define (namespace-completion pat)
+    (let* ([pat (if (string? pat) (string->bytes/utf-8 pat) pat)]
+           [pat (regexp-quote pat)]
+           [pat (regexp-replace* #px#"(\\w)\\b" pat #"\\1\\\\w*")]
+           [pat (byte-pregexp (bytes-append #"^" pat))])
+      (filter (lambda (bstr) (regexp-match pat bstr))
+              (get-namespace-bstrings))))
+
+  (set-completion-function! namespace-completion)
+
+
+  ;; --------------------------------------------------------------------------
   ;; History management
 
   (define local-history
@@ -45,7 +82,8 @@
    (let ([old (exit-handler)])
      (lambda (v) (save-history) (old v))))
 
-  ;; implement an input port that goes through readline
+  ;; --------------------------------------------------------------------------
+  ;; An input port that goes through readline
 
   ;; readline-prompt can be
   ;;   #f: no prompt (normal state),
@@ -106,6 +144,9 @@
                           (add1 left)]))])))
       (make-input-port 'readline reader #f close!)))
 
+  ;; --------------------------------------------------------------------------
+  ;; Reading functions
+
   ;; like read-syntax, but waits until valid input is ready
   (define read-complete-syntax
     (let ([leftovers '()]