blob: d4ef244a779f707ada3d7fc43c2bcf15e4a59e51 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
|
(define-module (catbird minibuffer)
#:use-module (catbird kernel)
#:use-module (catbird line-editor)
#:use-module (catbird mode)
#:use-module (catbird node)
#:use-module (catbird node-2d)
#:use-module (catbird region)
#:use-module (catbird scene)
#:use-module (chickadee)
#:use-module (chickadee graphics color)
#:use-module (chickadee graphics path)
#:use-module (chickadee graphics text)
#:use-module (chickadee math vector)
#:use-module (chickadee scripting)
#:use-module (ice-9 match)
#:use-module (oop goops)
#:export (<minibuffer>
<minibuffer-mode>
define-minibuffer-command))
(define %background-color (make-color 0.0 0.0 0.0 0.8))
(define %prompt "> ")
(define %padding 8.0)
(define-class <minibuffer> (<node-2d>)
(commands #:accessor commands #:allocation #:class
#:init-thunk make-hash-table))
(define (minibuffer-commands)
(class-slot-ref <minibuffer> 'commands))
(define (lookup-minibuffer-command name)
(hash-ref (minibuffer-commands) name))
(define (add-minibuffer-command name thunk)
(hash-set! (minibuffer-commands) name thunk))
(define-syntax-rule (define-minibuffer-command name body ...)
(add-minibuffer-command (symbol->string 'name) (lambda () body ...)))
(define-method (on-boot (minibuffer <minibuffer>))
(attach-to minibuffer
(make <canvas>
#:name 'background)
(make <line-editor>
#:name 'editor
#:rank 1
#:position (vec2 %padding %padding)
#:prompt %prompt)))
(define-method (resize-minibuffer (minibuffer <minibuffer>) width)
(set! (painter (& minibuffer background))
(with-style ((fill-color %background-color))
(fill
(rectangle (vec2 0.0 0.0)
width
(+ (font-line-height (font (& minibuffer editor)))
(* %padding 2.0)))))))
(define-method (clear-minibuffer (minibuffer <minibuffer>))
(clear-line (& minibuffer editor)))
;; TODO: The line editor should have a generic completion facility.
(define-method (autocomplete (minibuffer <minibuffer>))
(let ((prefix (get-line (& minibuffer editor))))
;; Auto-complete if there is a single command name that starts
;; with the characters the user has already typed.
(match (hash-fold (lambda (key value prev)
(if (string-prefix? prefix key)
(cons key prev)
prev))
'()
(minibuffer-commands))
((name)
(overwrite (& minibuffer editor) name))
;; TODO: Display multiple completion options to user.
(_ #f))))
(define-method (get-command (minibuffer <minibuffer>))
(lookup-minibuffer-command (get-line (& minibuffer editor))))
(define-method (valid-command? (minibuffer <minibuffer>))
(procedure? (get-command minibuffer)))
(define-method (run-command (minibuffer <minibuffer>))
(let ((thunk (get-command minibuffer)))
(save-to-history (& minibuffer editor))
(when (procedure? thunk)
(thunk))))
;;;
;;; Minibuffer major mode
;;;
(define-class <minibuffer-mode> (<major-mode>)
(prev-keyboard-focus #:accessor prev-keyboard-focus))
(define-method (on-enter (mode <minibuffer-mode>))
(let* ((scene (parent mode))
(region (car (regions scene)))
(minibuffer (or (& scene minibuffer)
(make <minibuffer>
#:name 'minibuffer
#:rank 999))))
(if (parent minibuffer)
(begin
(clear-minibuffer minibuffer)
(show (& scene minibuffer)))
(attach-to (parent mode) minibuffer))
(resize-minibuffer minibuffer (area-width region))
(set! (prev-keyboard-focus mode) (current-keyboard-focus))
(take-keyboard-focus region)
(add-minor-mode scene (make <line-edit-mode>
#:editor (& scene minibuffer editor)))))
(define-method (on-exit (mode <minibuffer-mode>))
(hide (& (parent mode) minibuffer))
(remove-minor-mode (parent mode) <line-edit-mode>)
(take-keyboard-focus (prev-keyboard-focus mode)))
(define-method (close-minibuffer (mode <minibuffer-mode>))
(pop-major-mode (parent mode)))
(define-method (autocomplete (mode <minibuffer-mode>))
(autocomplete (& (parent mode) minibuffer)))
(define-method (run-command (mode <minibuffer-mode>))
;; The minibuffer needs to be closed before running the command so
;; that this mode is no longer active and we've had a chance to
;; clean up the state of the overlay scene.
(let ((minibuffer (& (parent mode) minibuffer)))
(when (valid-command? minibuffer)
(close-minibuffer mode)
(run-command minibuffer))))
(bind-input <minibuffer-mode> (key-press 'escape) close-minibuffer)
(bind-input <minibuffer-mode> (key-press 'g '(ctrl)) close-minibuffer)
(bind-input <minibuffer-mode> (key-press 'tab) autocomplete)
(bind-input <minibuffer-mode> (key-press 'return) run-command)
;;;
;;; Basic minibuffer commands
;;;
(define (for-each-user-scene proc)
(for-each (lambda (region)
(unless (eq? (name region) 'overlay)
(let ((s (scene region)))
(and s (proc s)))))
(all-regions)))
;; General purpose built-in commands.
(define-minibuffer-command pause (for-each-user-scene pause))
(define-minibuffer-command resume (for-each-user-scene resume))
(define-minibuffer-command quit (exit-catbird))
|
