suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

restored word completion for the full languages (not teaching languages yet)

Browse Source 
svn: r8018

original commit: f790d7e10ed5314a651a3a2b28439912c97a9ec7
This commit is contained in:
Robby Findler 2007-12-15 21:10:20 +00:00
parent 7fb2184475
commit effaca815d
2 changed files with 2704 additions and 2696 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/framework/framework.ss
View File

@ -82,11 +82,12 @@
"" ""
"Defaults to 15.") "Defaults to 15.")
(text:get-completions/manuals (text:get-completions/manuals
(-> (listof string?) (listof string?)) (-> (or/c false/c (listof symbol?)) (listof string?))
(manuals) (manuals)
"Returns the list of keywords for the manuals from \\var{manuals}" "Returns the list of keywords for the manuals from \\var{manuals}"
"by reading them from the \\texttt{keywords}" "by extracting all of the documented exports of the manuals."
"files in the corresponding manuals' directories") "The symbols are meant to be module paths."
"If \\var{manuals} is false, then all of the documented names are used.")
(number-snip:make-repeating-decimal-snip (number-snip:make-repeating-decimal-snip
(number? boolean? . -> . (is-a?/c snip%)) (number? boolean? . -> . (is-a?/c snip%))

293
collects/framework/private/text.ss
View File

@ -6,7 +6,7 @@ WARNING: printf is rebound in the body of the unit to always
|# |#
#lang scheme/unit #lang scheme/unit
(require (lib "string-constant.ss" "string-constants") (require (lib "string-constant.ss" "string-constants")
(lib "class.ss") (lib "class.ss")
(lib "match.ss") (lib "match.ss")
scheme/path scheme/path
@ -20,8 +20,14 @@ WARNING: printf is rebound in the body of the unit to always
(lib "dirs.ss" "setup") (lib "dirs.ss" "setup")
(lib "string.ss") (lib "string.ss")
(prefix-in srfi1: (lib "1.ss" "srfi"))) (prefix-in srfi1: (lib "1.ss" "srfi")))
(require setup/scribble-index
scribble/struct
scribble/manual-struct
scribble/decode
scribble/basic
(prefix-in s/m: scribble/manual))
(import mred^ (import mred^
[prefix icon: framework:icon^] [prefix icon: framework:icon^]
[prefix editor: framework:editor^] [prefix editor: framework:editor^]
[prefix keymap: framework:keymap^] [prefix keymap: framework:keymap^]
@ -30,22 +36,22 @@ WARNING: printf is rebound in the body of the unit to always
[prefix scheme: framework:scheme^] [prefix scheme: framework:scheme^]
[prefix number-snip: framework:number-snip^] [prefix number-snip: framework:number-snip^]
[prefix finder: framework:finder^]) [prefix finder: framework:finder^])
(export (rename framework:text^ (export (rename framework:text^
[-keymap% keymap%])) [-keymap% keymap%]))
(init-depend framework:editor^) (init-depend framework:editor^)
(define original-output-port (current-output-port)) (define original-output-port (current-output-port))
(define (printf . args) (define (printf . args)
(apply fprintf original-output-port args) (apply fprintf original-output-port args)
(void)) (void))
(define-struct range (start end b/w-bitmap color caret-space?)) (define-struct range (start end b/w-bitmap color caret-space?))
(define-struct rectangle (left top right bottom b/w-bitmap color)) (define-struct rectangle (left top right bottom b/w-bitmap color))
;; wx: `default-wrapping?', add as the initial value for auto-wrap bitmap, ;; wx: `default-wrapping?', add as the initial value for auto-wrap bitmap,
;; unless matthew makes it primitive ;; unless matthew makes it primitive
(define basic<%> (define basic<%>
(interface (editor:basic<%> (class->interface text%)) (interface (editor:basic<%> (class->interface text%))
highlight-range highlight-range
unhighlight-range unhighlight-range
@ -58,7 +64,7 @@ WARNING: printf is rebound in the body of the unit to always
get-port-name get-port-name
port-name-matches?)) port-name-matches?))
(define basic-mixin (define basic-mixin
(mixin (editor:basic<%> (class->interface text%)) (basic<%>) (mixin (editor:basic<%> (class->interface text%)) (basic<%>)
(inherit get-canvas get-canvases get-admin split-snip get-snip-position (inherit get-canvas get-canvases get-admin split-snip get-snip-position
begin-edit-sequence end-edit-sequence begin-edit-sequence end-edit-sequence
@ -406,11 +412,11 @@ WARNING: printf is rebound in the body of the unit to always
(super-new) (super-new)
(set-autowrap-bitmap (initial-autowrap-bitmap)))) (set-autowrap-bitmap (initial-autowrap-bitmap))))
(define foreground-color<%> (define foreground-color<%>
(interface (basic<%> editor:standard-style-list<%>) (interface (basic<%> editor:standard-style-list<%>)
)) ))
(define foreground-color-mixin (define foreground-color-mixin
(mixin (basic<%> editor:standard-style-list<%>) (foreground-color<%>) (mixin (basic<%> editor:standard-style-list<%>) (foreground-color<%>)
(inherit begin-edit-sequence end-edit-sequence change-style get-style-list) (inherit begin-edit-sequence end-edit-sequence change-style get-style-list)
@ -423,8 +429,8 @@ WARNING: printf is rebound in the body of the unit to always
(editor:get-default-color-style-name))) (editor:get-default-color-style-name)))
(super-new))) (super-new)))
(define hide-caret/selection<%> (interface (basic<%>))) (define hide-caret/selection<%> (interface (basic<%>)))
(define hide-caret/selection-mixin (define hide-caret/selection-mixin
(mixin (basic<%>) (hide-caret/selection<%>) (mixin (basic<%>) (hide-caret/selection<%>)
(inherit get-start-position get-end-position hide-caret) (inherit get-start-position get-end-position hide-caret)
(define/augment (after-set-position) (define/augment (after-set-position)
@ -432,8 +438,8 @@ WARNING: printf is rebound in the body of the unit to always
(inner (void) after-set-position)) (inner (void) after-set-position))
(super-new))) (super-new)))
(define nbsp->space<%> (interface ((class->interface text%)))) (define nbsp->space<%> (interface ((class->interface text%))))
(define nbsp->space-mixin (define nbsp->space-mixin
(mixin ((class->interface text%)) (nbsp->space<%>) (mixin ((class->interface text%)) (nbsp->space<%>)
(field [rewriting #f]) (field [rewriting #f])
(inherit begin-edit-sequence end-edit-sequence delete insert get-character) (inherit begin-edit-sequence end-edit-sequence delete insert get-character)
@ -458,15 +464,15 @@ WARNING: printf is rebound in the body of the unit to always
(inner (void) after-insert start len)) (inner (void) after-insert start len))
(super-instantiate ()))) (super-instantiate ())))
(define searching<%> (interface (editor:keymap<%> basic<%>))) (define searching<%> (interface (editor:keymap<%> basic<%>)))
(define searching-mixin (define searching-mixin
(mixin (editor:keymap<%> basic<%>) (searching<%>) (mixin (editor:keymap<%> basic<%>) (searching<%>)
(define/override (get-keymaps) (define/override (get-keymaps)
(cons (keymap:get-search) (super get-keymaps))) (cons (keymap:get-search) (super get-keymaps)))
(super-instantiate ()))) (super-instantiate ())))
(define return<%> (interface ((class->interface text%)))) (define return<%> (interface ((class->interface text%))))
(define return-mixin (define return-mixin
(mixin ((class->interface text%)) (return<%>) (mixin ((class->interface text%)) (return<%>)
(init-field return) (init-field return)
(define/override (on-local-char key) (define/override (on-local-char key)
@ -480,12 +486,12 @@ WARNING: printf is rebound in the body of the unit to always
(super on-local-char key)))) (super on-local-char key))))
(super-new))) (super-new)))
(define wide-snip<%> (define wide-snip<%>
(interface (basic<%>) (interface (basic<%>)
add-wide-snip add-wide-snip
add-tall-snip)) add-tall-snip))
(define wide-snip-mixin (define wide-snip-mixin
(mixin (basic<%>) (wide-snip<%>) (mixin (basic<%>) (wide-snip<%>)
(define wide-snips '()) (define wide-snips '())
(define tall-snips '()) (define tall-snips '())
@ -495,11 +501,11 @@ WARNING: printf is rebound in the body of the unit to always
(define/public (get-tall-snips) tall-snips) (define/public (get-tall-snips) tall-snips)
(super-new))) (super-new)))
(define delegate<%> (interface (basic<%>) (define delegate<%> (interface (basic<%>)
get-delegate get-delegate
set-delegate)) set-delegate))
(define small-version-of-snip% (define small-version-of-snip%
(class snip% (class snip%
(init-field big-snip) (init-field big-snip)
(define width 0) (define width 0)
@ -526,7 +532,7 @@ WARNING: printf is rebound in the body of the unit to always
(define/override (copy) (instantiate small-version-of-snip% () (big-snip big-snip))) (define/override (copy) (instantiate small-version-of-snip% () (big-snip big-snip)))
(super-instantiate ()))) (super-instantiate ())))
(define 1-pixel-string-snip% (define 1-pixel-string-snip%
(class string-snip% (class string-snip%
(init-rest args) (init-rest args)
(inherit get-text get-count set-count get-flags) (inherit get-text get-count set-count get-flags)
@ -592,7 +598,7 @@ WARNING: printf is rebound in the body of the unit to always
(cache-function dc x y)))) (cache-function dc x y))))
(apply super-make-object args))) (apply super-make-object args)))
(define 1-pixel-tab-snip% (define 1-pixel-tab-snip%
(class tab-snip% (class tab-snip%
(init-rest args) (init-rest args)
(inherit get-text get-count set-count get-flags) (inherit get-text get-count set-count get-flags)
@ -635,11 +641,11 @@ WARNING: printf is rebound in the body of the unit to always
(void)) (void))
(apply super-make-object args))) (apply super-make-object args)))
(define (set/f! b n) (define (set/f! b n)
(when (box? b) (when (box? b)
(set-box! b n))) (set-box! b n)))
(define delegate-mixin (define delegate-mixin
(mixin (basic<%>) (delegate<%>) (mixin (basic<%>) (delegate<%>)
(inherit split-snip find-snip get-snip-position (inherit split-snip find-snip get-snip-position
find-first-snip get-style-list set-tabs) find-first-snip get-style-list set-tabs)
@ -806,9 +812,9 @@ WARNING: printf is rebound in the body of the unit to always
(inner (void) after-load-file success?)) (inner (void) after-load-file success?))
(super-instantiate ()))) (super-instantiate ())))
(define info<%> (interface (basic<%>))) (define info<%> (interface (basic<%>)))
(define info-mixin (define info-mixin
(mixin (editor:keymap<%> basic<%>) (info<%>) (mixin (editor:keymap<%> basic<%>) (info<%>)
(inherit get-start-position get-end-position get-canvas (inherit get-start-position get-end-position get-canvas
run-after-edit-sequence) run-after-edit-sequence)
@ -866,9 +872,9 @@ WARNING: printf is rebound in the body of the unit to always
(inner (void) after-delete start len)) (inner (void) after-delete start len))
(super-new))) (super-new)))
(define clever-file-format<%> (interface ((class->interface text%)))) (define clever-file-format<%> (interface ((class->interface text%))))
(define clever-file-format-mixin (define clever-file-format-mixin
(mixin ((class->interface text%)) (clever-file-format<%>) (mixin ((class->interface text%)) (clever-file-format<%>)
(inherit get-file-format set-file-format find-first-snip) (inherit get-file-format set-file-format find-first-snip)
(define/private (all-string-snips) (define/private (all-string-snips)
@ -904,12 +910,12 @@ WARNING: printf is rebound in the body of the unit to always
(super-instantiate ()))) (super-instantiate ())))
(define file<%> (define file<%>
(interface (editor:file<%> basic<%>) (interface (editor:file<%> basic<%>)
get-read-write? get-read-write?
while-unlocked)) while-unlocked))
(define file-mixin (define file-mixin
(mixin (editor:file<%> basic<%>) (file<%>) (mixin (editor:file<%> basic<%>) (file<%>)
(inherit get-filename) (inherit get-filename)
(define read-write? #t) (define read-write? #t)
@ -949,7 +955,7 @@ WARNING: printf is rebound in the body of the unit to always
(super-new))) (super-new)))
(define ports<%> (define ports<%>
(interface () (interface ()
delete/io delete/io
get-insertion-point get-insertion-point
@ -980,22 +986,22 @@ WARNING: printf is rebound in the body of the unit to always
get-box-input-editor-snip% get-box-input-editor-snip%
get-box-input-text%)) get-box-input-text%))
(define-struct peeker (bytes skip-count pe resp-chan nack polling?) #:inspector (make-inspector)) (define-struct peeker (bytes skip-count pe resp-chan nack polling?) #:inspector (make-inspector))
(define-struct committer (kr commit-peeker-evt done-evt resp-chan resp-nack)) (define-struct committer (kr commit-peeker-evt done-evt resp-chan resp-nack))
(define msec-timeout 500) (define msec-timeout 500)
(define output-buffer-full 4096) (define output-buffer-full 4096)
(define-local-member-name (define-local-member-name
new-box-input new-box-input
box-input-not-used-anymore box-input-not-used-anymore
set-port-text) set-port-text)
(define (set-box/f! b v) (when (box? b) (set-box! b v))) (define (set-box/f! b v) (when (box? b) (set-box! b v)))
(define arrow-cursor (make-object cursor% 'arrow)) (define arrow-cursor (make-object cursor% 'arrow))
(define eof-snip% (define eof-snip%
(class image-snip% (class image-snip%
(init-field port-text) (init-field port-text)
(define/override (get-extent dc x y w h descent space lspace rspace) (define/override (get-extent dc x y w h descent space lspace rspace)
@ -1011,10 +1017,10 @@ WARNING: printf is rebound in the body of the unit to always
(inherit set-flags get-flags) (inherit set-flags get-flags)
(set-flags (list* 'handles-events (get-flags))))) (set-flags (list* 'handles-events (get-flags)))))
(define out-style-name "text:ports out") (define out-style-name "text:ports out")
(define error-style-name "text:ports err") (define error-style-name "text:ports err")
(define value-style-name "text:ports value") (define value-style-name "text:ports value")
(let ([create-style-name (let ([create-style-name
(λ (name sd) (λ (name sd)
(let* ([sl (editor:get-standard-style-list)]) (let* ([sl (editor:get-standard-style-list)])
(send sl new-named-style (send sl new-named-style
@ -1032,7 +1038,7 @@ WARNING: printf is rebound in the body of the unit to always
(send value-sd set-delta-foreground (make-object color% 0 0 175)) (send value-sd set-delta-foreground (make-object color% 0 0 175))
(create-style-name value-style-name value-sd))) (create-style-name value-style-name value-sd)))
(define ports-mixin (define ports-mixin
(mixin (wide-snip<%>) (ports<%>) (mixin (wide-snip<%>) (ports<%>)
(inherit begin-edit-sequence (inherit begin-edit-sequence
change-style change-style
@ -1656,11 +1662,11 @@ WARNING: printf is rebound in the body of the unit to always
(define-values (in-box-port box-read-chan box-clear-input-chan) (define-values (in-box-port box-read-chan box-clear-input-chan)
(start-text-input-port this (lambda () (on-box-peek)))))) (start-text-input-port this (lambda () (on-box-peek))))))
(define input-box<%> (define input-box<%>
(interface ((class->interface text%)) (interface ((class->interface text%))
)) ))
(define input-box-mixin (define input-box-mixin
(mixin ((class->interface text%)) (input-box<%>) (mixin ((class->interface text%)) (input-box<%>)
(inherit erase lock) (inherit erase lock)
@ -1682,7 +1688,7 @@ WARNING: printf is rebound in the body of the unit to always
(super-new))) (super-new)))
(define (start-text-input-port source on-peek) (define (start-text-input-port source on-peek)
;; eventspace at the time this function was called. used for peek callbacks ;; eventspace at the time this function was called. used for peek callbacks
(define eventspace (current-eventspace)) (define eventspace (current-eventspace))
@ -2011,23 +2017,23 @@ WARNING: printf is rebound in the body of the unit to always
(values p read-chan clear-input-chan))) (values p read-chan clear-input-chan)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; queues ;; queues
;; ;;
(define-struct queue (front back count) #:mutable) (define-struct queue (front back count) #:mutable)
(define (empty-queue) (make-queue '() '() 0)) (define (empty-queue) (make-queue '() '() 0))
(define (enqueue e q) (make-queue (define (enqueue e q) (make-queue
(cons e (queue-front q)) (cons e (queue-front q))
(queue-back q) (queue-back q)
(+ (queue-count q) 1))) (+ (queue-count q) 1)))
(define (queue-first q) (define (queue-first q)
(flip-around q) (flip-around q)
(let ([back (queue-back q)]) (let ([back (queue-back q)])
(if (null? back) (if (null? back)
(error 'queue-first "empty queue") (error 'queue-first "empty queue")
(car back)))) (car back))))
(define (queue-rest q) (define (queue-rest q)
(flip-around q) (flip-around q)
(let ([back (queue-back q)]) (let ([back (queue-back q)])
(if (null? back) (if (null? back)
@ -2035,24 +2041,24 @@ WARNING: printf is rebound in the body of the unit to always
(make-queue (queue-front q) (make-queue (queue-front q)
(cdr back) (cdr back)
(- (queue-count q) 1))))) (- (queue-count q) 1)))))
(define (flip-around q) (define (flip-around q)
(when (null? (queue-back q)) (when (null? (queue-back q))
(set-queue-back! q (reverse (queue-front q))) (set-queue-back! q (reverse (queue-front q)))
(set-queue-front! q '()))) (set-queue-front! q '())))
(define (queue-empty? q) (zero? (queue-count q))) (define (queue-empty? q) (zero? (queue-count q)))
(define (queue-size q) (queue-count q)) (define (queue-size q) (queue-count q))
;; queue->list : (queue x) -> (listof x) ;; queue->list : (queue x) -> (listof x)
;; returns the elements in the order that successive deq's would have ;; returns the elements in the order that successive deq's would have
(define (queue->list q) (define (queue->list q)
(let ([ans (append (queue-back q) (reverse (queue-front q)))]) (let ([ans (append (queue-back q) (reverse (queue-front q)))])
(set-queue-back! q ans) (set-queue-back! q ans)
(set-queue-front! q '()) (set-queue-front! q '())
ans)) ans))
;; dequeue-n : queue number -> queue ;; dequeue-n : queue number -> queue
(define (dequeue-n queue n) (define (dequeue-n queue n)
(let loop ([q queue] (let loop ([q queue]
[n n]) [n n])
(cond (cond
@ -2060,8 +2066,8 @@ WARNING: printf is rebound in the body of the unit to always
[(queue-empty? q) (error 'dequeue-n "not enough!")] [(queue-empty? q) (error 'dequeue-n "not enough!")]
[else (loop (queue-rest q) (- n 1))]))) [else (loop (queue-rest q) (- n 1))])))
;; peek-n : queue number -> queue ;; peek-n : queue number -> queue
(define (peek-n queue init-n) (define (peek-n queue init-n)
(let loop ([q queue] (let loop ([q queue]
[n init-n]) [n init-n])
(cond (cond
@ -2076,10 +2082,10 @@ WARNING: printf is rebound in the body of the unit to always
(error 'dequeue-n "not enough!")) (error 'dequeue-n "not enough!"))
(loop (queue-rest q) (- n 1))]))) (loop (queue-rest q) (- n 1))])))
;; ;;
;; end queue abstraction ;; end queue abstraction
;; ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#| #|
=== AUTOCOMPLETE === === AUTOCOMPLETE ===
@ -2197,7 +2203,7 @@ designates the character that triggers autocompletion
|# |#
(define autocomplete<%> (define autocomplete<%>
(interface ((class->interface text%)) (interface ((class->interface text%))
auto-complete auto-complete
get-autocomplete-border-color get-autocomplete-border-color
@ -2207,12 +2213,12 @@ designates the character that triggers autocompletion
get-all-words get-all-words
get-word-at)) get-word-at))
;; ============================================================ ;; ============================================================
;; auto-complete-text (mixin) implementation ;; auto-complete-text (mixin) implementation
(define selected-color (make-object color% 204 153 255)) (define selected-color (make-object color% 204 153 255))
(define autocomplete-mixin (define autocomplete-mixin
(mixin ((class->interface text%)) (autocomplete<%>) (mixin ((class->interface text%)) (autocomplete<%>)
(inherit invalidate-bitmap-cache get-dc get-start-position get-end-position (inherit invalidate-bitmap-cache get-dc get-start-position get-end-position
@ -2239,9 +2245,7 @@ designates the character that triggers autocompletion
[else [else
#f])) #f]))
(define/public (get-all-words) (define/public (get-all-words) (get-completions/manuals #f))
(get-completions/manuals
'("framework" "foreign" "scribble" "mzlib" "mrlib" "mzscheme" "mred" "r5rs")))
(define completions-box #f) ; completions-box% or #f if no completions box is active right now (define completions-box #f) ; completions-box% or #f if no completions box is active right now
(define word-start-pos #f) ; start pos of that word, or #f if no autocompletion (define word-start-pos #f) ; start pos of that word, or #f if no autocompletion
@ -2386,10 +2390,10 @@ designates the character that triggers autocompletion
(super-new))) (super-new)))
;; ============================================================ ;; ============================================================
;; autocompletion-cursor<%> implementations ;; autocompletion-cursor<%> implementations
(define autocompletion-cursor<%> (define autocompletion-cursor<%>
(interface () (interface ()
get-completions ; -> (listof string) get-completions ; -> (listof string)
get-length ; -> int get-length ; -> int
@ -2397,7 +2401,7 @@ designates the character that triggers autocompletion
narrow ; char -> autocompletion-cursor<%> narrow ; char -> autocompletion-cursor<%>
widen)) ; -> autocompletion-cursor<%> | #f widen)) ; -> autocompletion-cursor<%> | #f
(define scrolling-cursor<%> (define scrolling-cursor<%>
(interface (autocompletion-cursor<%>) (interface (autocompletion-cursor<%>)
items-are-hidden? items-are-hidden?
get-visible-completions get-visible-completions
@ -2405,7 +2409,7 @@ designates the character that triggers autocompletion
scroll-down scroll-down
scroll-up)) scroll-up))
(define autocompletion-cursor% (define autocompletion-cursor%
(class* object% (autocompletion-cursor<%>) (class* object% (autocompletion-cursor<%>)
(init-field word all-words) (init-field word all-words)
@ -2437,7 +2441,7 @@ designates the character that triggers autocompletion
(super-new))) (super-new)))
(define scroll-manager% (define scroll-manager%
(class* object% () (class* object% ()
(init-field cursor) (init-field cursor)
@ -2499,13 +2503,13 @@ designates the character that triggers autocompletion
(initialize-state!) (initialize-state!)
(super-new))) (super-new)))
;; ============================================================ ;; ============================================================
;; completion-box<%> implementation ;; completion-box<%> implementation
(define menu-padding-x 4) (define menu-padding-x 4)
(define menu-padding-y 0) (define menu-padding-y 0)
(define completion-box<%> (define completion-box<%>
(interface () (interface ()
draw ; dc<%> int int -> void draw ; dc<%> int int -> void
redraw ; -> void redraw ; -> void
@ -2520,14 +2524,14 @@ designates the character that triggers autocompletion
empty?)) ; -> boolean empty?)) ; -> boolean
(define hidden-completions-text "⋮") (define hidden-completions-text "⋮")
(define-struct geometry (menu-x (define-struct geometry (menu-x
menu-y menu-y
menu-width menu-width
menu-height menu-height
mouse->menu-item-vector)) mouse->menu-item-vector))
(define completion-box% (define completion-box%
(class* object% (completion-box<%>) (class* object% (completion-box<%>)
(init-field completions ; scroll-manager% the possible completions (all of which have base-word as a prefix) (init-field completions ; scroll-manager% the possible completions (all of which have base-word as a prefix)
@ -2779,10 +2783,10 @@ designates the character that triggers autocompletion
(super-new))) (super-new)))
;; ============================================================ ;; ============================================================
;; configuration parameters ;; configuration parameters
(define (make-guarded-parameter name description default okay?) (define (make-guarded-parameter name description default okay?)
(make-parameter (make-parameter
default default
(λ (v) (λ (v)
@ -2793,40 +2797,43 @@ designates the character that triggers autocompletion
(string->immutable-string (string->immutable-string
(format "parameter ~a: expected ~a, given: ~e" name description v))))])))) (format "parameter ~a: expected ~a, given: ~e" name description v))))]))))
(define autocomplete-append-after (define autocomplete-append-after
(make-guarded-parameter 'append-after "string" "" string?)) (make-guarded-parameter 'append-after "string" "" string?))
(define autocomplete-limit (define autocomplete-limit
(make-guarded-parameter 'limit "positive integer" 15 (λ (x) (and (integer? x) (> x 0))))) (make-guarded-parameter 'limit "positive integer" 15 (λ (x) (and (integer? x) (> x 0)))))
;; ============================================================ ;; ============================================================
;; read keywords from manuals ;; read keywords from manuals
(define (get-completions/manuals manuals) (define xref #f)
(define (read-keywords dir)
(let ([ddir (find-doc-dir)])
(if ddir
(let ([keywords (build-path ddir dir "keywords")])
(if (file-exists? keywords)
(map (λ (x) (string->symbol (car x)))
(call-with-input-file keywords
read))
'()))
'())))
(let ([ht (make-hash-table)]) (define (get-completions/manuals manuals)
(for-each (λ (x) (hash-table-put! ht x #t)) (let* ([sym->mpi (λ (mp) (module-path-index-resolve (module-path-index-join mp #f)))]
(apply append (map read-keywords manuals))) [manual-mpis (and manuals (map sym->mpi manuals))])
(sort
(hash-table-map ht (λ (x y) (symbol->string x)))
string<=?)))
;; ============================================================ (unless xref
;; auto complete example code (set! xref (load-xref)))
#; (let ([ht (make-hash-table 'equal)])
(begin (for-each
(define all-words (get-completions/manuals (λ (entry)
'("framework" "foreign" "scribble" "mzlib" "mrlib" "mzscheme" "mred" "r5rs"))) (let ([desc (entry-desc entry)])
(when (exported-index-desc? desc)
(let ([name (exported-index-desc-name desc)])
(when name
(when (or (not manual-mpis)
(ormap (λ (from-lib) (memq from-lib manual-mpis))
(map sym->mpi (exported-index-desc-from-libs desc))))
(hash-table-put! ht (symbol->string name) #t)))))))
(xref-index xref))
(sort (hash-table-map ht (λ (x y) x)) string<=?))))
;; ============================================================
;; auto complete example code
#;
(begin
(define all-words (get-completions/manuals #f))
(let* ([f (new frame% (label "Test") (height 400) (width 400))] (let* ([f (new frame% (label "Test") (height 400) (width 400))]
[e (new (autocomplete-mixin text%))] [e (new (autocomplete-mixin text%))]
@ -2836,18 +2843,18 @@ designates the character that triggers autocompletion
(send e set-position (send e last-position) (send e last-position)) (send e set-position (send e last-position) (send e last-position))
(send f show #t))) (send f show #t)))
(define basic% (basic-mixin (editor:basic-mixin text%))) (define basic% (basic-mixin (editor:basic-mixin text%)))
(define hide-caret/selection% (hide-caret/selection-mixin basic%)) (define hide-caret/selection% (hide-caret/selection-mixin basic%))
(define nbsp->space% (nbsp->space-mixin basic%)) (define nbsp->space% (nbsp->space-mixin basic%))
(define delegate% (delegate-mixin basic%)) (define delegate% (delegate-mixin basic%))
(define wide-snip% (wide-snip-mixin basic%)) (define wide-snip% (wide-snip-mixin basic%))
(define standard-style-list% (editor:standard-style-list-mixin wide-snip%)) (define standard-style-list% (editor:standard-style-list-mixin wide-snip%))
(define input-box% (input-box-mixin standard-style-list%)) (define input-box% (input-box-mixin standard-style-list%))
(define -keymap% (editor:keymap-mixin standard-style-list%)) (define -keymap% (editor:keymap-mixin standard-style-list%))
(define return% (return-mixin -keymap%)) (define return% (return-mixin -keymap%))
(define autowrap% (editor:autowrap-mixin -keymap%)) (define autowrap% (editor:autowrap-mixin -keymap%))
(define file% (file-mixin (editor:file-mixin autowrap%))) (define file% (file-mixin (editor:file-mixin autowrap%)))
(define clever-file-format% (clever-file-format-mixin file%)) (define clever-file-format% (clever-file-format-mixin file%))
(define backup-autosave% (editor:backup-autosave-mixin clever-file-format%)) (define backup-autosave% (editor:backup-autosave-mixin clever-file-format%))
(define searching% (searching-mixin backup-autosave%)) (define searching% (searching-mixin backup-autosave%))
(define info% (info-mixin (editor:info-mixin searching%))) (define info% (info-mixin (editor:info-mixin searching%)))